Page MenuHomeHEPForge
Files F7060626

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
diff --git a/AUTHORS b/AUTHORS
new file mode 100644
index 0000000..28fd0e2
--- /dev/null
+++ b/AUTHORS
@@ -0,0 +1,7 @@
+This package is maintained by
+
+Thomas Reiter <reiterth@mpp.mpg.de>
+
+This package includes codes from various authors.
+Please, refer to the list given in the README file,
+which should be part of this distribution.
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..8724fbf
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,8 @@
+This package is a collection of different tools
+and libraries from different authors.
+
+The copyright conditions of the bundled packages
+apply individually.
+
+Please, read the README file, which should be
+part of this distribution.
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000..477bf72
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,17 @@
+2011-11-02 Thomas Reiter <reiterth@mpp.mpg.de>
+ * gosam-contrib.tar.gz: Initial upload of the whole package
+2011-11-18 Thomas Reiter <reiterth@mpp.mpg.de>
+ * gosam.conf.in: Changed wrongly set linker flag -lgolem95 into -lgolem.
+2012-03-06 Gudrun Heinrich <gudrun@mpp.mpg.de>
+ * golem95c-1.2.1/: Updated to include latest upstream fixes
+2012-03-26 Johann Felix v. Soden-Fraunhofen <jfsoden@mpp.mpg.de>
+ * gosam-contrib.tar.gz: Files generated by ./configure removed.
+ * configure.ac: Call Fortran compiler with long line option if available.
+ * samurai-2.1.1/: Updated to include latest upstream fixes.
+2012-04-05 Johann Felix v. Soden-Fraunhofen <jfsoden@mpp.mpg.de>
+ * golem95c-1.2.1/: Updated to latest upstream tarball.
+ * configure.ac: Do not fail if Fortran compiler has no long line option
+ and enable long line support also for Fortran 77 compiler if available.
+2012-07-18 Gudrun Heinrich <gudrun@mpp.mpg.de>
+ * golem95c-1.2.1/: bugfix in renormalisation scale dependence of two-point
+ functions with complex masses
diff --git a/INSTALL b/INSTALL
new file mode 100644
index 0000000..7d1c323
--- /dev/null
+++ b/INSTALL
@@ -0,0 +1,365 @@
+Installation Instructions
+*************************
+
+Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005,
+2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved. This file is offered as-is,
+without warranty of any kind.
+
+Basic Installation
+==================
+
+ Briefly, the shell commands `./configure; make; make install' should
+configure, build, and install this package. The following
+more-detailed instructions are generic; see the `README' file for
+instructions specific to this package. Some packages provide this
+`INSTALL' file but do not implement all of the features documented
+below. The lack of an optional feature in a given package is not
+necessarily a bug. More recommendations for GNU packages can be found
+in *note Makefile Conventions: (standards)Makefile Conventions.
+
+ The `configure' shell script attempts to guess correct values for
+various system-dependent variables used during compilation. It uses
+those values to create a `Makefile' in each directory of the package.
+It may also create one or more `.h' files containing system-dependent
+definitions. Finally, it creates a shell script `config.status' that
+you can run in the future to recreate the current configuration, and a
+file `config.log' containing compiler output (useful mainly for
+debugging `configure').
+
+ It can also use an optional file (typically called `config.cache'
+and enabled with `--cache-file=config.cache' or simply `-C') that saves
+the results of its tests to speed up reconfiguring. Caching is
+disabled by default to prevent problems with accidental use of stale
+cache files.
+
+ If you need to do unusual things to compile the package, please try
+to figure out how `configure' could check whether to do them, and mail
+diffs or instructions to the address given in the `README' so they can
+be considered for the next release. If you are using the cache, and at
+some point `config.cache' contains results you don't want to keep, you
+may remove or edit it.
+
+ The file `configure.ac' (or `configure.in') is used to create
+`configure' by a program called `autoconf'. You need `configure.ac' if
+you want to change it or regenerate `configure' using a newer version
+of `autoconf'.
+
+ The simplest way to compile this package is:
+
+ 1. `cd' to the directory containing the package's source code and type
+ `./configure' to configure the package for your system.
+
+ Running `configure' might take a while. While running, it prints
+ some messages telling which features it is checking for.
+
+ 2. Type `make' to compile the package.
+
+ 3. Optionally, type `make check' to run any self-tests that come with
+ the package, generally using the just-built uninstalled binaries.
+
+ 4. Type `make install' to install the programs and any data files and
+ documentation. When installing into a prefix owned by root, it is
+ recommended that the package be configured and built as a regular
+ user, and only the `make install' phase executed with root
+ privileges.
+
+ 5. Optionally, type `make installcheck' to repeat any self-tests, but
+ this time using the binaries in their final installed location.
+ This target does not install anything. Running this target as a
+ regular user, particularly if the prior `make install' required
+ root privileges, verifies that the installation completed
+ correctly.
+
+ 6. You can remove the program binaries and object files from the
+ source code directory by typing `make clean'. To also remove the
+ files that `configure' created (so you can compile the package for
+ a different kind of computer), type `make distclean'. There is
+ also a `make maintainer-clean' target, but that is intended mainly
+ for the package's developers. If you use it, you may have to get
+ all sorts of other programs in order to regenerate files that came
+ with the distribution.
+
+ 7. Often, you can also type `make uninstall' to remove the installed
+ files again. In practice, not all packages have tested that
+ uninstallation works correctly, even though it is required by the
+ GNU Coding Standards.
+
+ 8. Some packages, particularly those that use Automake, provide `make
+ distcheck', which can by used by developers to test that all other
+ targets like `make install' and `make uninstall' work correctly.
+ This target is generally not run by end users.
+
+Compilers and Options
+=====================
+
+ Some systems require unusual options for compilation or linking that
+the `configure' script does not know about. Run `./configure --help'
+for details on some of the pertinent environment variables.
+
+ You can give `configure' initial values for configuration parameters
+by setting variables in the command line or in the environment. Here
+is an example:
+
+ ./configure CC=c99 CFLAGS=-g LIBS=-lposix
+
+ *Note Defining Variables::, for more details.
+
+Compiling For Multiple Architectures
+====================================
+
+ You can compile the package for more than one kind of computer at the
+same time, by placing the object files for each architecture in their
+own directory. To do this, you can use GNU `make'. `cd' to the
+directory where you want the object files and executables to go and run
+the `configure' script. `configure' automatically checks for the
+source code in the directory that `configure' is in and in `..'. This
+is known as a "VPATH" build.
+
+ With a non-GNU `make', it is safer to compile the package for one
+architecture at a time in the source code directory. After you have
+installed the package for one architecture, use `make distclean' before
+reconfiguring for another architecture.
+
+ On MacOS X 10.5 and later systems, you can create libraries and
+executables that work on multiple system types--known as "fat" or
+"universal" binaries--by specifying multiple `-arch' options to the
+compiler but only a single `-arch' option to the preprocessor. Like
+this:
+
+ ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
+ CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
+ CPP="gcc -E" CXXCPP="g++ -E"
+
+ This is not guaranteed to produce working output in all cases, you
+may have to build one architecture at a time and combine the results
+using the `lipo' tool if you have problems.
+
+Installation Names
+==================
+
+ By default, `make install' installs the package's commands under
+`/usr/local/bin', include files under `/usr/local/include', etc. You
+can specify an installation prefix other than `/usr/local' by giving
+`configure' the option `--prefix=PREFIX', where PREFIX must be an
+absolute file name.
+
+ You can specify separate installation prefixes for
+architecture-specific files and architecture-independent files. If you
+pass the option `--exec-prefix=PREFIX' to `configure', the package uses
+PREFIX as the prefix for installing programs and libraries.
+Documentation and other data files still use the regular prefix.
+
+ In addition, if you use an unusual directory layout you can give
+options like `--bindir=DIR' to specify different values for particular
+kinds of files. Run `configure --help' for a list of the directories
+you can set and what kinds of files go in them. In general, the
+default for these options is expressed in terms of `${prefix}', so that
+specifying just `--prefix' will affect all of the other directory
+specifications that were not explicitly provided.
+
+ The most portable way to affect installation locations is to pass the
+correct locations to `configure'; however, many packages provide one or
+both of the following shortcuts of passing variable assignments to the
+`make install' command line to change installation locations without
+having to reconfigure or recompile.
+
+ The first method involves providing an override variable for each
+affected directory. For example, `make install
+prefix=/alternate/directory' will choose an alternate location for all
+directory configuration variables that were expressed in terms of
+`${prefix}'. Any directories that were specified during `configure',
+but not in terms of `${prefix}', must each be overridden at install
+time for the entire installation to be relocated. The approach of
+makefile variable overrides for each directory variable is required by
+the GNU Coding Standards, and ideally causes no recompilation.
+However, some platforms have known limitations with the semantics of
+shared libraries that end up requiring recompilation when using this
+method, particularly noticeable in packages that use GNU Libtool.
+
+ The second method involves providing the `DESTDIR' variable. For
+example, `make install DESTDIR=/alternate/directory' will prepend
+`/alternate/directory' before all installation names. The approach of
+`DESTDIR' overrides is not required by the GNU Coding Standards, and
+does not work on platforms that have drive letters. On the other hand,
+it does better at avoiding recompilation issues, and works well even
+when some directory options were not specified in terms of `${prefix}'
+at `configure' time.
+
+Optional Features
+=================
+
+ If the package supports it, you can cause programs to be installed
+with an extra prefix or suffix on their names by giving `configure' the
+option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'.
+
+ Some packages pay attention to `--enable-FEATURE' options to
+`configure', where FEATURE indicates an optional part of the package.
+They may also pay attention to `--with-PACKAGE' options, where PACKAGE
+is something like `gnu-as' or `x' (for the X Window System). The
+`README' should mention any `--enable-' and `--with-' options that the
+package recognizes.
+
+ For packages that use the X Window System, `configure' can usually
+find the X include and library files automatically, but if it doesn't,
+you can use the `configure' options `--x-includes=DIR' and
+`--x-libraries=DIR' to specify their locations.
+
+ Some packages offer the ability to configure how verbose the
+execution of `make' will be. For these packages, running `./configure
+--enable-silent-rules' sets the default to minimal output, which can be
+overridden with `make V=1'; while running `./configure
+--disable-silent-rules' sets the default to verbose, which can be
+overridden with `make V=0'.
+
+Particular systems
+==================
+
+ On HP-UX, the default C compiler is not ANSI C compatible. If GNU
+CC is not installed, it is recommended to use the following options in
+order to use an ANSI C compiler:
+
+ ./configure CC="cc -Ae -D_XOPEN_SOURCE=500"
+
+and if that doesn't work, install pre-built binaries of GCC for HP-UX.
+
+ On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot
+parse its `<wchar.h>' header file. The option `-nodtk' can be used as
+a workaround. If GNU CC is not installed, it is therefore recommended
+to try
+
+ ./configure CC="cc"
+
+and if that doesn't work, try
+
+ ./configure CC="cc -nodtk"
+
+ On Solaris, don't put `/usr/ucb' early in your `PATH'. This
+directory contains several dysfunctional programs; working variants of
+these programs are available in `/usr/bin'. So, if you need `/usr/ucb'
+in your `PATH', put it _after_ `/usr/bin'.
+
+ On Haiku, software installed for all users goes in `/boot/common',
+not `/usr/local'. It is recommended to use the following options:
+
+ ./configure --prefix=/boot/common
+
+Specifying the System Type
+==========================
+
+ There may be some features `configure' cannot figure out
+automatically, but needs to determine by the type of machine the package
+will run on. Usually, assuming the package is built to be run on the
+_same_ architectures, `configure' can figure that out, but if it prints
+a message saying it cannot guess the machine type, give it the
+`--build=TYPE' option. TYPE can either be a short name for the system
+type, such as `sun4', or a canonical name which has the form:
+
+ CPU-COMPANY-SYSTEM
+
+where SYSTEM can have one of these forms:
+
+ OS
+ KERNEL-OS
+
+ See the file `config.sub' for the possible values of each field. If
+`config.sub' isn't included in this package, then this package doesn't
+need to know the machine type.
+
+ If you are _building_ compiler tools for cross-compiling, you should
+use the option `--target=TYPE' to select the type of system they will
+produce code for.
+
+ If you want to _use_ a cross compiler, that generates code for a
+platform different from the build platform, you should specify the
+"host" platform (i.e., that on which the generated programs will
+eventually be run) with `--host=TYPE'.
+
+Sharing Defaults
+================
+
+ If you want to set default values for `configure' scripts to share,
+you can create a site shell script called `config.site' that gives
+default values for variables like `CC', `cache_file', and `prefix'.
+`configure' looks for `PREFIX/share/config.site' if it exists, then
+`PREFIX/etc/config.site' if it exists. Or, you can set the
+`CONFIG_SITE' environment variable to the location of the site script.
+A warning: not all `configure' scripts look for a site script.
+
+Defining Variables
+==================
+
+ Variables not defined in a site shell script can be set in the
+environment passed to `configure'. However, some packages may run
+configure again during the build, and the customized values of these
+variables may be lost. In order to avoid this problem, you should set
+them in the `configure' command line, using `VAR=value'. For example:
+
+ ./configure CC=/usr/local2/bin/gcc
+
+causes the specified `gcc' to be used as the C compiler (unless it is
+overridden in the site shell script).
+
+Unfortunately, this technique does not work for `CONFIG_SHELL' due to
+an Autoconf bug. Until the bug is fixed you can use this workaround:
+
+ CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash
+
+`configure' Invocation
+======================
+
+ `configure' recognizes the following options to control how it
+operates.
+
+`--help'
+`-h'
+ Print a summary of all of the options to `configure', and exit.
+
+`--help=short'
+`--help=recursive'
+ Print a summary of the options unique to this package's
+ `configure', and exit. The `short' variant lists options used
+ only in the top level, while the `recursive' variant lists options
+ also present in any nested packages.
+
+`--version'
+`-V'
+ Print the version of Autoconf used to generate the `configure'
+ script, and exit.
+
+`--cache-file=FILE'
+ Enable the cache: use and save the results of the tests in FILE,
+ traditionally `config.cache'. FILE defaults to `/dev/null' to
+ disable caching.
+
+`--config-cache'
+`-C'
+ Alias for `--cache-file=config.cache'.
+
+`--quiet'
+`--silent'
+`-q'
+ Do not print messages saying which checks are being made. To
+ suppress all normal output, redirect it to `/dev/null' (any error
+ messages will still be shown).
+
+`--srcdir=DIR'
+ Look for the package's source code in directory DIR. Usually
+ `configure' can determine that directory automatically.
+
+`--prefix=DIR'
+ Use DIR as the installation prefix. *note Installation Names::
+ for more details, including other options available for fine-tuning
+ the installation locations.
+
+`--no-create'
+`-n'
+ Run the configure checks, but stop before creating any output
+ files.
+
+`configure' also accepts some other, not widely useful, options. Run
+`configure --help' for more details.
+
diff --git a/Makefile.am b/Makefile.am
new file mode 100644
index 0000000..7c563b8
--- /dev/null
+++ b/Makefile.am
@@ -0,0 +1,46 @@
+# vim: ts=3:sw=3
+SUBDIRS=
+
+if COMPILE_FF
+SUBDIRS+= ff-2.0
+else
+# nop
+endif
+
+if COMPILE_QL
+SUBDIRS+= qcdloop-1.9
+else
+# nop
+endif
+
+if COMPILE_OLO
+SUBDIRS+= avh_olo-2.2.1
+else
+# nop
+endif
+
+if COMPILE_GOLEM95C
+SUBDIRS+= golem95c-1.2.1
+else
+# nop
+endif
+
+if COMPILE_SAMURAI
+SUBDIRS+= samurai-2.1.1
+else
+# nop
+endif
+
+pkgconfigdir= $(libdir)/pkgconfig
+pkgconfig_DATA=samurai.pc
+
+dist_noinst_SCRIPTS= autogen.sh
+
+dist_pkgdata_DATA=\
+ $(top_srcdir)/ff-2.0/fferr.dat \
+ $(top_srcdir)/ff-2.0/ffperm5.dat \
+ $(top_srcdir)/ff-2.0/ffwarn.dat
+
+pkgdata_DATA=gosam.conf
+ACLOCAL_AMFLAGS= -I m4
+EXTRA_DIST=m4
diff --git a/Makefile.in b/Makefile.in
new file mode 100644
index 0000000..732c804
--- /dev/null
+++ b/Makefile.in
@@ -0,0 +1,866 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+@COMPILE_FF_TRUE@am__append_1 = ff-2.0
+# nop
+@COMPILE_QL_TRUE@am__append_2 = qcdloop-1.9
+# nop
+@COMPILE_OLO_TRUE@am__append_3 = avh_olo-2.2.1
+# nop
+@COMPILE_GOLEM95C_TRUE@am__append_4 = golem95c-1.2.1
+# nop
+@COMPILE_SAMURAI_TRUE@am__append_5 = samurai-2.1.1
+subdir = .
+DIST_COMMON = README $(am__configure_deps) $(dist_noinst_SCRIPTS) \
+ $(dist_pkgdata_DATA) $(srcdir)/Makefile.am \
+ $(srcdir)/Makefile.in $(srcdir)/gosam.conf.in \
+ $(srcdir)/samurai.pc.in $(top_srcdir)/configure AUTHORS \
+ COPYING ChangeLog INSTALL NEWS config.aux/config.guess \
+ config.aux/config.sub config.aux/install-sh \
+ config.aux/ltmain.sh config.aux/missing
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \
+ configure.lineno config.status.lineno
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES = gosam.conf samurai.pc
+CONFIG_CLEAN_VPATH_FILES =
+SCRIPTS = $(dist_noinst_SCRIPTS)
+SOURCES =
+DIST_SOURCES =
+RECURSIVE_TARGETS = all-recursive check-recursive dvi-recursive \
+ html-recursive info-recursive install-data-recursive \
+ install-dvi-recursive install-exec-recursive \
+ install-html-recursive install-info-recursive \
+ install-pdf-recursive install-ps-recursive install-recursive \
+ installcheck-recursive installdirs-recursive pdf-recursive \
+ ps-recursive uninstall-recursive
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgdatadir)" \
+ "$(DESTDIR)$(pkgconfigdir)" "$(DESTDIR)$(pkgdatadir)"
+DATA = $(dist_pkgdata_DATA) $(pkgconfig_DATA) $(pkgdata_DATA)
+RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \
+ distclean-recursive maintainer-clean-recursive
+AM_RECURSIVE_TARGETS = $(RECURSIVE_TARGETS:-recursive=) \
+ $(RECURSIVE_CLEAN_TARGETS:-recursive=) tags TAGS ctags CTAGS \
+ distdir dist dist-all distcheck
+ETAGS = etags
+CTAGS = ctags
+DIST_SUBDIRS = ff-2.0 qcdloop-1.9 avh_olo-2.2.1 golem95c-1.2.1 \
+ samurai-2.1.1
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+distdir = $(PACKAGE)-$(VERSION)
+top_distdir = $(distdir)
+am__remove_distdir = \
+ { test ! -d "$(distdir)" \
+ || { find "$(distdir)" -type d ! -perm -200 -exec chmod u+w {} ';' \
+ && rm -fr "$(distdir)"; }; }
+am__relativize = \
+ dir0=`pwd`; \
+ sed_first='s,^\([^/]*\)/.*$$,\1,'; \
+ sed_rest='s,^[^/]*/*,,'; \
+ sed_last='s,^.*/\([^/]*\)$$,\1,'; \
+ sed_butlast='s,/*[^/]*$$,,'; \
+ while test -n "$$dir1"; do \
+ first=`echo "$$dir1" | sed -e "$$sed_first"`; \
+ if test "$$first" != "."; then \
+ if test "$$first" = ".."; then \
+ dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \
+ dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \
+ else \
+ first2=`echo "$$dir2" | sed -e "$$sed_first"`; \
+ if test "$$first2" = "$$first"; then \
+ dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \
+ else \
+ dir2="../$$dir2"; \
+ fi; \
+ dir0="$$dir0"/"$$first"; \
+ fi; \
+ fi; \
+ dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \
+ done; \
+ reldir="$$dir2"
+DIST_ARCHIVES = $(distdir).tar.gz
+GZIP_ENV = --best
+distuninstallcheck_listfiles = find . -type f -print
+distcleancheck_listfiles = find . -type f -print
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+
+# vim: ts=3:sw=3
+SUBDIRS = $(am__append_1) $(am__append_2) $(am__append_3) \
+ $(am__append_4) $(am__append_5)
+# nop
+pkgconfigdir = $(libdir)/pkgconfig
+pkgconfig_DATA = samurai.pc
+dist_noinst_SCRIPTS = autogen.sh
+dist_pkgdata_DATA = \
+ $(top_srcdir)/ff-2.0/fferr.dat \
+ $(top_srcdir)/ff-2.0/ffperm5.dat \
+ $(top_srcdir)/ff-2.0/ffwarn.dat
+
+pkgdata_DATA = gosam.conf
+ACLOCAL_AMFLAGS = -I m4
+EXTRA_DIST = m4
+all: all-recursive
+
+.SUFFIXES:
+am--refresh:
+ @:
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ echo ' cd $(srcdir) && $(AUTOMAKE) --gnu'; \
+ $(am__cd) $(srcdir) && $(AUTOMAKE) --gnu \
+ && exit 0; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ echo ' $(SHELL) ./config.status'; \
+ $(SHELL) ./config.status;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ $(SHELL) ./config.status --recheck
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ $(am__cd) $(srcdir) && $(AUTOCONF)
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS)
+$(am__aclocal_m4_deps):
+gosam.conf: $(top_builddir)/config.status $(srcdir)/gosam.conf.in
+ cd $(top_builddir) && $(SHELL) ./config.status $@
+samurai.pc: $(top_builddir)/config.status $(srcdir)/samurai.pc.in
+ cd $(top_builddir) && $(SHELL) ./config.status $@
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+
+distclean-libtool:
+ -rm -f libtool config.lt
+install-dist_pkgdataDATA: $(dist_pkgdata_DATA)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgdatadir)" || $(MKDIR_P) "$(DESTDIR)$(pkgdatadir)"
+ @list='$(dist_pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgdatadir)'"; \
+ $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgdatadir)" || exit $$?; \
+ done
+
+uninstall-dist_pkgdataDATA:
+ @$(NORMAL_UNINSTALL)
+ @list='$(dist_pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgdatadir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgdatadir)" && rm -f $$files
+install-pkgconfigDATA: $(pkgconfig_DATA)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgconfigdir)" || $(MKDIR_P) "$(DESTDIR)$(pkgconfigdir)"
+ @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgconfigdir)'"; \
+ $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgconfigdir)" || exit $$?; \
+ done
+
+uninstall-pkgconfigDATA:
+ @$(NORMAL_UNINSTALL)
+ @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgconfigdir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgconfigdir)" && rm -f $$files
+install-pkgdataDATA: $(pkgdata_DATA)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgdatadir)" || $(MKDIR_P) "$(DESTDIR)$(pkgdatadir)"
+ @list='$(pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgdatadir)'"; \
+ $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgdatadir)" || exit $$?; \
+ done
+
+uninstall-pkgdataDATA:
+ @$(NORMAL_UNINSTALL)
+ @list='$(pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgdatadir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgdatadir)" && rm -f $$files
+
+# This directory's subdirectories are mostly independent; you can cd
+# into them and run `make' without going through this Makefile.
+# To change the values of `make' variables: instead of editing Makefiles,
+# (1) if the variable is set in `config.status', edit `config.status'
+# (which will cause the Makefiles to be regenerated when you run `make');
+# (2) otherwise, pass the desired values on the `make' command line.
+$(RECURSIVE_TARGETS):
+ @fail= failcom='exit 1'; \
+ for f in x $$MAKEFLAGS; do \
+ case $$f in \
+ *=* | --[!k]*);; \
+ *k*) failcom='fail=yes';; \
+ esac; \
+ done; \
+ dot_seen=no; \
+ target=`echo $@ | sed s/-recursive//`; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ echo "Making $$target in $$subdir"; \
+ if test "$$subdir" = "."; then \
+ dot_seen=yes; \
+ local_target="$$target-am"; \
+ else \
+ local_target="$$target"; \
+ fi; \
+ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+ || eval $$failcom; \
+ done; \
+ if test "$$dot_seen" = "no"; then \
+ $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \
+ fi; test -z "$$fail"
+
+$(RECURSIVE_CLEAN_TARGETS):
+ @fail= failcom='exit 1'; \
+ for f in x $$MAKEFLAGS; do \
+ case $$f in \
+ *=* | --[!k]*);; \
+ *k*) failcom='fail=yes';; \
+ esac; \
+ done; \
+ dot_seen=no; \
+ case "$@" in \
+ distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \
+ *) list='$(SUBDIRS)' ;; \
+ esac; \
+ rev=''; for subdir in $$list; do \
+ if test "$$subdir" = "."; then :; else \
+ rev="$$subdir $$rev"; \
+ fi; \
+ done; \
+ rev="$$rev ."; \
+ target=`echo $@ | sed s/-recursive//`; \
+ for subdir in $$rev; do \
+ echo "Making $$target in $$subdir"; \
+ if test "$$subdir" = "."; then \
+ local_target="$$target-am"; \
+ else \
+ local_target="$$target"; \
+ fi; \
+ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+ || eval $$failcom; \
+ done && test -z "$$fail"
+tags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test "$$subdir" = . || ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \
+ done
+ctags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test "$$subdir" = . || ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) ctags); \
+ done
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \
+ include_option=--etags-include; \
+ empty_fix=.; \
+ else \
+ include_option=--include; \
+ empty_fix=; \
+ fi; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ test ! -f $$subdir/TAGS || \
+ set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \
+ fi; \
+ done; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: ctags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ $(am__remove_distdir)
+ test -d "$(distdir)" || mkdir "$(distdir)"
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+ @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ test -d "$(distdir)/$$subdir" \
+ || $(MKDIR_P) "$(distdir)/$$subdir" \
+ || exit 1; \
+ fi; \
+ done
+ @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ dir1=$$subdir; dir2="$(distdir)/$$subdir"; \
+ $(am__relativize); \
+ new_distdir=$$reldir; \
+ dir1=$$subdir; dir2="$(top_distdir)"; \
+ $(am__relativize); \
+ new_top_distdir=$$reldir; \
+ echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \
+ echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \
+ ($(am__cd) $$subdir && \
+ $(MAKE) $(AM_MAKEFLAGS) \
+ top_distdir="$$new_top_distdir" \
+ distdir="$$new_distdir" \
+ am__remove_distdir=: \
+ am__skip_length_check=: \
+ am__skip_mode_fix=: \
+ distdir) \
+ || exit 1; \
+ fi; \
+ done
+ -test -n "$(am__skip_mode_fix)" \
+ || find "$(distdir)" -type d ! -perm -755 \
+ -exec chmod u+rwx,go+rx {} \; -o \
+ ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \
+ ! -type d ! -perm -400 -exec chmod a+r {} \; -o \
+ ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \
+ || chmod -R a+r "$(distdir)"
+dist-gzip: distdir
+ tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz
+ $(am__remove_distdir)
+
+dist-bzip2: distdir
+ tardir=$(distdir) && $(am__tar) | bzip2 -9 -c >$(distdir).tar.bz2
+ $(am__remove_distdir)
+
+dist-lzma: distdir
+ tardir=$(distdir) && $(am__tar) | lzma -9 -c >$(distdir).tar.lzma
+ $(am__remove_distdir)
+
+dist-xz: distdir
+ tardir=$(distdir) && $(am__tar) | xz -c >$(distdir).tar.xz
+ $(am__remove_distdir)
+
+dist-tarZ: distdir
+ tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z
+ $(am__remove_distdir)
+
+dist-shar: distdir
+ shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz
+ $(am__remove_distdir)
+
+dist-zip: distdir
+ -rm -f $(distdir).zip
+ zip -rq $(distdir).zip $(distdir)
+ $(am__remove_distdir)
+
+dist dist-all: distdir
+ tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz
+ $(am__remove_distdir)
+
+# This target untars the dist file and tries a VPATH configuration. Then
+# it guarantees that the distribution is self-contained by making another
+# tarfile.
+distcheck: dist
+ case '$(DIST_ARCHIVES)' in \
+ *.tar.gz*) \
+ GZIP=$(GZIP_ENV) gzip -dc $(distdir).tar.gz | $(am__untar) ;;\
+ *.tar.bz2*) \
+ bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\
+ *.tar.lzma*) \
+ lzma -dc $(distdir).tar.lzma | $(am__untar) ;;\
+ *.tar.xz*) \
+ xz -dc $(distdir).tar.xz | $(am__untar) ;;\
+ *.tar.Z*) \
+ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\
+ *.shar.gz*) \
+ GZIP=$(GZIP_ENV) gzip -dc $(distdir).shar.gz | unshar ;;\
+ *.zip*) \
+ unzip $(distdir).zip ;;\
+ esac
+ chmod -R a-w $(distdir); chmod a+w $(distdir)
+ mkdir $(distdir)/_build
+ mkdir $(distdir)/_inst
+ chmod a-w $(distdir)
+ test -d $(distdir)/_build || exit 0; \
+ dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \
+ && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \
+ && am__cwd=`pwd` \
+ && $(am__cd) $(distdir)/_build \
+ && ../configure --srcdir=.. --prefix="$$dc_install_base" \
+ $(DISTCHECK_CONFIGURE_FLAGS) \
+ && $(MAKE) $(AM_MAKEFLAGS) \
+ && $(MAKE) $(AM_MAKEFLAGS) dvi \
+ && $(MAKE) $(AM_MAKEFLAGS) check \
+ && $(MAKE) $(AM_MAKEFLAGS) install \
+ && $(MAKE) $(AM_MAKEFLAGS) installcheck \
+ && $(MAKE) $(AM_MAKEFLAGS) uninstall \
+ && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \
+ distuninstallcheck \
+ && chmod -R a-w "$$dc_install_base" \
+ && ({ \
+ (cd ../.. && umask 077 && mkdir "$$dc_destdir") \
+ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \
+ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \
+ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \
+ distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \
+ } || { rm -rf "$$dc_destdir"; exit 1; }) \
+ && rm -rf "$$dc_destdir" \
+ && $(MAKE) $(AM_MAKEFLAGS) dist \
+ && rm -rf $(DIST_ARCHIVES) \
+ && $(MAKE) $(AM_MAKEFLAGS) distcleancheck \
+ && cd "$$am__cwd" \
+ || exit 1
+ $(am__remove_distdir)
+ @(echo "$(distdir) archives ready for distribution: "; \
+ list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \
+ sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x'
+distuninstallcheck:
+ @$(am__cd) '$(distuninstallcheck_dir)' \
+ && test `$(distuninstallcheck_listfiles) | wc -l` -le 1 \
+ || { echo "ERROR: files left after uninstall:" ; \
+ if test -n "$(DESTDIR)"; then \
+ echo " (check DESTDIR support)"; \
+ fi ; \
+ $(distuninstallcheck_listfiles) ; \
+ exit 1; } >&2
+distcleancheck: distclean
+ @if test '$(srcdir)' = . ; then \
+ echo "ERROR: distcleancheck can only run from a VPATH build" ; \
+ exit 1 ; \
+ fi
+ @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \
+ || { echo "ERROR: files left in build directory after distclean:" ; \
+ $(distcleancheck_listfiles) ; \
+ exit 1; } >&2
+check-am: all-am
+check: check-recursive
+all-am: Makefile $(SCRIPTS) $(DATA)
+installdirs: installdirs-recursive
+installdirs-am:
+ for dir in "$(DESTDIR)$(pkgdatadir)" "$(DESTDIR)$(pkgconfigdir)" "$(DESTDIR)$(pkgdatadir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-recursive
+install-exec: install-exec-recursive
+install-data: install-data-recursive
+uninstall: uninstall-recursive
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-recursive
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-recursive
+
+clean-am: clean-generic clean-libtool mostlyclean-am
+
+distclean: distclean-recursive
+ -rm -f $(am__CONFIG_DISTCLEAN_FILES)
+ -rm -f Makefile
+distclean-am: clean-am distclean-generic distclean-libtool \
+ distclean-tags
+
+dvi: dvi-recursive
+
+dvi-am:
+
+html: html-recursive
+
+html-am:
+
+info: info-recursive
+
+info-am:
+
+install-data-am: install-dist_pkgdataDATA install-pkgconfigDATA \
+ install-pkgdataDATA
+
+install-dvi: install-dvi-recursive
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-recursive
+
+install-html-am:
+
+install-info: install-info-recursive
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-recursive
+
+install-pdf-am:
+
+install-ps: install-ps-recursive
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-recursive
+ -rm -f $(am__CONFIG_DISTCLEAN_FILES)
+ -rm -rf $(top_srcdir)/autom4te.cache
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-recursive
+
+mostlyclean-am: mostlyclean-generic mostlyclean-libtool
+
+pdf: pdf-recursive
+
+pdf-am:
+
+ps: ps-recursive
+
+ps-am:
+
+uninstall-am: uninstall-dist_pkgdataDATA uninstall-pkgconfigDATA \
+ uninstall-pkgdataDATA
+
+.MAKE: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) ctags-recursive \
+ install-am install-strip tags-recursive
+
+.PHONY: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) CTAGS GTAGS \
+ all all-am am--refresh check check-am clean clean-generic \
+ clean-libtool ctags ctags-recursive dist dist-all dist-bzip2 \
+ dist-gzip dist-lzma dist-shar dist-tarZ dist-xz dist-zip \
+ distcheck distclean distclean-generic distclean-libtool \
+ distclean-tags distcleancheck distdir distuninstallcheck dvi \
+ dvi-am html html-am info info-am install install-am \
+ install-data install-data-am install-dist_pkgdataDATA \
+ install-dvi install-dvi-am install-exec install-exec-am \
+ install-html install-html-am install-info install-info-am \
+ install-man install-pdf install-pdf-am install-pkgconfigDATA \
+ install-pkgdataDATA install-ps install-ps-am install-strip \
+ installcheck installcheck-am installdirs installdirs-am \
+ maintainer-clean maintainer-clean-generic mostlyclean \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags tags-recursive uninstall uninstall-am \
+ uninstall-dist_pkgdataDATA uninstall-pkgconfigDATA \
+ uninstall-pkgdataDATA
+
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..e69de29
diff --git a/README b/README
new file mode 100644
index 0000000..ddc1ade
--- /dev/null
+++ b/README
@@ -0,0 +1,151 @@
+#=========
+# Synopsis
+#=========
+
+This package is a collection of tools by different authors.
+These tools are used by the GoSam package. This package is
+intended to simplify the installation and setup of the single
+libraries and tools.
+
+Some packages are included only as stripped or modified versions.
+For the full packages, documentation, full author list and the original code
+please refer to the given URLs.
+
+#=============
+# Installation
+#=============
+
+In order to install the libraries under a common path run
+
+ ./configure --prefix=<your prefix>
+ make
+ make install
+
+After successful installation you will find the file
+
+ <your prefix>/share/gosam-contrib/gosam.conf
+
+which you should either copy or link to your home directory
+
+ ln -s <your prefix>/share/gosam-contrib/gosam.conf $HOME
+
+Furthermore, you should ensure that the LD_LIBRARY_PATH is updated
+to contain the installation path of this library, e.g. by setting
+the variable either locally or in your startup script ($HOME/.bashrc, ...):
+
+ LD_LIBRARY_PATH=$LD_LIBRARY_PATH:<your prefix>/lib
+
+For more information consult the file 'INSTALL'.
+
+#=========
+# Contents
+#=========
+
+#---
+# FF
+#---
+
+URL: http://www.nikhef.nl/~t68/ff/
+
+ ====================================================
+ FF 2.0, a package to evaluate one-loop integrals
+ written by G. J. van Oldenborgh, NIKHEF-H, Amsterdam
+ ====================================================
+ for the algorithms used see preprint NIKHEF-H 89/17,
+ 'New Algorithms for One-loop Integrals', by G.J. van
+ Oldenborgh and J.A.M. Vermaseren, published in
+ Zeitschrift fuer Physik C46(1990)425.
+ ====================================================
+
+#--------
+# QCDLoop
+#--------
+
+URL: http://qcdloop.fnal.gov/
+
+ ====================================================
+ This is QCDLoop - version 1.9
+ Authors: Keith Ellis and Giulia Zanderighi
+ (ellis@fnal.gov, g.zanderighi1@physics.ox.ac.uk)
+ For details see FERMILAB-PUB-07-633-T,OUTP-07/16P
+ arXiv:0712.1851 [hep-ph], published in
+ JHEP 0802:002,2008.
+ ====================================================
+
+#------------
+# AVH OneLOop
+#------------
+
+URL: http://helac-phegas.web.cern.ch/helac-phegas/OneLOop.html
+
+########################################################################
+# #
+# You are using OneLOop-2.2.1 #
+# #
+# for the evaluation of 1-loop scalar 1-, 2-, 3- and 4-point functions #
+# #
+# author: Andreas van Hameren <hamerenREMOVETHIS@ifj.edu.pl> #
+# date: 07-09-2011 #
+# #
+# Please cite #
+# A. van Hameren, #
+# Comput.Phys.Commun. 182 (2011) 2427-2438, arXiv:1007.4716 #
+# A. van Hameren, C.G. Papadopoulos and R. Pittau, #
+# JHEP 0909:106,2009, arXiv:0903.4665 #
+# in publications with results obtained with the help of this program. #
+# #
+########################################################################
+
+#---------
+# Golem95C
+#---------
+
+URL: http://projects.hepforge.org/~golem/95/
+
+#--------
+# Samurai
+#--------
+
+URL: http://cern.ch/samurai/
+ http://projects.hepforge.org/~samurai/
+
+ ********************************************************************
+ ********************** SAMURAI - version 2.1.1
+ ********************************************************************
+ * *
+ * *
+ * Authors: P. Mastrolia, G. Ossola, T. Reiter and F. Tramontano *
+ * *
+ * pierpaolo.mastrolia@cern.ch *
+ * gossola@citytech.cuny.edu *
+ * reiterth@mpp.mpg.de *
+ * francesco.tramontano@cern.ch *
+ * *
+ * For details please see: arXiv:1006.0710 *
+ * *
+ * On the web: http://cern.ch/samurai *
+ * *
+ ********************************************************************
+ * *
+ * output files: <output.log> [ for verbosity.gt.0 ] *
+ * *
+ * <bad.points> [ for itest.gt.0 ] *
+ * *
+ ********************************************************************
+
+#===========================
+# Notes on various compilers
+#===========================
+
+* The compilers ifort and pgf90 require the additional flag "-module ."
+ You should call make with the following options:
+
+ make FCFLAGS="-module ."
+
+* FF has been modified such that in ffinit.f the actual installation
+ path is set such that the .dat files can be reliably found at runtime.
+ Depending on the installation location this might require to pass
+ an option to the Fortran 77 compiler allowing for longer lines.
+ For gfortran this would be
+
+ make FFLAGS="-ffixed-line-length-none"
diff --git a/acinclude.m4 b/acinclude.m4
new file mode 100644
index 0000000..824764a
--- /dev/null
+++ b/acinclude.m4
@@ -0,0 +1,79 @@
+
+# MY_F77_LINE_LENGTH([LENGTH], [ACTION-IF-SUCCESS],
+# [ACTION-IF-FAILURE = FAILURE])
+# ------------------------------------------------
+# Look for a compiler flag to make the Fortran (FC) compiler accept long lines
+# in the current (free- or fixed-format) source code, and adds it to FFLAGS.
+# The optional LENGTH may be 80, 132 (default), or `unlimited' for longer
+# lines. Note that line lengths above 254 columns are not portable, and some
+# compilers (hello ifort) do not accept more than 132 columns at least for
+# fixed format. Call ACTION-IF-SUCCESS (defaults to nothing) if successful
+# (i.e. can compile code using new extension) and ACTION-IF-FAILURE (defaults
+# to failing with an error message) if not. (Defined via DEFUN_ONCE to
+# prevent flag from being added to FFLAGS multiple times.)
+# You should call AC_FC_FREEFORM or AC_FC_FIXEDFORM to set the desired format
+# prior to using this macro.
+#
+# The known flags are:
+# -ffixed-line-length-N with N 72, 80, 132, or 0 or none for none.
+# -ffixed-line-length-none: GNU gfortran
+# -qfixed=132 80 72: IBM compiler (xlf)
+# -Mextend: Cray
+# -132 -80 -72: Intel compiler (ifort)
+# Needs to come before -extend_source because ifort
+# accepts that as well with an optional parameter and
+# doesn't fail but only warns about unknown arguments.
+# -extend_source: SGI compiler
+# -W NN (132, 80, 72): Absoft Fortran
+# +extend_source: HP Fortran (254 in either form, default is 72 fixed,
+# 132 free)
+# -wide: Lahey/Fujitsu Fortran (255 cols in fixed form)
+# -e: Sun Fortran compiler (132 characters)
+AC_DEFUN_ONCE([MY_F77_LINE_LENGTH],
+[AC_LANG_PUSH([Fortran 77])dnl
+m4_case(m4_default([$1], [132]),
+ [unlimited], [my_f77_line_len_string=unlimited
+ my_f77_line_len=0
+ my_f77_line_length_test='
+ subroutine longer_than_132(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,'\
+'arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,arg17,arg18,arg19)'],
+ [132], [my_f77_line_len=132
+ my_f77_line_length_test='
+ subroutine longer_than_80(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,'\
+'arg10)'],
+ [80], [my_f77_line_len=80
+ my_f77_line_length_test='
+ subroutine longer_than_72(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9)'],
+ [m4_warning([Invalid length argument `$1'])])
+: ${my_f77_line_len_string=$my_f77_line_len}
+AC_CACHE_CHECK(
+[for Fortran 77 flag needed to accept $my_f77_line_len_string column source lines],
+ [my_cv_f77_line_length],
+[my_cv_f77_line_length=unknown
+my_f77_line_length_FFLAGS_save=$FFLAGS
+for ac_flag in none \
+ -ffixed-line-length-none \
+ -ffixed-line-length-$my_f77_line_len \
+ -qfixed=$my_f77_line_len -Mextend \
+ -$my_f77_line_len -extend_source \
+ "-W $my_f77_line_len" +extend_source -wide -e
+do
+ test "x$ac_flag" != xnone && FFLAGS="$my_f77_line_length_FFLAGS_save $ac_flag"
+ AC_COMPILE_IFELSE([[$my_f77_line_length_test
+ end subroutine]],
+ [my_cv_f77_line_length=$ac_flag; break])
+done
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+FFLAGS=$my_f77_line_length_FFLAGS_save
+])
+if test "x$my_cv_f77_line_length" = xunknown; then
+ m4_default([$3],
+ [AC_MSG_ERROR([Fortran does not accept long source lines], 77)])
+else
+ if test "x$my_cv_f77_line_length" != xnone; then
+ FFLAGS="$FFLAGS $my_cv_f77_line_length"
+ fi
+ $2
+fi
+AC_LANG_POP([Fortran 77])dnl
+])# MY_F77_LINE_LENGTH
diff --git a/aclocal.m4 b/aclocal.m4
new file mode 100644
index 0000000..a621780
--- /dev/null
+++ b/aclocal.m4
@@ -0,0 +1,957 @@
+# generated automatically by aclocal 1.11.1 -*- Autoconf -*-
+
+# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+m4_ifndef([AC_AUTOCONF_VERSION],
+ [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl
+m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.68],,
+[m4_warning([this file was generated for autoconf 2.68.
+You have another version of autoconf. It may work, but is not guaranteed to.
+If you have problems, you may need to regenerate the build system entirely.
+To do so, use the procedure documented by the package, typically `autoreconf'.])])
+
+# Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_AUTOMAKE_VERSION(VERSION)
+# ----------------------------
+# Automake X.Y traces this macro to ensure aclocal.m4 has been
+# generated from the m4 files accompanying Automake X.Y.
+# (This private macro should not be called outside this file.)
+AC_DEFUN([AM_AUTOMAKE_VERSION],
+[am__api_version='1.11'
+dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to
+dnl require some minimum version. Point them to the right macro.
+m4_if([$1], [1.11.1], [],
+ [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl
+])
+
+# _AM_AUTOCONF_VERSION(VERSION)
+# -----------------------------
+# aclocal traces this macro to find the Autoconf version.
+# This is a private macro too. Using m4_define simplifies
+# the logic in aclocal, which can simply ignore this definition.
+m4_define([_AM_AUTOCONF_VERSION], [])
+
+# AM_SET_CURRENT_AUTOMAKE_VERSION
+# -------------------------------
+# Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced.
+# This function is AC_REQUIREd by AM_INIT_AUTOMAKE.
+AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION],
+[AM_AUTOMAKE_VERSION([1.11.1])dnl
+m4_ifndef([AC_AUTOCONF_VERSION],
+ [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl
+_AM_AUTOCONF_VERSION(m4_defn([AC_AUTOCONF_VERSION]))])
+
+# AM_AUX_DIR_EXPAND -*- Autoconf -*-
+
+# Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets
+# $ac_aux_dir to `$srcdir/foo'. In other projects, it is set to
+# `$srcdir', `$srcdir/..', or `$srcdir/../..'.
+#
+# Of course, Automake must honor this variable whenever it calls a
+# tool from the auxiliary directory. The problem is that $srcdir (and
+# therefore $ac_aux_dir as well) can be either absolute or relative,
+# depending on how configure is run. This is pretty annoying, since
+# it makes $ac_aux_dir quite unusable in subdirectories: in the top
+# source directory, any form will work fine, but in subdirectories a
+# relative path needs to be adjusted first.
+#
+# $ac_aux_dir/missing
+# fails when called from a subdirectory if $ac_aux_dir is relative
+# $top_srcdir/$ac_aux_dir/missing
+# fails if $ac_aux_dir is absolute,
+# fails when called from a subdirectory in a VPATH build with
+# a relative $ac_aux_dir
+#
+# The reason of the latter failure is that $top_srcdir and $ac_aux_dir
+# are both prefixed by $srcdir. In an in-source build this is usually
+# harmless because $srcdir is `.', but things will broke when you
+# start a VPATH build or use an absolute $srcdir.
+#
+# So we could use something similar to $top_srcdir/$ac_aux_dir/missing,
+# iff we strip the leading $srcdir from $ac_aux_dir. That would be:
+# am_aux_dir='\$(top_srcdir)/'`expr "$ac_aux_dir" : "$srcdir//*\(.*\)"`
+# and then we would define $MISSING as
+# MISSING="\${SHELL} $am_aux_dir/missing"
+# This will work as long as MISSING is not called from configure, because
+# unfortunately $(top_srcdir) has no meaning in configure.
+# However there are other variables, like CC, which are often used in
+# configure, and could therefore not use this "fixed" $ac_aux_dir.
+#
+# Another solution, used here, is to always expand $ac_aux_dir to an
+# absolute PATH. The drawback is that using absolute paths prevent a
+# configured tree to be moved without reconfiguration.
+
+AC_DEFUN([AM_AUX_DIR_EXPAND],
+[dnl Rely on autoconf to set up CDPATH properly.
+AC_PREREQ([2.50])dnl
+# expand $ac_aux_dir to an absolute path
+am_aux_dir=`cd $ac_aux_dir && pwd`
+])
+
+# AM_CONDITIONAL -*- Autoconf -*-
+
+# Copyright (C) 1997, 2000, 2001, 2003, 2004, 2005, 2006, 2008
+# Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 9
+
+# AM_CONDITIONAL(NAME, SHELL-CONDITION)
+# -------------------------------------
+# Define a conditional.
+AC_DEFUN([AM_CONDITIONAL],
+[AC_PREREQ(2.52)dnl
+ ifelse([$1], [TRUE], [AC_FATAL([$0: invalid condition: $1])],
+ [$1], [FALSE], [AC_FATAL([$0: invalid condition: $1])])dnl
+AC_SUBST([$1_TRUE])dnl
+AC_SUBST([$1_FALSE])dnl
+_AM_SUBST_NOTMAKE([$1_TRUE])dnl
+_AM_SUBST_NOTMAKE([$1_FALSE])dnl
+m4_define([_AM_COND_VALUE_$1], [$2])dnl
+if $2; then
+ $1_TRUE=
+ $1_FALSE='#'
+else
+ $1_TRUE='#'
+ $1_FALSE=
+fi
+AC_CONFIG_COMMANDS_PRE(
+[if test -z "${$1_TRUE}" && test -z "${$1_FALSE}"; then
+ AC_MSG_ERROR([[conditional "$1" was never defined.
+Usually this means the macro was only invoked conditionally.]])
+fi])])
+
+# Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2009
+# Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 10
+
+# There are a few dirty hacks below to avoid letting `AC_PROG_CC' be
+# written in clear, in which case automake, when reading aclocal.m4,
+# will think it sees a *use*, and therefore will trigger all it's
+# C support machinery. Also note that it means that autoscan, seeing
+# CC etc. in the Makefile, will ask for an AC_PROG_CC use...
+
+
+# _AM_DEPENDENCIES(NAME)
+# ----------------------
+# See how the compiler implements dependency checking.
+# NAME is "CC", "CXX", "GCJ", or "OBJC".
+# We try a few techniques and use that to set a single cache variable.
+#
+# We don't AC_REQUIRE the corresponding AC_PROG_CC since the latter was
+# modified to invoke _AM_DEPENDENCIES(CC); we would have a circular
+# dependency, and given that the user is not expected to run this macro,
+# just rely on AC_PROG_CC.
+AC_DEFUN([_AM_DEPENDENCIES],
+[AC_REQUIRE([AM_SET_DEPDIR])dnl
+AC_REQUIRE([AM_OUTPUT_DEPENDENCY_COMMANDS])dnl
+AC_REQUIRE([AM_MAKE_INCLUDE])dnl
+AC_REQUIRE([AM_DEP_TRACK])dnl
+
+ifelse([$1], CC, [depcc="$CC" am_compiler_list=],
+ [$1], CXX, [depcc="$CXX" am_compiler_list=],
+ [$1], OBJC, [depcc="$OBJC" am_compiler_list='gcc3 gcc'],
+ [$1], UPC, [depcc="$UPC" am_compiler_list=],
+ [$1], GCJ, [depcc="$GCJ" am_compiler_list='gcc3 gcc'],
+ [depcc="$$1" am_compiler_list=])
+
+AC_CACHE_CHECK([dependency style of $depcc],
+ [am_cv_$1_dependencies_compiler_type],
+[if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then
+ # We make a subdir and do the tests there. Otherwise we can end up
+ # making bogus files that we don't know about and never remove. For
+ # instance it was reported that on HP-UX the gcc test will end up
+ # making a dummy file named `D' -- because `-MD' means `put the output
+ # in D'.
+ mkdir conftest.dir
+ # Copy depcomp to subdir because otherwise we won't find it if we're
+ # using a relative directory.
+ cp "$am_depcomp" conftest.dir
+ cd conftest.dir
+ # We will build objects and dependencies in a subdirectory because
+ # it helps to detect inapplicable dependency modes. For instance
+ # both Tru64's cc and ICC support -MD to output dependencies as a
+ # side effect of compilation, but ICC will put the dependencies in
+ # the current directory while Tru64 will put them in the object
+ # directory.
+ mkdir sub
+
+ am_cv_$1_dependencies_compiler_type=none
+ if test "$am_compiler_list" = ""; then
+ am_compiler_list=`sed -n ['s/^#*\([a-zA-Z0-9]*\))$/\1/p'] < ./depcomp`
+ fi
+ am__universal=false
+ m4_case([$1], [CC],
+ [case " $depcc " in #(
+ *\ -arch\ *\ -arch\ *) am__universal=true ;;
+ esac],
+ [CXX],
+ [case " $depcc " in #(
+ *\ -arch\ *\ -arch\ *) am__universal=true ;;
+ esac])
+
+ for depmode in $am_compiler_list; do
+ # Setup a source with many dependencies, because some compilers
+ # like to wrap large dependency lists on column 80 (with \), and
+ # we should not choose a depcomp mode which is confused by this.
+ #
+ # We need to recreate these files for each test, as the compiler may
+ # overwrite some of them when testing with obscure command lines.
+ # This happens at least with the AIX C compiler.
+ : > sub/conftest.c
+ for i in 1 2 3 4 5 6; do
+ echo '#include "conftst'$i'.h"' >> sub/conftest.c
+ # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with
+ # Solaris 8's {/usr,}/bin/sh.
+ touch sub/conftst$i.h
+ done
+ echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf
+
+ # We check with `-c' and `-o' for the sake of the "dashmstdout"
+ # mode. It turns out that the SunPro C++ compiler does not properly
+ # handle `-M -o', and we need to detect this. Also, some Intel
+ # versions had trouble with output in subdirs
+ am__obj=sub/conftest.${OBJEXT-o}
+ am__minus_obj="-o $am__obj"
+ case $depmode in
+ gcc)
+ # This depmode causes a compiler race in universal mode.
+ test "$am__universal" = false || continue
+ ;;
+ nosideeffect)
+ # after this tag, mechanisms are not by side-effect, so they'll
+ # only be used when explicitly requested
+ if test "x$enable_dependency_tracking" = xyes; then
+ continue
+ else
+ break
+ fi
+ ;;
+ msvisualcpp | msvcmsys)
+ # This compiler won't grok `-c -o', but also, the minuso test has
+ # not run yet. These depmodes are late enough in the game, and
+ # so weak that their functioning should not be impacted.
+ am__obj=conftest.${OBJEXT-o}
+ am__minus_obj=
+ ;;
+ none) break ;;
+ esac
+ if depmode=$depmode \
+ source=sub/conftest.c object=$am__obj \
+ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \
+ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \
+ >/dev/null 2>conftest.err &&
+ grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 &&
+ grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 &&
+ grep $am__obj sub/conftest.Po > /dev/null 2>&1 &&
+ ${MAKE-make} -s -f confmf > /dev/null 2>&1; then
+ # icc doesn't choke on unknown options, it will just issue warnings
+ # or remarks (even with -Werror). So we grep stderr for any message
+ # that says an option was ignored or not supported.
+ # When given -MP, icc 7.0 and 7.1 complain thusly:
+ # icc: Command line warning: ignoring option '-M'; no argument required
+ # The diagnosis changed in icc 8.0:
+ # icc: Command line remark: option '-MP' not supported
+ if (grep 'ignoring option' conftest.err ||
+ grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else
+ am_cv_$1_dependencies_compiler_type=$depmode
+ break
+ fi
+ fi
+ done
+
+ cd ..
+ rm -rf conftest.dir
+else
+ am_cv_$1_dependencies_compiler_type=none
+fi
+])
+AC_SUBST([$1DEPMODE], [depmode=$am_cv_$1_dependencies_compiler_type])
+AM_CONDITIONAL([am__fastdep$1], [
+ test "x$enable_dependency_tracking" != xno \
+ && test "$am_cv_$1_dependencies_compiler_type" = gcc3])
+])
+
+
+# AM_SET_DEPDIR
+# -------------
+# Choose a directory name for dependency files.
+# This macro is AC_REQUIREd in _AM_DEPENDENCIES
+AC_DEFUN([AM_SET_DEPDIR],
+[AC_REQUIRE([AM_SET_LEADING_DOT])dnl
+AC_SUBST([DEPDIR], ["${am__leading_dot}deps"])dnl
+])
+
+
+# AM_DEP_TRACK
+# ------------
+AC_DEFUN([AM_DEP_TRACK],
+[AC_ARG_ENABLE(dependency-tracking,
+[ --disable-dependency-tracking speeds up one-time build
+ --enable-dependency-tracking do not reject slow dependency extractors])
+if test "x$enable_dependency_tracking" != xno; then
+ am_depcomp="$ac_aux_dir/depcomp"
+ AMDEPBACKSLASH='\'
+fi
+AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno])
+AC_SUBST([AMDEPBACKSLASH])dnl
+_AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl
+])
+
+# Generate code to set up dependency tracking. -*- Autoconf -*-
+
+# Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2008
+# Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+#serial 5
+
+# _AM_OUTPUT_DEPENDENCY_COMMANDS
+# ------------------------------
+AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS],
+[{
+ # Autoconf 2.62 quotes --file arguments for eval, but not when files
+ # are listed without --file. Let's play safe and only enable the eval
+ # if we detect the quoting.
+ case $CONFIG_FILES in
+ *\'*) eval set x "$CONFIG_FILES" ;;
+ *) set x $CONFIG_FILES ;;
+ esac
+ shift
+ for mf
+ do
+ # Strip MF so we end up with the name of the file.
+ mf=`echo "$mf" | sed -e 's/:.*$//'`
+ # Check whether this is an Automake generated Makefile or not.
+ # We used to match only the files named `Makefile.in', but
+ # some people rename them; so instead we look at the file content.
+ # Grep'ing the first line is not enough: some people post-process
+ # each Makefile.in and add a new line on top of each file to say so.
+ # Grep'ing the whole file is not good either: AIX grep has a line
+ # limit of 2048, but all sed's we know have understand at least 4000.
+ if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then
+ dirpart=`AS_DIRNAME("$mf")`
+ else
+ continue
+ fi
+ # Extract the definition of DEPDIR, am__include, and am__quote
+ # from the Makefile without running `make'.
+ DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"`
+ test -z "$DEPDIR" && continue
+ am__include=`sed -n 's/^am__include = //p' < "$mf"`
+ test -z "am__include" && continue
+ am__quote=`sed -n 's/^am__quote = //p' < "$mf"`
+ # When using ansi2knr, U may be empty or an underscore; expand it
+ U=`sed -n 's/^U = //p' < "$mf"`
+ # Find all dependency output files, they are included files with
+ # $(DEPDIR) in their names. We invoke sed twice because it is the
+ # simplest approach to changing $(DEPDIR) to its actual value in the
+ # expansion.
+ for file in `sed -n "
+ s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \
+ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do
+ # Make sure the directory exists.
+ test -f "$dirpart/$file" && continue
+ fdir=`AS_DIRNAME(["$file"])`
+ AS_MKDIR_P([$dirpart/$fdir])
+ # echo "creating $dirpart/$file"
+ echo '# dummy' > "$dirpart/$file"
+ done
+ done
+}
+])# _AM_OUTPUT_DEPENDENCY_COMMANDS
+
+
+# AM_OUTPUT_DEPENDENCY_COMMANDS
+# -----------------------------
+# This macro should only be invoked once -- use via AC_REQUIRE.
+#
+# This code is only required when automatic dependency tracking
+# is enabled. FIXME. This creates each `.P' file that we will
+# need in order to bootstrap the dependency handling code.
+AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS],
+[AC_CONFIG_COMMANDS([depfiles],
+ [test x"$AMDEP_TRUE" != x"" || _AM_OUTPUT_DEPENDENCY_COMMANDS],
+ [AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir"])
+])
+
+# Do all the work for Automake. -*- Autoconf -*-
+
+# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 16
+
+# This macro actually does too much. Some checks are only needed if
+# your package does certain things. But this isn't really a big deal.
+
+# AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE])
+# AM_INIT_AUTOMAKE([OPTIONS])
+# -----------------------------------------------
+# The call with PACKAGE and VERSION arguments is the old style
+# call (pre autoconf-2.50), which is being phased out. PACKAGE
+# and VERSION should now be passed to AC_INIT and removed from
+# the call to AM_INIT_AUTOMAKE.
+# We support both call styles for the transition. After
+# the next Automake release, Autoconf can make the AC_INIT
+# arguments mandatory, and then we can depend on a new Autoconf
+# release and drop the old call support.
+AC_DEFUN([AM_INIT_AUTOMAKE],
+[AC_PREREQ([2.62])dnl
+dnl Autoconf wants to disallow AM_ names. We explicitly allow
+dnl the ones we care about.
+m4_pattern_allow([^AM_[A-Z]+FLAGS$])dnl
+AC_REQUIRE([AM_SET_CURRENT_AUTOMAKE_VERSION])dnl
+AC_REQUIRE([AC_PROG_INSTALL])dnl
+if test "`cd $srcdir && pwd`" != "`pwd`"; then
+ # Use -I$(srcdir) only when $(srcdir) != ., so that make's output
+ # is not polluted with repeated "-I."
+ AC_SUBST([am__isrc], [' -I$(srcdir)'])_AM_SUBST_NOTMAKE([am__isrc])dnl
+ # test to see if srcdir already configured
+ if test -f $srcdir/config.status; then
+ AC_MSG_ERROR([source directory already configured; run "make distclean" there first])
+ fi
+fi
+
+# test whether we have cygpath
+if test -z "$CYGPATH_W"; then
+ if (cygpath --version) >/dev/null 2>/dev/null; then
+ CYGPATH_W='cygpath -w'
+ else
+ CYGPATH_W=echo
+ fi
+fi
+AC_SUBST([CYGPATH_W])
+
+# Define the identity of the package.
+dnl Distinguish between old-style and new-style calls.
+m4_ifval([$2],
+[m4_ifval([$3], [_AM_SET_OPTION([no-define])])dnl
+ AC_SUBST([PACKAGE], [$1])dnl
+ AC_SUBST([VERSION], [$2])],
+[_AM_SET_OPTIONS([$1])dnl
+dnl Diagnose old-style AC_INIT with new-style AM_AUTOMAKE_INIT.
+m4_if(m4_ifdef([AC_PACKAGE_NAME], 1)m4_ifdef([AC_PACKAGE_VERSION], 1), 11,,
+ [m4_fatal([AC_INIT should be called with package and version arguments])])dnl
+ AC_SUBST([PACKAGE], ['AC_PACKAGE_TARNAME'])dnl
+ AC_SUBST([VERSION], ['AC_PACKAGE_VERSION'])])dnl
+
+_AM_IF_OPTION([no-define],,
+[AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE", [Name of package])
+ AC_DEFINE_UNQUOTED(VERSION, "$VERSION", [Version number of package])])dnl
+
+# Some tools Automake needs.
+AC_REQUIRE([AM_SANITY_CHECK])dnl
+AC_REQUIRE([AC_ARG_PROGRAM])dnl
+AM_MISSING_PROG(ACLOCAL, aclocal-${am__api_version})
+AM_MISSING_PROG(AUTOCONF, autoconf)
+AM_MISSING_PROG(AUTOMAKE, automake-${am__api_version})
+AM_MISSING_PROG(AUTOHEADER, autoheader)
+AM_MISSING_PROG(MAKEINFO, makeinfo)
+AC_REQUIRE([AM_PROG_INSTALL_SH])dnl
+AC_REQUIRE([AM_PROG_INSTALL_STRIP])dnl
+AC_REQUIRE([AM_PROG_MKDIR_P])dnl
+# We need awk for the "check" target. The system "awk" is bad on
+# some platforms.
+AC_REQUIRE([AC_PROG_AWK])dnl
+AC_REQUIRE([AC_PROG_MAKE_SET])dnl
+AC_REQUIRE([AM_SET_LEADING_DOT])dnl
+_AM_IF_OPTION([tar-ustar], [_AM_PROG_TAR([ustar])],
+ [_AM_IF_OPTION([tar-pax], [_AM_PROG_TAR([pax])],
+ [_AM_PROG_TAR([v7])])])
+_AM_IF_OPTION([no-dependencies],,
+[AC_PROVIDE_IFELSE([AC_PROG_CC],
+ [_AM_DEPENDENCIES(CC)],
+ [define([AC_PROG_CC],
+ defn([AC_PROG_CC])[_AM_DEPENDENCIES(CC)])])dnl
+AC_PROVIDE_IFELSE([AC_PROG_CXX],
+ [_AM_DEPENDENCIES(CXX)],
+ [define([AC_PROG_CXX],
+ defn([AC_PROG_CXX])[_AM_DEPENDENCIES(CXX)])])dnl
+AC_PROVIDE_IFELSE([AC_PROG_OBJC],
+ [_AM_DEPENDENCIES(OBJC)],
+ [define([AC_PROG_OBJC],
+ defn([AC_PROG_OBJC])[_AM_DEPENDENCIES(OBJC)])])dnl
+])
+_AM_IF_OPTION([silent-rules], [AC_REQUIRE([AM_SILENT_RULES])])dnl
+dnl The `parallel-tests' driver may need to know about EXEEXT, so add the
+dnl `am__EXEEXT' conditional if _AM_COMPILER_EXEEXT was seen. This macro
+dnl is hooked onto _AC_COMPILER_EXEEXT early, see below.
+AC_CONFIG_COMMANDS_PRE(dnl
+[m4_provide_if([_AM_COMPILER_EXEEXT],
+ [AM_CONDITIONAL([am__EXEEXT], [test -n "$EXEEXT"])])])dnl
+])
+
+dnl Hook into `_AC_COMPILER_EXEEXT' early to learn its expansion. Do not
+dnl add the conditional right here, as _AC_COMPILER_EXEEXT may be further
+dnl mangled by Autoconf and run in a shell conditional statement.
+m4_define([_AC_COMPILER_EXEEXT],
+m4_defn([_AC_COMPILER_EXEEXT])[m4_provide([_AM_COMPILER_EXEEXT])])
+
+
+# When config.status generates a header, we must update the stamp-h file.
+# This file resides in the same directory as the config header
+# that is generated. The stamp files are numbered to have different names.
+
+# Autoconf calls _AC_AM_CONFIG_HEADER_HOOK (when defined) in the
+# loop where config.status creates the headers, so we can generate
+# our stamp files there.
+AC_DEFUN([_AC_AM_CONFIG_HEADER_HOOK],
+[# Compute $1's index in $config_headers.
+_am_arg=$1
+_am_stamp_count=1
+for _am_header in $config_headers :; do
+ case $_am_header in
+ $_am_arg | $_am_arg:* )
+ break ;;
+ * )
+ _am_stamp_count=`expr $_am_stamp_count + 1` ;;
+ esac
+done
+echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count])
+
+# Copyright (C) 2001, 2003, 2005, 2008 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_PROG_INSTALL_SH
+# ------------------
+# Define $install_sh.
+AC_DEFUN([AM_PROG_INSTALL_SH],
+[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl
+if test x"${install_sh}" != xset; then
+ case $am_aux_dir in
+ *\ * | *\ *)
+ install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;;
+ *)
+ install_sh="\${SHELL} $am_aux_dir/install-sh"
+ esac
+fi
+AC_SUBST(install_sh)])
+
+# Copyright (C) 2003, 2005 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 2
+
+# Check whether the underlying file-system supports filenames
+# with a leading dot. For instance MS-DOS doesn't.
+AC_DEFUN([AM_SET_LEADING_DOT],
+[rm -rf .tst 2>/dev/null
+mkdir .tst 2>/dev/null
+if test -d .tst; then
+ am__leading_dot=.
+else
+ am__leading_dot=_
+fi
+rmdir .tst 2>/dev/null
+AC_SUBST([am__leading_dot])])
+
+# Check to see how 'make' treats includes. -*- Autoconf -*-
+
+# Copyright (C) 2001, 2002, 2003, 2005, 2009 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 4
+
+# AM_MAKE_INCLUDE()
+# -----------------
+# Check to see how make treats includes.
+AC_DEFUN([AM_MAKE_INCLUDE],
+[am_make=${MAKE-make}
+cat > confinc << 'END'
+am__doit:
+ @echo this is the am__doit target
+.PHONY: am__doit
+END
+# If we don't find an include directive, just comment out the code.
+AC_MSG_CHECKING([for style of include used by $am_make])
+am__include="#"
+am__quote=
+_am_result=none
+# First try GNU make style include.
+echo "include confinc" > confmf
+# Ignore all kinds of additional output from `make'.
+case `$am_make -s -f confmf 2> /dev/null` in #(
+*the\ am__doit\ target*)
+ am__include=include
+ am__quote=
+ _am_result=GNU
+ ;;
+esac
+# Now try BSD make style include.
+if test "$am__include" = "#"; then
+ echo '.include "confinc"' > confmf
+ case `$am_make -s -f confmf 2> /dev/null` in #(
+ *the\ am__doit\ target*)
+ am__include=.include
+ am__quote="\""
+ _am_result=BSD
+ ;;
+ esac
+fi
+AC_SUBST([am__include])
+AC_SUBST([am__quote])
+AC_MSG_RESULT([$_am_result])
+rm -f confinc confmf
+])
+
+# Fake the existence of programs that GNU maintainers use. -*- Autoconf -*-
+
+# Copyright (C) 1997, 1999, 2000, 2001, 2003, 2004, 2005, 2008
+# Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 6
+
+# AM_MISSING_PROG(NAME, PROGRAM)
+# ------------------------------
+AC_DEFUN([AM_MISSING_PROG],
+[AC_REQUIRE([AM_MISSING_HAS_RUN])
+$1=${$1-"${am_missing_run}$2"}
+AC_SUBST($1)])
+
+
+# AM_MISSING_HAS_RUN
+# ------------------
+# Define MISSING if not defined so far and test if it supports --run.
+# If it does, set am_missing_run to use it, otherwise, to nothing.
+AC_DEFUN([AM_MISSING_HAS_RUN],
+[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl
+AC_REQUIRE_AUX_FILE([missing])dnl
+if test x"${MISSING+set}" != xset; then
+ case $am_aux_dir in
+ *\ * | *\ *)
+ MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;;
+ *)
+ MISSING="\${SHELL} $am_aux_dir/missing" ;;
+ esac
+fi
+# Use eval to expand $SHELL
+if eval "$MISSING --run true"; then
+ am_missing_run="$MISSING --run "
+else
+ am_missing_run=
+ AC_MSG_WARN([`missing' script is too old or missing])
+fi
+])
+
+# Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_PROG_MKDIR_P
+# ---------------
+# Check for `mkdir -p'.
+AC_DEFUN([AM_PROG_MKDIR_P],
+[AC_PREREQ([2.60])dnl
+AC_REQUIRE([AC_PROG_MKDIR_P])dnl
+dnl Automake 1.8 to 1.9.6 used to define mkdir_p. We now use MKDIR_P,
+dnl while keeping a definition of mkdir_p for backward compatibility.
+dnl @MKDIR_P@ is magic: AC_OUTPUT adjusts its value for each Makefile.
+dnl However we cannot define mkdir_p as $(MKDIR_P) for the sake of
+dnl Makefile.ins that do not define MKDIR_P, so we do our own
+dnl adjustment using top_builddir (which is defined more often than
+dnl MKDIR_P).
+AC_SUBST([mkdir_p], ["$MKDIR_P"])dnl
+case $mkdir_p in
+ [[\\/$]]* | ?:[[\\/]]*) ;;
+ */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;;
+esac
+])
+
+# Helper functions for option handling. -*- Autoconf -*-
+
+# Copyright (C) 2001, 2002, 2003, 2005, 2008 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 4
+
+# _AM_MANGLE_OPTION(NAME)
+# -----------------------
+AC_DEFUN([_AM_MANGLE_OPTION],
+[[_AM_OPTION_]m4_bpatsubst($1, [[^a-zA-Z0-9_]], [_])])
+
+# _AM_SET_OPTION(NAME)
+# ------------------------------
+# Set option NAME. Presently that only means defining a flag for this option.
+AC_DEFUN([_AM_SET_OPTION],
+[m4_define(_AM_MANGLE_OPTION([$1]), 1)])
+
+# _AM_SET_OPTIONS(OPTIONS)
+# ----------------------------------
+# OPTIONS is a space-separated list of Automake options.
+AC_DEFUN([_AM_SET_OPTIONS],
+[m4_foreach_w([_AM_Option], [$1], [_AM_SET_OPTION(_AM_Option)])])
+
+# _AM_IF_OPTION(OPTION, IF-SET, [IF-NOT-SET])
+# -------------------------------------------
+# Execute IF-SET if OPTION is set, IF-NOT-SET otherwise.
+AC_DEFUN([_AM_IF_OPTION],
+[m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])])
+
+# Check to make sure that the build environment is sane. -*- Autoconf -*-
+
+# Copyright (C) 1996, 1997, 2000, 2001, 2003, 2005, 2008
+# Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 5
+
+# AM_SANITY_CHECK
+# ---------------
+AC_DEFUN([AM_SANITY_CHECK],
+[AC_MSG_CHECKING([whether build environment is sane])
+# Just in case
+sleep 1
+echo timestamp > conftest.file
+# Reject unsafe characters in $srcdir or the absolute working directory
+# name. Accept space and tab only in the latter.
+am_lf='
+'
+case `pwd` in
+ *[[\\\"\#\$\&\'\`$am_lf]]*)
+ AC_MSG_ERROR([unsafe absolute working directory name]);;
+esac
+case $srcdir in
+ *[[\\\"\#\$\&\'\`$am_lf\ \ ]]*)
+ AC_MSG_ERROR([unsafe srcdir value: `$srcdir']);;
+esac
+
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments. Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+ set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null`
+ if test "$[*]" = "X"; then
+ # -L didn't work.
+ set X `ls -t "$srcdir/configure" conftest.file`
+ fi
+ rm -f conftest.file
+ if test "$[*]" != "X $srcdir/configure conftest.file" \
+ && test "$[*]" != "X conftest.file $srcdir/configure"; then
+
+ # If neither matched, then we have a broken ls. This can happen
+ # if, for instance, CONFIG_SHELL is bash and it inherits a
+ # broken ls alias from the environment. This has actually
+ # happened. Such a system could not be considered "sane".
+ AC_MSG_ERROR([ls -t appears to fail. Make sure there is not a broken
+alias in your environment])
+ fi
+
+ test "$[2]" = conftest.file
+ )
+then
+ # Ok.
+ :
+else
+ AC_MSG_ERROR([newly created file is older than distributed files!
+Check your system clock])
+fi
+AC_MSG_RESULT(yes)])
+
+# Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_PROG_INSTALL_STRIP
+# ---------------------
+# One issue with vendor `install' (even GNU) is that you can't
+# specify the program used to strip binaries. This is especially
+# annoying in cross-compiling environments, where the build's strip
+# is unlikely to handle the host's binaries.
+# Fortunately install-sh will honor a STRIPPROG variable, so we
+# always use install-sh in `make install-strip', and initialize
+# STRIPPROG with the value of the STRIP variable (set by the user).
+AC_DEFUN([AM_PROG_INSTALL_STRIP],
+[AC_REQUIRE([AM_PROG_INSTALL_SH])dnl
+# Installed binaries are usually stripped using `strip' when the user
+# run `make install-strip'. However `strip' might not be the right
+# tool to use in cross-compilation environments, therefore Automake
+# will honor the `STRIP' environment variable to overrule this program.
+dnl Don't test for $cross_compiling = yes, because it might be `maybe'.
+if test "$cross_compiling" != no; then
+ AC_CHECK_TOOL([STRIP], [strip], :)
+fi
+INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s"
+AC_SUBST([INSTALL_STRIP_PROGRAM])])
+
+# Copyright (C) 2006, 2008 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 2
+
+# _AM_SUBST_NOTMAKE(VARIABLE)
+# ---------------------------
+# Prevent Automake from outputting VARIABLE = @VARIABLE@ in Makefile.in.
+# This macro is traced by Automake.
+AC_DEFUN([_AM_SUBST_NOTMAKE])
+
+# AM_SUBST_NOTMAKE(VARIABLE)
+# ---------------------------
+# Public sister of _AM_SUBST_NOTMAKE.
+AC_DEFUN([AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE($@)])
+
+# Check how to create a tarball. -*- Autoconf -*-
+
+# Copyright (C) 2004, 2005 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 2
+
+# _AM_PROG_TAR(FORMAT)
+# --------------------
+# Check how to create a tarball in format FORMAT.
+# FORMAT should be one of `v7', `ustar', or `pax'.
+#
+# Substitute a variable $(am__tar) that is a command
+# writing to stdout a FORMAT-tarball containing the directory
+# $tardir.
+# tardir=directory && $(am__tar) > result.tar
+#
+# Substitute a variable $(am__untar) that extract such
+# a tarball read from stdin.
+# $(am__untar) < result.tar
+AC_DEFUN([_AM_PROG_TAR],
+[# Always define AMTAR for backward compatibility.
+AM_MISSING_PROG([AMTAR], [tar])
+m4_if([$1], [v7],
+ [am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -'],
+ [m4_case([$1], [ustar],, [pax],,
+ [m4_fatal([Unknown tar format])])
+AC_MSG_CHECKING([how to create a $1 tar archive])
+# Loop over all known methods to create a tar archive until one works.
+_am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none'
+_am_tools=${am_cv_prog_tar_$1-$_am_tools}
+# Do not fold the above two line into one, because Tru64 sh and
+# Solaris sh will not grok spaces in the rhs of `-'.
+for _am_tool in $_am_tools
+do
+ case $_am_tool in
+ gnutar)
+ for _am_tar in tar gnutar gtar;
+ do
+ AM_RUN_LOG([$_am_tar --version]) && break
+ done
+ am__tar="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$$tardir"'
+ am__tar_="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$tardir"'
+ am__untar="$_am_tar -xf -"
+ ;;
+ plaintar)
+ # Must skip GNU tar: if it does not support --format= it doesn't create
+ # ustar tarball either.
+ (tar --version) >/dev/null 2>&1 && continue
+ am__tar='tar chf - "$$tardir"'
+ am__tar_='tar chf - "$tardir"'
+ am__untar='tar xf -'
+ ;;
+ pax)
+ am__tar='pax -L -x $1 -w "$$tardir"'
+ am__tar_='pax -L -x $1 -w "$tardir"'
+ am__untar='pax -r'
+ ;;
+ cpio)
+ am__tar='find "$$tardir" -print | cpio -o -H $1 -L'
+ am__tar_='find "$tardir" -print | cpio -o -H $1 -L'
+ am__untar='cpio -i -H $1 -d'
+ ;;
+ none)
+ am__tar=false
+ am__tar_=false
+ am__untar=false
+ ;;
+ esac
+
+ # If the value was cached, stop now. We just wanted to have am__tar
+ # and am__untar set.
+ test -n "${am_cv_prog_tar_$1}" && break
+
+ # tar/untar a dummy directory, and stop if the command works
+ rm -rf conftest.dir
+ mkdir conftest.dir
+ echo GrepMe > conftest.dir/file
+ AM_RUN_LOG([tardir=conftest.dir && eval $am__tar_ >conftest.tar])
+ rm -rf conftest.dir
+ if test -s conftest.tar; then
+ AM_RUN_LOG([$am__untar <conftest.tar])
+ grep GrepMe conftest.dir/file >/dev/null 2>&1 && break
+ fi
+done
+rm -rf conftest.dir
+
+AC_CACHE_VAL([am_cv_prog_tar_$1], [am_cv_prog_tar_$1=$_am_tool])
+AC_MSG_RESULT([$am_cv_prog_tar_$1])])
+AC_SUBST([am__tar])
+AC_SUBST([am__untar])
+]) # _AM_PROG_TAR
+
+m4_include([m4/libtool.m4])
+m4_include([m4/ltoptions.m4])
+m4_include([m4/ltsugar.m4])
+m4_include([m4/ltversion.m4])
+m4_include([m4/lt~obsolete.m4])
+m4_include([acinclude.m4])
diff --git a/autogen.sh b/autogen.sh
new file mode 100755
index 0000000..2d8179c
--- /dev/null
+++ b/autogen.sh
@@ -0,0 +1,6 @@
+#!/bin/sh -e
+test -n "$srcdir" || srcdir=`dirname "$0"`
+test -n "$srcdir" || srcdir=.
+
+autoreconf --force --install --verbose "$srcdir"
+test -n "$NOCONFIGURE" || "$srcdir/configure" "$@"
diff --git a/avh_olo-2.2.1/Makefile.am b/avh_olo-2.2.1/Makefile.am
new file mode 100644
index 0000000..80edacc
--- /dev/null
+++ b/avh_olo-2.2.1/Makefile.am
@@ -0,0 +1,28 @@
+lib_LTLIBRARIES=libavh_olo.la
+libavh_olo_la_SOURCES= avh_olo_boxc.f90 avh_olo_box.f90 avh_olo_bub.f90 \
+ avh_olo_func.f90 avh_olo_kinds.f90 avh_olo_main.f90 avh_olo_print.f90 \
+ avh_olo_tri.f90 avh_olo_units.f90 avh_olo_wrp01.f90 avh_olo_xkind.f90
+
+noinst_HEADERS=\
+ avh_olo_a0_a.h90 avh_olo_a0_b.h90 avh_olo_b0_a.h90 avh_olo_b0_b.h90 \
+ avh_olo_b11_a.h90 avh_olo_b11_b.h90 avh_olo_c0_a.h90 avh_olo_c0_b.h90 \
+ avh_olo_d0_a.h90 avh_olo_d0_b.h90
+nodist_pkginclude_HEADERS=\
+ avh_olo_bern.mod avh_olo_boxc.mod avh_olo_box.mod avh_olo_bub.mod \
+ avh_olo_func.mod avh_olo_kinds.mod avh_olo_li2a.mod avh_olo_li2c2.mod \
+ avh_olo_li2c.mod avh_olo_loga2.mod avh_olo_loga.mod avh_olo_logc2.mod \
+ avh_olo_logc.mod avh_olo.mod avh_olo_print.mod avh_olo_tri.mod \
+ avh_olo_units.mod avh_olo_xkind.mod
+
+CLEANFILES=$(nodist_pkginclude_HEADERS)
+
+include Makefile.dep
+
+avh_olo_func.mod avh_olo_loga.mod avh_olo_bern.mod avh_olo_li2a.mod \
+avh_olo_loga2.mod avh_olo_logc.mod avh_olo_li2c.mod avh_olo_logc2.mod \
+avh_olo_li2c2.mod: avh_olo_func.o
+
+avh_olo.mod: $(nodist_pkginclude_HEADERS:avh_olo.mod=)
+
+%.mod: %.o %.f90
+ @true
diff --git a/avh_olo-2.2.1/Makefile.dep b/avh_olo-2.2.1/Makefile.dep
new file mode 100644
index 0000000..42bbfa2
--- /dev/null
+++ b/avh_olo-2.2.1/Makefile.dep
@@ -0,0 +1,42 @@
+# Module dependencies
+avh_olo_box.o: avh_olo_func.o avh_olo_kinds.o avh_olo_units.o
+avh_olo_box.lo: avh_olo_func.lo avh_olo_kinds.lo avh_olo_units.lo
+avh_olo_box.obj: avh_olo_func.obj avh_olo_kinds.obj avh_olo_units.obj
+avh_olo_boxc.o: avh_olo_box.o avh_olo_func.o avh_olo_kinds.o avh_olo_units.o
+avh_olo_boxc.lo: avh_olo_box.lo avh_olo_func.lo avh_olo_kinds.lo \
+ avh_olo_units.lo
+avh_olo_boxc.obj: avh_olo_box.obj avh_olo_func.obj avh_olo_kinds.obj \
+ avh_olo_units.obj
+avh_olo_bub.o: avh_olo_func.o avh_olo_kinds.o avh_olo_units.o
+avh_olo_bub.lo: avh_olo_func.lo avh_olo_kinds.lo avh_olo_units.lo
+avh_olo_bub.obj: avh_olo_func.obj avh_olo_kinds.obj avh_olo_units.obj
+avh_olo_func.o: avh_olo_kinds.o avh_olo_units.o
+avh_olo_func.lo: avh_olo_kinds.lo avh_olo_units.lo
+avh_olo_func.obj: avh_olo_kinds.obj avh_olo_units.obj
+avh_olo_kinds.o: avh_olo_xkind.o
+avh_olo_kinds.lo: avh_olo_xkind.lo
+avh_olo_kinds.obj: avh_olo_xkind.obj
+avh_olo_main.o: avh_olo_box.o avh_olo_boxc.o avh_olo_bub.o avh_olo_func.o \
+ avh_olo_kinds.o avh_olo_print.o avh_olo_tri.o avh_olo_units.o \
+ avh_olo_a0_a.h90 avh_olo_a0_b.h90 avh_olo_b0_a.h90 avh_olo_b0_b.h90 \
+ avh_olo_b11_a.h90 avh_olo_b11_b.h90 avh_olo_c0_a.h90 avh_olo_c0_b.h90 \
+ avh_olo_d0_a.h90 avh_olo_d0_b.h90
+avh_olo_main.lo: avh_olo_box.lo avh_olo_boxc.lo avh_olo_bub.lo avh_olo_func.lo \
+ avh_olo_kinds.lo avh_olo_print.lo avh_olo_tri.lo avh_olo_units.lo \
+ avh_olo_a0_a.h90 avh_olo_a0_b.h90 avh_olo_b0_a.h90 avh_olo_b0_b.h90 \
+ avh_olo_b11_a.h90 avh_olo_b11_b.h90 avh_olo_c0_a.h90 avh_olo_c0_b.h90 \
+ avh_olo_d0_a.h90 avh_olo_d0_b.h90
+avh_olo_main.obj: avh_olo_box.obj avh_olo_boxc.obj avh_olo_bub.obj \
+ avh_olo_func.obj avh_olo_kinds.obj avh_olo_print.obj avh_olo_tri.obj \
+ avh_olo_units.obj avh_olo_a0_a.h90 avh_olo_a0_b.h90 avh_olo_b0_a.h90 \
+ avh_olo_b0_b.h90 avh_olo_b11_a.h90 avh_olo_b11_b.h90 avh_olo_c0_a.h90 \
+ avh_olo_c0_b.h90 avh_olo_d0_a.h90 avh_olo_d0_b.h90
+avh_olo_print.o: avh_olo_kinds.o
+avh_olo_print.lo: avh_olo_kinds.lo
+avh_olo_print.obj: avh_olo_kinds.obj
+avh_olo_tri.o: avh_olo_func.o avh_olo_kinds.o avh_olo_units.o
+avh_olo_tri.lo: avh_olo_func.lo avh_olo_kinds.lo avh_olo_units.lo
+avh_olo_tri.obj: avh_olo_func.obj avh_olo_kinds.obj avh_olo_units.obj
+avh_olo_wrp01.o: avh_olo_main.o
+avh_olo_wrp01.lo: avh_olo_main.lo
+avh_olo_wrp01.obj: avh_olo_main.obj
diff --git a/avh_olo-2.2.1/Makefile.in b/avh_olo-2.2.1/Makefile.in
new file mode 100644
index 0000000..2afe47e
--- /dev/null
+++ b/avh_olo-2.2.1/Makefile.in
@@ -0,0 +1,632 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(noinst_HEADERS) $(srcdir)/Makefile.am \
+ $(srcdir)/Makefile.dep $(srcdir)/Makefile.in
+subdir = avh_olo-2.2.1
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgincludedir)"
+LTLIBRARIES = $(lib_LTLIBRARIES)
+libavh_olo_la_LIBADD =
+am_libavh_olo_la_OBJECTS = avh_olo_boxc.lo avh_olo_box.lo \
+ avh_olo_bub.lo avh_olo_func.lo avh_olo_kinds.lo \
+ avh_olo_main.lo avh_olo_print.lo avh_olo_tri.lo \
+ avh_olo_units.lo avh_olo_wrp01.lo avh_olo_xkind.lo
+libavh_olo_la_OBJECTS = $(am_libavh_olo_la_OBJECTS)
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libavh_olo_la_SOURCES)
+DIST_SOURCES = $(libavh_olo_la_SOURCES)
+HEADERS = $(nodist_pkginclude_HEADERS) $(noinst_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+lib_LTLIBRARIES = libavh_olo.la
+libavh_olo_la_SOURCES = avh_olo_boxc.f90 avh_olo_box.f90 avh_olo_bub.f90 \
+ avh_olo_func.f90 avh_olo_kinds.f90 avh_olo_main.f90 avh_olo_print.f90 \
+ avh_olo_tri.f90 avh_olo_units.f90 avh_olo_wrp01.f90 avh_olo_xkind.f90
+
+noinst_HEADERS = \
+ avh_olo_a0_a.h90 avh_olo_a0_b.h90 avh_olo_b0_a.h90 avh_olo_b0_b.h90 \
+ avh_olo_b11_a.h90 avh_olo_b11_b.h90 avh_olo_c0_a.h90 avh_olo_c0_b.h90 \
+ avh_olo_d0_a.h90 avh_olo_d0_b.h90
+
+nodist_pkginclude_HEADERS = \
+ avh_olo_bern.mod avh_olo_boxc.mod avh_olo_box.mod avh_olo_bub.mod \
+ avh_olo_func.mod avh_olo_kinds.mod avh_olo_li2a.mod avh_olo_li2c2.mod \
+ avh_olo_li2c.mod avh_olo_loga2.mod avh_olo_loga.mod avh_olo_logc2.mod \
+ avh_olo_logc.mod avh_olo.mod avh_olo_print.mod avh_olo_tri.mod \
+ avh_olo_units.mod avh_olo_xkind.mod
+
+CLEANFILES = $(nodist_pkginclude_HEADERS)
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu avh_olo-2.2.1/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu avh_olo-2.2.1/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+install-libLTLIBRARIES: $(lib_LTLIBRARIES)
+ @$(NORMAL_INSTALL)
+ test -z "$(libdir)" || $(MKDIR_P) "$(DESTDIR)$(libdir)"
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ list2=; for p in $$list; do \
+ if test -f $$p; then \
+ list2="$$list2 $$p"; \
+ else :; fi; \
+ done; \
+ test -z "$$list2" || { \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \
+ }
+
+uninstall-libLTLIBRARIES:
+ @$(NORMAL_UNINSTALL)
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ for p in $$list; do \
+ $(am__strip_dir) \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \
+ done
+
+clean-libLTLIBRARIES:
+ -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES)
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libavh_olo.la: $(libavh_olo_la_OBJECTS) $(libavh_olo_la_DEPENDENCIES)
+ $(FCLINK) -rpath $(libdir) $(libavh_olo_la_OBJECTS) $(libavh_olo_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libLTLIBRARIES clean-libtool \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am: install-libLTLIBRARIES
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-libLTLIBRARIES \
+ uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libLTLIBRARIES clean-libtool ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am \
+ install-libLTLIBRARIES install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-libLTLIBRARIES \
+ uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+avh_olo_box.o: avh_olo_func.o avh_olo_kinds.o avh_olo_units.o
+avh_olo_box.lo: avh_olo_func.lo avh_olo_kinds.lo avh_olo_units.lo
+avh_olo_box.obj: avh_olo_func.obj avh_olo_kinds.obj avh_olo_units.obj
+avh_olo_boxc.o: avh_olo_box.o avh_olo_func.o avh_olo_kinds.o avh_olo_units.o
+avh_olo_boxc.lo: avh_olo_box.lo avh_olo_func.lo avh_olo_kinds.lo \
+ avh_olo_units.lo
+avh_olo_boxc.obj: avh_olo_box.obj avh_olo_func.obj avh_olo_kinds.obj \
+ avh_olo_units.obj
+avh_olo_bub.o: avh_olo_func.o avh_olo_kinds.o avh_olo_units.o
+avh_olo_bub.lo: avh_olo_func.lo avh_olo_kinds.lo avh_olo_units.lo
+avh_olo_bub.obj: avh_olo_func.obj avh_olo_kinds.obj avh_olo_units.obj
+avh_olo_func.o: avh_olo_kinds.o avh_olo_units.o
+avh_olo_func.lo: avh_olo_kinds.lo avh_olo_units.lo
+avh_olo_func.obj: avh_olo_kinds.obj avh_olo_units.obj
+avh_olo_kinds.o: avh_olo_xkind.o
+avh_olo_kinds.lo: avh_olo_xkind.lo
+avh_olo_kinds.obj: avh_olo_xkind.obj
+avh_olo_main.o: avh_olo_box.o avh_olo_boxc.o avh_olo_bub.o avh_olo_func.o \
+ avh_olo_kinds.o avh_olo_print.o avh_olo_tri.o avh_olo_units.o \
+ avh_olo_a0_a.h90 avh_olo_a0_b.h90 avh_olo_b0_a.h90 avh_olo_b0_b.h90 \
+ avh_olo_b11_a.h90 avh_olo_b11_b.h90 avh_olo_c0_a.h90 avh_olo_c0_b.h90 \
+ avh_olo_d0_a.h90 avh_olo_d0_b.h90
+avh_olo_main.lo: avh_olo_box.lo avh_olo_boxc.lo avh_olo_bub.lo avh_olo_func.lo \
+ avh_olo_kinds.lo avh_olo_print.lo avh_olo_tri.lo avh_olo_units.lo \
+ avh_olo_a0_a.h90 avh_olo_a0_b.h90 avh_olo_b0_a.h90 avh_olo_b0_b.h90 \
+ avh_olo_b11_a.h90 avh_olo_b11_b.h90 avh_olo_c0_a.h90 avh_olo_c0_b.h90 \
+ avh_olo_d0_a.h90 avh_olo_d0_b.h90
+avh_olo_main.obj: avh_olo_box.obj avh_olo_boxc.obj avh_olo_bub.obj \
+ avh_olo_func.obj avh_olo_kinds.obj avh_olo_print.obj avh_olo_tri.obj \
+ avh_olo_units.obj avh_olo_a0_a.h90 avh_olo_a0_b.h90 avh_olo_b0_a.h90 \
+ avh_olo_b0_b.h90 avh_olo_b11_a.h90 avh_olo_b11_b.h90 avh_olo_c0_a.h90 \
+ avh_olo_c0_b.h90 avh_olo_d0_a.h90 avh_olo_d0_b.h90
+avh_olo_print.o: avh_olo_kinds.o
+avh_olo_print.lo: avh_olo_kinds.lo
+avh_olo_print.obj: avh_olo_kinds.obj
+avh_olo_tri.o: avh_olo_func.o avh_olo_kinds.o avh_olo_units.o
+avh_olo_tri.lo: avh_olo_func.lo avh_olo_kinds.lo avh_olo_units.lo
+avh_olo_tri.obj: avh_olo_func.obj avh_olo_kinds.obj avh_olo_units.obj
+avh_olo_wrp01.o: avh_olo_main.o
+avh_olo_wrp01.lo: avh_olo_main.lo
+avh_olo_wrp01.obj: avh_olo_main.obj
+
+avh_olo_func.mod avh_olo_loga.mod avh_olo_bern.mod avh_olo_li2a.mod \
+avh_olo_loga2.mod avh_olo_logc.mod avh_olo_li2c.mod avh_olo_logc2.mod \
+avh_olo_li2c2.mod: avh_olo_func.o
+
+avh_olo.mod: $(nodist_pkginclude_HEADERS:avh_olo.mod=)
+
+%.mod: %.o %.f90
+ @true
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/avh_olo-2.2.1/avh_olo_a0_a.h90 b/avh_olo-2.2.1/avh_olo_a0_a.h90
new file mode 100644
index 0000000..5430928
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_a0_a.h90
@@ -0,0 +1,23 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ complex(kindc2) :: ss
+ real(kindr2) :: am,thrs,mulocal,mulocal2
+ character(25+99) ,parameter :: warning=&
+ 'WARNING from OneLOop a0: '//warnonshell
+ if (intro) call hello
diff --git a/avh_olo-2.2.1/avh_olo_a0_b.h90 b/avh_olo-2.2.1/avh_olo_a0_b.h90
new file mode 100644
index 0000000..6afaeb3
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_a0_b.h90
@@ -0,0 +1,41 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ am = abs(mm)
+!
+ mulocal2 = mulocal*mulocal
+!
+ if (nonzerothrs) then
+ thrs = onshellthrs
+ if (am.lt.thrs) am = R0P0
+ elseif (wunit.gt.0) then
+ thrs = onshellthrs*max(am,mulocal2)
+ if (R0P0.lt.am.and.am.lt.thrs) write(wunit,*) warning
+ endif
+!
+ ss = mm
+ call tadp( rslt ,ss ,am ,mulocal2 )
+!
+ if (punit.gt.0) then
+ if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
+ write(punit,*) 'muscale:',trim(myprint(mulocal))
+ write(punit,*) ' mm:',trim(myprint(mm))
+ write(punit,*) 'a0(2):',trim(myprint(rslt(2)))
+ write(punit,*) 'a0(1):',trim(myprint(rslt(1)))
+ write(punit,*) 'a0(0):',trim(myprint(rslt(0)))
+ endif
diff --git a/avh_olo-2.2.1/avh_olo_b0_a.h90 b/avh_olo-2.2.1/avh_olo_b0_a.h90
new file mode 100644
index 0000000..be3000b
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_b0_a.h90
@@ -0,0 +1,27 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ complex(kindc2) :: ss,r1,r2
+ real(kindr2) :: app,am1,am2,thrs,mulocal,mulocal2
+ character(25+99) ,parameter :: warning=&
+ 'WARNING from OneLOop b0: '//warnonshell
+ if (intro) call hello
+!
+ ss = pp
+ r1 = m1
+ r2 = m2
diff --git a/avh_olo-2.2.1/avh_olo_b0_b.h90 b/avh_olo-2.2.1/avh_olo_b0_b.h90
new file mode 100644
index 0000000..3366d9a
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_b0_b.h90
@@ -0,0 +1,44 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ mulocal2 = mulocal*mulocal
+!
+ if (nonzerothrs) then
+ thrs = onshellthrs
+ if (app.lt.thrs) app = R0P0
+ if (am1.lt.thrs) am1 = R0P0
+ if (am2.lt.thrs) am2 = R0P0
+ elseif (wunit.gt.0) then
+ thrs = onshellthrs*max(app,am1,am2,mulocal2)
+ if (R0P0.lt.app.and.app.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.am1.and.am1.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.am2.and.am2.lt.thrs) write(wunit,*) warning
+ endif
+!
+ call bub0( rslt ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
+!
+ if (punit.gt.0) then
+ if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
+ write(punit,*) 'muscale:',trim(myprint(mulocal))
+ write(punit,*) ' pp:',trim(myprint(pp))
+ write(punit,*) ' m1:',trim(myprint(m1))
+ write(punit,*) ' m2:',trim(myprint(m2))
+ write(punit,*) 'b0(2):',trim(myprint(rslt(2)))
+ write(punit,*) 'b0(1):',trim(myprint(rslt(1)))
+ write(punit,*) 'b0(0):',trim(myprint(rslt(0)))
+ endif
diff --git a/avh_olo-2.2.1/avh_olo_b11_a.h90 b/avh_olo-2.2.1/avh_olo_b11_a.h90
new file mode 100644
index 0000000..3552269
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_b11_a.h90
@@ -0,0 +1,27 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ complex(kindc2) :: ss,r1,r2
+ real(kindr2) :: app,am1,am2,thrs,mulocal,mulocal2
+ character(26+99) ,parameter :: warning=&
+ 'WARNING from OneLOop b11: '//warnonshell
+ if (intro) call hello
+!
+ ss = pp
+ r1 = m1
+ r2 = m2
diff --git a/avh_olo-2.2.1/avh_olo_b11_b.h90 b/avh_olo-2.2.1/avh_olo_b11_b.h90
new file mode 100644
index 0000000..0de96b7
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_b11_b.h90
@@ -0,0 +1,53 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ mulocal2 = mulocal*mulocal
+!
+ if (nonzerothrs) then
+ thrs = onshellthrs
+ if (app.lt.thrs) app = R0P0
+ if (am1.lt.thrs) am1 = R0P0
+ if (am2.lt.thrs) am2 = R0P0
+ elseif (wunit.gt.0) then
+ thrs = onshellthrs*max(app,am1,am2,mulocal2)
+ if (R0P0.lt.app.and.app.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.am1.and.am1.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.am2.and.am2.lt.thrs) write(wunit,*) warning
+ endif
+!
+ call bub11( b11,b00,b1,b0 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
+!
+ if (punit.gt.0) then
+ if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
+ write(punit,*) 'muscale:',trim(myprint(mulocal))
+ write(punit,*) ' pp:',trim(myprint(pp))
+ write(punit,*) ' m1:',trim(myprint(m1))
+ write(punit,*) ' m2:',trim(myprint(m2))
+ write(punit,*) 'b11(2):',trim(myprint(b11(2)))
+ write(punit,*) 'b11(1):',trim(myprint(b11(1)))
+ write(punit,*) 'b11(0):',trim(myprint(b11(0)))
+ write(punit,*) 'b00(2):',trim(myprint(b00(2)))
+ write(punit,*) 'b00(1):',trim(myprint(b00(1)))
+ write(punit,*) 'b00(0):',trim(myprint(b00(0)))
+ write(punit,*) ' b1(2):',trim(myprint(b1(2) ))
+ write(punit,*) ' b1(1):',trim(myprint(b1(1) ))
+ write(punit,*) ' b1(0):',trim(myprint(b1(0) ))
+ write(punit,*) ' b0(2):',trim(myprint(b0(2) ))
+ write(punit,*) ' b0(1):',trim(myprint(b0(1) ))
+ write(punit,*) ' b0(0):',trim(myprint(b0(0) ))
+ endif
diff --git a/avh_olo-2.2.1/avh_olo_box.f90 b/avh_olo-2.2.1/avh_olo_box.f90
new file mode 100644
index 0000000..d2a833e
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_box.f90
@@ -0,0 +1,1551 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+module avh_olo_box
+ use avh_olo_kinds
+ use avh_olo_units
+ use avh_olo_func
+ implicit none
+ private
+ public :: box00,box03,box05,box06,box07,box08,box09,box10,box11,box12 &
+ ,box13,box14,box15,box16,boxf1,boxf2,boxf3,boxf5,boxf4 &
+ ,permtable,casetable,base
+ complex(kindc2) ,parameter :: oieps=C1P0+CiP0*epsilon(R1P0)**2
+ integer ,parameter :: permtable(6,0:15)=reshape((/ &
+ 1,2,3,4 ,5,6 &! 0, 0 masses non-zero, no perm
+ ,1,2,3,4 ,5,6 &! 1, 1 mass non-zero, no perm
+ ,4,1,2,3 ,6,5 &! 2, 1 mass non-zero, 1 cyclic perm
+ ,1,2,3,4 ,5,6 &! 3, 2 neighbour masses non-zero, no perm
+ ,3,4,1,2 ,5,6 &! 4, 1 mass non-zero, 2 cyclic perm's
+ ,1,2,3,4 ,5,6 &! 5, 2 opposite masses non-zero, no perm
+ ,4,1,2,3 ,6,5 &! 6, 2 neighbour masses non-zero, 1 cyclic perm
+ ,1,2,3,4 ,5,6 &! 7, 3 masses non-zero, no perm
+ ,2,3,4,1 ,6,5 &! 8, 1 mass non-zero, 3 cyclic perm's
+ ,2,3,4,1 ,6,5 &! 9, 2 neighbour masses non-zero, 3 cyclic perm's
+ ,4,1,2,3 ,6,5 &!10, 2 opposite masses non-zero, 1 cyclic perm
+ ,2,3,4,1 ,6,5 &!11, 3 masses non-zero, 3 cyclic perm's
+ ,3,4,1,2 ,5,6 &!12, 2 neighbour masses non-zero, 2 cyclic perm's
+ ,3,4,1,2 ,5,6 &!13, 3 masses non-zero, 2 cyclic perm's
+ ,4,1,2,3 ,6,5 &!14, 3 masses non-zero, 1 cyclic perm
+ ,1,2,3,4 ,5,6 &!15, 4 masses non-zero, no perm
+ /),(/6,16/)) ! 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15
+ integer ,parameter :: casetable(0:15)= &
+ (/0,1,1,2,1,5,2,3,1,2, 5, 3, 2, 3, 3, 4/)
+ integer ,parameter :: base(4)=(/8,4,2,1/)
+contains
+
+ subroutine box16( rslt ,p2,p3,p12,p23 ,m2,m3,m4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | ------------------------------------------------------
+! i*pi^2 / q^2 [(q+k1)^2-m2] [(q+k1+k2)^2-m3] [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=m2, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
+! m2,m4 should NOT be identically 0d0
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p2,p3,p12,p23 ,m2,m3,m4
+ real(kindr2) ,intent(in) :: rmu
+ complex(kindc2) :: cp2,cp3,cp12,cp23,cm2,cm3,cm4,sm1,sm2,sm3,sm4 &
+ ,r13,r23,r24,r34,d23,d24,d34,log24,cc
+ type(qmplx_type) :: q13,q23,q24,q34,qss,qy1,qy2,qz1,qz2
+!
+! write(*,*) 'MESSAGE from OneLOop box16: you are calling me' !CALLINGME
+!
+ if (abs(m2).gt.abs(m4)) then
+ cm2=m2 ;cm4=m4 ;cp2=p2 ;cp3=p3
+ else
+ cm2=m4 ;cm4=m2 ;cp2=p3 ;cp3=p2
+ endif
+ cm3=m3 ;cp12=p12 ;cp23=p23
+!
+ if (cp12.eq.cm3) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box16: ' &
+ ,'p12=m3, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ sm1 = cmplx(abs(rmu))
+ sm2 = mysqrt(cm2)
+ sm3 = mysqrt(cm3)
+ sm4 = mysqrt(cm4)
+!
+ r13 = (cm3-cp12)/(sm1*sm3)
+ call rfun( r23,d23 ,(cm2+cm3-cp2 )/(sm2*sm3) )
+ call rfun( r24,d24 ,(cm2+cm4-cp23)/(sm2*sm4) )
+ call rfun( r34,d34 ,(cm3+cm4-cp3 )/(sm3*sm4) )
+ q13 = qonv(r13,-1)
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ if (r24.eq.-C1P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box16: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ qss = q23*q34
+ qy1 = qss*q24
+ qy2 = qss/q24
+!
+ qss = q23/q34
+ qz1 = qss*q24
+ qz2 = qss/q24
+!
+ qss = q13*q23
+ qss = (qss*qss)/q24
+!
+ cc = C1P0/( sm2*sm4*(cp12-cm3) )
+ log24 = logc2(q24)*r24/(C1P0+r24)
+ rslt(2) = C0P0
+ rslt(1) = -log24
+ rslt(0) = log24*logc(qss) + li2c2(q24*q24,qonv(C1P0))*r24 &
+ - li2c2(qy1,qy2)*r23*r34 - li2c2(qz1,qz2)*r23/r34
+ rslt(1) = cc*rslt(1)
+ rslt(0) = cc*rslt(0)
+ end subroutine
+
+
+ subroutine box15( rslt ,p2,p3,p12,p23 ,m2,m4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | -------------------------------------------------
+! i*pi^2 / q^2 [(q+k1)^2-m2] (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=m2, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
+! m2,m4 should NOT be identically 0d0
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p2,p3,p12,p23 ,m2,m4
+ real(kindr2) ,intent(in) :: rmu
+ complex(kindc2) :: cp2,cp3,cp12,cp23,cm2,cm4,sm1,sm2,sm3,sm4 &
+ ,r13,r23,r24,r34,d24,log24,cc
+ type(qmplx_type) :: q13,q23,q24,q34,qss,qz1,qz2
+!
+! write(*,*) 'MESSAGE from OneLOop box15: you are calling me' !CALLINGME
+!
+ if (abs(m2-p2).gt.abs(m4-p3)) then
+ cm2=m2 ;cm4=m4 ;cp2=p2 ;cp3=p3
+ else
+ cm2=m4 ;cm4=m2 ;cp2=p3 ;cp3=p2
+ endif
+ cp12=p12 ;cp23=p23
+!
+ if (cp12.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box15: ' &
+ ,'p12=0, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ sm1 = cmplx(abs(rmu),kind=kindc2)
+ sm2 = mysqrt(cm2)
+ sm4 = mysqrt(cm4)
+ sm3 = cmplx(abs(sm2),kind=kindc2)
+ r13 = ( -cp12)/(sm1*sm3)
+ r23 = (cm2 -cp2 )/(sm2*sm3)
+ r34 = ( cm4-cp3 )/(sm3*sm4)
+ call rfun( r24,d24 ,(cm2+cm4-cp23)/(sm2*sm4) )
+!
+ if (r24.eq.-C1P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box15: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ q13 = qonv(r13,-1)
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ qss = q13/q23
+ qss = (qss*qss)/q24
+!
+ cc = r24/(sm2*sm4*cp12)
+ log24 = logc2(q24)/(C1P0+r24)
+ rslt(2) = C0P0
+ rslt(1) = -log24
+ rslt(0) = log24 * logc(qss) + li2c2(q24*q24,qonv(C1P0))
+ if (r34.ne.C0P0) then
+ qss = q34/q23
+ qz1 = qss*q24
+ qz2 = qss/q24
+ rslt(0) = rslt(0) - li2c2(qz1,qz2)*r34/(r23*r24)
+ endif
+ rslt(1) = cc*rslt(1)
+ rslt(0) = cc*rslt(0)
+ end subroutine
+
+
+ subroutine box14( rslt ,cp12,cp23 ,cm2,cm4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | -------------------------------------------------
+! i*pi^2 / q^2 [(q+k1)^2-m2] (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=m2, k2^2=m2, k3^2=m4, (k1+k2+k3)^2=m4
+! m2,m4 should NOT be identically 0d0
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp12,cp23,cm2,cm4
+ real(kindr2) ,intent(in) :: rmu
+ complex(kindc2) :: sm2,sm4,r24,d24,cc
+!
+! write(*,*) 'MESSAGE from OneLOop box14: you are calling me' !CALLINGME
+!
+ if (cp12.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box14: ' &
+ ,'p12=0, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ sm2 = mysqrt(cm2)
+ sm4 = mysqrt(cm4)
+ call rfun( r24,d24 ,(cm2+cm4-cp23)/(sm2*sm4) )
+!
+ if (r24.eq.-C1P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box14: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ cc = -2*logc2(qonv(r24,-1))*r24/(C1P0+r24)/(sm2*sm4*cp12)
+!
+ rslt(2) = C0P0
+ rslt(1) = cc
+ rslt(0) = -cc*logc(qonv(-cp12/(rmu*rmu),-1))
+ end subroutine
+
+
+ subroutine box13( rslt ,p2,p3,p4,p12,p23 ,m3,m4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | -------------------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3] [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=0, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=p4
+! m3,m4 should NOT be identically 0d0
+! p4 should NOT be identical to m4
+! p2 should NOT be identical to m3
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p2,p3,p4,p12,p23,m3,m4
+ real(kindr2) ,intent(in) :: rmu
+ complex(kindc2) :: cp2,cp3,cp4,cp12,cp23,cm3,cm4,sm3,sm4,sm1,sm2 &
+ ,r13,r14,r23,r24,r34,d34,cc,logd,li2d,loge,li2f,li2b,li2e
+ type(qmplx_type) :: q13,q14,q23,q24,q34,qy1,qy2
+ real(kindr2) :: h1,h2
+!
+! write(*,*) 'MESSAGE from OneLOop box13: you are calling me' !CALLINGME
+!
+ if (p12.eq.m3) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
+ ,'p12=m3, returning 0'
+ rslt = C0P0
+ return
+ endif
+ if (p23.eq.m4) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
+ ,'p23=m4, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ h1 = abs((m3-p12)*(m4-p23))
+ h2 = abs((m3-p2 )*(m4-p4 ))
+ if (h1.ge.h2) then
+ cp2=p2 ;cp3=p3 ;cp4=p4 ;cp12=p12 ;cp23=p23 ;cm3=m3 ;cm4=m4
+ else
+ cp2=p12 ;cp3=p3 ;cp4=p23 ;cp12=p2 ;cp23=p4 ;cm3=m3 ;cm4=m4
+ endif
+!
+ sm3 = mysqrt(cm3)
+ sm4 = mysqrt(cm4)
+ sm1 = cmplx(abs(rmu),kind=kindc2)
+ sm2 = sm1
+!
+ r13 = (cm3-cp12)/(sm1*sm3)
+ r14 = (cm4-cp4 )/(sm1*sm4)
+ r23 = (cm3-cp2 )/(sm2*sm3)
+ r24 = (cm4-cp23)/(sm2*sm4)
+ call rfun( r34,d34 ,(cm3+cm4-cp3)/(sm3*sm4) )
+!
+ q13 = qonv(r13,-1)
+ q14 = qonv(r14,-1)
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ qy1 = q14*q23/q13/q24
+ logd = logc2(qy1 )/(r13*r24)
+ li2d = li2c2(qy1,qonv(C1P0))/(r13*r24)
+ loge = logc(q13)
+!
+ qy1 = q23/q24
+ qy2 = q13/q14
+ li2f = li2c2( qy1*q34,qy2*q34 )*r34/(r14*r24)
+ li2b = li2c2( qy1/q34,qy2/q34 )/(r34*r14*r24)
+ li2e = li2c2( q14/q24,q13/q23 )/(r23*r24)
+!
+ rslt(2) = C0P0
+ rslt(1) = logd
+ rslt(0) = li2f + li2b + 2*li2e - 2*li2d - 2*logd*loge
+ cc = sm1*sm2*sm3*sm4
+ rslt(1) = rslt(1)/cc
+ rslt(0) = rslt(0)/cc
+ end subroutine
+
+
+ subroutine box12( rslt ,cp3,cp4,cp12,cp23 ,cm3,cm4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | -------------------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3] [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=0, k2^2=m3, k3^2=p3, (k1+k2+k3)^2=p4
+! m3,m4 should NOT be indentiallcy 0d0
+! p4 should NOT be identical to m4
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_li2c ,only: li2c
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp3,cp4,cp12,cp23,cm3,cm4
+ real(kindc2) ,intent(in) :: rmu
+ complex(kindc2) :: sm3,sm4,sm1,sm2,r13,r14,r24,r34,d34,cc &
+ ,log13,log14,log24,log34,li2f,li2b,li2d
+ type(qmplx_type) :: q13,q14,q24,q34,qyy
+ complex(kindc2) ,parameter :: const=C1P0*TWOPI*TWOPI/32
+!
+! write(*,*) 'MESSAGE from OneLOop box12: you are calling me' !CALLINGME
+!
+ if (cp12.eq.cm3) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box12: ' &
+ ,'p12=m3, returning 0'
+ rslt = C0P0
+ return
+ endif
+ if (cp23.eq.cm4) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box12: ' &
+ ,'p23=m4, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ sm3 = mysqrt(cm3)
+ sm4 = mysqrt(cm4)
+ sm1 = cmplx(abs(rmu),kind=kindc2)
+ sm2 = sm1
+!
+ r13 = (cm3-cp12)/(sm1*sm3)
+ r14 = (cm4-cp4 )/(sm1*sm4)
+ r24 = (cm4-cp23)/(sm2*sm4)
+ call rfun( r34,d34 ,(cm3+cm4-cp3)/(sm3*sm4) )
+!
+ q13 = qonv(r13,-1)
+ q14 = qonv(r14,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ log13 = logc(q13)
+ log14 = logc(q14)
+ log24 = logc(q24)
+ log34 = logc(q34)
+!
+ qyy = q14/q13
+ li2f = li2c(qyy*q34)
+ li2b = li2c(qyy/q34)
+ li2d = li2c(q14/q24)
+!
+ rslt(2) = C1P0/2
+ rslt(1) = log14 - log24 - log13
+ rslt(0) = 2*log13*log24 - log14*log14 - log34*log34 &
+ - 2*li2d - li2f - li2b - const
+ cc = (cm3-cp12)*(cm4-cp23) ! = sm1*sm2*sm3*sm4*r13*r24
+ rslt(2) = rslt(2)/cc
+ rslt(1) = rslt(1)/cc
+ rslt(0) = rslt(0)/cc
+ end subroutine
+
+
+ subroutine box11( rslt ,cp3,cp12,cp23 ,cm3,cm4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | -------------------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3] [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=0, k2^2=m3, k3^2=p3, (k1+k2+k3)^2=m4
+! m3,m4 should NOT be indentiallcy 0d0
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp3,cp12,cp23,cm3,cm4
+ real(kindr2) ,intent(in) :: rmu
+ complex(kindc2) :: sm3,sm4,sm1,sm2,r13,r24,r34,d34 &
+ ,cc,log13,log24,log34
+ complex(kindc2) ,parameter :: const=(C1P0*TWOPI*TWOPI*7)/48
+!
+! write(*,*) 'MESSAGE from OneLOop box11: you are calling me' !CALLINGME
+!
+ if (cp12.eq.cm3) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box11: ' &
+ ,'p12=m3, returning 0'
+ rslt = C0P0
+ return
+ endif
+ if (cp23.eq.cm4) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box11: ' &
+ ,'p23=m4, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ sm3 = mysqrt(cm3)
+ sm4 = mysqrt(cm4)
+ sm1 = cmplx(abs(rmu),kind=kindc2)
+ sm2 = sm1
+!
+ r13 = (cm3-cp12)/(sm1*sm3)
+ r24 = (cm4-cp23)/(sm2*sm4)
+ call rfun( r34,d34 ,(cm3+cm4-cp3 )/(sm3*sm4) )
+!
+ log13 = logc(qonv(r13,-1))
+ log24 = logc(qonv(r24,-1))
+ log34 = logc(qonv(r34,-1))
+!
+ rslt(2) = C1P0
+ rslt(1) = -log13-log24
+ rslt(0) = 2*log13*log24 - log34*log34 - const
+ cc = (cm3-cp12)*(cm4-cp23) ! = sm1*sm2*sm3*sm4*r13*r24
+ rslt(2) = rslt(2)/cc
+ rslt(1) = rslt(1)/cc
+ rslt(0) = rslt(0)/cc
+ end subroutine
+
+
+ subroutine box10( rslt ,p2,p3,p4,p12,p23 ,m4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | --------------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=0, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=p4
+! m4 should NOT be identically 0d0
+! p2 should NOT be identically 0d0
+! p4 should NOT be identical to m4
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p2,p3,p4,p12,p23,m4
+ real(kindr2) ,intent(in) :: rmu
+ complex(kindc2) :: cp2,cp3,cp4,cp12,cp23,cm4,r13,r14,r23,r24,r34,z1,z0
+ type(qmplx_type) :: q13,q14,q23,q24,q34,qm4,qxx,qx1,qx2
+ real(kindr2) :: h1,h2
+!
+! write(*,*) 'MESSAGE from OneLOop box10: you are calling me' !CALLINGME
+!
+ if (p12.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box10: ' &
+ ,'p12=0, returning 0'
+ rslt = C0P0
+ return
+ endif
+ if (p23.eq.m4) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box10: ' &
+ ,'p23=mm, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ h1 = abs(p12*(m4-p23))
+ h2 = abs( p2*(m4-p4 ))
+ if (h1.ge.h2) then
+ cp2=p2 ;cp3=p3 ;cp4=p4 ;cp12=p12 ;cp23=p23 ;cm4=m4
+ else
+ cp2=p12 ;cp3=p3 ;cp4=p23 ;cp12=p2 ;cp23=p4 ;cm4=m4
+ endif
+!
+ r23 = -cp2
+ r13 = -cp12
+ r34 = cm4-cp3
+ r14 = cm4-cp4
+ r24 = cm4-cp23
+ q23 = qonv(r23,-1)
+ q13 = qonv(r13,-1)
+ q34 = qonv(r34,-1)
+ q14 = qonv(r14,-1)
+ q24 = qonv(r24,-1)
+ qm4 = qonv(cm4,-1)
+!
+ if (r34.ne.C0P0) then
+ qx1 = q34/qm4
+ qx2 = qx1*q14/q13
+ qx1 = qx1*q24/q23
+ z0 = -li2c2(qx1,qx2)*r34/(2*cm4*r23)
+ else
+ z0 = C0P0
+ endif
+!
+ qx1 = q23/q13
+ qx2 = q24/q14
+ qxx = qx1/qx2
+ z1 = -logc2(qxx)/r24
+ z0 = z0 - li2c2(qx1,qx2)/r14
+ z0 = z0 + li2c2(qxx,qonv(C1P0))/r24
+ z0 = z0 + z1*( logc(qm4/q24) - logc(qm4/(rmu*rmu))/2 )
+!
+ rslt(2) = C0P0
+ rslt(1) = -z1/r13
+ rslt(0) = -2*z0/r13
+ end subroutine
+
+
+ subroutine box09( rslt ,cp2,cp3,cp12,cp23 ,cm4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | --------------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=0, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
+! m4 should NOT be identically 0d0
+! p2 should NOT be identically 0d0
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_li2c ,only: li2c
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp2,cp3,cp12,cp23,cm4
+ real(kindr2) ,intent(in) :: rmu
+ complex(kindc2) :: logm,log12,log23,li12,li23,z2,z1,z0,cc &
+ ,r13,r23,r24,r34
+ type(qmplx_type) :: q13,q23,q24,q34,qm4,qxx
+ complex(kindc2) ,parameter :: const=C1P0*TWOPI*TWOPI/96
+!
+! write(*,*) 'MESSAGE from OneLOop box09: you are calling me' !CALLINGME
+!
+ if (cp12.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box09: ' &
+ ,'p12=0, returning 0'
+ rslt = C0P0
+ return
+ endif
+ if (cp23.eq.cm4) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box09: ' &
+ ,'p23=mm, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ r23 = -cp2
+ r13 = -cp12
+ r34 = cm4-cp3
+ r24 = cm4-cp23
+ q23 = qonv(r23,-1)
+ q13 = qonv(r13,-1)
+ q34 = qonv(r34,-1)
+ q24 = qonv(r24,-1)
+ qm4 = qonv(cm4,-1)
+!
+ logm = logc(qm4/(rmu*rmu))
+ qxx = q13/q23
+ log12 = logc(qxx)
+ li12 = li2c(qxx)
+!
+ qxx = q24/qm4
+ log23 = logc(qxx)
+ li23 = li2c(qxx*q34/q23)
+!
+ z2 = C1P0/2
+ z1 = -log12 - log23
+ z0 = li23 + 2*li12 + z1*z1 + const
+ cc = C1P0/(r13*r24)
+ rslt(2) = cc*z2
+ rslt(1) = cc*(z1 - z2*logm)
+ rslt(0) = cc*(z0 + (z2*logm/2-z1)*logm)
+ end subroutine
+
+
+ subroutine box08( rslt ,cp3,cp4,cp12,cp23 ,cm4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | --------------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=k2^2=0, k3^2=p3, (k1+k2+k3)^2=p4
+! mm should NOT be identically 0d0
+! p3 NOR p4 should be identically m4
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_li2c ,only: li2c
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp3,cp4,cp12,cp23,cm4
+ real(kindr2) ,intent(in) :: rmu
+ type(qmplx_type) :: q13,q14,q24,q34,qm4,qxx,qx1,qx2,qx3
+ complex(kindc2) :: r13,r14,r24,r34,z1,z0,cc
+ real(kindr2) :: rmu2
+ complex(kindc2) ,parameter :: const=C1P0*TWOPI*TWOPI/16
+!
+! write(*,*) 'MESSAGE from OneLOop box08: you are calling me' !CALLINGME
+!
+ if (cp12.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box08: ' &
+ ,'p12=0, returning 0'
+ rslt = C0P0
+ return
+ endif
+ if (cp23.eq.cm4) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box08: ' &
+ ,'p23=mm, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ rmu2 = rmu*rmu
+ r13 = -cp12
+ r34 = cm4-cp3
+ r14 = cm4-cp4
+ r24 = cm4-cp23
+ q13 = qonv(r13,-1)
+ q34 = qonv(r34,-1)
+ q14 = qonv(r14,-1)
+ q24 = qonv(r24,-1)
+ qm4 = qonv(cm4,-1)
+!
+ qx1 = q34/q24
+ qx2 = q14/q24
+ qx3 = q13/rmu2
+ z1 = logc(qx1*qx2/qx3)
+ z0 = 2*( logc(q24/rmu2)*logc(qx3) - (li2c(qx1)+li2c(qx2)) )
+!
+ qx1 = q34/rmu2
+ qx2 = q14/rmu2
+ qxx = qx1*qx2/qx3
+ z0 = z0 - logc(qx1)**2 - logc(qx2)**2 &
+ + logc(qxx)**2/2 + li2c(qm4/qxx/rmu2)
+!
+ cc = C1P0/(r13*r24)
+ rslt(2) = cc
+ rslt(1) = cc*z1
+ rslt(0) = cc*( z0 - const )
+ end subroutine
+
+
+ subroutine box07( rslt ,cp4,cp12,cp23 ,cm4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | --------------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=k2^2=0, k3^2=m4, (k1+k2+k3)^2=p4
+! m3 should NOT be identically 0d0
+! p4 should NOT be identically m4
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_li2c ,only: li2c
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp4,cp12,cp23,cm4
+ real(kindr2) ,intent(in) :: rmu
+ type(qmplx_type) :: q13,q14,q24,qm4
+ complex(kindc2) :: r13,r14,r24,logm,log12,log23,log4,li423 &
+ ,z2,z1,z0,cc
+ complex(kindc2) ,parameter :: const=(C1P0*TWOPI*TWOPI*13)/96
+!
+! write(*,*) 'MESSAGE from OneLOop box07: you are calling me' !CALLINGME
+!
+ if (cp12.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box07: ' &
+ ,'p12=0, returning 0'
+ rslt = C0P0
+ return
+ endif
+ if (cp23.eq.cm4) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box07: ' &
+ ,'p23=mm, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ r13 = -cp12
+ r14 = cm4-cp4
+ r24 = cm4-cp23
+ q13 = qonv(r13,-1)
+ q14 = qonv(r14,-1)
+ q24 = qonv(r24,-1)
+ qm4 = qonv(cm4,-1)
+!
+ logm = logc(qm4/(rmu*rmu))
+ log12 = logc(q13/qm4)
+ log23 = logc(q24/qm4)
+ log4 = logc(q14/qm4)
+ li423 = li2c(q14/q24)
+!
+ z2 = (C1P0*3)/2
+ z1 = -2*log23 - log12 + log4
+ z0 = 2*(log12*log23 - li423) - log4*log4 - const
+ cc = C1P0/(r13*r24)
+ rslt(2) = cc*z2
+ rslt(1) = cc*(z1 - z2*logm)
+ rslt(0) = cc*(z0 + (z2*logm/2-z1)*logm)
+ end subroutine
+
+
+ subroutine box06( rslt ,cp12,cp23 ,cm4 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | --------------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
+!
+! with k1^2=k2^2=0, k3^2=(k1+k2+k3)^2=m4
+! m3 should NOT be identically 0d0
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp12,cp23,cm4
+ real(kindr2) ,intent(in) :: rmu
+ type(qmplx_type) :: q13,q24,qm4
+ complex(kindc2) :: r13,r24,logm,log1,log2,z2,z1,z0,cc
+ complex(kindc2) ,parameter :: const=C1P0*TWOPI*TWOPI/12
+!
+! write(*,*) 'MESSAGE from OneLOop box06: you are calling me' !CALLINGME
+!
+ if (cp12.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box06: ' &
+ ,'p12=0, returning 0'
+ rslt = C0P0
+ return
+ endif
+ if (cp23.eq.cm4) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box06: ' &
+ ,'p23=mm, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ r13 = -cp12
+ r24 = cm4-cp23
+ q13 = qonv(r13,-1)
+ q24 = qonv(r24,-1)
+ qm4 = qonv(cm4,-1)
+!
+ logm = logc(qm4/(rmu*rmu))
+ log1 = logc(q13/qm4)
+ log2 = logc(q24/qm4)
+!
+ z2 = C1P0*2
+ z1 = -2*log2 - log1
+ z0 = 2*(log2*log1 - const)
+ cc = C1P0/(r13*r24)
+ rslt(2) = cc*z2
+ rslt(1) = cc*(z1 - z2*logm)
+ rslt(0) = cc*(z0 + (z2*logm/2-z1)*logm)
+ end subroutine
+
+
+ subroutine box03( rslt ,p2,p4,p5,p6 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | ---------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 (q+k1+k2+k3)^2
+!
+! with k1^2=k3^2=0
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p2,p4,p5,p6
+ real(kindr2) ,intent(in) :: rmu
+ type(qmplx_type) :: q2,q4,q5,q6,q26,q54,qy
+ complex(kindc2) :: logy
+ real(kindr2) :: rmu2
+!
+! write(*,*) 'MESSAGE from OneLOop box03: you are calling me' !CALLINGME
+!
+ rmu2 = rmu*rmu
+ q2 = qonv(-p2,-1)
+ q4 = qonv(-p4,-1)
+ q5 = qonv(-p5,-1)
+ q6 = qonv(-p6,-1)
+ q26 = q2/q6
+ q54 = q5/q4
+ qy = q26/q54
+ logy = logc2(qy)/(p5*p6)
+ rslt(1) = logy
+ rslt(0) = li2c2(q6/q4,q2/q5)/(p4*p5) &
+ + li2c2(q54,q26)/(p4*p6) &
+ - li2c2(qonv(C1P0),qy)/(p5*p6) &
+ - logy*logc(q54*q2*q6/(rmu2*rmu2))/2
+ rslt(2) = C0P0
+ rslt(1) = 2*rslt(1)
+ rslt(0) = 2*rslt(0)
+ end subroutine
+
+
+ subroutine box05( rslt ,p2,p3,p4,p5,p6 ,rmu )
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | ---------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 (q+k1+k2+k3)^2
+!
+! with k1^2=0
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p2,p3,p4,p5,p6
+ real(kindr2) ,intent(in) :: rmu
+ type(qmplx_type) ::q2,q3,q4,q5,q6 ,q25,q64,qy,qz
+ complex(kindc2) :: logy
+ real(kindr2) :: rmu2
+!
+! write(*,*) 'MESSAGE from OneLOop box05: you are calling me' !CALLINGME
+!
+ rmu2 = rmu*rmu
+ q2 = qonv(-p2,-1)
+ q3 = qonv(-p3,-1)
+ q4 = qonv(-p4,-1)
+ q5 = qonv(-p5,-1)
+ q6 = qonv(-p6,-1)
+ q25 = q2/q5
+ q64 = q6/q4
+ qy = q25/q64
+ qz = q64*q2*q5*q6*q6/q3/q3/(rmu2*rmu2)
+!
+ logy = logc2(qy)/(p5*p6)
+ rslt(2) = C0P0
+ rslt(1) = logy
+ rslt(0) = li2c2(q64,q25)/(p4*p5) &
+ - li2c2(qonv(C1P0),qy)/(p5*p6) &
+ - logy*logc(qz)/4
+ rslt(0) = 2*rslt(0)
+ end subroutine
+
+
+ subroutine box00( rslt ,cp ,api ,rmu )
+!*******************************************************************
+! calculates
+! C / d^(Dim)q
+! ------ | ---------------------------------------
+! i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 (q+k1+k2+k3)^2
+!
+! with Dim = 4-2*eps
+! C = pi^eps * mu^(2*eps) * exp(gamma_Euler*eps)
+!
+! input: p1 = k1^2, p2 = k2^2, p3 = k3^2, p4 = (k1+k2+k3)^2,
+! p12 = (k1+k2)^2, p23 = (k2+k3)^2
+! output: rslt(0) = eps^0 -coefficient
+! rslt(1) = eps^(-1)-coefficient
+! rslt(2) = eps^(-2)-coefficient
+!
+! If any of these numbers is IDENTICALLY 0d0, the corresponding
+! IR-singular case is returned.
+!*******************************************************************
+ use avh_olo_loga ,only: loga
+ use avh_olo_li2a ,only: li2a
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp(6)
+ real(kindr2) ,intent(in) :: api(6),rmu
+ complex(kindc2) :: log3,log4,log5,log6,li24,li25,li26 &
+ ,li254,li263
+ real(kindr2) :: rp1,rp2,rp3,rp4,rp5,rp6,pp(6),ap(6),gg,ff,hh,arg,rmu2
+ integer :: icase,sf,sgn,i3,i4,i5,i6
+ integer ,parameter :: base(4)=(/8,4,2,1/)
+ complex(kindc2) ,parameter :: pi2=C1P0*TWOPI*TWOPI/4
+!
+ rmu2 = rmu*rmu
+ ff = api(5)*api(6)
+ gg = api(2)*api(4)
+ hh = api(1)*api(3)
+ if (ff.ge.gg.and.ff.ge.hh) then
+ pp(1)=real(cp(1)) ;ap(1)=api(1)
+ pp(2)=real(cp(2)) ;ap(2)=api(2)
+ pp(3)=real(cp(3)) ;ap(3)=api(3)
+ pp(4)=real(cp(4)) ;ap(4)=api(4)
+ pp(5)=real(cp(5)) ;ap(5)=api(5)
+ pp(6)=real(cp(6)) ;ap(6)=api(6)
+ elseif (gg.ge.ff.and.gg.ge.hh) then
+ pp(1)=real(cp(1)) ;ap(1)=api(1)
+ pp(2)=real(cp(6)) ;ap(2)=api(6)
+ pp(3)=real(cp(3)) ;ap(3)=api(3)
+ pp(4)=real(cp(5)) ;ap(4)=api(5)
+ pp(5)=real(cp(4)) ;ap(5)=api(4)
+ pp(6)=real(cp(2)) ;ap(6)=api(2)
+ else
+ pp(1)=real(cp(5)) ;ap(1)=api(5)
+ pp(2)=real(cp(2)) ;ap(2)=api(2)
+ pp(3)=real(cp(6)) ;ap(3)=api(6)
+ pp(4)=real(cp(4)) ;ap(4)=api(4)
+ pp(5)=real(cp(1)) ;ap(5)=api(1)
+ pp(6)=real(cp(3)) ;ap(6)=api(3)
+ endif
+!
+ icase = 0
+ if (ap(1).gt.R0P0) icase = icase + base(1)
+ if (ap(2).gt.R0P0) icase = icase + base(2)
+ if (ap(3).gt.R0P0) icase = icase + base(3)
+ if (ap(4).gt.R0P0) icase = icase + base(4)
+ rp1 = pp(permtable(1,icase))
+ rp2 = pp(permtable(2,icase))
+ rp3 = pp(permtable(3,icase))
+ rp4 = pp(permtable(4,icase))
+ rp5 = pp(permtable(5,icase))
+ rp6 = pp(permtable(6,icase))
+ icase = casetable( icase)
+!
+ i3=0 ;if (-rp3.lt.R0P0) i3=-1
+ i4=0 ;if (-rp4.lt.R0P0) i4=-1
+ i5=0 ;if (-rp5.lt.R0P0) i5=-1
+ i6=0 ;if (-rp6.lt.R0P0) i6=-1
+!
+ if (icase.eq.0) then
+! 0 masses non-zero
+! write(*,*) 'MESSAGE from OneLOop box00 0: you are calling me' !CALLINGME
+ gg = R1P0/( rp5 * rp6 )
+ log5 = loga(-rp5/rmu2, i5 )
+ log6 = loga(-rp6/rmu2, i6 )
+ rslt(2) = gg*( 4*C1P0 )
+ rslt(1) = gg*(-2*(log5 + log6) )
+ rslt(0) = gg*( log5**2 + log6**2 - loga( rp5/rp6 ,i5-i6 )**2 - (pi2*4)/3 )
+ elseif (icase.eq.1) then
+! 1 mass non-zero
+! write(*,*) 'MESSAGE from OneLOop box00 1: you are calling me' !CALLINGME
+ gg = R1P0/( rp5 * rp6 )
+ ff = gg*( rp5 + rp6 - rp4 )
+ log4 = loga(-rp4/rmu2,i4)
+ log5 = loga(-rp5/rmu2,i5)
+ log6 = loga(-rp6/rmu2,i6)
+ sf = nint(sign(R1P0,ff))
+ sgn = 0
+ arg = rp4*ff
+ if (arg.lt.R0P0) sgn = sf
+ li24 = li2a(arg,sgn)
+ sgn = 0
+ arg = rp5*ff
+ if (arg.lt.R0P0) sgn = sf
+ li25 = li2a(arg,sgn)
+ sgn = 0
+ arg = rp6*ff
+ if (arg.lt.R0P0) sgn = sf
+ li26 = li2a(arg,sgn)
+ rslt(2) = gg*( 2*C1P0 )
+ rslt(1) = gg*( 2*(log4-log5-log6) )
+ rslt(0) = gg*( log5**2 + log6**2 - log4**2 - pi2/2 &
+ + 2*(li25 + li26 - li24) )
+ elseif (icase.eq.2) then
+! 2 neighbour masses non-zero
+! write(*,*) 'MESSAGE from OneLOop box00 2: you are calling me' !CALLINGME
+ gg = R1P0/( rp5 * rp6 )
+ ff = gg*( rp5 + rp6 - rp4 )
+ log3 = loga(-rp3/rmu2,i3)
+ log4 = loga(-rp4/rmu2,i4)
+ log5 = loga(-rp5/rmu2,i5)
+ log6 = loga(-rp6/rmu2,i6)
+ li254 = li2a( rp4/rp5 ,i4-i5 )
+ li263 = li2a( rp3/rp6 ,i3-i6 )
+ sf = nint(sign(R1P0,ff))
+ sgn = 0
+ arg = rp4*ff
+ if (arg.lt.R0P0) sgn = sf
+ li24 = li2a(arg,sgn)
+ sgn = 0
+ arg = rp5*ff
+ if (arg.lt.R0P0) sgn = sf
+ li25 = li2a(arg,sgn)
+ sgn = 0
+ arg = rp6*ff
+ if (arg.lt.R0P0) sgn = sf
+ li26 = li2a(arg,sgn)
+ rslt(2) = gg
+ rslt(1) = gg*( log4 + log3 - log5 - 2*log6 )
+ rslt(0) = gg*( log5**2 + log6**2 - log3**2 - log4**2 &
+ + (log3 + log4 - log5)**2/2 &
+ - pi2/12 + 2*(li254 - li263 + li25 + li26 - li24) )
+ elseif (icase.eq.5) then
+! 2 opposite masses non-zero
+ call box03( rslt ,cmplx(rp2,kind=kindc2),cmplx(rp4,kind=kindc2) &
+ ,cmplx(rp5,kind=kindc2),cmplx(rp6,kind=kindc2) ,rmu )
+ elseif (icase.eq.3) then
+! 3 masses non-zero
+ call box05( rslt ,cmplx(rp2,kind=kindc2),cmplx(rp3,kind=kindc2) &
+ ,cmplx(rp4,kind=kindc2),cmplx(rp5,kind=kindc2) &
+ ,cmplx(rp6,kind=kindc2) ,rmu )
+ elseif (icase.eq.4) then
+! 4 masses non-zero
+ call boxf0( rslt ,cmplx(rp1,kind=kindc2),cmplx(rp2,kind=kindc2) &
+ ,cmplx(rp3,kind=kindc2),cmplx(rp4,kind=kindc2) &
+ ,cmplx(rp5,kind=kindc2),cmplx(rp6,kind=kindc2) )
+ endif
+ end subroutine
+
+
+ subroutine boxf0( rslt ,p1,p2,p3,p4,p12,p23 )
+!*******************************************************************
+! Finite 1-loop scalar 4-point function with all internal masses
+! equal zero. Based on the formulas from
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3,p4,p12,p23
+ type(qmplx_type) :: q12,q13,q14,q23,q24,q34,qx1,qx2,qss
+ complex(kindc2) :: aa,bb,cc,dd,x1,x2,ss,r12,r13,r14,r23,r24,r34
+ real(kindr2) :: hh
+!
+! write(*,*) 'MESSAGE from OneLOop boxf0: you are calling me' !CALLINGME
+!
+ r12 = -p1 ! p1
+ r13 = -p12 ! p1+p2
+ r14 = -p4 ! p1+p2+p3
+ r23 = -p2 ! p2
+ r24 = -p23 ! p2+p3
+ r34 = -p3 ! p3
+!
+ aa = r34*r24
+!
+ if (r13.eq.C0P0.or.aa.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf0: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ bb = r13*r24 + r12*r34 - r14*r23
+ cc = r12*r13
+ hh = real(r23)
+ dd = mysqrt( bb*bb - 4*aa*cc , -real(aa)*hh )
+ call solabc(x1,x2,dd ,aa,bb,cc ,1)
+ x1 = -x1
+ x2 = -x2
+!
+ qx1 = qonv(x1 , hh)
+ qx2 = qonv(x2 ,-hh)
+ q12 = qonv(r12,-1)
+ q13 = qonv(r13,-1)
+ q14 = qonv(r14,-1)
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ rslt = C0P0
+!
+ qss = q34/q13
+ rslt(0) = rslt(0) + li2c2(qx1*qss,qx2*qss) * r34/r13
+!
+ qss = q24/q12
+ rslt(0) = rslt(0) + li2c2(qx1*qss,qx2*qss) * r24/r12
+!
+ ss = -logc2(qx1/qx2) / x2
+ rslt(0) = rslt(0) + ss*( logc(qx1*qx2)/2 - logc(q12*q13/q14/q23) )
+!
+ rslt(0) = -rslt(0) / aa
+ end subroutine
+
+
+ subroutine boxf1( rslt ,p1,p2,p3,p4,p12,p23 ,m4 )
+!*******************************************************************
+! Finite 1-loop scalar 4-point function with one internal mass
+! non-zero. Based on the formulas from
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m4
+ type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34
+ complex(kindc2) :: smm,sm4,aa,bb,cc,dd,x1,x2,r12,r13,r14,r23,r24,r34
+ logical :: r12zero,r13zero
+!
+! write(*,*) 'MESSAGE from OneLOop boxf1: you are calling me' !CALLINGME
+!
+ sm4 = mysqrt(m4)
+ smm = cmplx(abs(sm4),kind=kindc2)
+!
+ r12 = C0P0
+ r13 = C0P0
+ r14 = C0P0
+ r23 = C0P0
+ r24 = C0P0
+ r34 = C0P0
+ if (m4.ne.p4 ) r12 = ( m4-p4 *oieps )/(smm*sm4)
+ if (m4.ne.p23) r13 = ( m4-p23*oieps )/(smm*sm4)
+ if (m4.ne.p3 ) r14 = ( m4-p3 *oieps )/(smm*sm4)
+ r23 = ( -p1 *oieps )/(smm*smm)
+ r24 = ( -p12*oieps )/(smm*smm)
+ r34 = ( -p2 *oieps )/(smm*smm)
+!
+ r12zero = (r12.eq.C0P0)
+ r13zero = (r13.eq.C0P0)
+!
+ aa = r34*r24
+!
+ if (aa.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf1: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ bb = r13*r24 + r12*r34 - r14*r23
+ cc = r12*r13 - r23
+ call solabc(x1,x2,dd ,aa,bb,cc ,0)
+ x1 = -x1
+ x2 = -x2
+!
+ qx1 = qonv(x1 ,1 )
+ qx2 = qonv(x2 ,1 )
+ q12 = qonv(r12,-1)
+ q13 = qonv(r13,-1)
+ q14 = qonv(r14,-1)
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ rslt = C0P0
+!
+ if (r12zero.and.r13zero) then
+ qss = qx1*qx2*q34*q24/q23
+ qss = qss*qss
+ rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
+ else
+ if (r13zero) then
+ qss = q34*q12/q23
+ qss = qx1*qx2*qss*qss
+ rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
+ else
+ qss = q34/q13
+ rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34/r13
+ endif
+ if (r12zero) then
+ qss = q24*q13/q23
+ qss = qx1*qx2*qss*qss
+ rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
+ else
+ qss = q24/q12
+ rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r24/r12
+ endif
+ if (.not.r12zero.and..not.r13zero) then
+ rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( q12*q13/q23 )/x2
+ endif
+ endif
+!
+ if (r14.ne.C0P0) then
+ rslt(0) = rslt(0) - li2c2( qx1*q14 ,qx2*q14 )*r14
+ endif
+!
+ rslt(0) = -rslt(0)/(aa*smm*smm*smm*sm4)
+ end subroutine
+
+
+ subroutine boxf5( rslt ,p1,p2,p3,p4,p12,p23, m2,m4 )
+!*******************************************************************
+! Finite 1-loop scalar 4-point function with two opposite internal
+! masses non-zero. Based on the formulas from
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+!*******************************************************************
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3,p4,p12,p23,m2,m4
+ call boxf2( rslt ,p12,p2,p23,p4,p1,p3 ,m2,m4 )
+ end subroutine
+
+
+ subroutine boxf2( rslt ,p1,p2,p3,p4,p12,p23 ,m3,m4 )
+!*******************************************************************
+! Finite 1-loop scalar 4-point function with two adjacent internal
+! masses non-zero. Based on the formulas from
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3,p4,p12,p23,m3,m4
+ type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34
+ complex(kindc2) :: smm,sm3,sm4,aa,bb,cc,dd,x1,x2 &
+ ,r12,r13,r14,r23,r24,r34,d14,k14
+ logical :: r12zero,r13zero,r24zero,r34zero
+!
+! write(*,*) 'MESSAGE from OneLOop boxf2: you are calling me' !CALLINGME
+!
+ sm3 = mysqrt(m3)
+ sm4 = mysqrt(m4)
+!
+ smm = cmplx(abs(sm3),kind=kindc2)
+!
+ r12 = C0P0
+ r13 = C0P0
+ k14 = C0P0
+ r23 = C0P0
+ r24 = C0P0
+ r34 = C0P0
+ if ( m4.ne.p4 ) r12 = ( m4-p4 *oieps )/(smm*sm4)
+ if ( m4.ne.p23) r13 = ( m4-p23*oieps )/(smm*sm4)
+ if (m3+m4.ne.p3 ) k14 = ( m3+m4-p3 *oieps )/(sm3*sm4)
+ r23 = ( -p1 *oieps )/(smm*smm)
+ if ( m3.ne.p12) r24 = ( m3-p12*oieps )/(smm*sm3)
+ if ( m3.ne.p2 ) r34 = ( m3-p2 *oieps )/(smm*sm3)
+!
+ r12zero = (r12.eq.C0P0)
+ r13zero = (r13.eq.C0P0)
+ r24zero = (r24.eq.C0P0)
+ r34zero = (r34.eq.C0P0)
+ if (r12zero.and.r24zero) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf2: ' &
+ ,'m4=p4 and m3=p12, returning 0'
+ rslt = C0P0
+ return
+ endif
+ if (r13zero.and.r34zero) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf2: ' &
+ ,'m4=p23 and m3=p2, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ call rfun( r14,d14 ,k14 )
+!
+ aa = r34*r24 - r23
+!
+ if (aa.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf2: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ bb = r13*r24 + r12*r34 - k14*r23
+ cc = r12*r13 - r23
+ call solabc(x1,x2,dd ,aa,bb,cc ,0)
+ x1 = -x1
+ x2 = -x2
+!
+ qx1 = qonv(x1 ,1 )
+ qx2 = qonv(x2 ,1 )
+ q12 = qonv(r12,-1)
+ q13 = qonv(r13,-1)
+ q14 = qonv(r14,-1)
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ rslt = C0P0
+!
+ rslt(0) = rslt(0) - li2c2( qx1*q14 ,qx2*q14 )*r14
+ rslt(0) = rslt(0) - li2c2( qx1/q14 ,qx2/q14 )/r14
+!
+ if (r12zero.and.r13zero) then
+ qss = qx1*qx2*q34*q24/q23
+ qss = qss*qss
+ rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
+ else
+ if (r13zero) then
+ qss = q34*q12/q23
+ qss = qx1*qx2*qss*qss
+ rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
+ elseif (.not.r34zero) then
+ qss = q34/q13
+ rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34/r13
+ endif
+ if (r12zero) then
+ qss = q24*q13/q23
+ qss = qx1*qx2*qss*qss
+ rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
+ elseif (.not.r24zero) then
+ qss = q24/q12
+ rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r24/r12
+ endif
+ if (.not.r12zero.and..not.r13zero) then
+ rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( q12*q13/q23 )/x2
+ endif
+ endif
+!
+ rslt(0) = -rslt(0)/(aa*smm*smm*sm3*sm4)
+ end subroutine
+
+
+ subroutine boxf3( rslt ,pp ,mm )
+!*******************************************************************
+! Finite 1-loop scalar 4-point function with three internal masses
+! non-zero.
+!*******************************************************************
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: pp(6),mm(4)
+ integer :: j
+ integer ,parameter :: ip(6)=(/4,5,2,6,3,1/)
+ integer ,parameter :: im(4)=(/4,1,3,2/)
+ integer ,parameter :: ic(4,6)=reshape((/1,2,3,4 ,2,3,4,1 ,3,4,1,2 &
+ ,4,1,2,3 ,5,6,5,6 ,6,5,6,5/),(/4,6/))
+!
+ if (mm(1).eq.C0P0) then ;j=3
+ elseif (mm(2).eq.C0P0) then ;j=4
+ elseif (mm(3).eq.C0P0) then ;j=1
+ else ;j=2
+ endif
+ call boxf33( rslt ,pp(ic(j,ip(1))) ,pp(ic(j,ip(2))) ,pp(ic(j,ip(3))) &
+ ,pp(ic(j,ip(4))) ,pp(ic(j,ip(5))) ,pp(ic(j,ip(6))) &
+ ,mm(ic(j,im(1))) ,mm(ic(j,im(2))) ,mm(ic(j,im(4))) )
+ end subroutine
+
+ subroutine boxf33( rslt ,p1,p2,p3,p4,p12,p23, m1,m2,m4 )
+!*******************************************************************
+! Finite 1-loop scalar 4-point function with three internal masses
+! non-zero, and m3=0. Based on the formulas from
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3,p4,p12,p23,m1,m2,m4
+ type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34,qy1,qy2
+ complex(kindc2) :: sm1,sm2,sm3,sm4 ,aa,bb,cc,dd,x1,x2 &
+ ,r12,r13,r14,r23,r24,r34,d12,d14,d24,k12,k14,k24
+ logical ::r13zero,r23zero,r34zero
+!
+! write(*,*) 'MESSAGE from OneLOop boxf33: you are calling me' !CALLINGME
+!
+ sm1 = mysqrt(m1)
+ sm2 = mysqrt(m2)
+ sm4 = mysqrt(m4)
+ sm3 = cmplx(abs(sm2),kind=kindc2)
+!
+ k12 = C0P0
+ r13 = C0P0
+ k14 = C0P0
+ r23 = C0P0
+ k24 = C0P0
+ r34 = C0P0
+ if (m1+m2.ne.p1 ) k12 = ( m1 + m2 - p1 *oieps )/(sm1*sm2) ! p1
+ if (m1 .ne.p12) r13 = ( m1 - p12*oieps )/(sm1*sm3) ! p1+p2
+ if (m1+m4.ne.p4 ) k14 = ( m1 + m4 - p4 *oieps )/(sm1*sm4) ! p1+p2+p3
+ if (m2 .ne.p2 ) r23 = ( m2 - p2 *oieps )/(sm2*sm3) ! p2
+ if (m2+m4.ne.p23) k24 = ( m2 + m4 - p23*oieps )/(sm2*sm4) ! p2+p3
+ if ( m4.ne.p3 ) r34 = ( m4 - p3 *oieps )/(sm3*sm4) ! p3
+!
+ r13zero = (r13.eq.C0P0)
+ r23zero = (r23.eq.C0P0)
+ r34zero = (r34.eq.C0P0)
+ if (r13zero) then
+ if (r23zero) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf33: ' &
+ ,'m4=p4 and m3=p12, returning 0'
+ rslt = C0P0
+ return
+ elseif (r34zero) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf33: ' &
+ ,'m2=p1 and m3=p12, returning 0'
+ rslt = C0P0
+ return
+ endif
+ endif
+!
+ call rfun( r12,d12 ,k12 )
+ call rfun( r14,d14 ,k14 )
+ call rfun( r24,d24 ,k24 )
+!
+ aa = r34/r24 - r23
+!
+ if (aa.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf33: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ bb = -r13*d24 + k12*r34 - k14*r23
+ cc = k12*r13 + r24*r34 - k14*r24*r13 - r23
+ call solabc(x1,x2,dd ,aa,bb,cc ,0)
+ x1 = -x1
+ x2 = -x2
+!
+ qx1 = qonv(x1 ,1 ) ! x1 SHOULD HAVE im. part
+ qx2 = qonv(x2 ,1 ) ! x2 SHOULD HAVE im. part
+ q12 = qonv(r12,-1)
+ q13 = qonv(r13,-1)
+ q14 = qonv(r14,-1)
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ rslt = C0P0
+!
+ qy1 = qx1/q24
+ qy2 = qx2/q24
+ rslt(0) = rslt(0) + li2c2( qy1*q12 ,qy2*q12 )/r24*r12
+ rslt(0) = rslt(0) + li2c2( qy1/q12 ,qy2/q12 )/r24/r12
+ rslt(0) = rslt(0) - li2c2( qx1*q14 ,qx2*q14 )*r14
+ rslt(0) = rslt(0) - li2c2( qx1/q14 ,qx2/q14 )/r14
+!
+ if (.not.r13zero) then
+ if (.not.r23zero) then
+ qss = q23/q13/q24
+ rslt(0) = rslt(0) - li2c2( qx1*qss ,qx2*qss )*r23/(r13*r24)
+ endif
+ if (.not.r34zero) then
+ qss = q34/q13
+ rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34/r13
+ endif
+ else
+ rslt(0) = rslt(0) - logc2( qx1/qx2 )*logc( q23/q24/q34 )/x2
+ endif
+!
+ rslt(0) = -rslt(0)/(aa*sm1*sm2*sm3*sm4)
+ end subroutine
+
+
+ subroutine boxf4( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
+!*******************************************************************
+! Finite 1-loop scalar 4-point function with all internal masses
+! non-zero. Based on the formulas from
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+!*******************************************************************
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3,p4,p12,p23,m1,m2,m3,m4
+ type(qmplx_type) :: q12,q13,q14,q23,q24,q34,qx1,qx2,qy1,qy2,qtt
+ complex(kindc2) :: sm1,sm2,sm3,sm4 ,aa,bb,cc,dd,x1,x2,tt &
+ ,k12,k13,k14,k23,k24,k34 &
+ ,r12,r13,r14,r23,r24,r34 &
+ ,d12,d13,d14,d23,d24,d34
+ real(kindr2) :: h1,h2
+!
+! write(*,*) 'MESSAGE from OneLOop boxf4: you are calling me' !CALLINGME
+!
+ sm1 = mysqrt(m1)
+ sm2 = mysqrt(m2)
+ sm3 = mysqrt(m3)
+ sm4 = mysqrt(m4)
+!
+ k12 = C0P0
+ k13 = C0P0
+ k14 = C0P0
+ k23 = C0P0
+ k24 = C0P0
+ k34 = C0P0
+ if (m1+m2.ne.p1 ) k12 = ( m1 + m2 - p1 *oieps)/(sm1*sm2) ! p1
+ if (m1+m3.ne.p12) k13 = ( m1 + m3 - p12*oieps)/(sm1*sm3) ! p1+p2
+ if (m1+m4.ne.p4 ) k14 = ( m1 + m4 - p4 *oieps)/(sm1*sm4) ! p1+p2+p3
+ if (m2+m3.ne.p2 ) k23 = ( m2 + m3 - p2 *oieps)/(sm2*sm3) ! p2
+ if (m2+m4.ne.p23) k24 = ( m2 + m4 - p23*oieps)/(sm2*sm4) ! p2+p3
+ if (m3+m4.ne.p3 ) k34 = ( m3 + m4 - p3 *oieps)/(sm3*sm4) ! p3
+!
+ call rfun( r12,d12 ,k12 )
+ call rfun( r13,d13 ,k13 )
+ call rfun( r14,d14 ,k14 )
+ call rfun( r23,d23 ,k23 )
+ call rfun( r24,d24 ,k24 )
+ call rfun( r34,d34 ,k34 )
+!
+ aa = k34/r24 + r13*k12 - k14*r13/r24 - k23
+!
+ if (aa.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf4: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ bb = d13*d24 + k12*k34 - k14*k23
+ cc = k12/r13 + r24*k34 - k14*r24/r13 - k23
+ call solabc(x1,x2,dd ,aa,bb,cc ,0)
+!
+ h1 = real(k23 - r13*k12 - r24*k34 + r13*r24*k14)
+ h2 = h1*real(aa)*real(x1)
+ h1 = h1*real(aa)*real(x2)
+!
+ qx1 = qonv(-x1,-h1) ! x1 should have im. part
+ qx2 = qonv(-x2,-h2) ! x2 should have im. part
+ q12 = qonv(r12,-1)
+ q13 = qonv(r13,-1)
+ q14 = qonv(r14,-1)
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ rslt = C0P0
+!
+ qy1 = qx1/q24
+ qy2 = qx2/q24
+ rslt(0) = rslt(0) + ( li2c2( qy1*q12 ,qy2*q12 )*r12 &
+ + li2c2( qy1/q12 ,qy2/q12 )/r12 )/r24
+ tt = r13/r24
+ qtt = qonv(tt,-real(r24) )
+ qy1 = qx1*qtt
+ qy2 = qx2*qtt
+ rslt(0) = rslt(0) - ( li2c2( qy1*q23 ,qy2*q23 )*r23 &
+ + li2c2( qy1/q23 ,qy2/q23 )/r23 )*tt
+ qy1 = qx1*q13
+ qy2 = qx2*q13
+ rslt(0) = rslt(0) + ( li2c2( qy1*q34 ,qy2*q34 )*r34 &
+ + li2c2( qy1/q34 ,qy2/q34 )/r34 )*r13
+!
+ rslt(0) = rslt(0) - ( li2c2( qx1*q14 ,qx2*q14 )*r14 &
+ + li2c2( qx1/q14 ,qx2/q14 )/r14 )
+!
+ rslt(0) = -rslt(0)/(aa*sm1*sm2*sm3*sm4)
+ end subroutine
+
+end module
diff --git a/avh_olo-2.2.1/avh_olo_boxc.f90 b/avh_olo-2.2.1/avh_olo_boxc.f90
new file mode 100644
index 0000000..f538af4
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_boxc.f90
@@ -0,0 +1,617 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+module avh_olo_boxc
+ use avh_olo_kinds
+ use avh_olo_units
+ use avh_olo_func
+ implicit none
+ private
+ public :: boxc,init_boxc
+ real(kindr2) :: thrss3fun=epsilon(R1P0)*1000
+ integer :: ndigits=0
+contains
+
+ subroutine init_boxc(ndig)
+ integer ,intent(in) :: ndig
+ if (ndigits.eq.ndig) return ;ndigits=ndig
+ if (ndigits.lt.16) then ;thrss3fun = epsilon(R1P0)*1000
+ elseif (ndigits.lt.24) then ;thrss3fun = epsilon(R1P0)*30000
+ else ;thrss3fun = epsilon(R1P0)*1000000
+ endif
+ end subroutine
+
+
+ subroutine boxc( rslt ,pp_in,mm_in ,ap_in )
+!*******************************************************************
+! Finite 1-loop scalar 4-point function for complex internal masses
+! Based on the formulas from
+! Dao Thi Nhung and Le Duc Ninh, arXiv:0902.0325 [hep-ph]
+! G. 't Hooft and M.J.G. Veltman, Nucl.Phys.B153:365-401,1979
+!*******************************************************************
+ use avh_olo_box ,only: base,casetable,ll=>permtable
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(inout) :: pp_in(6),mm_in(4)
+ real(kindr2) ,intent(in) :: ap_in(6)
+ complex(kindc2) :: pp(6),mm(4)
+ real(kindr2) :: ap(6),aptmp(6),rem,imm,hh
+ complex(kindc2) :: a,b,c,d,e,f,g,h,j,k,dpe,epk,x1,x2,sdnt,o1,j1,e1
+ integer :: icase,jcase,ii,jj
+ integer ,parameter :: lp(6,3)=&
+ reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
+ integer ,parameter :: lm(4,3)=&
+ reshape((/1,2,3,4 ,1,3,2,4 ,1,2,4,3 /),(/4,3/))
+ real(kindr2) ,parameter :: small=epsilon(R1P0)
+!
+! write(*,*) 'MESSAGE from OneLOop boxc: you are calling me' !CALLINGME
+!
+ rslt = C0P0
+!
+ hh = R0P0
+ do ii=1,6
+ aptmp(ii) = ap_in(ii)
+ if (aptmp(ii).gt.hh) hh = aptmp(ii)
+ enddo
+ hh = 100*small*hh
+ do ii=1,6
+ if (aptmp(ii).lt.hh) aptmp(ii) = R0P0
+ enddo
+!
+ if (aptmp(5).eq.R0P0.or.aptmp(6).eq.R0P0) then
+ if (aptmp(1).eq.R0P0.or.aptmp(3).eq.R0P0) then
+ if (aptmp(2).eq.R0P0.or.aptmp(4).eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxc: ' &
+ ,'no choice with |s| and |t| large enough, putting them by hand'
+ if (aptmp(5).eq.R0P0) then
+ aptmp(5) = hh
+ pp_in(5) = cmplx(sign(hh,real(pp_in(5))),kind=kindc2)
+ endif
+ if (aptmp(6).eq.R0P0) then
+ aptmp(6) = hh
+ pp_in(6) = cmplx(sign(hh,real(pp_in(6))),kind=kindc2)
+ endif
+ jj = 1
+ else
+ jj = 3
+ endif
+ else
+ jj = 2
+ endif
+ else
+ jj = 1
+ endif
+ do ii=1,6
+ ap(ii) = aptmp(lp(ii,jj))
+ if (ap(ii).gt.R0P0) then ;pp(ii) = pp_in(lp(ii,jj))
+ else ;pp(ii) = C0P0
+ endif
+ enddo
+ do ii=1,4
+ rem = real(mm_in(lm(ii,jj)))
+ imm = aimag(mm_in(lm(ii,jj)))
+ hh = small*abs(rem)
+ if (abs(imm).lt.hh) imm = -hh
+ mm(ii) = cmplx(rem,imm,kind=kindc2)
+ enddo
+!
+ icase = 0
+ do ii=1,4
+ if (ap(ii).gt.R0P0) icase = icase + base(ii)
+ enddo
+!
+ if (icase.lt.15) then
+! at least one exernal mass equal zero
+ jcase = casetable(icase)
+ if (jcase.eq.0.or.jcase.eq.1.or.jcase.eq.5) then
+! two opposite masses equal zero
+ a = pp(ll(5,icase)) - pp(ll(1,icase))
+ c = pp(ll(4,icase)) - pp(ll(5,icase)) - pp(ll(3,icase))
+ g = pp(ll(2,icase))
+ h = pp(ll(6,icase)) - pp(ll(2,icase)) - pp(ll(3,icase))
+ d = (mm(ll(3,icase)) - mm(ll(4,icase))) - pp(ll(3,icase))
+ e = (mm(ll(1,icase)) - mm(ll(3,icase))) + pp(ll(3,icase)) - pp(ll(4,icase))
+ f = mm(ll(4,icase))
+ j = (mm(ll(2,icase)) - mm(ll(3,icase))) - pp(ll(6,icase)) + pp(ll(3,icase))
+ rslt(0) = t13fun( a,c,g,h ,d,e,f,j )
+ else
+ a = pp(ll(3,icase))
+ b = pp(ll(2,icase))
+ c = pp(ll(6,icase)) - pp(ll(2,icase)) - pp(ll(3,icase))
+ h = pp(ll(4,icase)) - pp(ll(5,icase)) - pp(ll(6,icase)) + pp(ll(2,icase))
+ j = pp(ll(5,icase)) - pp(ll(1,icase)) - pp(ll(2,icase))
+ d = (mm(ll(3,icase)) - mm(ll(4,icase))) - pp(ll(3,icase))
+ e = (mm(ll(2,icase)) - mm(ll(3,icase))) - pp(ll(6,icase)) + pp(ll(3,icase))
+ k = (mm(ll(1,icase)) - mm(ll(2,icase))) + pp(ll(6,icase)) - pp(ll(4,icase))
+ f = mm(ll(4,icase))
+ epk = (mm(ll(1,icase)) - mm(ll(3,icase))) + pp(ll(3,icase)) - pp(ll(4,icase))
+ rslt(0) = tfun( a,b ,c ,h,j ,d,e ,f,k ) &
+ - tfun( a,b+j,c+h,h,j ,d,epk,f,k )
+ endif
+ else
+! no extenal mass equal zero
+ if (real((pp(5)-pp(1)-pp(2))**2-4*pp(1)*pp(2)).gt.R0P0)then ;icase=0 !12, no permutation
+ elseif(real((pp(6)-pp(2)-pp(3))**2-4*pp(2)*pp(3)).gt.R0P0)then ;icase=8 !23, 1 cyclic permutation
+ elseif(real((pp(4)-pp(5)-pp(3))**2-4*pp(5)*pp(3)).gt.R0P0)then ;icase=4 !34, 2 cyclic permutations
+ elseif(real((pp(4)-pp(1)-pp(6))**2-4*pp(1)*pp(6)).gt.R0P0)then ;icase=2 !41, 3 cyclic permutations
+ else
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxc: ' &
+ ,'no positive lambda, returning 0'
+ return
+ endif
+ a = pp(ll(3,icase))
+ b = pp(ll(2,icase))
+ g = pp(ll(1,icase))
+ c = pp(ll(6,icase)) - pp(ll(2,icase)) - pp(ll(3,icase))
+ h = pp(ll(4,icase)) - pp(ll(5,icase)) - pp(ll(6,icase)) + pp(ll(2,icase))
+ j = pp(ll(5,icase)) - pp(ll(1,icase)) - pp(ll(2,icase))
+ d = (mm(ll(3,icase)) - mm(ll(4,icase))) - pp(ll(3,icase))
+ e = (mm(ll(2,icase)) - mm(ll(3,icase))) - pp(ll(6,icase)) + pp(ll(3,icase))
+ k = (mm(ll(1,icase)) - mm(ll(2,icase))) + pp(ll(6,icase)) - pp(ll(4,icase))
+ f = mm(ll(4,icase))
+ dpe = (mm(ll(2,icase)) - mm(ll(4,icase))) - pp(ll(6,icase))
+ epk = (mm(ll(1,icase)) - mm(ll(3,icase))) + pp(ll(3,icase)) - pp(ll(4,icase))
+ call solabc( x1,x2 ,sdnt ,g,j,b ,0 )
+ if (aimag(sdnt).ne.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxc: ' &
+ ,'no real solution for alpha, returning 0'
+ return
+ endif
+!BAD if (abs(real(x1)).gt.abs(real(x2))) then
+ if (abs(real(x1)).lt.abs(real(x2))) then !BETTER
+ sdnt = x1
+ x1 = x2
+ x2 = sdnt
+ endif
+ o1 = C1P0-x1
+ j1 = j+2*g*x1
+ e1 = e+k*x1
+ rslt(0) = -tfun( a+b+c,g ,j+h,c+2*b+(h+j)*x1,j1 ,dpe,k ,f,e1 ) &
+ + o1*tfun( a ,b+g+j,c+h,c+h*x1 ,o1*j1 ,d ,epk,f,e1 ) &
+ + x1*tfun( a ,b ,c ,c+h*x1 ,-j1*x1,d ,e ,f,e1 )
+ endif
+ end subroutine
+
+
+ function t13fun( aa,cc,gg,hh ,dd,ee,ff,jj ) result(rslt)
+!*******************************************************************
+! /1 /x y
+! | dx | dy -----------------------------------------------------
+! /0 /0 (gy^2 + hxy + dx + jy + f)*(ax^2 + cxy + dx + ey + f)
+!
+! jj should have negative imaginary part
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: aa,cc,gg,hh ,dd,ee,ff,jj
+ complex(kindc2) :: rslt ,kk,ll,nn,y1,y2,sdnt,ieps
+ real(kindr2) ,parameter :: small=epsilon(R1P0)**2
+!
+! write(*,*) 'MESSAGE from OneLOop t13fun: you are calling me' !CALLINGME
+!
+ ieps = cmplx(R0P0,small*abs(real(ff)),kind=kindc2)
+!
+ kk = hh*aa - cc*gg
+ ll = aa*dd + hh*ee - dd*gg - cc*jj
+ nn = dd*(ee - jj) + (hh - cc)*(ff-ieps)
+ call solabc( y1,y2 ,sdnt ,kk,ll,nn ,0 )
+!
+ rslt = - s3fun( y1,y2 ,C0P0,C1P0 ,aa ,ee+cc,dd+ff ) &
+ + s3fun( y1,y2 ,C0P0,C1P0 ,gg ,jj+hh,dd+ff ) &
+ - s3fun( y1,y2 ,C0P0,C1P0 ,gg+hh,dd+jj,ff ) &
+ + s3fun( y1,y2 ,C0P0,C1P0 ,aa+cc,ee+dd,ff )
+!
+ rslt = rslt/kk
+ end function
+
+
+ function t1fun( aa,cc,gg,hh ,dd,ee,ff,jj ) result(rslt)
+!*******************************************************************
+! /1 /x 1
+! | dx | dy ----------------------------------------------
+! /0 /0 (g*x + h*x + j)*(a*x^2 + c*xy + d*x + e*y + f)
+!
+! jj should have negative imaginary part
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: aa,cc,gg,hh ,dd,ee,ff,jj
+ complex(kindc2) ::rslt ,kk,ll,nn,y1,y2,sdnt,ieps
+ real(kindr2) ,parameter :: small=epsilon(R1P0)**2
+!
+! write(*,*) 'MESSAGE from OneLOop t1fun: you are calling me' !CALLINGME
+!
+ ieps = cmplx(R0P0,small*abs(real(ff)),kind=kindc2)
+!
+ kk = hh*aa - cc*gg
+ ll = hh*dd - cc*jj - ee*gg
+ nn = hh*(ff-ieps) - ee*jj
+ call solabc( y1,y2 ,sdnt ,kk,ll,nn ,0 )
+!
+ rslt = - s3fun( y1,y2 ,C0P0,C1P0 ,aa+cc,dd+ee,ff ) &
+ + s3fun( y1,y2 ,C0P0,C1P0 ,C0P0 ,gg+hh,jj ) &
+ - s3fun( y1,y2 ,C0P0,C1P0 ,C0P0 ,gg ,jj ) &
+ + s3fun( y1,y2 ,C0P0,C1P0 ,aa ,dd ,ff )
+!
+ rslt = rslt/kk
+ end function
+
+
+ function tfun( aa,bb,cc ,gin,hin ,dd,ee,ff ,jin ) result(rslt)
+!*******************************************************************
+! /1 /x 1
+! | dx | dy ------------------------------------------------------
+! /0 /0 (g*x + h*x + j)*(a*x^2 + b*y^2 + c*xy + d*x + e*y + f)
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: aa,bb,cc ,gin,hin ,dd,ee,ff ,jin
+ complex(kindc2) :: rslt ,gg,hh,jj,zz(2),beta,tmpa(2),tmpb(2) &
+ ,tmpc(2),kiz(2),ll,nn,kk,y1,y2,yy(2,2),sdnt,ieps
+ real(kindr2) :: sj,ab1,ab2,ac1,ac2,abab,acac,abac,det,ap1,ap2 &
+ ,apab,apac,x1(2,2),x2(2,2),xmin
+ integer :: iz,iy,izmin
+ logical :: pp(2,2),p1,p2
+ real(kindr2) ,parameter :: small=epsilon(R1P0)**2
+!
+! write(*,*) 'MESSAGE from OneLOop tfun: you are calling me' !CALLINGME
+!
+ sj = aimag(jin)
+ if (sj.eq.R0P0) then
+ sj = -R1P0
+ else
+ sj = sign(R1P0,aimag(jin))
+ endif
+ gg = -sj*gin
+ hh = -sj*hin
+ jj = -sj*jin
+!
+ if (bb.eq.C0P0) then
+ rslt = -sj*t1fun( aa,cc,gg,hh ,dd,ee,ff,jj )
+ return
+ elseif (aa.eq.C0P0) then
+ rslt = -sj*t1fun( bb+cc,-cc,-gg-hh,gg,-dd-ee-2*(bb+cc),dd+cc,dd+ee+bb+cc+ff,gg+hh+jj )
+ return
+ endif
+!
+ ieps = cmplx(R0P0,small*abs(real(ff)),kind=kindc2)
+!
+ call solabc( zz(1),zz(2) ,sdnt ,bb,cc,aa ,0 )
+ if (abs(zz(1)).gt.abs(zz(2))) then
+ beta = zz(1)
+ zz(1) = zz(2)
+ zz(2) = beta
+ endif
+!
+ do iz=1,2
+ beta = zz(iz)
+ tmpa(iz) = gg + beta*hh
+ tmpb(iz) = cc + 2*beta*bb
+ tmpc(iz) = dd + beta*ee
+ kiz(iz) = bb*tmpa(iz) - hh*tmpb(iz)
+ ll = ee*tmpa(iz) - hh*tmpc(iz) - jj*tmpb(iz)
+ nn = (ff-ieps)*tmpa(iz) - jj*tmpc(iz)
+ call solabc( yy(iz,1),yy(iz,2) ,sdnt ,kiz(iz),ll,nn ,0 )
+ if (abs(aimag(beta)).ne.R0P0) then
+ ab1 = real(-beta)
+ ab2 = aimag(-beta)
+ ac1 = ab1+R1P0 !real(C1P0-beta)
+ ac2 = ab2 !aimag(C1P0-beta)
+ abab = ab1*ab1 + ab2*ab2
+ acac = ac1*ac1 + ac2*ac2
+ abac = ab1*ac1 + ab2*ac2
+ det = abab*acac - abac*abac
+ do iy=1,2
+ ap1 = real(yy(iz,iy))
+ ap2 = aimag(yy(iz,iy))
+ apab = ap1*ab1 + ap2*ab2
+ apac = ap1*ac1 + ap2*ac2
+ x1(iz,iy) = ( acac*apab - abac*apac )/det
+ x2(iz,iy) = (-abac*apab + abab*apac )/det
+ enddo
+ else
+ do iy=1,2
+ x1(iz,iy) = -R1P0
+ x2(iz,iy) = -R1P0
+ enddo
+ endif
+ enddo
+ xmin = R1P0
+ izmin = 2
+ do iz=1,2
+ do iy=1,2
+ if ( x1(iz,iy).ge.R0P0.and.x2(iz,iy).ge.R0P0 &
+ .and.x1(iz,iy)+x2(iz,iy).le.R1P0 ) then
+ pp(iz,iy) = .true.
+ if (x1(iz,iy).lt.xmin) then
+ xmin = x1(iz,iy)
+ izmin = iz
+ endif
+ if (x2(iz,iy).lt.xmin) then
+ xmin = x2(iz,iy)
+ izmin = iz
+ endif
+ else
+ pp(iz,iy) = .false.
+ endif
+ enddo
+ enddo
+ iz = izmin+1
+ if (iz.eq.3) iz = 1
+!
+ beta = zz(iz)
+ kk = kiz(iz)
+ y1 = yy(iz,1)
+ y2 = yy(iz,2)
+ p1 = pp(iz,1)
+ p2 = pp(iz,2)
+!
+ rslt = + s3fun( y1,y2 ,beta ,C1P0 ,C0P0 ,hh ,gg+jj ) &
+ - s3fun( y1,y2 ,C0P0 ,C1P0-beta ,C0P0 ,gg+hh, jj ) &
+ + s3fun( y1,y2 ,C0P0 , -beta ,C0P0 ,gg , jj ) &
+ - s3fun( y1,y2 ,beta ,C1P0 ,bb ,cc+ee,aa+dd+ff ) &
+ + s3fun( y1,y2 ,C0P0 ,C1P0-beta ,aa+bb+cc,dd+ee,ff ) &
+ - s3fun( y1,y2 ,C0P0 , -beta ,aa ,dd ,ff )
+!
+ sdnt = plnr( y1,y2 ,p1,p2, tmpa(iz),tmpb(iz),tmpc(iz) )
+ if (aimag(beta).le.R0P0) then ;rslt = rslt + sdnt
+ else ;rslt = rslt - sdnt
+ endif
+!
+ rslt = -sj*rslt/kk
+ end function
+
+
+ function s3fun( y1i,y2i ,dd,ee ,aa,bb,cin ) result(rslt)
+!*******************************************************************
+! Calculate
+! ( S3(y1i) - S3(y2i) )/( y1i - y2i )
+! where
+! /1 ee * ln( aa*x^2 + bb*x + cc )
+! S3(y) = | dx -----------------------------
+! /0 ee*x - y - dd
+!
+! y1i,y2i should have a non-zero imaginary part
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ complex(kindc2) ,intent(in) :: y1i,y2i ,dd,ee ,aa,bb,cin
+ complex(kindc2) :: rslt ,y1,y2,fy1y2,z1,z2,tmp,cc
+ real(kindr2) ::rea,reb,rez1,rez2,imz1,imz2,simc
+ real(kindr2) ,parameter :: small=epsilon(R1P0)**2
+!
+ if (ee.eq.C0P0) then
+ rslt = C0P0
+ return
+ endif
+!
+ cc = cin
+ rea = abs(aa)
+ reb = abs(bb)
+ simc = abs(cc)
+ if (simc.lt.thrss3fun*min(rea,reb)) cc = C0P0
+!
+ simc = aimag(cc)
+ if (simc.eq.R0P0) then
+ simc = aimag(bb)
+ if (simc.eq.R0P0) simc = -R1P0
+ endif
+ simc = sign(R1P0,simc)
+!
+ y1 = (dd+y1i)/ee
+ y2 = (dd+y2i)/ee
+ if (aimag(y1).eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop s3fun: ' &
+ ,'y1 has zero imaginary part'
+ endif
+ if (aimag(y2).eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop s3fun: ' &
+ ,'y2 has zero imaginary part'
+ endif
+ fy1y2 = r0fun( y1,y2 )
+!
+ if (aa.ne.C0P0) then
+!
+ call solabc( z1,z2 ,tmp ,aa,bb,cc ,0 )
+ rea = sign(R1P0,real(aa))
+ rez1 = real(z1)
+ rez2 = real(z2)
+ imz1 = aimag(z1) ! sign(Im(a*z1*z2)) = simc
+ imz2 = aimag(z2)
+ if (imz1.eq.R0P0) imz1 = simc*rea*sign(R1P0,rez2)*abs(small*rez1)
+ if (imz2.eq.R0P0) imz2 = simc*rea*sign(R1P0,rez1)*abs(small*rez2)
+ z1 = cmplx( rez1,imz1,kind=kindc2 )
+ z2 = cmplx( rez2,imz2,kind=kindc2 )
+ rslt = fy1y2 * ( logc(qonv(aa,simc)) &
+ + eta3( -z1,-imz1,-z2,-imz2,C0P0,simc*rea ) ) &
+ + r1fun( z1,y1,y2,fy1y2 ) &
+ + r1fun( z2,y1,y2,fy1y2 )
+!
+ elseif (bb.ne.C0P0) then
+!
+ z1 = -cc/bb ! - i|eps|Re(b)
+ reb = real(bb)
+ rez1 = real(z1)
+ imz1 = aimag(z1)
+ if (abs(imz1).eq.R0P0) then
+ imz1 = -simc*reb*abs(small*rez1/reb)
+ z1 = cmplx( rez1,imz1,kind=kindc2 )
+ endif
+ rslt = fy1y2 * ( logc(qonv(bb,simc)) &
+ + eta3(bb,simc ,-z1,-imz1 ,cc,simc) ) &
+ + r1fun( z1,y1,y2,fy1y2 )
+!
+ elseif (cc.ne.C0P0) then
+!
+ rslt = logc( qonv(cc,simc) )*fy1y2
+!
+ else!if (aa=bb=cc=0)
+!
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop s3fun: ' &
+ ,'cc equal zero, returning 0'
+ rslt = C0P0
+!
+ endif
+!
+ rslt = rslt/ee
+ end function
+
+
+ function r1fun( zz,y1,y2,fy1y2 ) result(rslt)
+!*******************************************************************
+! calculates ( R1(y1,z) - R1(y2,z) )/( y1 - y2 )
+! where
+! / / 1-y \ / 1-z \ \
+! R1(y,z) = ln(y-z) * | log |-----| - log |-----| |
+! \ \ -y / \ -z / /
+!
+! / y-z \ / y-z \
+! - Li2 |1 - ----| + Li2 |1 - ----|
+! \ -z / \ 1-z /
+!
+! / 1-y1 \ / 1-y2 \
+! log |------| - log |------|
+! input fy1y2 should be equal to \ -y1 / \ -y2 /
+! ---------------------------
+! y1 - y2
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_li2c ,only: li2c
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(in) :: y1,y2,zz,fy1y2
+ complex(kindc2) :: rslt ,oz
+ type(qmplx_type) :: q1z,q2z,qq
+ real(kindr2) :: h12,hz1,hz2,hzz,hoz
+ logical :: zzsmall,ozsmall
+!
+ oz = C1P0-zz
+ h12 = abs(y1-y2)
+ hz1 = abs(y1-zz)
+ hz2 = abs(y2-zz)
+ hzz = abs(zz)
+ hoz = abs(oz)
+ q1z = qonv(y1-zz)
+ q2z = qonv(y2-zz)
+!
+ zzsmall = .false.
+ ozsmall = .false.
+ if (hzz.lt.hz1.and.hzz.lt.hz2.and.hzz.lt.hoz) then ! |z| < |y1-z|,|y2-z|
+ zzsmall = .true.
+ rslt = fy1y2*logc( q1z ) &
+ - ( logc(q1z*q2z)/2 + logc(qonv((y2-C1P0)/y2)) &
+ - logc(qonv(oz)) )*logc2(q1z/q2z)/(y2-zz)
+ elseif (hoz.lt.hz1.and.hoz.lt.hz2) then ! |1-z| < |y1-z|,|y2-z|
+ ozsmall = .true.
+ rslt = fy1y2*logc( q1z ) &
+ - (-logc(q1z*q2z)/2 + logc(qonv((y2-C1P0)/y2)) &
+ + logc(qonv(-zz)) )*logc2(q1z/q2z)/(y2-zz)
+ elseif (h12.le.hz2.and.hz2.le.hz1) then ! |y1-y2| < |y2-z| < |y1-z|
+ rslt = fy1y2*logc( q1z ) - r0fun( y2,zz )*logc2( q1z/q2z )
+ elseif (h12.le.hz1.and.hz1.le.hz2) then ! |y1-y2| < |y2-z| < |y1-z|
+ rslt = fy1y2*logc( q2z ) - r0fun( y1,zz )*logc2( q2z/q1z )
+ else!if(hz1.lt.h12.or.hz2.lt.h12) then ! |y2-z|,|y1-z| < |y1-y2|
+ rslt = C0P0
+ if (hz1.ne.R0P0) rslt = rslt + (y1-zz)*logc( q1z )*r0fun( y1,zz )
+ if (hz2.ne.R0P0) rslt = rslt - (y2-zz)*logc( q2z )*r0fun( y2,zz )
+ rslt = rslt/(y1-y2)
+ endif
+!
+ if (zzsmall) then ! |z| < |y1-z|,|y2-z|
+ qq = qonv(-zz)
+ rslt = rslt + ( li2c( qq/q1z ) - li2c( qq/q2z ) )/(y1-y2)
+ else
+ qq = qonv(-zz)
+ rslt = rslt + li2c2( q1z/qq ,q2z/qq )/zz
+ endif
+!
+ if (ozsmall) then ! |1-z| < |y1-z|,|y2-z|
+ qq = qonv(oz)
+ rslt = rslt - ( li2c( qq/q1z ) - li2c( qq/q2z ) )/(y1-y2)
+ else
+ qq = qonv(oz)
+ rslt = rslt + li2c2( q1z/qq ,q2z/qq )/oz
+ endif
+ end function
+
+
+ function r0fun( y1,y2 ) result(rslt)
+!*******************************************************************
+! / 1-y1 \ / 1-y2 \
+! log |------| - log |------|
+! \ -y1 / \ -y2 /
+! ---------------------------
+! y1 - y2
+!
+! y1,y2 should have non-zero imaginary parts
+!*******************************************************************
+ use avh_olo_logc2 ,only: logc2
+ complex(kindc2) ,intent(in) :: y1,y2
+ complex(kindc2) :: rslt ,oy1,oy2
+ oy1 = C1P0-y1
+ oy2 = C1P0-y2
+ rslt = logc2( qonv(-y2)/qonv(-y1) )/y1 &
+ + logc2( qonv(oy2)/qonv(oy1) )/oy1
+ end function
+
+
+ function plnr( y1,y2 ,p1,p2 ,aa,bb,cc ) result(rslt)
+!*******************************************************************
+! / a \ / a \
+! p1*log |--------| - p2*log |--------|
+! \ b*y1+c / \ b*y2+c /
+! 2*pi*imag* -------------------------------------
+! y1 - y2
+!
+! p1,p2 are logical, to be interpreted as 0,1 in the formula above
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ complex(kindc2) ,intent(in) :: y1,y2 ,aa,bb,cc
+ logical ,intent(in) :: p1,p2
+ complex(kindc2) :: rslt ,x1,x2,xx
+ type(qmplx_type) :: q1,q2
+ complex(kindc2) ,parameter :: twopii=CiP0*TWOPI
+!
+ if (p1) then
+ x1 = bb*y1 + cc
+ xx = aa/x1
+ if (aimag(xx).eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop plnr: ' &
+ ,'aa/x1 has zero imaginary part'
+ endif
+ q1 = qonv(xx)
+ endif
+ if (p2) then
+ x2 = bb*y2 + cc
+ xx = aa/x2
+ if (aimag(xx).eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop plnr: ' &
+ ,'aa/x2 has zero imaginary part'
+ endif
+ q2 = qonv(xx)
+ endif
+ if (p1) then
+ if (p2) then
+ rslt = logc2( q2/q1 ) * twopii*bb/x2
+ else
+ rslt = logc( q1 ) * twopii/(y1-y2)
+ endif
+ elseif (p2) then
+ rslt = logc( q2 ) * twopii/(y2-y1) ! minus sign
+ else
+ rslt = C0P0
+ endif
+ end function
+
+
+end module
diff --git a/avh_olo-2.2.1/avh_olo_bub.f90 b/avh_olo-2.2.1/avh_olo_bub.f90
new file mode 100644
index 0000000..c5be2cd
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_bub.f90
@@ -0,0 +1,508 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+module avh_olo_bub
+ use avh_olo_kinds
+ use avh_olo_units
+ implicit none
+ private
+ public :: init_bub ,tadp ,bub0 ,bub11
+ integer ,parameter :: d=kindr2
+ integer ,parameter :: ntrmmax=20
+ real(kindr2) ,parameter :: thrslistd(ntrmmax)=&
+ (/5e-5_d,5e-3_d,0.05_d,0.10_d,0.15_d,0.20_d,0.30_d,0.40_d &
+ ,0.50_d,0.60_d,0.65_d,0.68_d,0.72_d,0.74_d,0.76_d,0.78_d &
+ ,0.80_d,0.82_d,0.83_d,0.84_d/)
+ real(kindr2) ,parameter :: thrslisth(ntrmmax)=&
+ (/7e-8_d,5e-4_d,2e-3_d,1e-2_d,3e-2_d,6e-2_d,0.11_d,0.17_d &
+ ,0.22_d,0.28_d,0.33_d,0.37_d,0.42_d,0.47_d,0.51_d,0.54_d &
+ ,0.58_d,0.60_d,0.62_d,0.65_d/)
+ real(kindr2) ,parameter :: thrslistq(ntrmmax)=&
+ (/1e-10_d,5e-5_d,1e-4_d,1e-3_d,7e-3_d,0.02_d,0.04_d,0.07_d &
+ ,0.10_d,0.13_d,0.17_d,0.20_d,0.25_d,0.30_d,0.34_d,0.38_d &
+ ,0.42_d,0.44_d,0.47_d,0.50_d/)
+ real(kindr2) :: thrs=0.07_d
+ real(kindr2) :: thrsexp=0.01_d
+ real(kindr2) :: thrslist(1:ntrmmax)=thrslistd(1:ntrmmax)
+ integer :: ntrm=11,nnexp=7
+ complex(kindc2) :: aaexp(8)=C0P0
+ integer :: ndigits=0
+contains
+!
+ subroutine init_bub(ndig)
+ integer ,intent(in) :: ndig
+ integer :: ii
+ if (ndigits.eq.ndig) return ;ndigits=ndig
+ if (ndigits.lt.16) then
+ thrs = 0.07_kindr2 ! double precision,
+ ntrm = 11 ! tested to suit also b11
+ thrsexp = 0.01_kindr2 !
+ nnexp = 7 !
+ thrslist = thrslistd ! double precision
+ elseif (ndigits.lt.24) then
+ thrs = 0.02_kindr2 ! guess
+ ntrm = 11 !
+ thrsexp = 0.001_kindr2 !
+ nnexp = 7 !
+ thrslist = thrslisth !
+ else
+ thrs = 0.005_kindr2 ! quadruple precision, not tested
+ ntrm = 11 !
+ thrsexp = 0.0001_kindr2 !
+ nnexp = 7 !
+ thrslist = thrslistq ! quadruple precision
+ endif
+ do ii=1,nnexp
+ aaexp(ii) = C1P0/(ii*(ii+1))
+ enddo
+ end subroutine
+
+
+ subroutine tadp( rslt ,mm ,amm ,rmu2 )
+!*******************************************************************
+! The 1-loop scalar 1-point function.
+!*******************************************************************
+ use avh_olo_func
+ use avh_olo_logc ,only : logc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: mm
+ real(kindr2) ,intent(in) :: amm,rmu2
+!
+! write(*,*) 'MESSAGE from OneLOop tadp: you are calling me' !CALLINGME
+!
+ rslt(2) = C0P0
+ if (amm.eq.R0P0) then
+ rslt(1) = C0P0
+ rslt(0) = C0P0
+ else
+ rslt(1) = mm
+ rslt(0) = mm - mm*logc( qonv(mm/rmu2,-1) )
+ endif
+ end subroutine
+
+
+ subroutine bub0( rslt ,pp,m1i,m2i ,app,am1i,am2i ,rmu2 )
+!*******************************************************************
+! The 1-loop scalar 2-point function. Based on the formulas from
+! A. Denner, Fortsch.Phys.41:307-420,1993 arXiv:0709.1075 [hep-ph]
+!*******************************************************************
+ use avh_olo_func
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: pp,m1i,m2i
+ real(kindr2) ,intent(in) :: app,am1i,am2i,rmu2
+ complex(kindc2) :: cc(0:ntrmmax),m1,m2,hh,aa,bb,rr,dd
+ type(qmplx_type) :: qmm,qz1
+ complex(kindc2) ,parameter :: two=C1P0*2
+ real(kindr2) :: am1,am2,tt
+ integer :: ii
+!
+! write(*,*) 'MESSAGE from OneLOop bub0: you are calling me' !CALLINGME
+!
+ tt = max(am1i,am2i)
+ if (am1i.lt.tt) then
+ m1=m1i ;am1=am1i
+ m2=m2i ;am2=am2i
+ else
+ m1=m2i ;am1=am2i
+ m2=m1i ;am2=am1i
+ endif
+!
+ rslt(2) = C0P0
+ rslt(1) = C1P0
+!
+ if (am2.eq.R0P0) then
+ if (app.eq.R0P0) then
+ rslt(1) = C0P0
+ rslt(0) = C0P0
+ else
+ rslt(0) = two - logc(qonv(-pp/rmu2,-1))
+ endif
+ else!if(am2.ne.R0P0)
+ tt = app/tt
+ if (am1.eq.R0P0) then
+ qmm = qonv(m2/rmu2,-1)
+ if (app.eq.R0P0) then
+ rslt(0) = C1P0 - logc(qmm)
+ elseif (pp.eq.m2) then
+ rslt(0) = two - logc(qmm)
+ elseif (tt.lt.R1P0) then
+ hh = m2-pp
+ rslt(0) = two + (hh/pp)*logc(qonv(hh/rmu2,-1)/qmm) - logc(qmm)
+ else!if (tt.ge.R1P0) then
+ hh = m2-pp
+ rslt(0) = two - (m2/pp)*logc(qmm) + (hh/pp)*logc(qonv(hh/rmu2,-1))
+ endif
+ else!if(am1.ne.R0P0)
+ if (app.eq.R0P0) then
+ qz1 = qonv(m1/rmu2,-1)
+ rslt(0) = C1P0 + logc2(qz1/qonv(m2/rmu2,-1)) - logc(qz1)
+ else!if(pp.ne.C0P0)
+ if (tt.le.thrs) then
+ call expans( cc ,m1,m2 ,am1,am2 ,rmu2 ,ntrm)
+ rslt(0) = cc(ntrm)
+ do ii=ntrm-1,0,-1
+ rslt(0) = cc(ii) + pp*rslt(0)
+ enddo
+ elseif (tt.lt.R1P0) then
+ hh = mysqrt(m1)
+ bb = mysqrt(m2)
+ aa = hh*bb ! sm1*sm2
+ bb = hh/bb ! sm1/sm2
+ hh = (m1+m2-pp)/aa
+ dd = (m2-m1)**2 + ( pp - 2*(m1+m2) )*pp
+ dd = mysqrt(dd)/aa
+ call rfun0( rr ,dd ,hh )
+ qz1 = qonv(bb,-1) ! sm1/sm2
+ rslt(0) = two - logc(qonv(m2/rmu2,-1)) &
+ + logc(qz1)*two*m1/(aa*rr-m1) &
+ + logc2(qz1*qonv(rr,-1))*dd*aa/(aa*rr-m1+pp)
+ else
+ hh = mysqrt(m1)
+ bb = mysqrt(m2)
+ aa = hh*bb ! sm1*sm2
+ bb = hh/bb ! sm1/sm2
+ hh = (m1+m2-pp)/aa
+ call rfun( rr,dd ,hh )
+ rslt(0) = two - logc(qonv(aa/rmu2,-1)) &
+ + (logc(qonv(bb,-1))*(m2-m1) + logc(qonv(rr,-1))*dd*aa)/pp
+ endif
+! call expans( cc ,m1,m2 ,am1,am2 ,rmu2 ,ntrm) !DEBUG
+! hh = cc(ntrm) !DEBUG
+! do ii=ntrm-1,0,-1 !DEBUG
+! hh = cc(ii) + pp*hh !DEBUG
+! enddo !DEBUG
+! write(*,'(a4,2d24.16)') 'exp:',hh !DEBUG
+ endif
+ endif
+ endif
+ end subroutine
+
+
+ subroutine bub11( b11,b00,b1,b0 ,pp,m0,m1 ,app,am0,am1 ,rmu2 )
+!*******************************************************************
+! Return the Passarino-Veltman functions b11,b00,b1,b0 , for
+!
+! C / d^(Dim)q
+! ------ | -------------------- = b0
+! i*pi^2 / [q^2-m0][(q+p)^2-m1]
+!
+! C / d^(Dim)q q^mu
+! ------ | -------------------- = p^mu b1
+! i*pi^2 / [q^2-m0][(q+p)^2-m1]
+!
+! C / d^(Dim)q q^mu q^nu
+! ------ | -------------------- = g^{mu,nu} b00 + p^mu p^nu b11
+! i*pi^2 / [q^2-m0][(q+p)^2-m1]
+!
+!*******************************************************************
+ complex(kindc2) ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
+ complex(kindc2) ,intent(in) :: pp,m0,m1
+ real(kindr2) ,intent(in) :: app,am0,am1,rmu2
+ complex(kindc2) :: a1(0:2),a0(0:2),ff,gg,c1,c2,cc(0:ntrmmax)
+ real(kindr2) :: rr,maxm
+ integer :: ii
+!
+ maxm = max(am0,am1)
+ if (maxm.eq.R0P0) then
+ if (app.eq.R0P0) then
+ b0 = C0P0
+ b1 = C0P0
+ b00 = C0P0
+ b11 = C0P0
+ return
+ endif
+ rr = R1P0+thrs
+ else
+ rr = app/maxm
+ endif
+!
+ ff = pp - m1 + m0
+ gg = m0 + m1 - pp/3
+ b0(2) = C0P0
+ b1(2) = C0P0
+ b00(2) = C0P0
+ b11(2) = C0P0
+ b0(1) = C1P0
+ b1(1) = -C1P0/2
+ b00(1) = gg/4
+ b11(1) = C1P0/3
+ call tadp( a1 ,m0 ,am0 ,rmu2 )
+ call tadp( a0 ,m1 ,am1 ,rmu2 )
+!
+ if (rr.le.thrs) then
+! write(*,*) 'expansion' !DEBUG
+ call expans( cc ,m0,m1 ,am0,am1 ,rmu2 ,ntrm )
+ c2 = cc(ntrm)
+ do ii=ntrm-1,2,-1
+ c2 = cc(ii) + pp*c2
+ enddo
+ c1 = cc(1) + pp*c2
+ b0(0) = cc(0) + pp*c1
+ b1(0) = -( cc(0) + ff*c1 )/2
+ b00(0) = ( a0(0) + ff*b1(0) + 2*m0*b0(0) + gg )/6
+ b11(0) = cc(0) + (ff+m0-m1)*cc(1) + ff*ff*c2 - m0*c1
+ b11(0) = ( b11(0) + C1P0/6 )/3
+ else
+ call bub0( b0 ,pp,m0,m1 ,app,am0,am1 ,rmu2 )
+ b1(0) = ( a1(0) - a0(0) - ff*b0(0) )/(2*pp)
+ b00(0) = ( a0(0) + ff*b1(0) + 2*m0*b0(0) + gg )/6
+ b11(0) = ( a0(0) - 2*ff*b1(0) - m0*b0(0) - gg/2 )/(3*pp)
+ endif
+!
+ end subroutine
+
+
+ subroutine expans( cc ,m1i,m2i ,am1i,am2i ,rmu2 ,ntrm )
+!*******************************************************************
+! Returns the first 1+ntrm coefficients of the expansion in p^2 of
+! the finite part of the 1-loop scalar 2-point function
+!*******************************************************************
+ use avh_olo_func
+ use avh_olo_logc ,only: logc
+ integer ,intent(in) :: ntrm
+ complex(kindc2) ,intent(out) :: cc(0:ntrm)
+ complex(kindc2) ,intent(in) :: m1i,m2i
+ real(kindr2) ,intent(in) :: am1i,am2i,rmu2
+ complex(kindc2) :: m1,m2,zz,oz,xx,logz,tt(ntrm)
+ type(qmplx_type) :: qm1,qm2,qzz
+ real(kindr2) :: am1,am2
+ integer :: ii
+ real(kindr2) ::rr
+!
+! write(*,*) 'MESSAGE from OneLOop bub expans: you are calling me' !CALLINGME
+!
+ if (am1i.lt.am2i) then
+ m1=m1i ;am1=am1i
+ m2=m2i ;am2=am2i
+ else
+ m1=m2i ;am1=am2i
+ m2=m1i ;am2=am1i
+ endif
+!
+ if (am2.eq.R0P0) then
+!
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop bub expans: ' &
+ ,'m1=m2=0, returning 0'
+ do ii=0,ntrm
+ cc(ii) = C0P0
+ enddo
+!
+ else
+!
+ qm1 = qonv(m1/rmu2,-1)
+ qm2 = qonv(m2/rmu2,-1)
+ qzz = qm1/qm2
+ if (mod(qzz%p,2).eq.0) then
+ zz = qzz%c
+ else
+ zz = -qzz%c
+ endif
+!
+ if (m1.eq.C0P0) then
+ cc(0) = C1P0 - logc(qm2)
+ else
+ oz = C1P0-zz
+ rr = abs(oz)
+ if (rr.lt.thrsexp) then
+ xx = aaexp(nnexp)
+ do ii=nnexp-1,1,-1
+ xx = aaexp(ii) + oz*xx
+ enddo
+ xx = oz*xx
+ else
+ logz = logc( qzz )
+ xx = zz*logz + oz
+ xx = xx/oz
+ endif
+ cc(0) = xx - logc(qm2)
+ endif
+!
+ zz = C1P0-zz
+ xx = C1P0
+ call expans1(tt ,ntrm,zz)
+ do ii=1,ntrm
+ xx = xx*m2
+ cc(ii) = tt(ii)/(ii*xx)
+ enddo
+!
+ endif
+ end subroutine
+
+
+ subroutine expans1(tt ,ntrm,zz)
+!*******************************************************************
+! Returns tt(n) = int( ( x*(1-x)/(1-zz*x) )^n , x=0..1 )
+! for n=1...ntrm and |zz|=<1
+!
+! Gives at least 2 correct digits (4 at quad.) for tt(ntrm),
+! and increasingly more digits for tt(i<ntrm)
+!
+! Uses recursion on integrals of the type
+! int( x^m * (1-x)^n / (1-z*x)^n , x=0..1 )
+! and
+! int( x^m * (1-x)^n / (1+y*x)^(n+2) , x=0..1 )
+! where y = z/(1-z)
+! The latter integrals are related to the original ones via the
+! substitution x <- 1-x followed by x <- (1-x)/(1+y*x)
+!*******************************************************************
+ integer ,intent(in) :: ntrm
+ complex(kindc2) ,intent(in) :: zz
+ complex(kindc2) ,intent(out) :: tt(ntrm)
+ complex(kindc2) :: tu(ntrm),tv(ntrm) ,tt0,tu0,tv0,yy,y2,oy
+ real(kindr2) :: rr
+ integer :: nn,ii,jj
+!
+ rr = real(zz)
+ nn = ntrm
+ if (nn.lt.1) nn = 1
+ if (nn.gt.ntrmmax) then
+ if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop bub expans1: ' &
+ ,'ntrm =',nn,' > nmax =',ntrmmax,', using ntrm=nmax'
+ nn = ntrmmax
+ do ii=nn+1,ntrm
+ tt(ii) = C0P0
+ enddo
+ endif
+!
+ if (zz.eq.C1P0) then
+! write(*,'(a16,i4)') 'simple expansion',nn !DEBUG
+ do ii=1,nn
+ tt(ii) = cmplx(R1P0/(ii+1),kind=kindc2)
+ enddo
+ elseif (rr.lt.thrslist(nn)) then
+! Backward recursion, number of correct decimals constant, so need
+! full precision from the start
+! write(*,'(a8,i4,d24.16)') 'Backward',nn,rr !DEBUG
+ call expans2(tt(nn),tv(nn-1),tu(nn-1) ,nn,zz)
+ do ii=nn-1,2,-1
+ jj = ii+1
+ tt(ii ) = 2*tv(ii) - (zz*tt(jj)*ii)/jj
+ tu(ii-1) = (2+R1P0/ii)*tt(ii) - zz*tu(ii)
+ tv(ii-1) = (C1P0-zz)*tu(ii-1) + zz*( 2*tt(ii) - zz*tu(ii) )
+ enddo
+ tt(1) = 2*tv(1) - zz*tt(2)/2
+ else
+! Foreward recursion, number of correct decimals decreases
+! write(*,'(a8,i4,d24.16)') 'Foreward',nn,rr !DEBUG
+ yy = zz/(C1P0-zz)
+ y2 = yy*yy
+ oy = C1P0+yy ! C1P0/(C1P0-zz)
+ tt0 = C1P0-zz ! 1/(1+y)
+ tu0 = ( oy*log(oy)-yy )/( y2*oy )
+ tv0 = tt0/2
+ tt(1) = ( tt0-2*tu0 )/( 2*yy )
+ tv(1) = ( tv0 - 3*tt(1) )/( 3*yy )
+ tu(1) = ( oy*tu0 - 2*yy*tt(1) - tv0 )/y2
+ do ii=2,nn
+ jj = ii-1
+ tt(ii) = ii*( tt(jj)-2*tu(jj) )/( (ii+1)*yy )
+ tv(ii) = ( ii*tv(jj) - (ii+ii+1)*tt(ii) )/( (ii+2)*yy )
+ tu(ii) = ( oy*tu(jj) - 2*yy*tt(ii) - tv(jj) )/y2
+ enddo
+ yy = oy
+ do ii=1,nn
+ oy = oy*yy
+ tt(ii) = oy*tt(ii)
+ enddo
+ endif
+ end subroutine
+
+
+ subroutine expans2(ff,fa,fb ,nn_in,zz)
+!*******************************************************************
+! ff = Beta(nn+1,nn+1) * 2F1(nn ,nn+1;2*nn+2;zz)
+! fa = Beta(nn+1,nn ) * 2F1(nn-1,nn+1;2*nn+1;zz)
+! fb = Beta(nn ,nn+1) * 2F1(nn ,nn ;2*nn+1;zz)
+!*******************************************************************
+ complex(kindc2) ,intent(out) :: ff,fa,fb
+ complex(kindc2) ,intent(in) :: zz
+ integer ,intent(in) :: nn_in
+ integer ,parameter :: nmax=100
+ integer :: aa,bb,cc,ii,ntrm
+ complex(kindc2) ,save :: qq(0:nmax),qa(0:nmax),qb(0:nmax),gg,ga
+ real(kindr2) ,save :: logprec=-36.0_kindr2
+ integer ,save :: nn=0
+ real(kindr2) :: ac0,bc0,ai,bi,ci,ac,bc
+ if (nn.ne.nn_in) then
+ nn = nn_in
+ aa = nn-1
+ bb = nn
+ cc = nn+nn+1
+ qq(0) = C1P0
+ qa(0) = C1P0
+ qb(0) = C1P0
+ ac0 = real(aa,KIND=kindr2)/real(cc,KIND=kindr2)
+ bc0 = real(bb,KIND=kindr2)/real(cc,KIND=kindr2)
+ ntrm = nmax
+ do ii=1,ntrm
+ ai = real(aa+ii,KIND=kindr2)
+ bi = real(bb+ii,KIND=kindr2)
+ ci = real(cc+ii,KIND=kindr2)
+ ac = ai/ci
+ bc = bi/ci
+ qq(ii) = qq(ii-1) * ai*bc / ii
+ qa(ii) = qa(ii-1) * ac0*bi / ii
+ qb(ii) = qb(ii-1) * ai*bc0 / ii
+ ac0 = ac
+ bc0 = bc
+ enddo
+ ai = R1P0
+ do ii=2,nn-1
+ ai = ai*ii
+ enddo
+ ci = ai
+ cc = nn+nn
+ do ii=nn,cc
+ ci = ci*ii
+ enddo
+ bi = ai*nn
+ gg = bi*bi/(ci*(cc+1))
+ ga = ai*bi/ci
+ logprec = log(epsilon(R1P0))
+ endif
+!
+ ai = abs(zz)
+ if (ai.gt.R0P0) then
+ ntrm = 1 + int(logprec/log(ai))
+ else
+ ntrm = 1
+ endif
+ if (ntrm.gt.nmax) then
+ if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop bub expans2: ' &
+ ,'ntrm =',ntrm,' > nmax =',nmax,', putting ntrm=nmax'
+ ntrm = nmax
+ endif
+!
+ ff = qq(ntrm)
+ fa = qa(ntrm)
+ fb = qb(ntrm)
+ do ii=ntrm-1,0,-1
+ ff = qq(ii) + ff*zz
+ fa = qa(ii) + fa*zz
+ fb = qb(ii) + fb*zz
+ enddo
+ ff = gg*ff
+ fa = ga*fa
+ fb = ga*fb
+ end subroutine
+!
+end module
diff --git a/avh_olo-2.2.1/avh_olo_c0_a.h90 b/avh_olo-2.2.1/avh_olo_c0_a.h90
new file mode 100644
index 0000000..65937f7
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_c0_a.h90
@@ -0,0 +1,35 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ complex(kindc2) :: ss(3),rr(3)
+ real(kindr2) :: smax,ap(3),am(3),as(3),ar(3),thrs,s1r2,s2r3,s3r3
+ real(kindr2) :: mulocal,mulocal2
+ integer :: icase,ii
+ complex(kindc2) ,parameter :: const=C1P0*TWOPI*TWOPI/48
+ character(25+99) ,parameter :: warning=&
+ 'WARNING from OneLOop c0: '//warnonshell
+ if (intro) call hello
+!
+ pp(1) = p1
+ pp(2) = p2
+ pp(3) = p3
+ mm(1) = m1
+ mm(2) = m2
+ mm(3) = m3
+!
+ smax = R0P0
diff --git a/avh_olo-2.2.1/avh_olo_c0_b.h90 b/avh_olo-2.2.1/avh_olo_c0_b.h90
new file mode 100644
index 0000000..49d4ca8
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_c0_b.h90
@@ -0,0 +1,115 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ mulocal2 = mulocal*mulocal
+!
+ if (smax.eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
+ ,'all input equal zero, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ if (mulocal2.gt.smax) smax = mulocal2
+!
+ if (nonzerothrs) then
+ thrs = onshellthrs
+ do ii=1,3
+ if (ap(ii).lt.thrs) ap(ii) = R0P0
+ if (am(ii).lt.thrs) am(ii) = R0P0
+ enddo
+ else
+ thrs = onshellthrs*smax
+ if (wunit.gt.0) then
+ do ii=1,3
+ if (R0P0.lt.ap(ii).and.ap(ii).lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.am(ii).and.am(ii).lt.thrs) write(wunit,*) warning
+ enddo
+ endif
+ endif
+!
+ icase = 0
+ do ii=1,3
+ if (am(ii).gt.R0P0) icase = icase + base(ii)
+ enddo
+ ss(1)=pp(permtable(1,icase)) ;as(1)=ap(permtable(1,icase))
+ ss(2)=pp(permtable(2,icase)) ;as(2)=ap(permtable(2,icase))
+ ss(3)=pp(permtable(3,icase)) ;as(3)=ap(permtable(3,icase))
+ rr(1)=mm(permtable(1,icase)) ;ar(1)=am(permtable(1,icase))
+ rr(2)=mm(permtable(2,icase)) ;ar(2)=am(permtable(2,icase))
+ rr(3)=mm(permtable(3,icase)) ;ar(3)=am(permtable(3,icase))
+ icase = casetable(icase)
+!
+ s1r2 = abs(ss(1)-rr(2))
+ s2r3 = abs(ss(2)-rr(3))
+ s3r3 = abs(ss(3)-rr(3))
+ if (nonzerothrs) then
+ if (s1r2.lt.thrs) s1r2 = R0P0
+ if (s2r3.lt.thrs) s2r3 = R0P0
+ if (s3r3.lt.thrs) s3r3 = R0P0
+ elseif (wunit.gt.0) then
+ if (R0P0.lt.s1r2.and.s1r2.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.s2r3.and.s2r3.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.s3r3.and.s3r3.lt.thrs) write(wunit,*) warning
+ endif
+!
+ if (icase.eq.3) then
+! 3 non-zero internal masses
+ call trif3( rslt ,ss(1),ss(2),ss(3) ,rr(1),rr(2),rr(3) )
+ elseif (icase.eq.2) then
+! 2 non-zero internal masses
+ if (s1r2.ne.R0P0.or.s3r3.ne.R0P0) then
+ call trif2( rslt ,ss(1),ss(2),ss(3) ,rr(2),rr(3) )
+ else
+ call tria4( rslt ,ss(2) ,rr(2),rr(3) ,mulocal2 )
+ endif
+ elseif (icase.eq.1) then
+! 1 non-zero internal mass
+ if (as(1).ne.R0P0) then
+ call trif1( rslt ,ss(1),ss(2),ss(3), rr(3) )
+ elseif (s2r3.ne.R0P0) then
+ if (s3r3.ne.R0P0) then
+ call tria3( rslt ,ss(2),ss(3) ,rr(3) ,mulocal2 )
+ else
+ call tria2( rslt ,ss(2) ,rr(3) ,mulocal2 )
+ endif
+ elseif (s3r3.ne.R0P0) then
+ call tria2( rslt ,ss(3) ,rr(3) ,mulocal2 )
+ else
+ call tria1( rslt ,rr(3) ,mulocal2 )
+ endif
+ else
+! 0 non-zero internal masses
+ call tria0( rslt ,ss ,as ,mulocal2 )
+ endif
+! exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
+ rslt(0) = rslt(0) + const*rslt(2)
+!
+ if (punit.gt.0) then
+ if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
+ write(punit,*) 'muscale:',trim(myprint(mulocal))
+ write(punit,*) ' p1:',trim(myprint(p1))
+ write(punit,*) ' p2:',trim(myprint(p2))
+ write(punit,*) ' p3:',trim(myprint(p3))
+ write(punit,*) ' m1:',trim(myprint(m1))
+ write(punit,*) ' m2:',trim(myprint(m2))
+ write(punit,*) ' m3:',trim(myprint(m3))
+ write(punit,*) 'c0(2):',trim(myprint(rslt(2)))
+ write(punit,*) 'c0(1):',trim(myprint(rslt(1)))
+ write(punit,*) 'c0(0):',trim(myprint(rslt(0)))
+ endif
diff --git a/avh_olo-2.2.1/avh_olo_d0_a.h90 b/avh_olo-2.2.1/avh_olo_d0_a.h90
new file mode 100644
index 0000000..1189fb5
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_d0_a.h90
@@ -0,0 +1,40 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ complex(kindc2) :: ss(6),rr(4)
+ real(kindr2) :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
+ real(kindr2) :: mulocal,mulocal2,small,thrs
+ integer :: icase,ii
+ logical :: useboxc
+ complex(kindc2) ,parameter :: const=C1P0*TWOPI*TWOPI/48
+ character(25+99) ,parameter :: warning=&
+ 'WARNING from OneLOop d0: '//warnonshell
+ if (intro) call hello
+!
+ pp(1) = p1
+ pp(2) = p2
+ pp(3) = p3
+ pp(4) = p4
+ pp(5) = p12
+ pp(6) = p23
+ mm(1) = m1
+ mm(2) = m2
+ mm(3) = m3
+ mm(4) = m4
+!
+ smax = R0P0
diff --git a/avh_olo-2.2.1/avh_olo_d0_b.h90 b/avh_olo-2.2.1/avh_olo_d0_b.h90
new file mode 100644
index 0000000..4736e24
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_d0_b.h90
@@ -0,0 +1,198 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+ small = maxval(abs(ap))*epsilon(R1P0)*100
+ mulocal2 = mulocal*mulocal
+!
+ if (smax.eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
+ ,'all input equal zero, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ if (mulocal2.gt.smax) smax = mulocal2
+!
+ if (nonzerothrs) then
+ thrs = onshellthrs
+ do ii=1,4
+ if (ap(ii).lt.thrs) ap(ii) = R0P0
+ if (am(ii).lt.thrs) am(ii) = R0P0
+ enddo
+ else
+ thrs = onshellthrs*smax
+ if (wunit.gt.0) then
+ do ii=1,4
+ if (R0P0.lt.ap(ii).and.ap(ii).lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.am(ii).and.am(ii).lt.thrs) write(wunit,*) warning
+ enddo
+ endif
+ endif
+!
+ icase = 0
+ do ii=1,4
+ if (am(ii).gt.R0P0) icase = icase + base(ii)
+ enddo
+ ss(1)=pp(permtable(1,icase)) ;as(1)=ap(permtable(1,icase))
+ ss(2)=pp(permtable(2,icase)) ;as(2)=ap(permtable(2,icase))
+ ss(3)=pp(permtable(3,icase)) ;as(3)=ap(permtable(3,icase))
+ ss(4)=pp(permtable(4,icase)) ;as(4)=ap(permtable(4,icase))
+ ss(5)=pp(permtable(5,icase)) ;as(5)=ap(permtable(5,icase))
+ ss(6)=pp(permtable(6,icase)) ;as(6)=ap(permtable(6,icase))
+ rr(1)=mm(permtable(1,icase)) ;ar(1)=am(permtable(1,icase))
+ rr(2)=mm(permtable(2,icase)) ;ar(2)=am(permtable(2,icase))
+ rr(3)=mm(permtable(3,icase)) ;ar(3)=am(permtable(3,icase))
+ rr(4)=mm(permtable(4,icase)) ;ar(4)=am(permtable(4,icase))
+ icase = casetable(icase)
+!
+ s1r2 = abs(real(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
+ s2r2 = abs(real(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
+ s2r3 = abs(real(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
+ s3r4 = abs(real(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
+ s4r4 = abs(real(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
+ if (nonzerothrs) then
+ if (s1r2.lt.thrs) s1r2 = R0P0
+ if (s2r2.lt.thrs) s2r2 = R0P0
+ if (s2r3.lt.thrs) s2r3 = R0P0
+ if (s3r4.lt.thrs) s3r4 = R0P0
+ if (s4r4.lt.thrs) s4r4 = R0P0
+ elseif (wunit.gt.0) then
+ if (R0P0.lt.s1r2.and.s1r2.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.s2r2.and.s2r2.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.s2r3.and.s2r3.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.s3r4.and.s3r4.lt.thrs) write(wunit,*) warning
+ if (R0P0.lt.s4r4.and.s4r4.lt.thrs) write(wunit,*) warning
+ endif
+!
+ if (icase.eq.4) then
+!4 non-zero internal masses
+ useboxc = ( (ar(1).ne.R0P0.and.aimag(rr(1)).ne.R0P0) &
+ .or.(ar(2).ne.R0P0.and.aimag(rr(2)).ne.R0P0) &
+ .or.(ar(3).ne.R0P0.and.aimag(rr(3)).ne.R0P0) &
+ .or.(ar(4).ne.R0P0.and.aimag(rr(4)).ne.R0P0) &
+ .or.( real(ss(1)).ge.-small &
+ .and.real(ss(2)).ge.-small &
+ .and.real(ss(3)).ge.-small &
+ .and.real(ss(4)).ge.-small) )
+ if (useboxc) then
+ call boxc( rslt ,ss,rr ,as )
+ else
+ call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
+ endif
+ elseif (icase.eq.3) then
+!3 non-zero internal masses
+ if (s1r2.ne.R0P0.or.s4r4.ne.R0P0) then
+ useboxc = ( (ar(1).ne.R0P0.and.aimag(rr(1)).ne.R0P0) &
+ .or.(ar(2).ne.R0P0.and.aimag(rr(2)).ne.R0P0) &
+ .or.(ar(3).ne.R0P0.and.aimag(rr(3)).ne.R0P0) &
+ .or.(ar(4).ne.R0P0.and.aimag(rr(4)).ne.R0P0) &
+ .or.( real(ss(1)).ge.-small &
+ .and.real(ss(2)).ge.-small &
+ .and.real(ss(3)).ge.-small &
+ .and.real(ss(4)).ge.-small) )
+ if (useboxc) then
+ call boxc( rslt ,ss,rr ,as )
+ else
+ call boxf3( rslt, ss,rr )
+ endif
+ else
+ call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
+ endif
+ elseif (icase.eq.5) then
+!2 non-zero internal masses, opposite case
+ if (s1r2.ne.R0P0.or.s4r4.ne.R0P0) then
+ if (s2r2.ne.R0P0.or.s3r4.ne.R0P0) then
+ call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
+ else
+ call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
+ endif
+ elseif (s2r2.ne.R0P0.or.s3r4.ne.R0P0) then
+ call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
+ else
+ call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
+ endif
+ elseif (icase.eq.2) then
+!2 non-zero internal masses, adjacent case
+ if (as(1).ne.R0P0) then
+ call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
+ elseif (s2r3.ne.R0P0) then
+ if (s4r4.ne.R0P0) then
+ call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
+ else
+ call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
+ endif
+ elseif (s4r4.ne.R0P0) then
+ call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
+ else
+ call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
+ endif
+ elseif (icase.eq.1) then
+!1 non-zero internal mass
+ if (as(1).ne.R0P0) then
+ if (as(2).ne.R0P0) then
+ call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
+ else
+ if (s3r4.ne.R0P0) then
+ call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
+ else
+ call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
+ endif
+ endif
+ elseif (as(2).ne.R0P0) then
+ if (s4r4.ne.R0P0) then
+ call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
+ else
+ call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
+ endif
+ else
+ if (s3r4.ne.R0P0) then
+ if (s4r4.ne.R0P0) then
+ call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
+ else
+ call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
+ endif
+ elseif (s4r4.ne.R0P0) then
+ call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
+ else
+ call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
+ endif
+ endif
+ else
+!0 non-zero internal mass
+ call box00( rslt ,ss ,as ,mulocal )
+ endif
+!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
+ rslt(0) = rslt(0) + const*rslt(2)
+!
+ if (punit.gt.0) then
+ if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
+ write(punit,*) 'muscale:',trim(myprint(mulocal))
+ write(punit,*) ' p1:',trim(myprint(p1))
+ write(punit,*) ' p2:',trim(myprint(p2))
+ write(punit,*) ' p3:',trim(myprint(p3))
+ write(punit,*) ' p4:',trim(myprint(p4))
+ write(punit,*) 'p12:',trim(myprint(p12))
+ write(punit,*) 'p23:',trim(myprint(p23))
+ write(punit,*) ' m1:',trim(myprint(m1))
+ write(punit,*) ' m2:',trim(myprint(m2))
+ write(punit,*) ' m3:',trim(myprint(m3))
+ write(punit,*) ' m4:',trim(myprint(m4))
+ write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
+ write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
+ write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
+ endif
diff --git a/avh_olo-2.2.1/avh_olo_func.f90 b/avh_olo-2.2.1/avh_olo_func.f90
new file mode 100644
index 0000000..b6b1bba
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_func.f90
@@ -0,0 +1,1085 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+module avh_olo_func
+ use avh_olo_kinds
+ use avh_olo_units
+!
+ implicit none
+!
+ type :: qmplx_type
+ complex(kindc2) :: c
+ integer :: p
+ end type
+!
+ interface mysqrt
+ module procedure mysqrt_0,mysqrt_r,mysqrt_i
+ end interface
+!
+ interface qonv
+ module procedure qonv_r,qonv_0,qonv_i
+ end interface
+!
+ interface operator (*)
+ module procedure prduct,prduct_r
+ end interface
+ interface operator (/)
+ module procedure ratio,ratio_r
+ end interface
+!
+ interface eta5
+ module procedure eta5_0
+ end interface
+ interface eta3
+ module procedure eta3_r,eta3_0
+ end interface
+ interface eta2
+ module procedure eta2_r,eta2_0
+ end interface
+!
+contains
+!
+!
+ function mysqrt_0(xx) result(rslt)
+!*******************************************************************
+! Returns the square-root of xx .
+! If Im(xx) is equal zero and Re(xx) is negative, the result is
+! negative imaginary.
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: xx
+ complex(kindc2) :: rslt ,zz
+ real(kindr2) :: xim,xre
+ xim = aimag(xx)
+ if (xim.eq.R0P0) then
+ xre = real(xx)
+ if (xre.ge.R0P0) then
+ zz = cmplx(sqrt(xre),R0P0,kind=kindc2)
+ else
+ zz = cmplx(R0P0,-sqrt(-xre),kind=kindc2)
+ endif
+ else
+ zz = sqrt(xx)
+ endif
+ rslt = zz
+ end function
+
+ function mysqrt_r(xx,sgn) result(rslt)
+!*******************************************************************
+! Returns the square-root of xx .
+! If Im(xx) is equal zero and Re(xx) is negative, the result is
+! imaginary and has the same sign as sgn .
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: xx
+ real(kindr2) ,intent(in) :: sgn
+ complex(kindc2) :: rslt ,zz
+ real(kindr2) :: xim,xre
+ xim = aimag(xx)
+ if (xim.eq.R0P0) then
+ xre = real(xx)
+ if (xre.ge.R0P0) then
+ zz = cmplx(sqrt(xre),R0P0,kind=kindc2)
+ else
+ zz = cmplx(R0P0,sign(sqrt(-xre),sgn),kind=kindc2)
+ endif
+ else
+ zz = sqrt(xx)
+ endif
+ rslt = zz
+ end function
+
+ function mysqrt_i(xx,sgn) result(rslt)
+!*******************************************************************
+! Returns the square-root of xx .
+! If Im(xx) is equal zero and Re(xx) is negative, the result is
+! imaginary and has the same sign as sgn .
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: xx
+ integer ,intent(in) :: sgn
+ complex(kindc2) :: rslt ,zz
+ real(kindr2) :: xim,xre
+ xim = aimag(xx)
+ if (xim.eq.R0P0) then
+ xre = real(xx)
+ if (xre.ge.R0P0) then
+ zz = cmplx(sqrt(xre),R0P0,KIND=kindc2)
+ else
+ zz = cmplx(R0P0,sign(sqrt(-xre),real(sgn,KIND=kindr2)),KIND=kindc2)
+ endif
+ else
+ zz = sqrt(xx)
+ endif
+ rslt = zz
+ end function
+
+
+ subroutine solabc( x1,x2 ,dd ,aa,bb,cc ,imode )
+!*******************************************************************
+! Returns the solutions x1,x2 to the equation aa*x^2+bb*x+cc=0
+! Also returns dd = aa*(x1-x2)
+! If imode=/=0 it uses dd as input as value of sqrt(b^2-4*a*c)
+!*******************************************************************
+ complex(kindc2) ,intent(out) :: x1,x2
+ complex(kindc2) ,intent(inout) :: dd
+ complex(kindc2) ,intent(in) :: aa,bb,cc
+ integer ,intent(in) :: imode
+ complex(kindc2) :: qq,hh
+ real(kindr2) :: r1,r2
+!
+ if (aa.eq.C0P0) then
+ if (bb.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop solabc: ' &
+ ,'no solutions, returning 0'
+ x1 = C0P0
+ x2 = C0P0
+ dd = C0P0
+ else
+ x1 = -cc/bb
+ x2 = x1
+ dd = bb
+ endif
+ elseif (cc.eq.C0P0) then
+ dd = -bb
+ x1 = dd/aa
+ x2 = C0P0
+ else
+ if (imode.eq.0) dd = sqrt(bb*bb - 4*aa*cc)
+ qq = -bb+dd
+ hh = -bb-dd
+ r1 = abs(qq)
+ r2 = abs(hh)
+ if (r1.ge.r2) then
+ x1 = qq/(2*aa)
+ x2 = (2*cc)/qq
+ else
+ qq = hh
+ x2 = qq/(2*aa)
+ x1 = (2*cc)/qq
+ endif
+ endif
+ end subroutine
+
+
+ subroutine rfun(rr,dd ,qq)
+!*******************************************************************
+! Returns rr such that qq = rr + 1/rr and Im(rr) has the same
+! sign as Im(qq) .
+! If Im(qq) is zero, then Im(rr) is negative or zero.
+! If Im(rr) is zero, then |rr| > 1/|rr| .
+! Also returns dd = rr - 1/rr .
+!*******************************************************************
+ complex(kindc2) ,intent(out) :: rr,dd
+ complex(kindc2) ,intent(in) :: qq
+ complex(kindc2) :: r2
+ real(kindr2) :: aa,bb
+ integer :: ir,ik
+ complex(kindc2) ,parameter :: two=2*C1P0,four=4*C1P0
+ dd = sqrt(qq*qq-four)
+ rr = qq+dd
+ r2 = qq-dd
+ aa = abs(rr)
+ bb = abs(r2)
+ if (bb.gt.aa) then
+ rr = r2
+ dd = -dd
+ endif
+ aa = aimag(qq)
+ bb = aimag(rr)
+ if (aa.eq.R0P0) then
+ if (bb.le.R0P0) then
+ rr = rr/two
+ else
+ rr = two/rr
+ dd = -dd
+ endif
+ else
+ ik = int(sign(R1P0,aa))
+ ir = int(sign(R1P0,bb))
+ if (ir.eq.ik) then
+ rr = rr/two
+ else
+ rr = two/rr
+ dd = -dd
+ endif
+ endif
+ end subroutine
+
+ subroutine rfun0(rr ,dd,qq)
+!*******************************************************************
+! Like rfun, but now dd is input, which may get a minus sign
+!*******************************************************************
+ complex(kindc2) ,intent(out) :: rr
+ complex(kindc2) ,intent(inout) :: dd
+ complex(kindc2) ,intent(in) :: qq
+ complex(kindc2) :: r2
+ real(kindr2) :: aa,bb
+ integer :: ir,ik
+ complex(kindc2) ,parameter :: two=2*C1P0
+ rr = qq+dd
+ r2 = qq-dd
+ aa = abs(rr)
+ bb = abs(r2)
+ if (bb.gt.aa) then
+ rr = r2
+ dd = -dd
+ endif
+ aa = aimag(qq)
+ bb = aimag(rr)
+ if (aa.eq.R0P0) then
+ if (bb.le.R0P0) then
+ rr = rr/two
+ else
+ rr = two/rr
+ dd = -dd
+ endif
+ else
+ ik = int(sign(R1P0,aa))
+ ir = int(sign(R1P0,bb))
+ if (ir.eq.ik) then
+ rr = rr/two
+ else
+ rr = two/rr
+ dd = -dd
+ endif
+ endif
+ end subroutine
+
+
+ function qonv_r(xx,sgn) result(rslt)
+!*******************************************************************
+! zz=rslt%c ,iz=rslt%p
+! Determine zz,iz such that xx = zz*exp(iz*imag*pi) and Re(zz)
+! is positive. If Im(x)=0 and Re(x)<0 then iz becomes the
+! sign of sgn .
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: xx
+ real(kindr2) ,intent(in) :: sgn
+ type(qmplx_type) :: rslt
+ real(kindr2) :: xre,xim
+ xre = real(xx)
+ if (xre.ge.R0P0) then
+ rslt%c = xx
+ rslt%p = 0
+ else
+ xim = aimag(xx)
+ if (xim.eq.R0P0) then
+ rslt%c = cmplx(-xre,R0P0,kind=kindc2)
+ rslt%p = int(sign(R1P0,sgn))
+ else
+ rslt%c = -xx
+ rslt%p = int(sign(R1P0,xim)) ! xim = -Im(rslt%c)
+ endif
+ endif
+ end function
+!
+ function qonv_i(xx,sgn) result(rslt)
+!*******************************************************************
+! zz=rslt%c ,iz=rslt%p
+! Determine zz,iz such that xx = zz*exp(iz*imag*pi) and Re(zz)
+! is positive. If Im(x)=0 and Re(x)<0 then iz becomes the
+! sign of sgn .
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: xx
+ integer ,intent(in) :: sgn
+ type(qmplx_type) :: rslt
+ real(kindr2) :: xre,xim
+ xre = real(xx)
+ if (xre.ge.R0P0) then
+ rslt%c = xx
+ rslt%p = 0
+ else
+ xim = aimag(xx)
+ if (xim.eq.R0P0) then
+ rslt%c = cmplx(-xre,R0P0,kind=kindc2)
+ rslt%p = sign(1,sgn)
+ else
+ rslt%c = -xx
+ rslt%p = int(sign(R1P0,xim)) ! xim = -Im(rslt%c)
+ endif
+ endif
+ end function
+!
+ function qonv_0(xx) result(rslt)
+!*******************************************************************
+! zz=rslt%c ,iz=rslt%p
+! Determine zz,iz such that xx = zz*exp(iz*imag*pi) and Re(zz)
+! is positive. If Im(x)=0 and Re(x)<0 then iz=1
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: xx
+ type(qmplx_type) :: rslt
+ real(kindr2) :: xre,xim
+ xre = real(xx)
+ if (xre.ge.R0P0) then
+ rslt%c = xx
+ rslt%p = 0
+ else
+ xim = aimag(xx)
+ if (xim.eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop qonv: ' &
+ ,'negative input with undefined sign for the imaginary part, ' &
+ ,'putting +ieps'
+ rslt%c = cmplx(-xre,R0P0,kind=kindc2)
+ rslt%p = 1
+ else
+ rslt%c = -xx
+ rslt%p = int(sign(R1P0,xim)) ! xim = -Im(rslt%c)
+ endif
+ endif
+ end function
+!
+ function directly(xx,ix) result(rslt)
+!*******************************************************************
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: xx
+ integer ,intent(in) :: ix
+ type(qmplx_type) :: rslt
+ rslt%c = xx
+ rslt%p = ix
+ end function
+
+
+ function sheet(xx) result(ii)
+!*******************************************************************
+! Returns the number of the Riemann-sheet (times 2) for the complex
+! number xx*exp(ix*imag*pi) . The real part of xx is assumed to be
+! positive or zero. Examples:
+! xx=1+imag, ix=-1 -> ii= 0
+! xx=1+imag, ix= 1 -> ii= 2
+! xx=1-imag, ix=-1 -> ii=-2
+! xx=1-imag, ix= 1 -> ii= 0
+! xx=1 , ix= 1 -> ii= 0 convention that log(-1)=pi on
+! xx=1 , ix=-1 -> ii=-2 the principal Riemann-sheet
+!*******************************************************************
+ type(qmplx_type) ,intent(in) :: xx
+ integer :: ii,jj
+ real(kindr2) :: xim
+ ii = xx%p/2*2
+ jj = xx%p-ii
+ xim = aimag(xx%c)
+ if (xim.le.R0P0) then ! also xim=0 <==> log(-1)=pi, not -pi
+ if (jj.eq.-1) ii = ii-2
+ else
+ if (jj.eq. 1) ii = ii+2
+ endif
+ end function
+
+
+ function prduct(yy,xx) result(zz)
+!*******************************************************************
+! Return the product zz of yy and xx
+! keeping track of (the multiple of pi of) the phase %p such that
+! the real part of zz%c remains positive
+!*******************************************************************
+ type(qmplx_type) ,intent(in) :: yy,xx
+ type(qmplx_type) :: zz
+ zz%c = yy%c*xx%c
+ zz%p = yy%p+xx%p
+ if (real(zz%c).lt.R0P0) then
+ zz%p = zz%p + int(sign(R1P0,aimag(xx%c)))
+ zz%c = -zz%c
+ endif
+ end function
+
+ function prduct_r(yy,xx) result(zz)
+!*******************************************************************
+! Return the product zz of yy and xx
+! keeping track of (the multiple of pi of) the phase %p such that
+! the real part of zz%c remains positive
+!*******************************************************************
+ type(qmplx_type) ,intent(in) :: yy
+ real(kindr2) ,intent(in) :: xx
+ type(qmplx_type) :: zz
+ zz%c = yy%c*abs(xx)
+ zz%p = yy%p
+ end function
+
+ function ratio(yy,xx) result(zz)
+!*******************************************************************
+! Return the ratio zz of yy and xx
+! keeping track of (the multiple of pi of) the phase %p such that
+! the real part of zz%c remains positive
+!*******************************************************************
+ type(qmplx_type) ,intent(in) :: yy,xx
+ type(qmplx_type) :: zz
+ zz%c = yy%c/xx%c
+ zz%p = yy%p-xx%p
+ if (real(zz%c).lt.R0P0) then
+ zz%p = zz%p - int(sign(R1P0,aimag(xx%c)))
+ zz%c = -zz%c
+ endif
+ end function
+!
+ function ratio_r(yy,xx) result(zz)
+!*******************************************************************
+!*******************************************************************
+ type(qmplx_type) ,intent(in) :: yy
+ real(kindr2) ,intent(in) :: xx
+ type(qmplx_type) :: zz
+ zz%c = yy%c/abs(xx)
+ zz%p = yy%p
+ end function
+!
+!
+ function eta3_r( aa,sa ,bb,sb ,cc,sc ) result(rslt)
+!*******************************************************************
+! 2*pi*imag times the result of
+! theta(-Im(a))*theta(-Im(b))*theta( Im(c))
+! - theta( Im(a))*theta( Im(b))*theta(-Im(c))
+! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: aa,bb,cc
+ real(kindr2) ,intent(in) :: sa,sb,sc
+ complex(kindc2) :: rslt
+ real(kindr2) :: ima,imb,imc
+ ima = aimag(aa)
+ imb = aimag(bb)
+ imc = aimag(cc)
+ if (ima.eq.R0P0) ima = sa
+ if (imb.eq.R0P0) imb = sb
+ if (imc.eq.R0P0) imc = sc
+ ima = sign(R1P0,ima)
+ imb = sign(R1P0,imb)
+ imc = sign(R1P0,imc)
+ if (ima.eq.imb.and.ima.ne.imc) then
+ rslt = cmplx(R0P0,imc*TWOPI,kind=kindc2)
+ else
+ rslt = C0P0
+ endif
+ end function
+!
+ function eta3_0( aa ,bb ,cc ) result(rslt)
+!*******************************************************************
+! 2*pi*imag times the result of
+! theta(-Im(a))*theta(-Im(b))*theta( Im(c))
+! - theta( Im(a))*theta( Im(b))*theta(-Im(c))
+! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: aa,bb,cc
+ complex(kindc2) :: rslt
+ real(kindr2) :: ima,imb,imc
+ ima = aimag(aa)
+ imb = aimag(bb)
+ imc = aimag(cc)
+ ima = sign(R1P0,ima)
+ imb = sign(R1P0,imb)
+ imc = sign(R1P0,imc)
+ if (ima.eq.imb.and.ima.ne.imc) then
+ rslt = cmplx(R0P0,imc*TWOPI,kind=kindc2)
+ else
+ rslt = C0P0
+ endif
+ end function
+!
+ function eta5_0( aa ,b1,c1 ,b2,c2 ) result(rslt)
+!*******************************************************************
+! eta3(aa,b1,c1) - eta3(aa,b2,c2)
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: aa,b1,c1 ,b2,c2
+ complex(kindc2) :: rslt
+ real(kindr2) :: imaa,imb1,imc1,imb2,imc2
+ imaa = sign(R1P0,aimag(aa))
+ imb1 = sign(R1P0,aimag(b1))
+ imb2 = sign(R1P0,aimag(b2))
+ imc1 = sign(R1P0,aimag(c1))
+ imc2 = sign(R1P0,aimag(c2))
+ if (imaa.eq.imb1) then
+ if (imaa.eq.imb2) then
+ if (imc1.eq.imc2) then
+ rslt = C0P0
+ elseif (imaa.ne.imc1) then
+ rslt = cmplx(R0P0, imc1*TWOPI,kind=kindc2)
+ else
+ rslt = cmplx(R0P0,-imc2*TWOPI,kind=kindc2)
+ endif
+ elseif (imaa.ne.imc1) then
+ rslt = cmplx(R0P0, imc1*TWOPI,kind=kindc2)
+ else
+ rslt = C0P0
+ endif
+ elseif (imaa.eq.imb2.and.imaa.ne.imc2) then
+ rslt = cmplx(R0P0,-imc2*TWOPI,kind=kindc2)
+ else
+ rslt = C0P0
+ endif
+ end function
+
+ function eta2_r( aa,sa ,bb,sb ) result(rslt)
+!*******************************************************************
+! The same as eta3, but with c=a*b, so that
+! eta(a,b) = log(a*b) - log(a) - log(b)
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: aa,bb
+ real(kindr2) ,intent(in) :: sa,sb
+ complex(kindc2) :: rslt
+ real(kindr2) :: rea,reb,ima,imb,imab
+ rea = real(aa) ;ima = aimag(aa)
+ reb = real(bb) ;imb = aimag(bb)
+ imab = rea*imb + reb*ima
+ if (ima.eq.R0P0) ima = sa
+ if (imb.eq.R0P0) imb = sb
+ if (imab.eq.R0P0) imab = sign(rea,sb) + sign(reb,sa)
+ ima = sign(R1P0,ima)
+ imb = sign(R1P0,imb)
+ imab = sign(R1P0,imab)
+ if (ima.eq.imb.and.ima.ne.imab) then
+ rslt = cmplx(R0P0,imab*TWOPI,kind=kindc2)
+ else
+ rslt = C0P0
+ endif
+ end function
+!
+ function eta2_0( aa ,bb ) result(rslt)
+!*******************************************************************
+!*******************************************************************
+ complex(kindc2) ,intent(in) :: aa,bb
+ complex(kindc2) :: rslt
+ real(kindr2) :: rea,reb,ima,imb,imab
+ rea = real(aa) ;ima = aimag(aa)
+ reb = real(bb) ;imb = aimag(bb)
+ rea = rea*imb
+ reb = reb*ima
+ imab = rea+reb
+ ima = sign(R1P0,ima)
+ imb = sign(R1P0,imb)
+ imab = sign(R1P0,imab)
+ if (ima.eq.imb.and.ima.ne.imab) then
+ rslt = cmplx(R0P0,imab*TWOPI,kind=kindc2)
+ else
+ rslt = C0P0
+ endif
+ end function
+!
+end module
+
+
+module avh_olo_loga
+!*******************************************************************
+! log( |xx|*exp(imag*pi*iph) ) = log|xx| + imag*pi*iph
+!*******************************************************************
+ use avh_olo_kinds
+ use avh_olo_units
+ use avh_olo_func
+ implicit none
+ private
+ public :: loga
+ real(kindr2) ,parameter :: pi=TWOPI/2
+contains
+!
+ function loga(xx,iph) result(rslt)
+ real(kindr2) ,intent(in) :: xx
+ integer ,intent(in) :: iph
+ complex(kindc2) :: rslt
+ real(kindr2) :: rr
+!
+ rr = abs(xx)
+ if (rr.eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop loga: ' &
+ ,'|xx|=',rr
+ endif
+ rslt = cmplx(log(rr),iph*pi,kind=kindc2)
+ end function
+!
+end module
+
+
+module avh_olo_bern
+!*******************************************************************
+! the first nn Bernoulli numbers
+!*******************************************************************
+ use avh_olo_kinds
+ implicit none
+ private
+ public :: init_bern,rbern,cbern
+ integer ,parameter :: nn=40
+ real(kindr2) :: rbern(nn) !PROTECTED
+ complex(kindc2) :: cbern(nn) !PROTECTED
+ integer :: ndigits=0
+
+ ! protected :: rbern, cbern
+contains
+!
+ subroutine init_bern(ndig)
+ integer ,intent(in) :: ndig
+ integer :: jj
+ integer ,parameter :: d=kindr2
+ if (ndigits.eq.ndig) return ;ndigits=ndig
+ rbern(1:nn) = R0P0
+ rbern( 1) = -1._d/2._d
+ rbern( 2) = 1._d/6._d
+ rbern( 4) = -1._d/30._d
+ rbern( 6) = 1._d/42._d
+ rbern( 8) = -1._d/30._d
+ rbern(10) = 5._d/66._d
+ rbern(12) = -691._d/2730._d
+ rbern(14) = 7._d/6._d
+ rbern(16) = -3617._d/510._d
+ rbern(18) = 43867._d/798._d
+ rbern(20) = -174611._d/330._d
+ rbern(22) = 854513._d/138._d
+ rbern(24) = -236364091._d/2730._d
+ rbern(26) = 8553103._d/6._d
+ rbern(28) = -23749461029._d/870._d
+ rbern(30) = 8615841276005._d/14322._d
+ rbern(32) = -7709321041217._d/510._d
+ rbern(34) = 2577687858367._d/6._d
+ rbern(36) = -26315271553053477373._d/1919190._d
+ rbern(38) = 2929993913841559._d/6._d
+ rbern(40) = -261082718496449122051._d/13530._d
+ do jj=1,nn
+ cbern(jj) = cmplx(rbern(jj),kind=kindc2)
+ enddo
+ end subroutine
+!
+end module
+
+
+module avh_olo_li2a
+!*******************************************************************
+! /1 ln(1-zz*t)
+! avh_olo_li2a = - | dt ----------
+! /0 t
+! with zz = 1 - |xx|*exp(imag*pi*iph)
+! Examples:
+! In order to get the dilog of 1.1 use xx=1.1, iph=0
+! In order to get the dilog of -1.1 use xx=1.1, iph=1
+! Add multiples of 2 to iph in order to get the result on
+! different Riemann-sheets.
+!*******************************************************************
+ use avh_olo_kinds
+ use avh_olo_func
+ use avh_olo_bern
+ implicit none
+ private
+ public :: init_li2a,li2a
+ real(kindr2) ,parameter :: pi=TWOPI/2
+ complex(kindc2) ,parameter :: pi2o6=C1P0*TWOPI*TWOPI/24
+ integer :: nn=16
+ integer :: ndigits=0
+contains
+!
+ subroutine init_li2a(ndig)
+ integer ,intent(in) :: ndig
+ if (ndigits.eq.ndig) return ;ndigits=ndig
+ call init_bern(ndigits)
+ if (ndigits.lt.24) then
+ nn = 16
+ else
+ nn = 30
+ endif
+ end subroutine
+
+ function li2a(xx,iph) result(rslt)
+ real(kindr2) ,intent(in) :: xx
+ integer ,intent(in) :: iph
+ complex(kindc2) :: rslt
+ real(kindr2) :: rr,yy,lyy,loy,zz,z2,liox
+ integer :: ii,ntwo,ione
+ logical :: positive , r_gt_1 , y_lt_h
+!
+ rr = abs(xx)
+ ntwo = iph/2*2
+ ione = iph - ntwo
+ positive = (ione.eq.0)
+!
+ if (rr.eq.R0P0) then
+ rslt = pi2o6
+ elseif (rr.eq.R1P0.and.positive) then
+ rslt = C0P0
+ else
+ yy = rr
+ lyy = log(rr)
+ if (.not.positive) yy = -yy
+!
+ r_gt_1 = (rr.gt.R1P0)
+ if (r_gt_1) then
+ yy = R1P0/yy
+ lyy = -lyy
+ ntwo = -ntwo
+ ione = -ione
+ endif
+ loy = log(R1P0-yy) ! log(1-yy) is always real
+!
+ y_lt_h = (yy.lt.R5M1)
+ if (y_lt_h) then
+ zz = -loy ! log(1-yy) is real
+ else
+ zz = -lyy ! yy>0.5 => log(yy) is real
+ endif
+!
+ z2 = zz*zz
+ liox = rbern(nn)
+ do ii=nn,4,-2
+ liox = rbern(ii-2) + liox*z2/(ii*(ii+1))
+ enddo
+ liox = rbern(1) + liox*zz/3
+ liox = zz + liox*z2/2
+!
+ rslt = cmplx(liox,kind=kindc2)
+!
+ if (y_lt_h) then
+ rslt = pi2o6 - rslt - cmplx(loy*lyy,loy*pi*ione,kind=kindc2)
+ endif
+!
+ rslt = rslt + cmplx( R0P0 , -loy*pi*ntwo ,kind=kindc2)
+!
+ if (r_gt_1) rslt = -rslt - cmplx(-lyy,iph*pi,kind=kindc2)**2/2
+ endif
+ end function
+!
+end module
+
+
+module avh_olo_loga2
+!*******************************************************************
+! log(xx)/(1-xx) with xx = log|xx| + imag*pi*iph
+!*******************************************************************
+ use avh_olo_kinds
+ use avh_olo_units
+ use avh_olo_func
+ implicit none
+ private
+ public :: init_loga2,loga2
+ real(kindr2) :: thrs=epsilon(R1P0)
+ integer :: ndigits=0
+contains
+!
+ subroutine init_loga2(ndig)
+ integer ,intent(in) :: ndig
+ if (ndigits.eq.ndig) return ;ndigits=ndig
+ thrs = 10*thrs
+ end subroutine
+!
+ function loga2(xx,iph) result(rslt)
+ use avh_olo_loga ,only : loga
+ real(kindr2) ,intent(in) :: xx
+ integer ,intent(in) :: iph
+ complex(kindc2) :: rslt
+ real(kindr2) :: omx
+!
+ if (mod(iph,2).eq.0) then
+ omx = R1P0-abs(xx)
+ else
+ omx = R1P0+abs(xx)
+ endif
+!
+ if (iph.ne.0) then
+ if (omx.eq.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop loga2: ' &
+ ,'1-xx,iph=',omx,iph
+ rslt = C0P0
+ else
+ rslt = loga(xx,iph)/cmplx(omx,kind=kindc2)
+ endif
+ else
+ if (abs(omx).lt.thrs) then
+ rslt = cmplx(-R1P0-omx/2,kind=kindc2)
+ else
+ rslt = loga(xx,iph)/cmplx(omx,kind=kindc2)
+ endif
+ endif
+ end function
+!
+end module
+
+
+module avh_olo_logc
+!*******************************************************************
+! Returns log( |Re(xx)| + imag*Im(xx) ) + imag*pi*iph
+!*******************************************************************
+ use avh_olo_kinds
+ use avh_olo_units
+ use avh_olo_func
+ implicit none
+ private
+ public :: logc
+ complex(kindc2) ,parameter :: ipi=CiP0*TWOPI/2
+contains
+!
+ function logc(xx) result(rslt)
+ type(qmplx_type) ,intent(in) :: xx
+ complex(kindc2) :: rslt
+ if (xx%c.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop logc: xx%c =',xx%c
+ rslt = C0P0
+ else
+ rslt = log( cmplx(abs(real(xx%c)),aimag(xx%c),kind=kindc2) ) &
+ + ipi*xx%p
+ endif
+ end function
+!
+end module
+
+
+module avh_olo_li2c
+!*******************************************************************
+! /1 ln(1-zz*t)
+! avh_olo_li2c = - | dt ----------
+! /0 t
+! with zz = 1 - ( |Re(xx)| + imag*Im(xx) )*exp(imag*pi*iph)
+! Examples:
+! In order to get the dilog of 1+imag use xx=1+imag, iph= 0
+! In order to get the dilog of 1-imag use xx=1-imag, iph= 0
+! In order to get the dilog of -1+imag use xx=1-imag, iph= 1
+! In order to get the dilog of -1-imag use xx=1+imag, iph=-1
+! Add multiples of 2 to iph in order to get the result on
+! different Riemann-sheets.
+!*******************************************************************
+ use avh_olo_kinds
+ use avh_olo_func
+ use avh_olo_bern
+ use avh_olo_li2a
+ implicit none
+ private
+ public :: init_li2c,li2c
+ complex(kindc2) ,parameter :: ipi=CiP0*TWOPI/2
+ complex(kindc2) ,parameter :: pi2o6=C1P0*TWOPI*TWOPI/24
+ integer :: nn=18
+ integer :: ndigits=0
+contains
+!
+ subroutine init_li2c(ndig)
+ integer ,intent(in) :: ndig
+ if (ndigits.eq.ndig) return ;ndigits=ndig
+ call init_li2a(ndigits)
+ call init_bern(ndigits)
+ if (ndigits.lt.24) then
+ nn = 18
+ else
+ nn = 36
+ endif
+ end subroutine
+
+ function li2c(xx) result(rslt)
+ type(qmplx_type) :: xx
+ complex(kindc2) :: rslt ,yy,lyy,loy,zz,z2
+ real(kindr2) :: rex,imx
+ integer :: ii,iyy
+ logical :: x_gt_1 , y_lt_h
+!
+ rex = real(xx%c)
+ imx = aimag(xx%c)
+!
+ if (imx.eq.R0P0) then
+ rslt = li2a(rex,xx%p)
+ else
+ rex = abs(rex)
+!
+ if (mod(xx%p,2).eq.0) then
+ yy = cmplx(rex,imx,kind=kindc2)
+ iyy = xx%p
+ else
+ yy = cmplx(-rex,-imx,kind=kindc2)
+! Notice that iyy=xx%p/2*2 does not deal correctly with the
+! situation when xx%p-xx%p/2*2 = sign(Im(xx%c)) . The following does:
+ iyy = xx%p + nint(sign(R1P0,imx))
+ endif
+!
+ x_gt_1 = (abs(xx%c).gt.R1P0)
+ if (x_gt_1) then
+ yy = C1P0/yy
+ iyy = -iyy
+ endif
+ lyy = log(yy)
+ loy = log(C1P0-yy)
+!
+ y_lt_h = (real(yy).lt.R5M1)
+ if (y_lt_h) then
+ zz = -loy
+ else
+ zz = -lyy
+ endif
+!
+ z2 = zz*zz
+ rslt = cbern(nn)
+ do ii=nn,4,-2
+ rslt = cbern(ii-2) + rslt*z2/(ii*(ii+1))
+ enddo
+ rslt = cbern(1) + rslt*zz/3
+ rslt = zz + rslt*z2/2
+!
+ if (y_lt_h) rslt = pi2o6 - rslt - loy*lyy
+!
+ rslt = rslt - loy*ipi*iyy
+!
+ if (x_gt_1) rslt = -rslt - (lyy + ipi*iyy)**2/2
+ endif
+ end function
+!
+end module
+
+
+module avh_olo_logc2
+!*******************************************************************
+! log(xx)/(1-xx)
+! with log(xx) = log( |Re(xx)| + imag*Im(xx) ) + imag*pi*iph
+!*******************************************************************
+ use avh_olo_kinds
+ use avh_olo_units
+ use avh_olo_func
+ implicit none
+ private
+ public :: init_logc2,logc2
+ real(kindr2) :: thrs=epsilon(R1P0)
+ integer :: ndigits=0
+contains
+!
+ subroutine init_logc2(ndig)
+ integer ,intent(in) :: ndig
+ if (ndigits.eq.ndig) return ;ndigits=ndig
+ thrs = 10*thrs
+ end subroutine
+!
+ function logc2(xx) result(rslt)
+ use avh_olo_logc ,only : logc
+ type(qmplx_type) ,intent(in) :: xx
+ complex(kindc2) :: rslt ,omx
+ if (mod(xx%p,2).eq.0) then
+ omx = cmplx(1d0-abs(real(xx%c)),-aimag(xx%c),kind=kindc2)
+ else
+ omx = cmplx(1d0+abs(real(xx%c)), aimag(xx%c),kind=kindc2)
+ endif
+ if (xx%p.ne.0) then
+ if (omx.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop logc2: ' &
+ ,'1-xx%c,xx%p=',omx,xx%p
+ rslt = C0P0
+ else
+ rslt = logc(xx)/omx
+ endif
+ else
+ if (abs(omx).lt.thrs) then
+ rslt = -C1P0-omx/2
+ else
+ rslt = logc(xx)/omx
+ endif
+ endif
+ end function
+!
+end module
+
+
+module avh_olo_li2c2
+!*******************************************************************
+! avh_olo_li2c2 = ( li2(x1) - li2(x2) )/(x1%c-x2%c)
+!
+! /1 ln(1-zz*t)
+! where li2(x1) = - | dt ----------
+! /0 t
+! with zz = 1 - ( |Re(x1%c)| + imag*Im(x1%c) )*exp(imag*pi*x1%p)
+! and similarly for li2(x2)
+!*******************************************************************
+ use avh_olo_kinds
+ use avh_olo_units
+ use avh_olo_func
+ use avh_olo_li2c
+ use avh_olo_logc2
+ implicit none
+ private
+ public :: init_li2c2,li2c2
+ complex(kindc2) ,parameter :: ipi=CiP0*TWOPI/2
+ real(kindr2) ,parameter :: thrs1=epsilon(R1P0)
+ real(kindr2) :: thrs=0.11_kindr2
+ integer :: nmax=12
+ integer :: ndigits=0
+contains
+!
+ subroutine init_li2c2(ndig)
+ integer ,intent(in) :: ndig
+ if (ndigits.eq.ndig) return ;ndigits=ndig
+ call init_logc2(ndigits)
+ call init_li2c(ndigits)
+ if (ndigits.lt.16) then
+ thrs = 0.11_kindr2 ! double precision
+ nmax = 12
+ elseif (ndigits.lt.24) then
+ thrs = 0.02_kindr2 ! guess
+ nmax = 12
+ else
+ thrs = 0.008_kindr2 ! quadruple precision
+ nmax = 12
+ endif
+ end subroutine
+!
+ function li2c2(x1,x2) result(rslt)
+ type(qmplx_type) ,intent(in) :: x1,x2
+ complex(kindc2) :: rslt
+ complex(kindc2) :: x1r,x2r,delta,xx,xr,omx,del,hh,ff(0:20),zz
+ integer :: ih,ii
+!
+ if (mod(x1%p,2).eq.0) then
+ x1r = cmplx( abs(real(x1%c)), aimag(x1%c),kind=kindc2)
+ else
+ x1r = cmplx(-abs(real(x1%c)),-aimag(x1%c),kind=kindc2)
+ endif
+ if (mod(x2%p,2).eq.0) then
+ x2r = cmplx( abs(real(x2%c)), aimag(x2%c),kind=kindc2)
+ else
+ x2r = cmplx(-abs(real(x2%c)),-aimag(x2%c),kind=kindc2)
+ endif
+ delta = x1r-x2r
+!
+ if (x1%p.ne.x2%p) then
+ if (delta.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop li2c2: ' &
+ ,'x1%p,x2%p,delta=',x1%p,x2%p,delta
+ rslt = C0P0
+ else
+ rslt = ( li2c(x1)-li2c(x2) )/delta
+ endif
+ else
+ if (abs(delta/x1%c).gt.thrs) then
+ rslt = ( li2c(x1)-li2c(x2) )/delta
+ else
+ xx = x1%c
+ xr = x1r
+ omx = C1P0-xr
+ del = delta
+ hh = C1P0-x2r
+ if (abs(hh).gt.abs(omx)) then
+ xx = x2%c
+ xr = x2r
+ omx = hh
+ del = -delta
+ endif
+ if (abs(omx).lt.thrs1) then
+ zz = -C1P0-omx/2-del/4
+ else
+ ih = x1%p - x1%p/2*2
+ ff(0) = logc2(directly(xx,ih))
+ hh = -C1P0
+ do ii=1,nmax
+ hh = -hh/xr
+ ff(ii) = ( hh/ii + ff(ii-1) )/omx
+ enddo
+ zz = ff(nmax)/(nmax+1)
+ do ii=nmax-1,0,-1
+ zz = ff(ii)/(ii+1) - zz*del
+ enddo
+ endif
+ ih = x1%p-ih
+ if (ih.ne.0) then
+ omx = C1P0-x1r
+ zz = zz - ih*ipi*logc2(qonv((C1P0-x2r)/omx))/omx
+ endif
+ rslt = zz
+ endif
+ endif
+ end function
+!
+end module
diff --git a/avh_olo-2.2.1/avh_olo_kinds.f90 b/avh_olo-2.2.1/avh_olo_kinds.f90
new file mode 100644
index 0000000..07c04b9
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_kinds.f90
@@ -0,0 +1,42 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+module avh_olo_kinds
+ use avh_olo_xkind
+!
+ implicit none
+ private
+ public :: kindr2,kindc2 &
+ ,R0P0,R1P0,R5M1,TWOPI,SQRT2,C0P0,C1P0,CiP0
+!
+ integer ,parameter :: kindr2 = olo_xkind
+ integer ,parameter :: kindc2 = kindr2
+!
+ real(kindr2) ,parameter :: R0P0=0._kindr2
+ real(kindr2) ,parameter :: R1P0=1._kindr2
+ real(kindr2) ,parameter :: R5M1=0.5_kindr2
+! 1 2345678901234567890123456789012
+ real(kindr2) ,parameter :: TWOPI=6.2831853071795864769252867665590_kindr2
+ real(kindr2) ,parameter :: SQRT2=1.4142135623730950488016887242097_kindr2
+ complex(kindc2) ,parameter :: C0P0 = (0._kindr2,0._kindr2)
+ complex(kindc2) ,parameter :: C1P0 = (1._kindr2,0._kindr2)
+ complex(kindc2) ,parameter :: CiP0 = (0._kindr2,1._kindr2)
+!
+end module
diff --git a/avh_olo-2.2.1/avh_olo_main.f90 b/avh_olo-2.2.1/avh_olo_main.f90
new file mode 100644
index 0000000..7e16b66
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_main.f90
@@ -0,0 +1,1135 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+module avh_olo
+ use avh_olo_kinds
+ use avh_olo_units
+ use avh_olo_print
+!
+ implicit none
+ private
+ public :: olo_kind ,olo_unit ,olo_scale ,olo_onshell ,olo_setting &
+ ,olo_a0 ,olo_b0 ,olo_b11 ,olo_c0 ,olo_d0
+!
+ integer ,parameter :: olo_kind = kindr2
+!
+ integer :: ndigits = 0 ! corrected in subroutine hello
+ real(kindr2) :: onshellthrs = R0P0 ! corrected in subroutine hello
+ logical :: nonzerothrs = .false.
+!
+ real(kindr2) :: muscale = R1P0
+!
+ character(99) ,parameter :: warnonshell=&
+ 'it seems you forgot to put some input explicitly on shell. ' &
+ //'You may call olo_onshell to cure this.'
+!
+ logical :: intro=.true.
+!
+ interface olo_a0
+ module procedure loc_a0r,a0rr,loc_a0c,a0cr
+ end interface
+ interface olo_b0
+ module procedure b0rr,b0rrr,b0rc,b0rcr,b0cc,b0ccr
+ end interface
+ interface olo_b11
+ module procedure b11rr,b11rrr,b11rc,b11rcr,b11cc,b11ccr
+ end interface
+ interface olo_c0
+ module procedure c0rr,c0rrr,c0rc,c0rcr,c0cc,c0ccr
+ end interface
+ interface olo_d0
+ module procedure d0rr,d0rrr,d0rc,d0rcr,d0cc,d0ccr
+ end interface
+
+contains
+
+
+ subroutine hello
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_loga2 ,only: init_loga2
+ use avh_olo_li2c2 ,only: init_li2c2
+ use avh_olo_bub ,only: init_bub
+ use avh_olo_boxc ,only: init_boxc
+!
+ intro = .false.
+!
+ write(*,'(a72)') '########################################################################'
+ write(*,'(a72)') '# #'
+ write(*,'(a72)') '# You are using OneLOop-2.2.1 #'
+ write(*,'(a72)') '# #'
+ write(*,'(a72)') '# for the evaluation of 1-loop scalar 1-, 2-, 3- and 4-point functions #'
+ write(*,'(a72)') '# #'
+ write(*,'(a72)') '# author: Andreas van Hameren <hamerenREMOVETHIS@ifj.edu.pl> #'
+ write(*,'(a72)') '# date: 07-09-2011 #'
+ write(*,'(a72)') '# #'
+ write(*,'(a72)') '# Please cite #'
+ write(*,'(a72)') '# A. van Hameren, #'
+ write(*,'(a72)') '# Comput.Phys.Commun. 182 (2011) 2427-2438, arXiv:1007.4716 #'
+ write(*,'(a72)') '# A. van Hameren, C.G. Papadopoulos and R. Pittau, #'
+ write(*,'(a72)') '# JHEP 0909:106,2009, arXiv:0903.4665 #'
+ write(*,'(a72)') '# in publications with results obtained with the help of this program. #'
+ write(*,'(a72)') '# #'
+ write(*,'(a72)') '########################################################################'
+!
+ ndigits = int(digits(R1P0)*log(radix(R1P0)*R1P0)/log(R1P0*10))
+ if (ndigits.lt.16) then ;onshellthrs = epsilon(R1P0)*100
+ elseif (ndigits.lt.24) then ;onshellthrs = epsilon(R1P0)*1000
+ elseif (ndigits.lt.32) then ;onshellthrs = epsilon(R1P0)*10000
+ else ;onshellthrs = epsilon(R1P0)*1000000
+ endif
+!
+ call init_print( ndigits )
+ call init_loga2( ndigits )
+ call init_li2c2( ndigits )
+ call init_bub( ndigits )
+ call init_boxc( ndigits )
+!
+ end subroutine
+
+
+ subroutine olo_unit( val ,message )
+!*******************************************************************
+!*******************************************************************
+ integer ,intent(in) :: val
+ character(*),intent(in),optional :: message
+ if (intro) call hello
+ if (present(message)) then ;call set_unit( message ,val )
+ else ;call set_unit( 'all' ,val )
+ endif
+ end subroutine
+
+
+ subroutine olo_scale( val )
+!*******************************************************************
+!*******************************************************************
+ real(kindr2) ,intent(in) :: val
+ if (intro) call hello
+ muscale = val
+ end subroutine
+
+
+ subroutine olo_onshell( thrs )
+!*******************************************************************
+!*******************************************************************
+ real(kindr2) ,intent(in) :: thrs
+ if (intro) call hello
+ nonzerothrs = .true.
+ onshellthrs = thrs
+ end subroutine
+
+
+ subroutine olo_setting( iunit )
+!*******************************************************************
+!*******************************************************************
+ integer,optional,intent(in) :: iunit
+ integer :: nunit
+ if (intro) call hello
+ nunit = munit
+ if (present(iunit)) nunit = iunit
+ if (nunit.le.0) return
+!
+ write(nunit,*) 'MESSAGE from OneLOop: real kind parameter =',trim(myprint(kindr2))
+ write(nunit,*) 'MESSAGE from OneLOop: significant digits =',trim(myprint(ndigits))
+!
+ if (nonzerothrs) then
+ write(nunit,*) 'MESSAGE from OneLOop: on-shell threshold =',trim(myprint(onshellthrs))
+ else
+ write(nunit,*) 'MESSAGE from OneLOop: on-shell threshold is not set'
+ endif
+!
+ write(nunit,*) 'MESSAGE from OneLOop: scale (mu, not mu^2) =',trim(myprint(muscale))
+!
+ end subroutine
+
+
+!*******************************************************************
+!
+! C / d^(Dim)q
+! rslt = ------ | --------
+! i*pi^2 / (q^2-mm)
+!
+! with Dim = 4-2*eps
+! C = pi^eps * mu^(2*eps) * exp(gamma_Euler*eps)
+!
+! input: mm = mass squared
+! output: rslt(0) = eps^0 -coefficient
+! rslt(1) = eps^(-1)-coefficient
+! rslt(2) = eps^(-2)-coefficient
+!
+! Check the comments in subroutine olo_onshell to find out how
+! this routine decides when to return IR-divergent cases.
+!*******************************************************************
+!
+ subroutine loc_a0r( rslt ,mm )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: tadp
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: mm
+!
+ include 'avh_olo_a0_a.h90'
+!
+ mulocal = muscale
+!
+ include 'avh_olo_a0_b.h90'
+!
+ end subroutine
+!
+ subroutine a0rr( rslt ,mm ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: tadp
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: mm
+ real(kindr2) ,intent(in) :: rmu
+!
+ include 'avh_olo_a0_a.h90'
+!
+ mulocal = rmu
+!
+ include 'avh_olo_a0_b.h90'
+!
+ end subroutine
+!
+ subroutine loc_a0c( rslt ,mm )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: tadp
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: mm
+!
+ include 'avh_olo_a0_a.h90'
+!
+ mulocal = muscale
+!
+ include 'avh_olo_a0_b.h90'
+!
+ end subroutine
+!
+ subroutine a0cr( rslt ,mm ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: tadp
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: mm
+ real(kindr2) ,intent(in) :: rmu
+!
+ include 'avh_olo_a0_a.h90'
+!
+ mulocal = rmu
+!
+ include 'avh_olo_a0_b.h90'
+!
+ end subroutine
+
+
+!*******************************************************************
+!
+! C / d^(Dim)q
+! rslt = ------ | --------------------
+! i*pi^2 / [q^2-m1][(q+k)^2-m2]
+!
+! with Dim = 4-2*eps
+! C = pi^eps * mu^(2*eps) * exp(gamma_Euler*eps)
+!
+! input: pp = k^2, m1,m2 = mass squared
+! output: rslt(0) = eps^0 -coefficient
+! rslt(1) = eps^(-1)-coefficient
+! rslt(2) = eps^(-2)-coefficient
+!
+! Check the comments in subroutine olo_onshell to find out how
+! this routine decides when to return IR-divergent cases.
+!*******************************************************************
+!
+ subroutine b0rr( rslt ,pp ,m1,m2 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub0
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: pp,m1,m2
+!
+ include 'avh_olo_b0_a.h90'
+!
+ mulocal = muscale
+!
+ app = abs(pp)
+ am1 = abs(m1)
+ am2 = abs(m2)
+!
+ include 'avh_olo_b0_b.h90'
+!
+ end subroutine
+!
+ subroutine b0rrr( rslt ,pp ,m1,m2 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub0
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: pp,m1,m2,rmu
+!
+ include 'avh_olo_b0_a.h90'
+!
+ mulocal = rmu
+!
+ app = abs(pp)
+ am1 = abs(m1)
+ am2 = abs(m2)
+!
+ include 'avh_olo_b0_b.h90'
+!
+ end subroutine
+!
+ subroutine b0rc( rslt ,pp ,m1,m2 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub0
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: pp
+ complex(kindc2) ,intent(in) :: m1,m2
+ real(kindr2) :: hh
+!
+ include 'avh_olo_b0_a.h90'
+!
+ mulocal = muscale
+!
+ app = abs(pp)
+!
+ am1 = real(r1)
+ hh = aimag(r1)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'r1 has positive imaginary part, switching its sign.'
+ r1 = cmplx( am1 ,-hh ,kind=kindc2 )
+ endif
+ am1 = abs(am1) + abs(hh)
+!
+ am2 = real(r2)
+ hh = aimag(r2)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'r2 has positive imaginary part, switching its sign.'
+ r2 = cmplx( am2 ,-hh ,kind=kindc2 )
+ endif
+ am2 = abs(am2) + abs(hh)
+!
+ include 'avh_olo_b0_b.h90'
+!
+ end subroutine
+!
+ subroutine b0rcr( rslt ,pp,m1,m2 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub0
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: pp ,rmu
+ complex(kindc2) ,intent(in) :: m1,m2
+ real(kindr2) :: hh
+!
+ include 'avh_olo_b0_a.h90'
+!
+ mulocal = rmu
+!
+ app = abs(pp)
+!
+ am1 = real(r1)
+ hh = aimag(r1)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'r1 has positive imaginary part, switching its sign.'
+ r1 = cmplx( am1 ,-hh ,kind=kindc2 )
+ endif
+ am1 = abs(am1) + abs(hh)
+!
+ am2 = real(r2)
+ hh = aimag(r2)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'r2 has positive imaginary part, switching its sign.'
+ r2 = cmplx( am2 ,-hh ,kind=kindc2 )
+ endif
+ am2 = abs(am2) + abs(hh)
+!
+ include 'avh_olo_b0_b.h90'
+!
+ end subroutine
+!
+ subroutine b0cc( rslt ,pp,m1,m2 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub0
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: pp,m1,m2
+ real(kindr2) :: hh
+!
+ include 'avh_olo_b0_a.h90'
+!
+ mulocal = muscale
+!
+ app = real(ss)
+ if (aimag(ss).ne.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'ss has non-zero imaginary part, putting it to zero.'
+ ss = cmplx( app ,kind=kindc2 )
+ endif
+ app = abs(app)
+!
+ am1 = real(r1)
+ hh = aimag(r1)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'r1 has positive imaginary part, switching its sign.'
+ r1 = cmplx( am1 ,-hh ,kind=kindc2 )
+ endif
+ am1 = abs(am1) + abs(hh)
+!
+ am2 = real(r2)
+ hh = aimag(r2)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'r2 has positive imaginary part, switching its sign.'
+ r2 = cmplx( am2 ,-hh ,kind=kindc2 )
+ endif
+ am2 = abs(am2) + abs(hh)
+!
+ include 'avh_olo_b0_b.h90'
+!
+ end subroutine
+!
+ subroutine b0ccr( rslt ,pp,m1,m2 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub0
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: pp,m1,m2
+ real(kindr2) ,intent(in) :: rmu
+ real(kindr2) :: hh
+!
+ include 'avh_olo_b0_a.h90'
+!
+ mulocal = rmu
+!
+ app = real(ss)
+ if (aimag(ss).ne.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'ss has non-zero imaginary part, putting it to zero.'
+ ss = cmplx( app ,kind=kindc2 )
+ endif
+ app = abs(app)
+!
+ am1 = real(r1)
+ hh = aimag(r1)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'r1 has positive imaginary part, switching its sign.'
+ r1 = cmplx( am1 ,-hh ,kind=kindc2 )
+ endif
+ am1 = abs(am1) + abs(hh)
+!
+ am2 = real(r2)
+ hh = aimag(r2)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
+ ,'r2 has positive imaginary part, switching its sign.'
+ r2 = cmplx( am2 ,-hh ,kind=kindc2 )
+ endif
+ am2 = abs(am2) + abs(hh)
+!
+ include 'avh_olo_b0_b.h90'
+!
+ end subroutine
+
+
+!*******************************************************************
+! Return the Papparino-Veltman functions b11,b00,b1,b0 , for
+!
+! C / d^(Dim)q
+! ------ | -------------------- = b0
+! i*pi^2 / [q^2-m1][(q+p)^2-m2]
+!
+! C / d^(Dim)q q^mu
+! ------ | -------------------- = p^mu b1
+! i*pi^2 / [q^2-m1][(q+p)^2-m2]
+!
+! C / d^(Dim)q q^mu q^nu
+! ------ | -------------------- = g^{mu,nu} b00 + p^mu p^nu b11
+! i*pi^2 / [q^2-m1][(q+p)^2-m2]
+!
+! Check the comments in subroutine olo_onshell to find out how
+! this routine decides when to return IR-divergent cases.
+!*******************************************************************
+!
+ subroutine b11rr( b11,b00,b1,b0 ,pp,m1,m2 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub11
+ complex(kindc2) ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
+ real(kindr2) ,intent(in) :: pp,m1,m2
+!
+ include 'avh_olo_b11_a.h90'
+!
+ mulocal = muscale
+!
+ app = abs(pp)
+ am1 = abs(m1)
+ am2 = abs(m2)
+!
+ include 'avh_olo_b11_b.h90'
+!
+ end subroutine
+!
+ subroutine b11rrr( b11,b00,b1,b0 ,pp,m1,m2 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub11
+ complex(kindc2) ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
+ real(kindr2) ,intent(in) :: pp,m1,m2,rmu
+!
+ include 'avh_olo_b11_a.h90'
+!
+ mulocal = rmu
+!
+ app = abs(pp)
+ am1 = abs(m1)
+ am2 = abs(m2)
+!
+ include 'avh_olo_b11_b.h90'
+!
+ end subroutine
+!
+ subroutine b11rc( b11,b00,b1,b0 ,pp,m1,m2 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub11
+ complex(kindc2) ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
+ real(kindr2) ,intent(in) :: pp
+ complex(kindc2) ,intent(in) :: m1,m2
+ real(kindr2) :: hh
+!
+ include 'avh_olo_b11_a.h90'
+!
+ mulocal = muscale
+!
+ app = abs(pp)
+!
+ am1 = real(r1)
+ hh = aimag(r1)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'r1 has positive imaginary part, switching its sign.'
+ r1 = cmplx( am1 ,-hh ,kind=kindc2 )
+ endif
+ am1 = abs(am1) + abs(hh)
+!
+ am2 = real(r2)
+ hh = aimag(r2)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'r2 has positive imaginary part, switching its sign.'
+ r2 = cmplx( am2 ,-hh ,kind=kindc2 )
+ endif
+ am2 = abs(am2) + abs(hh)
+!
+ include 'avh_olo_b11_b.h90'
+!
+ end subroutine
+!
+ subroutine b11rcr( b11,b00,b1,b0 ,pp,m1,m2 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub11
+ complex(kindc2) ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
+ real(kindr2) ,intent(in) :: pp ,rmu
+ complex(kindc2) ,intent(in) :: m1,m2
+ real(kindr2) :: hh
+!
+ include 'avh_olo_b11_a.h90'
+!
+ mulocal = rmu
+!
+ app = abs(pp)
+!
+ am1 = real(r1)
+ hh = aimag(r1)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'r1 has positive imaginary part, switching its sign.'
+ r1 = cmplx( am1 ,-hh ,kind=kindc2 )
+ endif
+ am1 = abs(am1) + abs(hh)
+!
+ am2 = real(r2)
+ hh = aimag(r2)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'r2 has positive imaginary part, switching its sign.'
+ r2 = cmplx( am2 ,-hh ,kind=kindc2 )
+ endif
+ am2 = abs(am2) + abs(hh)
+!
+ include 'avh_olo_b11_b.h90'
+!
+ end subroutine
+!
+ subroutine b11cc( b11,b00,b1,b0 ,pp,m1,m2 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub11
+ complex(kindc2) ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
+ complex(kindc2) ,intent(in) :: pp,m1,m2
+ real(kindr2) :: hh
+!
+ include 'avh_olo_b11_a.h90'
+!
+ mulocal = muscale
+!
+ app = real(ss)
+ if (aimag(ss).ne.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'ss has non-zero imaginary part, putting it to zero.'
+ ss = cmplx( app ,kind=kindc2 )
+ endif
+ app = abs(app)
+!
+ am1 = real(r1)
+ hh = aimag(r1)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'r1 has positive imaginary part, switching its sign.'
+ r1 = cmplx( am1 ,-hh ,kind=kindc2 )
+ endif
+ am1 = abs(am1) + abs(hh)
+!
+ am2 = real(r2)
+ hh = aimag(r2)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'r2 has positive imaginary part, switching its sign.'
+ r2 = cmplx( am2 ,-hh ,kind=kindc2 )
+ endif
+ am2 = abs(am2) + abs(hh)
+!
+ include 'avh_olo_b11_b.h90'
+!
+ end subroutine
+!
+ subroutine b11ccr( b11,b00,b1,b0 ,pp,m1,m2 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_bub ,only: bub11
+ complex(kindc2) ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
+ complex(kindc2) ,intent(in) :: pp,m1,m2
+ real(kindr2) ,intent(in) :: rmu
+ real(kindr2) :: hh
+!
+ include 'avh_olo_b11_a.h90'
+!
+ mulocal = rmu
+!
+ app = real(ss)
+ if (aimag(ss).ne.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'ss has non-zero imaginary part, putting it to zero.'
+ ss = cmplx( app ,kind=kindc2 )
+ endif
+ app = abs(app)
+!
+ am1 = real(r1)
+ hh = aimag(r1)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'r1 has positive imaginary part, switching its sign.'
+ r1 = cmplx( am1 ,-hh ,kind=kindc2 )
+ endif
+ am1 = abs(am1) + abs(hh)
+!
+ am2 = real(r2)
+ hh = aimag(r2)
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
+ ,'r2 has positive imaginary part, switching its sign.'
+ r2 = cmplx( am2 ,-hh ,kind=kindc2 )
+ endif
+ am2 = abs(am2) + abs(hh)
+!
+ include 'avh_olo_b11_b.h90'
+!
+ end subroutine
+
+
+!*******************************************************************
+! calculates
+! C / d^(Dim)q
+! ------ | ---------------------------------------
+! i*pi^2 / [q^2-m1] [(q+k1)^2-m2] [(q+k1+k2)^2-m3]
+!
+! with Dim = 4-2*eps
+! C = pi^eps * mu^(2*eps)
+! * GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
+!
+! input: p1=k1^2, p2=k2^2, p3=(k1+k2)^2, m1,m2,m3=squared masses
+! output: rslt(0) = eps^0 -coefficient
+! rslt(1) = eps^(-1)-coefficient
+! rslt(2) = eps^(-2)-coefficient
+!
+! Check the comments in subroutine olo_onshell to find out how
+! this routine decides when to return IR-divergent cases.
+!*******************************************************************
+!
+ subroutine c0rr( rslt ,p1,p2,p3 ,m1,m2,m3 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_tri
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: p1,p2,p3 ,m1,m2,m3
+ real(kindr2) :: pp(3),mm(3)
+!
+ include 'avh_olo_c0_a.h90'
+!
+ mulocal = muscale
+!
+ do ii=1,3
+ ap(ii) = abs(pp(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,3
+ am(ii) = abs(mm(ii))
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_c0_b.h90'
+!
+ end subroutine
+!
+ subroutine c0rrr( rslt ,p1,p2,p3 ,m1,m2,m3 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_tri
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: p1,p2,p3 ,m1,m2,m3 ,rmu
+ real(kindr2) :: pp(3),mm(3)
+!
+ include 'avh_olo_c0_a.h90'
+!
+ mulocal = rmu
+!
+ do ii=1,3
+ ap(ii) = abs(pp(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,3
+ am(ii) = abs(mm(ii))
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_c0_b.h90'
+!
+ end subroutine
+!
+ subroutine c0rc( rslt ,p1,p2,p3 ,m1,m2,m3 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_tri
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: p1,p2,p3
+ complex(kindc2) ,intent(in) :: m1,m2,m3
+ real(kindr2) :: pp(3)
+ complex(kindc2) :: mm(3)
+ real(kindr2) :: hh
+!
+ include 'avh_olo_c0_a.h90'
+!
+ mulocal = muscale
+!
+ do ii=1,3
+ ap(ii) = abs(pp(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,3
+ am(ii) = real(mm(ii))
+ hh = aimag(mm(ii))
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
+ ,'mass-squared has positive imaginary part, switching its sign.'
+ mm(ii) = cmplx( am(ii) ,-hh ,kind=kindc2 )
+ endif
+ am(ii) = abs(am(ii)) + abs(hh)
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_c0_b.h90'
+!
+ end subroutine
+!
+ subroutine c0rcr( rslt ,p1,p2,p3 ,m1,m2,m3 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_tri
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: p1,p2,p3 ,rmu
+ complex(kindc2) ,intent(in) :: m1,m2,m3
+ real(kindr2) :: pp(3)
+ complex(kindc2) :: mm(3)
+ real(kindr2) :: hh
+!
+ include 'avh_olo_c0_a.h90'
+!
+ mulocal = rmu
+!
+ do ii=1,3
+ ap(ii) = abs(pp(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,3
+ am(ii) = real(mm(ii))
+ hh = aimag(mm(ii))
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
+ ,'mass-squared has positive imaginary part, switching its sign.'
+ mm(ii) = cmplx( am(ii) ,-hh ,kind=kindc2 )
+ endif
+ am(ii) = abs(am(ii)) + abs(hh)
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_c0_b.h90'
+!
+ end subroutine
+!
+ subroutine c0cc( rslt ,p1,p2,p3 ,m1,m2,m3 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_tri
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3 ,m1,m2,m3
+ complex(kindc2) :: pp(3),mm(3)
+ real(kindr2) :: hh
+!
+ include 'avh_olo_c0_a.h90'
+!
+ mulocal = muscale
+!
+ do ii=1,3
+ ap(ii) = real(pp(ii))
+ if (aimag(pp(ii)).ne.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
+ ,'momentum with non-zero imaginary part, putting it to zero.'
+ pp(ii) = cmplx( ap(ii) ,kind=kindc2 )
+ endif
+ ap(ii) = abs(ap(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,3
+ am(ii) = real(mm(ii))
+ hh = aimag(mm(ii))
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
+ ,'mass-squared has positive imaginary part, switching its sign.'
+ mm(ii) = cmplx( am(ii) ,-hh ,kind=kindc2 )
+ endif
+ am(ii) = abs(am(ii)) + abs(hh)
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_c0_b.h90'
+!
+ end subroutine
+!
+ subroutine c0ccr( rslt ,p1,p2,p3 ,m1,m2,m3 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_tri
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3 ,m1,m2,m3
+ real(kindr2) ,intent(in) :: rmu
+ complex(kindc2) :: pp(3),mm(3)
+ real(kindr2) :: hh
+!
+ include 'avh_olo_c0_a.h90'
+!
+ mulocal = rmu
+!
+ do ii=1,3
+ ap(ii) = real(pp(ii))
+ if (aimag(pp(ii)).ne.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
+ ,'momentum with non-zero imaginary part, putting it to zero.'
+ pp(ii) = cmplx( ap(ii) ,kind=kindc2 )
+ endif
+ ap(ii) = abs(ap(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,3
+ am(ii) = real(mm(ii))
+ hh = aimag(mm(ii))
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
+ ,'mass-squared has positive imaginary part, switching its sign.'
+ mm(ii) = cmplx( am(ii) ,-hh ,kind=kindc2 )
+ endif
+ am(ii) = abs(am(ii)) + abs(hh)
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_c0_b.h90'
+!
+ end subroutine
+
+
+!*******************************************************************
+! calculates
+!
+! C / d^(Dim)q
+! ------ | --------------------------------------------------------
+! i*pi^2 / [q^2-m1][(q+k1)^2-m2][(q+k1+k2)^2-m3][(q+k1+k2+k3)^2-m4]
+!
+! with Dim = 4-2*eps
+! C = pi^eps * mu^(2*eps)
+! * GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
+!
+! input: p1=k1^2, p2=k2^2, p3=k3^2, p4=(k1+k2+k3)^2,
+! p12=(k1+k2)^2, p23=(k2+k3)^2,
+! m1,m2,m3,m4=squared masses
+! output: rslt(0) = eps^0 -coefficient
+! rslt(1) = eps^(-1)-coefficient
+! rslt(2) = eps^(-2)-coefficient
+!
+! Check the comments in avh_olo_onshell to find out how this
+! routines decides when to return IR-divergent cases.
+!*******************************************************************
+!
+ subroutine d0rr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_box
+ use avh_olo_boxc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4
+ real(kindr2) :: pp(6),mm(4)
+!
+ include 'avh_olo_d0_a.h90'
+!
+ mulocal = muscale
+!
+ do ii=1,6
+ ap(ii) = abs(pp(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,4
+ am(ii) = abs(mm(ii))
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_d0_b.h90'
+!
+ end subroutine
+!
+ subroutine d0rrr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_box
+ use avh_olo_boxc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu
+ real(kindr2) :: pp(6),mm(4)
+!
+ include 'avh_olo_d0_a.h90'
+!
+ mulocal = rmu
+!
+ do ii=1,6
+ ap(ii) = abs(pp(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,4
+ am(ii) = abs(mm(ii))
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_d0_b.h90'
+!
+ end subroutine
+!
+ subroutine d0rc( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_box
+ use avh_olo_boxc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: p1,p2,p3,p4,p12,p23
+ complex(kindc2) ,intent(in) :: m1,m2,m3,m4
+ real(kindr2) :: pp(6)
+ complex(kindc2) :: mm(4)
+ real(kindr2) :: hh
+!
+ include 'avh_olo_d0_a.h90'
+!
+ mulocal = muscale
+!
+ do ii=1,6
+ ap(ii) = abs(pp(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,4
+ am(ii) = real(mm(ii))
+ hh = aimag(mm(ii))
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
+ ,'mass-squared has positive imaginary part, switching its sign.'
+ mm(ii) = cmplx( am(ii) ,-hh ,kind=kindc2 )
+ endif
+ am(ii) = abs(am(ii)) + abs(hh)
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_d0_b.h90'
+!
+ end subroutine
+!
+ subroutine d0rcr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_box
+ use avh_olo_boxc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ real(kindr2) ,intent(in) :: p1,p2,p3,p4,p12,p23 ,rmu
+ complex(kindc2) ,intent(in) :: m1,m2,m3,m4
+ real(kindr2) :: pp(6)
+ complex(kindc2) :: mm(4)
+ real(kindr2) :: hh
+!
+ include 'avh_olo_d0_a.h90'
+!
+ mulocal = rmu
+!
+ do ii=1,6
+ ap(ii) = abs(pp(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,4
+ am(ii) = real(mm(ii))
+ hh = aimag(mm(ii))
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
+ ,'mass-squared has positive imaginary part, switching its sign.'
+ mm(ii) = cmplx( am(ii) ,-hh ,kind=kindc2 )
+ endif
+ am(ii) = abs(am(ii)) + abs(hh)
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_d0_b.h90'
+!
+ end subroutine
+!
+ subroutine d0cc( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_box
+ use avh_olo_boxc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4
+ complex(kindc2) :: pp(6),mm(4)
+ real(kindr2) :: hh
+!
+ include 'avh_olo_d0_a.h90'
+!
+ mulocal = muscale
+!
+ do ii=1,6
+ ap(ii) = real(pp(ii))
+ if (aimag(pp(ii)).ne.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
+ ,'momentum with non-zero imaginary part, putting it to zero.'
+ pp(ii) = cmplx( ap(ii) ,R0P0 ,kind=kindc2 )
+ endif
+ ap(ii) = abs(ap(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,4
+ am(ii) = real(mm(ii))
+ hh = aimag(mm(ii))
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
+ ,'mass-squared has positive imaginary part, switching its sign.'
+ mm(ii) = cmplx( am(ii) ,-hh ,kind=kindc2 )
+ endif
+ am(ii) = abs(am(ii)) + abs(hh)
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_d0_b.h90'
+!
+ end subroutine
+!
+ subroutine d0ccr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
+!*******************************************************************
+!*******************************************************************
+ use avh_olo_box
+ use avh_olo_boxc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4
+ real(kindr2) ,intent(in) :: rmu
+ complex(kindc2) :: pp(6),mm(4)
+ real(kindr2) :: hh
+!
+ include 'avh_olo_d0_a.h90'
+!
+ mulocal = rmu
+!
+ do ii=1,6
+ ap(ii) = real(pp(ii))
+ if (aimag(pp(ii)).ne.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
+ ,'momentum with non-zero imaginary part, putting it to zero.'
+ pp(ii) = cmplx( ap(ii) ,R0P0 ,kind=kindc2 )
+ endif
+ ap(ii) = abs(ap(ii))
+ if (ap(ii).gt.smax) smax = ap(ii)
+ enddo
+!
+ do ii=1,4
+ am(ii) = real(mm(ii))
+ hh = aimag(mm(ii))
+ if (hh.gt.R0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
+ ,'mass-squared has positive imaginary part, switching its sign.'
+ mm(ii) = cmplx( am(ii) ,-hh ,kind=kindc2 )
+ endif
+ am(ii) = abs(am(ii)) + abs(hh)
+ if (am(ii).gt.smax) smax = am(ii)
+ enddo
+!
+ include 'avh_olo_d0_b.h90'
+!
+ end subroutine
+
+end module
diff --git a/avh_olo-2.2.1/avh_olo_print.f90 b/avh_olo-2.2.1/avh_olo_print.f90
new file mode 100644
index 0000000..dd2dab8
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_print.f90
@@ -0,0 +1,79 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+module avh_olo_print
+ use avh_olo_kinds
+ implicit none
+ private
+ public :: myprint,init_print
+!
+ integer ,parameter :: noverh=10 !maximally 6 decimals for exponent
+ integer :: ndigits=19
+ integer :: nefrmt=19+noverh
+!
+ interface myprint
+ module procedure printr,printc,printi
+ end interface
+!
+contains
+!
+ subroutine init_print( ndig )
+ integer ,intent(in) :: ndig
+ ndigits = ndig+ndig/4+1
+ nefrmt = ndigits+noverh
+ end subroutine
+!
+ function printc( zz ) result(rslt)
+ complex(kindc2) ,intent(in) :: zz
+ character(nefrmt*2+3) :: rslt
+ rslt = '('//trim(printr(real(zz))) &
+ //','//trim(printr(aimag(zz) )) &
+ //')'
+ rslt = adjustl(rslt)
+ end function
+!
+ function printr( xx ) result(rslt)
+ real(kindr2) ,intent(in) :: xx
+ character(nefrmt ) :: rslt
+ character(nefrmt+1) :: cc
+ character(10) :: aa,bb
+ write(aa,'(i10)') nefrmt+1 ;aa=adjustl(aa)
+ write(bb,'(i10)') ndigits ;bb=adjustl(bb)
+ aa = '(e'//trim(aa)//'.'//trim(bb)//')'
+ write(cc,aa) xx ;cc=adjustl(cc)
+ if (cc(1:2).eq.'-0') then ;rslt = '-'//cc(3:ndigits*2)
+ else ;rslt = ' '//cc(2:ndigits*2)
+ endif
+ end function
+!
+ function printi( ii ) result(rslt)
+ integer ,intent(in) :: ii
+ character(ndigits) :: rslt
+ character(ndigits) :: cc
+ character(10) :: aa
+ write(aa,'(i10)') ndigits ;aa=adjustl(aa)
+ aa = '(i'//trim(aa)//')'
+ write(cc,aa) ii ;cc=adjustl(cc)
+ if (cc(1:1).ne.'-') then ;rslt=' '//cc
+ else ;rslt=cc
+ endif
+ end function
+!
+end module
diff --git a/avh_olo-2.2.1/avh_olo_tri.f90 b/avh_olo-2.2.1/avh_olo_tri.f90
new file mode 100644
index 0000000..4e706bd
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_tri.f90
@@ -0,0 +1,796 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+module avh_olo_tri
+ use avh_olo_kinds
+ use avh_olo_units
+ use avh_olo_func
+ implicit none
+ private
+ public :: tria0,tria1,tria2,tria3,tria4,trif0,trif1,trif2,trif3 &
+ ,trif3HV &
+ ,permtable,casetable,base
+ complex(kindc2) ,parameter :: oieps=C1P0+CiP0*epsilon(R1P0)**2
+ integer ,parameter :: permtable(3,0:7)=reshape((/ &
+ 1,2,3 &! 0, 0 masses non-zero, no permutation
+ ,1,2,3 &! 1, 1 mass non-zero, no permutation
+ ,3,1,2 &! 2, 1 mass non-zero, 1 cyclic permutation
+ ,1,2,3 &! 3, 2 masses non-zero, no permutation
+ ,2,3,1 &! 4, 1 mass non-zero, 2 cyclic permutations
+ ,2,3,1 &! 5, 2 masses non-zero, 2 cyclic permutations
+ ,3,1,2 &! 6, 2 masses non-zero, 1 cyclic permutation
+ ,1,2,3 &! 7, 3 masses non-zero, no permutation
+ /) ,(/3,8/)) ! 0,1,2,3,4,5,6,7
+ integer ,parameter :: casetable(0:7)=(/0,1,1,2,1,2,2,3/)
+ integer ,parameter :: base(3)=(/4,2,1/)
+
+contains
+
+ subroutine tria4( rslt ,cpp,cm2,cm3 ,rmu2 )
+!*******************************************************************
+! calculates
+! C / d^(Dim)q
+! ------ | ----------------------------------
+! i*pi^2 / q^2 [(q+k1)^2-m2] [(q+k1+k2)^2-m3]
+!
+! with k1^2=m2, k2^2=pp, (k1+k2)^2=m3.
+! m2,m3 should NOT be identically 0d0.
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cm2,cm3,cpp
+ real(kindr2) ,intent(in) :: rmu2
+ type(qmplx_type) :: q23,qm3,q32
+ complex(kindc2) :: sm2,sm3,k23,r23,d23,cc
+!
+! write(*,*) 'MESSAGE from OneLOop tria4: you are calling me' !CALLINGME
+!
+ sm2 = mysqrt(cm2)
+ sm3 = mysqrt(cm3)
+ k23 = (cm2+cm3-cpp)/(sm2*sm3)
+ call rfun( r23,d23, k23 )
+ if (r23.eq.-C1P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop tria4: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+ q23 = qonv(r23,-1)
+ qm3 = qonv(cm3/rmu2,-1)
+ q32 = qonv(sm3)/qonv(sm2)
+!
+ rslt(2) = C0P0
+ cc = logc2(q23) * r23/(C1P0+r23)/(sm2*sm3)
+ rslt(1) = -cc
+ rslt(0) = cc*( logc(qm3) - logc(q23) ) &
+ - li2c2(q32*q23,q32/q23) / cm2 &
+ + li2c2(q23*q23,qonv(C1P0)) * r23/(sm2*sm3)
+ end subroutine
+
+
+ subroutine tria3( rslt ,cp2,cp3,cm3 ,rmu2 )
+!*******************************************************************
+! calculates
+! C / d^(Dim)q
+! ------ | -----------------------------
+! i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3]
+!
+! with p2=k2^2, p3=(k1+k2)^2.
+! mm should NOT be identically 0d0,
+! and p2 NOR p3 should be identical to mm.
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp2,cp3,cm3
+ real(kindr2) ,intent(in) :: rmu2
+ type(qmplx_type) :: q13,q23,qm3,x1,x2
+ complex(kindc2) :: r13,r23
+!
+! write(*,*) 'MESSAGE from OneLOop tria3: you are calling me' !CALLINGME
+!
+ r13 = cm3-cp3
+ r23 = cm3-cp2
+ q13 = qonv(r13,-1)
+ q23 = qonv(r23,-1)
+ qm3 = qonv(cm3,-1)
+ x1 = q23/qm3
+ x2 = q13/qm3
+ rslt(2) = C0P0
+ rslt(1) = -logc2( q23/q13 )/r13
+ rslt(0) = -li2c2( x1,x2 )/cm3 &
+ - rslt(1)*( logc(x1*x2)+logc(qm3/rmu2) )
+ end subroutine
+
+
+ subroutine tria2( rslt ,cp3,cm3 ,rmu2 )
+!*******************************************************************
+! calculates
+! C / d^(Dim)q
+! ------ | -----------------------------
+! i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3]
+!
+! with k1^2 = 0 , k2^2 = m3 and (k1+k2)^2 = p3.
+! mm should NOT be identically 0d0,
+! and pp should NOT be identical to mm.
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_li2c ,only: li2c
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp3,cm3
+ real(kindr2) ,intent(in) :: rmu2
+ complex(kindc2) ,parameter :: const=C1P0*TWOPI*TWOPI/96
+ complex(kindc2) ,parameter :: half=C1P0/2
+ type(qmplx_type) :: q13,qm3,qxx
+ complex(kindc2) :: r13,logm,z2,z1,z0,cc
+!
+! write(*,*) 'MESSAGE from OneLOop tria2: you are calling me' !CALLINGME
+!
+ r13 = cm3-cp3
+ q13 = qonv(r13,-1)
+ qm3 = qonv(cm3,-1)
+ logm = logc( qm3/rmu2 )
+ qxx = qm3/q13
+ z2 = half
+ z1 = logc(qxx)
+ z0 = const + z1*z1/2 - li2c(qxx)
+ cc = -C1P0/r13
+ rslt(2) = cc*z2
+ rslt(1) = cc*(z1 - z2*logm)
+ rslt(0) = cc*(z0 + (z2*logm/2-z1)*logm)
+ end subroutine
+
+
+ subroutine tria1( rslt ,cm3 ,rmu2 )
+!*******************************************************************
+! calculates
+! C / d^(Dim)q
+! ------ | -----------------------------
+! i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3]
+!
+! with k1^2 = (k1+k2)^2 = m3.
+! mm should NOT be identically 0d0.
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cm3
+ real(kindr2) ,intent(in) :: rmu2
+ complex(kindc2) :: zm
+!
+! write(*,*) 'MESSAGE from OneLOop tria1: you are calling me' !CALLINGME
+!
+ zm = C1P0/(2*cm3)
+ rslt(2) = C0P0
+ rslt(1) = -zm
+ rslt(0) = zm*( 2*C1P0 + logc(qonv(cm3/rmu2,-1)) )
+ end subroutine
+
+
+ subroutine tria0( rslt ,cp ,ap ,rmu2 )
+!*******************************************************************
+! calculates
+! C / d^(Dim)q
+! ------ | ------------------------
+! i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2
+!
+! with Dim = 4-2*eps
+! C = pi^eps * mu^(2*eps) * exp(gamma_Euler*eps)
+!
+! input: p1 = k1^2, p2 = k2^2, p3 = k3^2
+! output: rslt(0) = eps^0 -coefficient
+! rslt(1) = eps^(-1)-coefficient
+! rslt(2) = eps^(-2)-coefficient
+!
+! If any of these numbers is IDENTICALLY 0d0, the corresponding
+! IR-singular case is returned.
+!*******************************************************************
+ use avh_olo_loga ,only: loga
+ use avh_olo_loga2 ,only: loga2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: cp(3)
+ real(kindr2) ,intent(in) :: ap(3),rmu2
+ real(kindr2) :: pp(3),rp1,rp2,rp3
+ complex(kindc2) ,parameter :: const=C1P0*TWOPI*TWOPI/48
+ complex(kindc2) :: log2,log3
+ integer :: icase,i1,i2,i3
+!
+ pp(1)=real(cp(1))
+ pp(2)=real(cp(2))
+ pp(3)=real(cp(3))
+!
+ icase = 0
+ if (ap(1).gt.R0P0) icase = icase + base(1)
+ if (ap(2).gt.R0P0) icase = icase + base(2)
+ if (ap(3).gt.R0P0) icase = icase + base(3)
+ rp1 = pp(permtable(1,icase))
+ rp2 = pp(permtable(2,icase))
+ rp3 = pp(permtable(3,icase))
+ icase = casetable( icase)
+!
+ i1=0 ;if (-rp1.lt.R0P0) i1=-1
+ i2=0 ;if (-rp2.lt.R0P0) i2=-1
+ i3=0 ;if (-rp3.lt.R0P0) i3=-1
+!
+ if (icase.eq.0) then
+! 0 masses non-zero
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop tria0: ' &
+ ,'all external masses equal zero, returning 0'
+ rslt = C0P0
+ elseif (icase.eq.1) then
+! 1 mass non-zero
+! write(*,*) 'MESSAGE from OneLOop tria0 1: you are calling me' !CALLINGME
+ log3 = loga( -rp3/rmu2 , i3 )
+ rslt(2) = cmplx( R1P0/rp3 ,kind=kindc2 )
+ rslt(1) = -log3/rp3
+ rslt(0) = ( log3**2/2 - const )/rp3
+ elseif (icase.eq.2) then
+! 2 masses non-zero
+! write(*,*) 'MESSAGE from OneLOop tria0 2: you are calling me' !CALLINGME
+ log2 = loga( -rp2/rmu2 ,i2 )
+ log3 = loga( -rp3/rmu2 ,i3 )
+ rslt(2) = C0P0
+ rslt(1) = loga2( rp3/rp2 ,i3-i2 )/rp2
+ rslt(0) = -rslt(1)*(log3+log2)/2
+ elseif (icase.eq.3) then
+! 3 masses non-zero
+ call trif0( rslt ,cp(1),cp(2),cp(3) )
+ endif
+ end subroutine
+
+
+ subroutine trif0( rslt ,p1,p2,p3 )
+!*******************************************************************
+! Finite 1-loop scalar 3-point function with all internal masses
+! equal zero. Obtained from the formulas for 4-point functions in
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+! by sending one internal mass to infinity.
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1,p2,p3
+ type(qmplx_type) :: q23,q24,q34,qx1,qx2
+ complex(kindc2) :: r23,r24,r34,aa,bb,cc,dd,x1,x2
+ real(kindr2) :: hh
+!
+! write(*,*) 'MESSAGE from OneLOop trif0: you are calling me' !CALLINGME
+!
+ r23 = -p1
+ r24 = -p3
+ r34 = -p2
+!
+ aa = r34*r24
+ bb = r24 + r34 - r23
+ cc = C1P0
+ hh = real(r23)
+ dd = mysqrt( bb*bb - 4*aa*cc , -real(aa)*hh )
+ call solabc( x1,x2,dd ,aa,bb,cc ,1 )
+ x1 = -x1
+ x2 = -x2
+!
+ qx1 = qonv(x1, hh)
+ qx2 = qonv(x2,-hh)
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+!
+ rslt = C0P0
+!
+ rslt(0) = li2c2( qx1*q34 ,qx2*q34 )*r34 &
+ + li2c2( qx1*q24 ,qx2*q24 )*r24 &
+ - logc2( qx1/qx2 )*logc( qx1*qx2 )/(x2*2) &
+ - logc2( qx1/qx2 )*logc( q23 )/x2
+!
+ rslt(0) = rslt(0)/aa
+ end subroutine
+
+
+ subroutine trif1( rslt ,p1i,p2i,p3i ,m3i )
+!*******************************************************************
+! Finite 1-loop scalar 3-point function with one internal masses
+! non-zero. Obtained from the formulas for 4-point functions in
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+! by sending one internal mass to infinity.
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1i,p2i,p3i ,m3i
+ type(qmplx_type) :: q23,q24,q34,qm4,qx1,qx2,qss
+ complex(kindc2) :: p2,p3,p4,p12,p23,m4,sm2,sm3,sm4 &
+ ,aa,bb,cc,dd,x1,x2,r23,r24,r34
+ real(kindr2) :: mhh
+ complex(kindc2) ,parameter :: oieps=C1P0+CiP0*epsilon(R1P0)**2
+!
+! write(*,*) 'MESSAGE from OneLOop trif1: you are calling me' !CALLINGME
+!
+! p1 = nul
+ p2 = p1i
+ p3 = p2i
+ p4 = p3i
+ p12 = p1i
+ p23 = p3i
+! m1 = infinite
+! m2 = m1i = C0P0
+! m3 = m2i = C0P0
+ m4 = m3i
+!
+ sm4 = mysqrt(m4)
+ mhh = abs(sm4)
+ sm3 = cmplx(mhh,kind=kindc2)
+ sm2 = sm3
+!
+ r24 = C0P0
+ r34 = C0P0
+ r23 = ( -p2 *oieps )/(sm2*sm3)
+ if (m4.ne.p23) r24 = ( m4-p23*oieps )/(sm2*sm4)
+ if (m4.ne.p3 ) r34 = ( m4-p3 *oieps )/(sm3*sm4)
+!
+ aa = r34*r24 - r23
+!
+ if (aa.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif1: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ bb = r24/sm3 + r34/sm2 - r23/sm4
+ cc = C1P0/(sm2*sm3)
+! hh = real(r23)
+! dd = mysqrt( bb*bb - 4*aa*cc , -real(aa)*hh )
+ call solabc( x1,x2,dd ,aa,bb,cc ,0 )
+ x1 = -x1
+ x2 = -x2
+!
+ qx1 = qonv(x1 ,1) ! x1 SHOULD HAVE im. part
+ qx2 = qonv(x2 ,1) ! x2 SHOULD HAVE im. part
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+ qm4 = qonv(sm4,-1)
+!
+ rslt = C0P0
+!
+ rslt(0) = -logc2( qx1/qx2 )*logc( qx1*qx2/(qm4*qm4) )/(x2*2) &
+ -li2c2( qx1*qm4 ,qx2*qm4 )*sm4
+!
+ if (r34.ne.C0P0) then
+ qss = q34*mhh
+ rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34*sm3
+ endif
+!
+ if (r24.ne.C0P0) then
+ qss = q24*mhh
+ rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r24*sm2
+ endif
+!
+ rslt(0) = rslt(0) - logc2( qx1/qx2 )*logc( q23*(mhh*mhh) )/x2
+!
+ rslt(0) = rslt(0)/(aa*sm2*sm3*sm4)
+ end subroutine
+
+
+ subroutine trif2( rslt ,p1i,p2i,p3i ,m2i,m3i )
+!*******************************************************************
+! Finite 1-loop scalar 3-point function with two internal masses
+! non-zero. Obtained from the formulas for 4-point functions in
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+! by sending one internal mass to infinity.
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1i,p2i,p3i ,m2i,m3i
+ type(qmplx_type) :: q23,q34,q24,qm2,qm3,qm4,qx1,qx2,qss,qy1,qy2
+ complex(kindc2) :: p2,p3,p23,m2,m4,sm2,sm3,sm4,aa,bb,cc,dd,x1,x2 &
+ ,r23,k24,r34,r24,d24
+ complex(kindc2) ,parameter :: oieps=C1P0+CiP0*epsilon(R1P0)**2
+!
+! write(*,*) 'MESSAGE from OneLOop trif2: you are calling me' !CALLINGME
+!
+! p1 = nul
+ p2 = p3i
+ p3 = p1i
+! p4 = p2i
+! p12 = p3i
+ p23 = p2i
+! m1 = infinite
+ m2 = m3i
+! m3 = m1i = C0P0
+ m4 = m2i
+!
+! sm1 = infinite
+ sm2 = mysqrt(m2)
+ sm3 = cmplx(abs(sm2),kind=kindc2) !mysqrt(m3)
+ sm4 = mysqrt(m4)
+!
+ r23 = C0P0
+ k24 = C0P0
+ r34 = C0P0
+ if (m2 .ne.p2 ) r23 = ( m2-p2 *oieps )/(sm2*sm3) ! p2
+ if (m2+m4.ne.p23) k24 = ( m2+m4-p23*oieps )/(sm2*sm4) ! p2+p3
+ if (m4 .ne.p3 ) r34 = ( m4-p3 *oieps )/(sm3*sm4) ! p3
+!
+ call rfun( r24,d24 ,k24 )
+!
+ aa = r34/r24 - r23
+!
+ if (aa.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif2: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ bb = -d24/sm3 + r34/sm2 - r23/sm4
+ cc = (sm4/sm2 - r24)/(sm3*sm4)
+! hh = dreal(r23 - r24*r34)
+! dd = mysqrt( bb*bb - 4*aa*cc , -dreal(aa)*hh )
+ call solabc(x1,x2,dd ,aa,bb,cc ,0)
+ x1 = -x1
+ x2 = -x2
+!
+ qx1 = qonv(x1 ,1 ) ! x1 SHOULD HAVE im. part
+ qx2 = qonv(x2 ,1 ) ! x2 SHOULD HAVE im. part
+ q23 = qonv(r23,-1)
+ q24 = qonv(r24,-1)
+ q34 = qonv(r34,-1)
+ qm2 = qonv(sm2,-1)
+ qm3 = qonv(sm3,-1)
+ qm4 = qonv(sm4,-1)
+!
+ rslt = C0P0
+!
+ qy1 = qx1/q24
+ qy2 = qx2/q24
+!
+ rslt(0) = li2c2( qy1*qm2 ,qy2*qm2 )/r24*sm2
+!
+ if (x2.ne.C0P0) then ! better to put a threshold on cc
+ rslt(0) = rslt(0) + ( logc2( qy1/qy2 )*logc( qy1*qy2/(qm2*qm2) ) &
+ -logc2( qx1/qx2 )*logc( qx1*qx2/(qm4*qm4) ) )/(x2*2)
+ endif
+!
+ rslt(0) = rslt(0) - li2c2( qx1*qm4 ,qx2*qm4 )*sm4
+!
+ if (r23.ne.C0P0) then
+ qss = q23*qm3/q24
+ rslt(0) = rslt(0) - li2c2( qx1*qss ,qx2*qss )*r23*sm3/r24
+ endif
+!
+ if (r34.ne.C0P0) then
+ qss = q34*qm3
+ rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34*sm3
+ endif
+!
+ rslt(0) = rslt(0)/(aa*sm2*sm3*sm4)
+ end subroutine
+
+
+ subroutine trif3( rslt ,p1i,p2i,p3i ,m1i,m2i,m3i )
+!*******************************************************************
+! Finite 1-loop scalar 3-point function with all internal masses
+! non-zero. Obtained from the formulas for 4-point functions in
+! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
+! by sending one internal mass to infinity.
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_logc2 ,only: logc2
+ use avh_olo_li2c2 ,only: li2c2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: p1i,p2i,p3i,m1i,m2i,m3i
+ type(qmplx_type) :: q12,q13,q23,qm1,qm2,qm3,qx1,qx2,qz1,qz2,qtt
+ complex(kindc2) :: p1,p2,p3,m1,m2,m3,sm1,sm2,sm3,aa,bb,cc,dd,x1,x2 &
+ ,k12,k13,k23,r12,r13,r23,d12,d13,d23
+ real(kindr2) :: h1,h2,h3
+ complex(kindc2) ,parameter :: oieps=C1P0+CiP0*epsilon(R1P0)**2
+!
+! write(*,*) 'MESSAGE from OneLOop trif3: you are calling me' !CALLINGME
+!
+ h1 = -aimag(m1i)
+ h2 = -aimag(m2i)
+ h3 = -aimag(m3i)
+ if (h2.ge.h1.and.h2.ge.h3) then
+ p1=p3i ;p2=p1i ;p3=p2i ;m1=m3i ;m2=m1i ;m3=m2i
+ else
+ p1=p1i ;p2=p2i ;p3=p3i ;m1=m1i ;m2=m2i ;m3=m3i
+ endif
+!
+ sm1 = mysqrt(m1)
+ sm2 = mysqrt(m2)
+ sm3 = mysqrt(m3)
+!
+ k12 = C0P0
+ k13 = C0P0
+ k23 = C0P0
+ if (m1+m2.ne.p1) k12 = ( m1+m2-p1*oieps )/(sm1*sm2) ! p1
+ if (m1+m3.ne.p3) k13 = ( m1+m3-p3*oieps )/(sm1*sm3) ! p1+p2 => p12
+ if (m2+m3.ne.p2) k23 = ( m2+m3-p2*oieps )/(sm2*sm3) ! p2
+!
+ call rfun( r12,d12 ,k12 )
+ call rfun( r13,d13 ,k13 )
+ call rfun( r23,d23 ,k23 )
+!
+ aa = sm2/sm3 - k23 + r13*(k12 - sm2/sm1)
+!
+ if (aa.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif3: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+!
+ bb = d13/sm2 + k12/sm3 - k23/sm1
+ cc = ( sm1/sm3 - C1P0/r13 )/(sm1*sm2)
+! hh = dreal( (r13-sm1/sm3)/(sm1*sm2) )
+! dd = mysqrt( bb*bb - 4*aa*cc , -dreal(aa)*hh )
+ call solabc( x1,x2,dd ,aa,bb,cc ,0 )
+ x1 = -x1
+ x2 = -x2
+!
+ qx1 = qonv(x1 ,1) ! x1 SHOULD HAVE im. part
+ qx2 = qonv(x2 ,1) ! x2 SHOULD HAVE im. part
+ q12 = qonv(r12,-1)
+ q13 = qonv(r13,-1)
+ q23 = qonv(r23,-1)
+ qm1 = qonv(sm1,-1)
+ qm2 = qonv(sm2,-1)
+ qm3 = qonv(sm3,-1)
+!
+ rslt = C0P0
+!
+ qz1 = qx1*qm2
+ qz2 = qx2*qm2
+ rslt(0) = rslt(0) + ( li2c2( qz1*q12 ,qz2*q12 )*r12 &
+ +li2c2( qz1/q12 ,qz2/q12 )/r12 )*sm2
+ qtt = q13*qm2
+ qz1 = qx1*qtt
+ qz2 = qx2*qtt
+ rslt(0) = rslt(0) - ( li2c2( qz1*q23 ,qz2*q23 )*r23 &
+ +li2c2( qz1/q23 ,qz2/q23 )/r23 )*r13*sm2
+ qz1 = qx1*q13
+ qz2 = qx2*q13
+ rslt(0) = rslt(0) + li2c2( qz1*qm3 ,qz2*qm3 )*r13*sm3 &
+ - li2c2( qx1*qm1 ,qx2*qm1 )*sm1
+ if (x2.ne.C0P0) then
+ rslt(0) = rslt(0) + ( logc2( qz1/qz2 )*logc( qz1*qz2/(qm3*qm3) ) &
+ -logc2( qx1/qx2 )*logc( qx1*qx2/(qm1*qm1) ) )/(x2*2)
+ endif
+!
+ rslt(0) = rslt(0)/(aa*sm1*sm2*sm3)
+ end subroutine
+
+
+ subroutine trif3HV( rslt ,pp,mm ,ap ,smax )
+!*******************************************************************
+! Finite 1-loop scalar 3-point function with all internal masses
+! non-zero. Based on the fomula of 't Hooft & Veltman
+!*******************************************************************
+ use avh_olo_logc ,only: logc
+ use avh_olo_li2c ,only: li2c
+ use avh_olo_logc2 ,only: logc2
+ complex(kindc2) ,intent(out) :: rslt(0:2)
+ complex(kindc2) ,intent(in) :: pp(3),mm(3)
+ real(kindr2) ,intent(in) :: ap(3),smax
+ complex(kindc2) :: p1,p2,p3,m1,m2,m3,slam,yy
+ complex(kindc2) :: sm1,sm2,sm3,sp1,sp2
+ type(qmplx_type) :: qm1,qm2,qm3
+ real(kindr2) :: a12,a23,a31,thrs,a1,a2,a3
+ real(kindc2) ,parameter :: eps1=epsilon(R1P0),eps2=eps1*eps1
+ real(kindc2) ,parameter :: small=eps1*100
+ complex(kindc2) ,parameter :: ieps2=CiP0*eps2
+!
+! write(*,*) 'MESSAGE from OneLOop trif3HV: you are calling me' !CALLINGME
+!
+! Order squared momenta, first one smallest
+ if (ap(1).le.ap(2).and.ap(1).le.ap(3)) then
+ if (ap(2).le.ap(3)) then
+ a1=ap(1) ;a2=ap(2) ;a3=ap(3)
+ p1=pp(1) ;p2=pp(2) ;p3=pp(3)
+ m1=mm(1) ;m2=mm(2) ;m3=mm(3)
+ else
+ a1=ap(1) ;a2=ap(3) ;a3=ap(2)
+ p1=pp(1) ;p2=pp(3) ;p3=pp(2)
+ m1=mm(2) ;m2=mm(1) ;m3=mm(3)
+ endif
+ elseif (ap(2).le.ap(3).and.ap(2).le.ap(1)) then
+ if (ap(3).le.ap(1)) then
+ a1=ap(2) ;a2=ap(3) ;a3=ap(1)
+ p1=pp(2) ;p2=pp(3) ;p3=pp(1)
+ m1=mm(2) ;m2=mm(3) ;m3=mm(1)
+ else
+ a1=ap(2) ;a2=ap(1) ;a3=ap(3)
+ p1=pp(2) ;p2=pp(1) ;p3=pp(3)
+ m1=mm(3) ;m2=mm(2) ;m3=mm(1)
+ endif
+ else
+ if (ap(1).le.ap(2)) then
+ a1=ap(3) ;a2=ap(1) ;a3=ap(2)
+ p1=pp(3) ;p2=pp(1) ;p3=pp(2)
+ m1=mm(3) ;m2=mm(1) ;m3=mm(2)
+ else
+ a1=ap(3) ;a2=ap(2) ;a3=ap(1)
+ p1=pp(3) ;p2=pp(2) ;p3=pp(1)
+ m1=mm(1) ;m2=mm(3) ;m3=mm(2)
+ endif
+ endif
+!
+! Need to cut out negligible squared momenta
+ thrs = smax*small
+!
+! Add infinitesimal imaginary parts to masses
+ m1=m1-abs(real(m1))*ieps2 ;m2=m2-abs(real(m2))*ieps2 ;m3=m3-abs(real(m3))*ieps2
+!
+ if (a1.gt.thrs) then ! 3 non-zero squared momenta
+ a1=sign(R1P0,real(p1)) ;a2=sign(R1P0,real(p2)) ;a3=sign(R1P0,real(p3))
+ if (a1.ne.a2) then ;slam=(p3-p1-p2)**2-4*p1*p2
+ elseif (a2.ne.a3) then ;slam=(p1-p2-p3)**2-4*p2*p3
+ elseif (a3.ne.a1) then ;slam=(p2-p3-p1)**2-4*p3*p1
+ else
+ sp1=mysqrt(p1,1) ;sp2=mysqrt(p2,1)
+ slam=(p3-(sp1+sp2)**2)*(p3-(sp1-sp2)**2)
+ endif
+ if (slam.eq.C0P0) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif3HV: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+ slam = mysqrt( slam ,1 )
+ sm1=mysqrt(m1,-1) ;sm2=mysqrt(m2,-1) ;sm3=mysqrt(m3,-1)
+ rslt = C0P0
+ rslt(0) = s3fun( p1,sm1,sm2 , (m2-m3)+p2 ,p3-p1-p2 ,p2 ,slam ) &
+ - s3fun( p3,sm1,sm3 ,-(m1-m2)+p3-p2 ,p2-p1-p3 ,p1 ,slam ) &
+ + s3fun( p2,sm2,sm3 ,-(m1-m2)+p3-p2 ,p1+p2-p3 ,p1 ,slam )
+ rslt(0) = -rslt(0)/slam
+!
+ elseif (a2.gt.thrs) then ! 2 non-zero squared momenta
+ if (p2.eq.p3) then
+ if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif3HV: ' &
+ ,'threshold singularity, returning 0'
+ rslt = C0P0
+ return
+ endif
+ sm1=mysqrt(m1,-1) ;sm2=mysqrt(m2,-1) ;sm3=mysqrt(m3,-1)
+ yy = ( (m1-m2)-p3+p2 )/( p2-p3 )
+ rslt = C0P0
+ rslt(0) = s3fun( p3,sm1,sm3 ,yy ) &
+ - s3fun( p2,sm2,sm3 ,yy )
+ rslt(0) = rslt(0)/(p2-p3)
+!
+ elseif (a3.gt.thrs) then ! 1 non-zero squared momentum
+ sm1=mysqrt(m1,-1) ;sm3=mysqrt(m3,-1)
+ rslt = C0P0
+ yy = -( (m1-m2)-p3 )/p3
+ rslt(0) = s3fun( p3,sm1,sm3 ,yy ) &
+ - s2fun( m2-m3 ,m3 ,yy )
+ rslt(0) = -rslt(0)/p3
+!
+ else ! all squared momenta zero
+ rslt = C0P0
+ a12=abs(m1-m2) ;a23=abs(m2-m3) ;a31=abs(m3-m1)
+ if (a12.ge.a23.and.a12.ge.a31) then
+ if (a12.eq.R0P0) then ;rslt(0)=-C1P0/(2*m3) ;else
+ qm1=qonv(m1) ;qm2=qonv(m2) ;qm3=qonv(m3)
+ rslt(0) = ( logc2(qm3/qm1) - logc2(qm3/qm2) )/(m1-m2)
+ endif
+ elseif (a23.ge.a12.and.a23.ge.a31) then
+ if (a23.eq.R0P0) then ;rslt(0)=-C1P0/(2*m1) ;else
+ qm1=qonv(m1) ;qm2=qonv(m2) ;qm3=qonv(m3)
+ rslt(0) = ( logc2(qm1/qm2) - logc2(qm1/qm3) )/(m2-m3)
+ endif
+ else
+ if (a31.eq.R0P0) then ;rslt(0)=-C1P0/(2*m2) ;else
+ qm1=qonv(m1) ;qm2=qonv(m2) ;qm3=qonv(m3)
+ rslt(0) = ( logc2(qm2/qm3) - logc2(qm2/qm1) )/(m3-m1)
+ endif
+ endif
+ endif
+!
+ contains
+!
+ function s3fun( aa,s1,s2 ,t1,t2,t3,t4 ) result(rslt)
+!***************************************************************
+! int( ( ln(a*y^2+b*y+c) - ln(a*y0^2+b*y0+c) )/(y-y0) ,y=0..1 )
+! with b=s1^2-s2^2-aa and c=s2^2
+! and with y0 in terms of t1,t2,t3,t4 defined at the "present"
+! function below.
+! t4 should be sqrt(lambda(aa,t2,t3))
+!***************************************************************
+ complex(kindc2) ,intent(in) :: aa,s1,s2,t1
+ complex(kindc2),optional,intent(in) :: t2,t3
+ complex(kindc2),optional,intent(inout) :: t4
+ complex(kindc2) :: rslt ,cc,bb,dd,y0,y1,y2,zz,hh,alpha
+ real(kindr2) :: rez,arez,aimz
+ type(qmplx_type) :: q1,q2
+ real(kindr2) ,parameter :: lower=eps1/100,upper=eps1*100
+!
+ bb = (s1+s2)*(s1-s2)-aa
+ cc = s2*s2
+ dd = (aa-(s1+s2)**2)*(aa-(s1-s2)**2)
+ dd = sqrt( dd )!+ sign(abs(dd),real(aa))*ieps2 )
+ call solabc( y1,y2 ,dd ,aa,bb,cc ,1 )
+!
+ if (present(t4)) then
+ call solabc( alpha,hh ,t4 ,aa,t2,t3 ,1 )
+ y0 = -(t1+bb*alpha)/t4
+ else
+ y0 = t1
+ endif
+!
+ q1 = qonv(y0-y1)
+ q2 = qonv(y0-y2)
+ rslt = li2c(qonv(-y1)/q1) - li2c(qonv(C1P0-y1)/q1) &
+ + li2c(qonv(-y2)/q2) - li2c(qonv(C1P0-y2)/q2)
+! Take some care about the imaginary part of a*y0^2+b*y0+c=a*(y0-y1)*(y0-y2)
+ zz = y0*(aa*y0+bb)
+ rez=real(zz) ;arez=abs(rez) ;aimz=abs(aimag(zz))
+ if (arez*lower.le.aimz.and.aimz.le.arez*upper) then
+! Here, the value of Imz is just numerical noise due to cancellations.
+! Realize that |Imz|~eps2 indicates there were no such cancellations,
+! so the lower limit is needed in in the if-statement!
+ zz = (rez + cc)/aa
+ else
+ zz = (zz + cc)/aa
+ endif
+ hh = eta3(-y1,-y2,cc/aa) - eta3(y0-y1,y0-y2,zz)
+ if (real(aa).lt.R0P0.and.aimag(zz).lt.R0P0) hh = hh - TWOPI*CiP0
+ if (hh.ne.C0P0) rslt = rslt + hh*logc(qonv((y0-C1P0)/y0,1))
+! write(*,*) 'y0',y0 !DEBUG
+! write(*,*) 'y1',y1 !DEBUG
+! write(*,*) 'y2',y2 !DEBUG
+! write(*,*) 'zz',(y0-y1)*(y0-y2),aimag(cc/aa) !DEBUG
+! write(*,*) 'OLO E',aimag(-y1),aimag(-y1),aimag(cc/aa),(eta3(-y1,-y2,cc/aa).ne.C0P0) !DEBUG
+! write(*,*) 'OLO F',aimag(y0-y1),aimag(y0-y1),aimag(zz),(eta3(y0-y1,y0-y2,zz).ne.C0P0) !DEBUG
+! write(*,*) 'OLO G',real(aa),aimag(zz),(real(aa).lt.R0P0.and.aimag(zz).lt.R0P0) !DEBUG
+!
+ end function
+!
+ function s2fun( aa,bb ,y0 ) result(rslt)
+!**************************************************
+! int( ( ln(a*y+b) - ln(a*y0+b) )/(y-y0) ,y=0..1 )
+!**************************************************
+ complex(kindc2) ,intent(in) :: aa,bb,y0
+ complex(kindc2) :: rslt ,y1,hh
+ type(qmplx_type) :: q1
+ y1 = -bb/aa
+ q1 = qonv(y0-y1)
+ rslt = li2c(qonv(-y1,-1)/q1) - li2c(qonv(C1P0-y1,-1)/q1)
+! aa may have imaginary part, so theta(-aa)*theta(-Im(y0-y1)) is not
+! sufficient and need the following:
+ hh = eta5( aa ,-y1,bb ,y0-y1,aa*(y0-y1) )
+ if (hh.ne.C0P0) rslt = rslt + hh*logc(qonv((y0-C1P0)/y0,1))
+! write(*,*) 'OLO s2fun aa',aa !DEBUG
+! write(*,*) 'OLO s2fun bb',bb !DEBUG
+! write(*,*) 'OLO s2fun y0',y0 !DEBUG
+! write(*,*) 'OLO s2fun y1',y1 !DEBUG
+ end function
+!
+ end subroutine
+
+
+end module
diff --git a/avh_olo-2.2.1/avh_olo_units.f90 b/avh_olo-2.2.1/avh_olo_units.f90
new file mode 100644
index 0000000..0e7b61b
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_units.f90
@@ -0,0 +1,49 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+module avh_olo_units
+ implicit none
+ integer :: eunit=6 !PROTECTED
+ integer :: wunit=6 !PROTECTED
+ integer :: munit=6 !PROTECTED
+ integer :: punit=0 !PROTECTED ! print all
+
+ ! protected :: eunit, wunit, munit, punit
+contains
+ subroutine set_unit( message ,val )
+!***********************************************************************
+! message is intended to be one of the following:
+! 'printall', 'message' ,'warning' ,'error'
+!***********************************************************************
+ character(*) ,intent(in) :: message
+ integer ,intent(in) :: val
+ if (.false.) then
+ elseif (message(1:8).eq.'printall') then ;punit=val
+ elseif (message(1:7).eq.'message' ) then ;munit=val
+ elseif (message(1:7).eq.'warning' ) then ;wunit=val
+ elseif (message(1:5).eq.'error' ) then ;eunit=val
+ else
+ eunit=val
+ wunit=val
+ munit=val
+ punit=0
+ endif
+ end subroutine
+end module
diff --git a/avh_olo-2.2.1/avh_olo_wrp01.f90 b/avh_olo-2.2.1/avh_olo_wrp01.f90
new file mode 100644
index 0000000..8afddec
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_wrp01.f90
@@ -0,0 +1,127 @@
+!!
+!! Copyright (C) 2011 Andreas van Hameren.
+!!
+!! This file is part of OneLOop-2.2.1.
+!!
+!! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+!! it under the terms of the GNU General Public License as published by
+!! the Free Software Foundation, either version 3 of the License, or
+!! (at your option) any later version.
+!!
+!! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+!! but WITHOUT ANY WARRANTY; without even the implied warranty of
+!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+!! GNU General Public License for more details.
+!!
+!! You should have received a copy of the GNU General Public License
+!! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!!
+
+
+ subroutine avh_olo_mu_set(mu)
+ use avh_olo
+ implicit none
+ real(olo_kind) ,intent(in) :: mu
+ call olo_scale( mu )
+ end subroutine
+
+ subroutine avh_olo_onshell(thrs)
+ use avh_olo
+ implicit none
+ real(olo_kind) ,intent(in) :: thrs
+ call olo_onshell( thrs )
+ end subroutine
+
+ subroutine avh_olo_unit( unit_in )
+ use avh_olo
+ implicit none
+ integer ,intent(in) :: unit_in
+ call olo_unit( unit_in ,'all' )
+ end subroutine
+
+ subroutine avh_olo_printall( unit_in )
+ use avh_olo
+ implicit none
+ integer ,intent(in) :: unit_in
+ call olo_unit( unit_in ,'printall' )
+ end subroutine
+
+ subroutine avh_olo_a0c( rslt ,mm )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: rslt(0:2)
+ complex(olo_kind) ,intent(in) :: mm
+ call olo_a0( rslt ,mm )
+ end subroutine
+
+ subroutine avh_olo_b0c( rslt ,pp,m1,m2 )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: rslt(0:2)
+ complex(olo_kind) ,intent(in) :: pp,m1,m2
+ call olo_b0( rslt ,pp,m1,m2 )
+ end subroutine
+
+ subroutine avh_olo_b11c( b11,b00,b1,b0 ,pp,m1,m2 )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
+ complex(olo_kind) ,intent(in) :: pp,m1,m2
+ call olo_b11( b11,b00,b1,b0 ,pp,m1,m2 )
+ end subroutine
+
+ subroutine avh_olo_c0c( rslt ,p1,p2,p3 ,m1,m2,m3 )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: rslt(0:2)
+ complex(olo_kind) ,intent(in) :: p1,p2,p3 ,m1,m2,m3
+ call olo_c0( rslt ,p1,p2,p3 ,m1,m2,m3 )
+ end subroutine
+
+ subroutine avh_olo_d0c( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: rslt(0:2)
+ complex(olo_kind) ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4
+ call olo_d0( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
+ end subroutine
+
+ subroutine avh_olo_a0m( rslt ,mm )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: rslt(0:2)
+ real(olo_kind) ,intent(in) :: mm
+ call olo_a0( rslt ,mm )
+ end subroutine
+
+ subroutine avh_olo_b0m( rslt ,pp,m1,m2 )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: rslt(0:2)
+ real(olo_kind) ,intent(in) :: pp,m1,m2
+ call olo_b0( rslt ,pp,m1,m2 )
+ end subroutine
+
+ subroutine avh_olo_b11m( b11,b00,b1,b0 ,pp,m1,m2 )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
+ real(olo_kind) ,intent(in) :: pp,m1,m2
+ call olo_b11( b11,b00,b1,b0 ,pp,m1,m2 )
+ end subroutine
+
+ subroutine avh_olo_c0m( rslt ,p1,p2,p3 ,m1,m2,m3 )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: rslt(0:2)
+ real(olo_kind) ,intent(in) :: p1,p2,p3 ,m1,m2,m3
+ call olo_c0( rslt ,p1,p2,p3 ,m1,m2,m3 )
+ end subroutine
+
+ subroutine avh_olo_d0m( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
+ use avh_olo
+ implicit none
+ complex(olo_kind) ,intent(out) :: rslt(0:2)
+ real(olo_kind) ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4
+ call olo_d0( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
+ end subroutine
diff --git a/avh_olo-2.2.1/avh_olo_xkind.f90 b/avh_olo-2.2.1/avh_olo_xkind.f90
new file mode 100644
index 0000000..9f3a111
--- /dev/null
+++ b/avh_olo-2.2.1/avh_olo_xkind.f90
@@ -0,0 +1,30 @@
+!
+! Copyright (C) 2011 Andreas van Hameren.
+!
+! This file is part of OneLOop-2.2.1.
+!
+! OneLOop-2.2.1 is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! OneLOop-2.2.1 is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with OneLOop-2.2.1. If not, see <http://www.gnu.org/licenses/>.
+!
+
+
+module avh_olo_xkind
+! use !XKIND_MODULE
+!
+ implicit none
+ private
+ public :: olo_xkind
+!
+ integer ,parameter :: olo_xkind=kind(1.0d0)
+!
+end module
diff --git a/config.aux/config.guess b/config.aux/config.guess
new file mode 100755
index 0000000..666c5ad
--- /dev/null
+++ b/config.aux/config.guess
@@ -0,0 +1,1511 @@
+#! /bin/sh
+# Attempt to guess a canonical system name.
+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+# Free Software Foundation, Inc.
+
+timestamp='2009-11-20'
+
+# This file is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
+# 02110-1301, USA.
+#
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+
+# Originally written by Per Bothner. Please send patches (context
+# diff format) to <config-patches@gnu.org> and include a ChangeLog
+# entry.
+#
+# This script attempts to guess a canonical system name similar to
+# config.sub. If it succeeds, it prints the system name on stdout, and
+# exits with 0. Otherwise, it exits with 1.
+#
+# You can get the latest version of this script from:
+# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD
+
+me=`echo "$0" | sed -e 's,.*/,,'`
+
+usage="\
+Usage: $0 [OPTION]
+
+Output the configuration name of the system \`$me' is run on.
+
+Operation modes:
+ -h, --help print this help, then exit
+ -t, --time-stamp print date of last modification, then exit
+ -v, --version print version number, then exit
+
+Report bugs and patches to <config-patches@gnu.org>."
+
+version="\
+GNU config.guess ($timestamp)
+
+Originally written by Per Bothner.
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+
+This is free software; see the source for copying conditions. There is NO
+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
+
+help="
+Try \`$me --help' for more information."
+
+# Parse command line
+while test $# -gt 0 ; do
+ case $1 in
+ --time-stamp | --time* | -t )
+ echo "$timestamp" ; exit ;;
+ --version | -v )
+ echo "$version" ; exit ;;
+ --help | --h* | -h )
+ echo "$usage"; exit ;;
+ -- ) # Stop option processing
+ shift; break ;;
+ - ) # Use stdin as input.
+ break ;;
+ -* )
+ echo "$me: invalid option $1$help" >&2
+ exit 1 ;;
+ * )
+ break ;;
+ esac
+done
+
+if test $# != 0; then
+ echo "$me: too many arguments$help" >&2
+ exit 1
+fi
+
+trap 'exit 1' 1 2 15
+
+# CC_FOR_BUILD -- compiler used by this script. Note that the use of a
+# compiler to aid in system detection is discouraged as it requires
+# temporary files to be created and, as you can see below, it is a
+# headache to deal with in a portable fashion.
+
+# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still
+# use `HOST_CC' if defined, but it is deprecated.
+
+# Portable tmp directory creation inspired by the Autoconf team.
+
+set_cc_for_build='
+trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ;
+trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ;
+: ${TMPDIR=/tmp} ;
+ { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
+ { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } ||
+ { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } ||
+ { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ;
+dummy=$tmp/dummy ;
+tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ;
+case $CC_FOR_BUILD,$HOST_CC,$CC in
+ ,,) echo "int x;" > $dummy.c ;
+ for c in cc gcc c89 c99 ; do
+ if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then
+ CC_FOR_BUILD="$c"; break ;
+ fi ;
+ done ;
+ if test x"$CC_FOR_BUILD" = x ; then
+ CC_FOR_BUILD=no_compiler_found ;
+ fi
+ ;;
+ ,,*) CC_FOR_BUILD=$CC ;;
+ ,*,*) CC_FOR_BUILD=$HOST_CC ;;
+esac ; set_cc_for_build= ;'
+
+# This is needed to find uname on a Pyramid OSx when run in the BSD universe.
+# (ghazi@noc.rutgers.edu 1994-08-24)
+if (test -f /.attbin/uname) >/dev/null 2>&1 ; then
+ PATH=$PATH:/.attbin ; export PATH
+fi
+
+UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
+UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown
+UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
+UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown
+
+case "${UNAME_MACHINE}" in
+ i?86)
+ test -z "$VENDOR" && VENDOR=pc
+ ;;
+ *)
+ test -z "$VENDOR" && VENDOR=unknown
+ ;;
+esac
+test -f /etc/SuSE-release -o -f /.buildenv && VENDOR=suse
+
+# Note: order is significant - the case branches are not exclusive.
+
+case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
+ *:NetBSD:*:*)
+ # NetBSD (nbsd) targets should (where applicable) match one or
+ # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*,
+ # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently
+ # switched to ELF, *-*-netbsd* would select the old
+ # object file format. This provides both forward
+ # compatibility and a consistent mechanism for selecting the
+ # object file format.
+ #
+ # Note: NetBSD doesn't particularly care about the vendor
+ # portion of the name. We always set it to "unknown".
+ sysctl="sysctl -n hw.machine_arch"
+ UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \
+ /usr/sbin/$sysctl 2>/dev/null || echo unknown)`
+ case "${UNAME_MACHINE_ARCH}" in
+ armeb) machine=armeb-unknown ;;
+ arm*) machine=arm-unknown ;;
+ sh3el) machine=shl-unknown ;;
+ sh3eb) machine=sh-unknown ;;
+ sh5el) machine=sh5le-unknown ;;
+ *) machine=${UNAME_MACHINE_ARCH}-unknown ;;
+ esac
+ # The Operating System including object format, if it has switched
+ # to ELF recently, or will in the future.
+ case "${UNAME_MACHINE_ARCH}" in
+ arm*|i386|m68k|ns32k|sh3*|sparc|vax)
+ eval $set_cc_for_build
+ if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \
+ | grep -q __ELF__
+ then
+ # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout).
+ # Return netbsd for either. FIX?
+ os=netbsd
+ else
+ os=netbsdelf
+ fi
+ ;;
+ *)
+ os=netbsd
+ ;;
+ esac
+ # The OS release
+ # Debian GNU/NetBSD machines have a different userland, and
+ # thus, need a distinct triplet. However, they do not need
+ # kernel version information, so it can be replaced with a
+ # suitable tag, in the style of linux-gnu.
+ case "${UNAME_VERSION}" in
+ Debian*)
+ release='-gnu'
+ ;;
+ *)
+ release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
+ ;;
+ esac
+ # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM:
+ # contains redundant information, the shorter form:
+ # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.
+ echo "${machine}-${os}${release}"
+ exit ;;
+ *:OpenBSD:*:*)
+ UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'`
+ echo ${UNAME_MACHINE_ARCH}-${VENDOR}-openbsd${UNAME_RELEASE}
+ exit ;;
+ *:ekkoBSD:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-ekkobsd${UNAME_RELEASE}
+ exit ;;
+ *:SolidBSD:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-solidbsd${UNAME_RELEASE}
+ exit ;;
+ macppc:MirBSD:*:*)
+ echo powerpc-${VENDOR}-mirbsd${UNAME_RELEASE}
+ exit ;;
+ *:MirBSD:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-mirbsd${UNAME_RELEASE}
+ exit ;;
+ alpha:OSF1:*:*)
+ case $UNAME_RELEASE in
+ *4.0)
+ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`
+ ;;
+ *5.*)
+ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'`
+ ;;
+ esac
+ # According to Compaq, /usr/sbin/psrinfo has been available on
+ # OSF/1 and Tru64 systems produced since 1995. I hope that
+ # covers most systems running today. This code pipes the CPU
+ # types through head -n 1, so we only detect the type of CPU 0.
+ ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1`
+ case "$ALPHA_CPU_TYPE" in
+ "EV4 (21064)")
+ UNAME_MACHINE="alpha" ;;
+ "EV4.5 (21064)")
+ UNAME_MACHINE="alpha" ;;
+ "LCA4 (21066/21068)")
+ UNAME_MACHINE="alpha" ;;
+ "EV5 (21164)")
+ UNAME_MACHINE="alphaev5" ;;
+ "EV5.6 (21164A)")
+ UNAME_MACHINE="alphaev56" ;;
+ "EV5.6 (21164PC)")
+ UNAME_MACHINE="alphapca56" ;;
+ "EV5.7 (21164PC)")
+ UNAME_MACHINE="alphapca57" ;;
+ "EV6 (21264)")
+ UNAME_MACHINE="alphaev6" ;;
+ "EV6.7 (21264A)")
+ UNAME_MACHINE="alphaev67" ;;
+ "EV6.8CB (21264C)")
+ UNAME_MACHINE="alphaev68" ;;
+ "EV6.8AL (21264B)")
+ UNAME_MACHINE="alphaev68" ;;
+ "EV6.8CX (21264D)")
+ UNAME_MACHINE="alphaev68" ;;
+ "EV6.9A (21264/EV69A)")
+ UNAME_MACHINE="alphaev69" ;;
+ "EV7 (21364)")
+ UNAME_MACHINE="alphaev7" ;;
+ "EV7.9 (21364A)")
+ UNAME_MACHINE="alphaev79" ;;
+ esac
+ # A Pn.n version is a patched version.
+ # A Vn.n version is a released version.
+ # A Tn.n version is a released field test version.
+ # A Xn.n version is an unreleased experimental baselevel.
+ # 1.2 uses "1.2" for uname -r.
+ echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
+ exit ;;
+ Alpha\ *:Windows_NT*:*)
+ # How do we know it's Interix rather than the generic POSIX subsystem?
+ # Should we change UNAME_MACHINE based on the output of uname instead
+ # of the specific Alpha model?
+ echo alpha-pc-interix
+ exit ;;
+ 21064:Windows_NT:50:3)
+ echo alpha-dec-winnt3.5
+ exit ;;
+ Amiga*:UNIX_System_V:4.0:*)
+ echo m68k-${VENDOR}-sysv4
+ exit ;;
+ *:[Aa]miga[Oo][Ss]:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-amigaos
+ exit ;;
+ *:[Mm]orph[Oo][Ss]:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-morphos
+ exit ;;
+ *:OS/390:*:*)
+ echo i370-ibm-openedition
+ exit ;;
+ *:z/VM:*:*)
+ echo s390-ibm-zvmoe
+ exit ;;
+ *:OS400:*:*)
+ echo powerpc-ibm-os400
+ exit ;;
+ arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
+ echo arm-acorn-riscix${UNAME_RELEASE}
+ exit ;;
+ arm:riscos:*:*|arm:RISCOS:*:*)
+ echo arm-${VENDOR}-riscos
+ exit ;;
+ SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*)
+ echo hppa1.1-hitachi-hiuxmpp
+ exit ;;
+ Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*)
+ # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.
+ if test "`(/bin/universe) 2>/dev/null`" = att ; then
+ echo pyramid-pyramid-sysv3
+ else
+ echo pyramid-pyramid-bsd
+ fi
+ exit ;;
+ NILE*:*:*:dcosx)
+ echo pyramid-pyramid-svr4
+ exit ;;
+ DRS?6000:unix:4.0:6*)
+ echo sparc-icl-nx6
+ exit ;;
+ DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*)
+ case `/usr/bin/uname -p` in
+ sparc) echo sparc-icl-nx7; exit ;;
+ esac ;;
+ s390x:SunOS:*:*)
+ echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4H:SunOS:5.*:*)
+ echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
+ echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*)
+ echo i386-pc-auroraux${UNAME_RELEASE}
+ exit ;;
+ i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*)
+ eval $set_cc_for_build
+ SUN_ARCH="i386"
+ # If there is a compiler, see if it is configured for 64-bit objects.
+ # Note that the Sun cc does not turn __LP64__ into 1 like gcc does.
+ # This test works for both compilers.
+ if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then
+ if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \
+ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \
+ grep IS_64BIT_ARCH >/dev/null
+ then
+ SUN_ARCH="x86_64"
+ fi
+ fi
+ echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4*:SunOS:6*:*)
+ # According to config.sub, this is the proper way to canonicalize
+ # SunOS6. Hard to guess exactly what SunOS6 will be like, but
+ # it's likely to be more like Solaris than SunOS4.
+ echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4*:SunOS:*:*)
+ case "`/usr/bin/arch -k`" in
+ Series*|S4*)
+ UNAME_RELEASE=`uname -v`
+ ;;
+ esac
+ # Japanese Language versions have a version number like `4.1.3-JL'.
+ echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
+ exit ;;
+ sun3*:SunOS:*:*)
+ echo m68k-sun-sunos${UNAME_RELEASE}
+ exit ;;
+ sun*:*:4.2BSD:*)
+ UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null`
+ test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3
+ case "`/bin/arch`" in
+ sun3)
+ echo m68k-sun-sunos${UNAME_RELEASE}
+ ;;
+ sun4)
+ echo sparc-sun-sunos${UNAME_RELEASE}
+ ;;
+ esac
+ exit ;;
+ aushp:SunOS:*:*)
+ echo sparc-auspex-sunos${UNAME_RELEASE}
+ exit ;;
+ # The situation for MiNT is a little confusing. The machine name
+ # can be virtually everything (everything which is not
+ # "atarist" or "atariste" at least should have a processor
+ # > m68000). The system name ranges from "MiNT" over "FreeMiNT"
+ # to the lowercase version "mint" (or "freemint"). Finally
+ # the system name "TOS" denotes a system which is actually not
+ # MiNT. But MiNT is downward compatible to TOS, so this should
+ # be no problem.
+ atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+ exit ;;
+ atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+ exit ;;
+ *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+ exit ;;
+ milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)
+ echo m68k-milan-mint${UNAME_RELEASE}
+ exit ;;
+ hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)
+ echo m68k-hades-mint${UNAME_RELEASE}
+ exit ;;
+ *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)
+ echo m68k-${VENDOR}-mint${UNAME_RELEASE}
+ exit ;;
+ m68k:machten:*:*)
+ echo m68k-apple-machten${UNAME_RELEASE}
+ exit ;;
+ powerpc:machten:*:*)
+ echo powerpc-apple-machten${UNAME_RELEASE}
+ exit ;;
+ RISC*:Mach:*:*)
+ echo mips-dec-mach_bsd4.3
+ exit ;;
+ RISC*:ULTRIX:*:*)
+ echo mips-dec-ultrix${UNAME_RELEASE}
+ exit ;;
+ VAX*:ULTRIX*:*:*)
+ echo vax-dec-ultrix${UNAME_RELEASE}
+ exit ;;
+ 2020:CLIX:*:* | 2430:CLIX:*:*)
+ echo clipper-intergraph-clix${UNAME_RELEASE}
+ exit ;;
+ mips:*:*:UMIPS | mips:*:*:RISCos)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+#ifdef __cplusplus
+#include <stdio.h> /* for printf() prototype */
+ int main (int argc, char *argv[]) {
+#else
+ int main (argc, argv) int argc; char *argv[]; {
+#endif
+ #if defined (host_mips) && defined (MIPSEB)
+ #if defined (SYSTYPE_SYSV)
+ printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0);
+ #endif
+ #if defined (SYSTYPE_SVR4)
+ printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0);
+ #endif
+ #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD)
+ printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0);
+ #endif
+ #endif
+ exit (-1);
+ }
+EOF
+ $CC_FOR_BUILD -o $dummy $dummy.c &&
+ dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` &&
+ SYSTEM_NAME=`$dummy $dummyarg` &&
+ { echo "$SYSTEM_NAME"; exit; }
+ echo mips-mips-riscos${UNAME_RELEASE}
+ exit ;;
+ Motorola:PowerMAX_OS:*:*)
+ echo powerpc-motorola-powermax
+ exit ;;
+ Motorola:*:4.3:PL8-*)
+ echo powerpc-harris-powermax
+ exit ;;
+ Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*)
+ echo powerpc-harris-powermax
+ exit ;;
+ Night_Hawk:Power_UNIX:*:*)
+ echo powerpc-harris-powerunix
+ exit ;;
+ m88k:CX/UX:7*:*)
+ echo m88k-harris-cxux7
+ exit ;;
+ m88k:*:4*:R4*)
+ echo m88k-motorola-sysv4
+ exit ;;
+ m88k:*:3*:R3*)
+ echo m88k-motorola-sysv3
+ exit ;;
+ AViiON:dgux:*:*)
+ # DG/UX returns AViiON for all architectures
+ UNAME_PROCESSOR=`/usr/bin/uname -p`
+ if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ]
+ then
+ if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \
+ [ ${TARGET_BINARY_INTERFACE}x = x ]
+ then
+ echo m88k-dg-dgux${UNAME_RELEASE}
+ else
+ echo m88k-dg-dguxbcs${UNAME_RELEASE}
+ fi
+ else
+ echo i586-dg-dgux${UNAME_RELEASE}
+ fi
+ exit ;;
+ M88*:DolphinOS:*:*) # DolphinOS (SVR3)
+ echo m88k-dolphin-sysv3
+ exit ;;
+ M88*:*:R3*:*)
+ # Delta 88k system running SVR3
+ echo m88k-motorola-sysv3
+ exit ;;
+ XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)
+ echo m88k-tektronix-sysv3
+ exit ;;
+ Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)
+ echo m68k-tektronix-bsd
+ exit ;;
+ *:IRIX*:*:*)
+ echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
+ exit ;;
+ ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
+ echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
+ exit ;; # Note that: echo "'`uname -s`'" gives 'AIX '
+ i*86:AIX:*:*)
+ echo i386-ibm-aix
+ exit ;;
+ ia64:AIX:*:*)
+ if [ -x /usr/bin/oslevel ] ; then
+ IBM_REV=`/usr/bin/oslevel`
+ else
+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ fi
+ echo ${UNAME_MACHINE}-ibm-aix${IBM_REV}
+ exit ;;
+ *:AIX:2:3)
+ if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #include <sys/systemcfg.h>
+
+ main()
+ {
+ if (!__power_pc())
+ exit(1);
+ puts("powerpc-ibm-aix3.2.5");
+ exit(0);
+ }
+EOF
+ if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy`
+ then
+ echo "$SYSTEM_NAME"
+ else
+ echo rs6000-ibm-aix3.2.5
+ fi
+ elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then
+ echo rs6000-ibm-aix3.2.4
+ else
+ echo rs6000-ibm-aix3.2
+ fi
+ exit ;;
+ *:AIX:*:[456])
+ IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'`
+ if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then
+ IBM_ARCH=rs6000
+ else
+ IBM_ARCH=powerpc
+ fi
+ if [ -x /usr/bin/oslevel ] ; then
+ IBM_REV=`/usr/bin/oslevel`
+ else
+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ fi
+ echo ${IBM_ARCH}-ibm-aix${IBM_REV}
+ exit ;;
+ *:AIX:*:*)
+ echo rs6000-ibm-aix
+ exit ;;
+ ibmrt:4.4BSD:*|romp-ibm:BSD:*)
+ echo romp-ibm-bsd4.4
+ exit ;;
+ ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and
+ echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
+ exit ;; # report: romp-ibm BSD 4.3
+ *:BOSX:*:*)
+ echo rs6000-bull-bosx
+ exit ;;
+ DPX/2?00:B.O.S.:*:*)
+ echo m68k-bull-sysv3
+ exit ;;
+ 9000/[34]??:4.3bsd:1.*:*)
+ echo m68k-hp-bsd
+ exit ;;
+ hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)
+ echo m68k-hp-bsd4.4
+ exit ;;
+ 9000/[34678]??:HP-UX:*:*)
+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
+ case "${UNAME_MACHINE}" in
+ 9000/31? ) HP_ARCH=m68000 ;;
+ 9000/[34]?? ) HP_ARCH=m68k ;;
+ 9000/[678][0-9][0-9])
+ if [ -x /usr/bin/getconf ]; then
+ sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null`
+ sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`
+ case "${sc_cpu_version}" in
+ 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0
+ 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1
+ 532) # CPU_PA_RISC2_0
+ case "${sc_kernel_bits}" in
+ 32) HP_ARCH="hppa2.0n" ;;
+ 64) HP_ARCH="hppa2.0w" ;;
+ '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20
+ esac ;;
+ esac
+ fi
+ if [ "${HP_ARCH}" = "" ]; then
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+
+ #define _HPUX_SOURCE
+ #include <stdlib.h>
+ #include <unistd.h>
+
+ int main ()
+ {
+ #if defined(_SC_KERNEL_BITS)
+ long bits = sysconf(_SC_KERNEL_BITS);
+ #endif
+ long cpu = sysconf (_SC_CPU_VERSION);
+
+ switch (cpu)
+ {
+ case CPU_PA_RISC1_0: puts ("hppa1.0"); break;
+ case CPU_PA_RISC1_1: puts ("hppa1.1"); break;
+ case CPU_PA_RISC2_0:
+ #if defined(_SC_KERNEL_BITS)
+ switch (bits)
+ {
+ case 64: puts ("hppa2.0w"); break;
+ case 32: puts ("hppa2.0n"); break;
+ default: puts ("hppa2.0"); break;
+ } break;
+ #else /* !defined(_SC_KERNEL_BITS) */
+ puts ("hppa2.0"); break;
+ #endif
+ default: puts ("hppa1.0"); break;
+ }
+ exit (0);
+ }
+EOF
+ (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy`
+ test -z "$HP_ARCH" && HP_ARCH=hppa
+ fi ;;
+ esac
+ if [ ${HP_ARCH} = "hppa2.0w" ]
+ then
+ eval $set_cc_for_build
+
+ # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating
+ # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler
+ # generating 64-bit code. GNU and HP use different nomenclature:
+ #
+ # $ CC_FOR_BUILD=cc ./config.guess
+ # => hppa2.0w-hp-hpux11.23
+ # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess
+ # => hppa64-hp-hpux11.23
+
+ if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) |
+ grep -q __LP64__
+ then
+ HP_ARCH="hppa2.0w"
+ else
+ HP_ARCH="hppa64"
+ fi
+ fi
+ echo ${HP_ARCH}-hp-hpux${HPUX_REV}
+ exit ;;
+ ia64:HP-UX:*:*)
+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
+ echo ia64-hp-hpux${HPUX_REV}
+ exit ;;
+ 3050*:HI-UX:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #include <unistd.h>
+ int
+ main ()
+ {
+ long cpu = sysconf (_SC_CPU_VERSION);
+ /* The order matters, because CPU_IS_HP_MC68K erroneously returns
+ true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct
+ results, however. */
+ if (CPU_IS_PA_RISC (cpu))
+ {
+ switch (cpu)
+ {
+ case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break;
+ case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break;
+ case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break;
+ default: puts ("hppa-hitachi-hiuxwe2"); break;
+ }
+ }
+ else if (CPU_IS_HP_MC68K (cpu))
+ puts ("m68k-hitachi-hiuxwe2");
+ else puts ("unknown-hitachi-hiuxwe2");
+ exit (0);
+ }
+EOF
+ $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` &&
+ { echo "$SYSTEM_NAME"; exit; }
+ echo unknown-hitachi-hiuxwe2
+ exit ;;
+ 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )
+ echo hppa1.1-hp-bsd
+ exit ;;
+ 9000/8??:4.3bsd:*:*)
+ echo hppa1.0-hp-bsd
+ exit ;;
+ *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*)
+ echo hppa1.0-hp-mpeix
+ exit ;;
+ hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )
+ echo hppa1.1-hp-osf
+ exit ;;
+ hp8??:OSF1:*:*)
+ echo hppa1.0-hp-osf
+ exit ;;
+ i*86:OSF1:*:*)
+ if [ -x /usr/sbin/sysversion ] ; then
+ echo ${UNAME_MACHINE}-${VENDOR}-osf1mk
+ else
+ echo ${UNAME_MACHINE}-${VENDOR}-osf1
+ fi
+ exit ;;
+ parisc*:Lites*:*:*)
+ echo hppa1.1-hp-lites
+ exit ;;
+ C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
+ echo c1-convex-bsd
+ exit ;;
+ C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
+ if getsysinfo -f scalar_acc
+ then echo c32-convex-bsd
+ else echo c2-convex-bsd
+ fi
+ exit ;;
+ C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
+ echo c34-convex-bsd
+ exit ;;
+ C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
+ echo c38-convex-bsd
+ exit ;;
+ C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
+ echo c4-convex-bsd
+ exit ;;
+ CRAY*Y-MP:*:*:*)
+ echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*[A-Z]90:*:*:*)
+ echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \
+ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \
+ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \
+ -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*TS:*:*:*)
+ echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*T3E:*:*:*)
+ echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*SV1:*:*:*)
+ echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ *:UNICOS/mp:*:*)
+ echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)
+ FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
+ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+ FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
+ echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+ exit ;;
+ 5000:UNIX_System_V:4.*:*)
+ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+ FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'`
+ echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+ exit ;;
+ i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)
+ echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
+ exit ;;
+ sparc*:BSD/OS:*:*)
+ echo sparc-${VENDOR}-bsdi${UNAME_RELEASE}
+ exit ;;
+ *:BSD/OS:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-bsdi${UNAME_RELEASE}
+ exit ;;
+ *:FreeBSD:*:*)
+ case ${UNAME_MACHINE} in
+ pc98)
+ echo i386-${VENDOR}-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+ amd64)
+ echo x86_64-${VENDOR}-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+ *)
+ echo ${UNAME_MACHINE}-${VENDOR}-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+ esac
+ exit ;;
+ i*:CYGWIN*:*)
+ echo ${UNAME_MACHINE}-pc-cygwin
+ exit ;;
+ *:MINGW*:*)
+ echo ${UNAME_MACHINE}-pc-mingw32
+ exit ;;
+ i*:windows32*:*)
+ # uname -m includes "-pc" on this system.
+ echo ${UNAME_MACHINE}-mingw32
+ exit ;;
+ i*:PW*:*)
+ echo ${UNAME_MACHINE}-pc-pw32
+ exit ;;
+ *:Interix*:*)
+ case ${UNAME_MACHINE} in
+ x86)
+ echo i586-pc-interix${UNAME_RELEASE}
+ exit ;;
+ authenticamd | genuineintel | EM64T)
+ echo x86_64-${VENDOR}-interix${UNAME_RELEASE}
+ exit ;;
+ IA64)
+ echo ia64-${VENDOR}-interix${UNAME_RELEASE}
+ exit ;;
+ esac ;;
+ [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*)
+ echo i${UNAME_MACHINE}-pc-mks
+ exit ;;
+ 8664:Windows_NT:*)
+ echo x86_64-pc-mks
+ exit ;;
+ i*:Windows_NT*:* | Pentium*:Windows_NT*:*)
+ # How do we know it's Interix rather than the generic POSIX subsystem?
+ # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we
+ # UNAME_MACHINE based on the output of uname instead of i386?
+ echo i586-pc-interix
+ exit ;;
+ i*:UWIN*:*)
+ echo ${UNAME_MACHINE}-pc-uwin
+ exit ;;
+ amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)
+ echo x86_64-${VENDOR}-cygwin
+ exit ;;
+ p*:CYGWIN*:*)
+ echo powerpcle-${VENDOR}-cygwin
+ exit ;;
+ prep*:SunOS:5.*:*)
+ echo powerpcle-${VENDOR}-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ *:GNU:*:*)
+ # the GNU system
+ echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-${VENDOR}-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
+ exit ;;
+ *:GNU/*:*:*)
+ # other systems with GNU libc and userland
+ echo ${UNAME_MACHINE}-${VENDOR}-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu
+ exit ;;
+ i*86:Minix:*:*)
+ echo ${UNAME_MACHINE}-pc-minix
+ exit ;;
+ alpha:Linux:*:*)
+ case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
+ EV5) UNAME_MACHINE=alphaev5 ;;
+ EV56) UNAME_MACHINE=alphaev56 ;;
+ PCA56) UNAME_MACHINE=alphapca56 ;;
+ PCA57) UNAME_MACHINE=alphapca56 ;;
+ EV6) UNAME_MACHINE=alphaev6 ;;
+ EV67) UNAME_MACHINE=alphaev67 ;;
+ EV68*) UNAME_MACHINE=alphaev68 ;;
+ esac
+ objdump --private-headers /bin/sh | grep -q ld.so.1
+ if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu${LIBC}
+ exit ;;
+ arm*:Linux:*:*)
+ eval $set_cc_for_build
+ if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \
+ | grep -q __ARM_EABI__
+ then
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu
+ else
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnueabi
+ fi
+ exit ;;
+ avr32*:Linux:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu
+ exit ;;
+ cris:Linux:*:*)
+ echo cris-axis-linux-gnu
+ exit ;;
+ crisv32:Linux:*:*)
+ echo crisv32-axis-linux-gnu
+ exit ;;
+ frv:Linux:*:*)
+ echo frv-${VENDOR}-linux-gnu
+ exit ;;
+ i*86:Linux:*:*)
+ LIBC=gnu
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #ifdef __dietlibc__
+ LIBC=dietlibc
+ #endif
+EOF
+ eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'`
+ echo "${UNAME_MACHINE}-${VENDOR}-linux-${LIBC}"
+ exit ;;
+ ia64:Linux:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu
+ exit ;;
+ m32r*:Linux:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu
+ exit ;;
+ m68*:Linux:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu
+ exit ;;
+ mips:Linux:*:* | mips64:Linux:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #undef CPU
+ #undef ${UNAME_MACHINE}
+ #undef ${UNAME_MACHINE}el
+ #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
+ CPU=${UNAME_MACHINE}el
+ #else
+ #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
+ CPU=${UNAME_MACHINE}
+ #else
+ CPU=
+ #endif
+ #endif
+EOF
+ eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'`
+ test x"${CPU}" != x && { echo "${CPU}-${VENDOR}-linux-gnu"; exit; }
+ ;;
+ or32:Linux:*:*)
+ echo or32-${VENDOR}-linux-gnu
+ exit ;;
+ padre:Linux:*:*)
+ echo sparc-${VENDOR}-linux-gnu
+ exit ;;
+ parisc64:Linux:*:* | hppa64:Linux:*:*)
+ echo hppa64-${VENDOR}-linux-gnu
+ exit ;;
+ parisc:Linux:*:* | hppa:Linux:*:*)
+ # Look for CPU level
+ case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in
+ PA7*) echo hppa1.1-${VENDOR}-linux-gnu ;;
+ PA8*) echo hppa2.0-${VENDOR}-linux-gnu ;;
+ *) echo hppa-${VENDOR}-linux-gnu ;;
+ esac
+ exit ;;
+ ppc64:Linux:*:*)
+ echo powerpc64-${VENDOR}-linux-gnu
+ exit ;;
+ ppc:Linux:*:*)
+ echo powerpc-${VENDOR}-linux-gnu
+ exit ;;
+ s390:Linux:*:* | s390x:Linux:*:*)
+ echo ${UNAME_MACHINE}-ibm-linux
+ exit ;;
+ sh64*:Linux:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu
+ exit ;;
+ sh*:Linux:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu
+ exit ;;
+ sparc:Linux:*:* | sparc64:Linux:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu
+ exit ;;
+ vax:Linux:*:*)
+ echo ${UNAME_MACHINE}-dec-linux-gnu
+ exit ;;
+ x86_64:Linux:*:*)
+ echo x86_64-${VENDOR}-linux-gnu
+ exit ;;
+ xtensa*:Linux:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-linux-gnu
+ exit ;;
+ i*86:DYNIX/ptx:4*:*)
+ # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.
+ # earlier versions are messed up and put the nodename in both
+ # sysname and nodename.
+ echo i386-sequent-sysv4
+ exit ;;
+ i*86:UNIX_SV:4.2MP:2.*)
+ # Unixware is an offshoot of SVR4, but it has its own version
+ # number series starting with 2...
+ # I am not positive that other SVR4 systems won't match this,
+ # I just have to hope. -- rms.
+ # Use sysv4.2uw... so that sysv4* matches it.
+ echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}
+ exit ;;
+ i*86:OS/2:*:*)
+ # If we were able to find `uname', then EMX Unix compatibility
+ # is probably installed.
+ echo ${UNAME_MACHINE}-pc-os2-emx
+ exit ;;
+ i*86:XTS-300:*:STOP)
+ echo ${UNAME_MACHINE}-${VENDOR}-stop
+ exit ;;
+ i*86:atheos:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-atheos
+ exit ;;
+ i*86:syllable:*:*)
+ echo ${UNAME_MACHINE}-pc-syllable
+ exit ;;
+ i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*)
+ echo i386-${VENDOR}-lynxos${UNAME_RELEASE}
+ exit ;;
+ i*86:*DOS:*:*)
+ echo ${UNAME_MACHINE}-pc-msdosdjgpp
+ exit ;;
+ i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*)
+ UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'`
+ if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
+ echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL}
+ else
+ echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL}
+ fi
+ exit ;;
+ i*86:*:5:[678]*)
+ # UnixWare 7.x, OpenUNIX and OpenServer 6.
+ case `/bin/uname -X | grep "^Machine"` in
+ *486*) UNAME_MACHINE=i486 ;;
+ *Pentium) UNAME_MACHINE=i586 ;;
+ *Pent*|*Celeron) UNAME_MACHINE=i686 ;;
+ esac
+ echo ${UNAME_MACHINE}-${VENDOR}-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}
+ exit ;;
+ i*86:*:3.2:*)
+ if test -f /usr/options/cb.name; then
+ UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
+ echo ${UNAME_MACHINE}-pc-isc$UNAME_REL
+ elif /bin/uname -X 2>/dev/null >/dev/null ; then
+ UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')`
+ (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486
+ (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \
+ && UNAME_MACHINE=i586
+ (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \
+ && UNAME_MACHINE=i686
+ (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \
+ && UNAME_MACHINE=i686
+ echo ${UNAME_MACHINE}-pc-sco$UNAME_REL
+ else
+ echo ${UNAME_MACHINE}-pc-sysv32
+ fi
+ exit ;;
+ pc:*:*:*)
+ # Left here for compatibility:
+ # uname -m prints for DJGPP always 'pc', but it prints nothing about
+ # the processor, so we play safe by assuming i586.
+ # Note: whatever this is, it MUST be the same as what config.sub
+ # prints for the "djgpp" host, or else GDB configury will decide that
+ # this is a cross-build.
+ echo i586-pc-msdosdjgpp
+ exit ;;
+ Intel:Mach:3*:*)
+ echo i386-pc-mach3
+ exit ;;
+ paragon:*:*:*)
+ echo i860-intel-osf1
+ exit ;;
+ i860:*:4.*:*) # i860-SVR4
+ if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
+ echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
+ else # Add other i860-SVR4 vendors below as they are discovered.
+ echo i860-${VENDOR}-sysv${UNAME_RELEASE} # Unknown i860-SVR4
+ fi
+ exit ;;
+ mini*:CTIX:SYS*5:*)
+ # "miniframe"
+ echo m68010-convergent-sysv
+ exit ;;
+ mc68k:UNIX:SYSTEM5:3.51m)
+ echo m68k-convergent-sysv
+ exit ;;
+ M680?0:D-NIX:5.3:*)
+ echo m68k-diab-dnix
+ exit ;;
+ M68*:*:R3V[5678]*:*)
+ test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;;
+ 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0)
+ OS_REL=''
+ test -r /etc/.relid \
+ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+ && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
+ /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
+ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
+ 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+ && { echo i486-ncr-sysv4; exit; } ;;
+ NCR*:*:4.2:* | MPRAS*:*:4.2:*)
+ OS_REL='.3'
+ test -r /etc/.relid \
+ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+ && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
+ /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
+ && { echo i586-ncr-sysv4.3${OS_REL}; exit; }
+ /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \
+ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
+ m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)
+ echo m68k-${VENDOR}-lynxos${UNAME_RELEASE}
+ exit ;;
+ mc68030:UNIX_System_V:4.*:*)
+ echo m68k-atari-sysv4
+ exit ;;
+ TSUNAMI:LynxOS:2.*:*)
+ echo sparc-${VENDOR}-lynxos${UNAME_RELEASE}
+ exit ;;
+ rs6000:LynxOS:2.*:*)
+ echo rs6000-${VENDOR}-lynxos${UNAME_RELEASE}
+ exit ;;
+ PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*)
+ echo powerpc-${VENDOR}-lynxos${UNAME_RELEASE}
+ exit ;;
+ SM[BE]S:UNIX_SV:*:*)
+ echo mips-dde-sysv${UNAME_RELEASE}
+ exit ;;
+ RM*:ReliantUNIX-*:*:*)
+ echo mips-sni-sysv4
+ exit ;;
+ RM*:SINIX-*:*:*)
+ echo mips-sni-sysv4
+ exit ;;
+ *:SINIX-*:*:*)
+ if uname -p 2>/dev/null >/dev/null ; then
+ UNAME_MACHINE=`(uname -p) 2>/dev/null`
+ echo ${UNAME_MACHINE}-sni-sysv4
+ else
+ echo ns32k-sni-sysv
+ fi
+ exit ;;
+ PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
+ # says <Richard.M.Bartel@ccMail.Census.GOV>
+ echo i586-unisys-sysv4
+ exit ;;
+ *:UNIX_System_V:4*:FTX*)
+ # From Gerald Hewes <hewes@openmarket.com>.
+ # How about differentiating between stratus architectures? -djm
+ echo hppa1.1-stratus-sysv4
+ exit ;;
+ *:*:*:FTX*)
+ # From seanf@swdc.stratus.com.
+ echo i860-stratus-sysv4
+ exit ;;
+ i*86:VOS:*:*)
+ # From Paul.Green@stratus.com.
+ echo ${UNAME_MACHINE}-stratus-vos
+ exit ;;
+ *:VOS:*:*)
+ # From Paul.Green@stratus.com.
+ echo hppa1.1-stratus-vos
+ exit ;;
+ mc68*:A/UX:*:*)
+ echo m68k-apple-aux${UNAME_RELEASE}
+ exit ;;
+ news*:NEWS-OS:6*:*)
+ echo mips-sony-newsos6
+ exit ;;
+ R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)
+ if [ -d /usr/nec ]; then
+ echo mips-nec-sysv${UNAME_RELEASE}
+ else
+ echo mips-${VENDOR}-sysv${UNAME_RELEASE}
+ fi
+ exit ;;
+ BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only.
+ echo powerpc-be-beos
+ exit ;;
+ BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only.
+ echo powerpc-apple-beos
+ exit ;;
+ BePC:BeOS:*:*) # BeOS running on Intel PC compatible.
+ echo i586-pc-beos
+ exit ;;
+ BePC:Haiku:*:*) # Haiku running on Intel PC compatible.
+ echo i586-pc-haiku
+ exit ;;
+ SX-4:SUPER-UX:*:*)
+ echo sx4-nec-superux${UNAME_RELEASE}
+ exit ;;
+ SX-5:SUPER-UX:*:*)
+ echo sx5-nec-superux${UNAME_RELEASE}
+ exit ;;
+ SX-6:SUPER-UX:*:*)
+ echo sx6-nec-superux${UNAME_RELEASE}
+ exit ;;
+ SX-7:SUPER-UX:*:*)
+ echo sx7-nec-superux${UNAME_RELEASE}
+ exit ;;
+ SX-8:SUPER-UX:*:*)
+ echo sx8-nec-superux${UNAME_RELEASE}
+ exit ;;
+ SX-8R:SUPER-UX:*:*)
+ echo sx8r-nec-superux${UNAME_RELEASE}
+ exit ;;
+ Power*:Rhapsody:*:*)
+ echo powerpc-apple-rhapsody${UNAME_RELEASE}
+ exit ;;
+ *:Rhapsody:*:*)
+ echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE}
+ exit ;;
+ *:Darwin:*:*)
+ UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown
+ case $UNAME_PROCESSOR in
+ i386)
+ eval $set_cc_for_build
+ if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then
+ if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \
+ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \
+ grep IS_64BIT_ARCH >/dev/null
+ then
+ UNAME_PROCESSOR="x86_64"
+ fi
+ fi ;;
+ unknown) UNAME_PROCESSOR=powerpc ;;
+ esac
+ echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE}
+ exit ;;
+ *:procnto*:*:* | *:QNX:[0123456789]*:*)
+ UNAME_PROCESSOR=`uname -p`
+ if test "$UNAME_PROCESSOR" = "x86"; then
+ UNAME_PROCESSOR=i386
+ UNAME_MACHINE=pc
+ fi
+ echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE}
+ exit ;;
+ *:QNX:*:4*)
+ echo i386-pc-qnx
+ exit ;;
+ NSE-?:NONSTOP_KERNEL:*:*)
+ echo nse-tandem-nsk${UNAME_RELEASE}
+ exit ;;
+ NSR-?:NONSTOP_KERNEL:*:*)
+ echo nsr-tandem-nsk${UNAME_RELEASE}
+ exit ;;
+ *:NonStop-UX:*:*)
+ echo mips-compaq-nonstopux
+ exit ;;
+ BS2000:POSIX*:*:*)
+ echo bs2000-siemens-sysv
+ exit ;;
+ DS/*:UNIX_System_V:*:*)
+ echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE}
+ exit ;;
+ *:Plan9:*:*)
+ # "uname -m" is not consistent, so use $cputype instead. 386
+ # is converted to i386 for consistency with other x86
+ # operating systems.
+ if test "$cputype" = "386"; then
+ UNAME_MACHINE=i386
+ else
+ UNAME_MACHINE="$cputype"
+ fi
+ echo ${UNAME_MACHINE}-${VENDOR}-plan9
+ exit ;;
+ *:TOPS-10:*:*)
+ echo pdp10-${VENDOR}-tops10
+ exit ;;
+ *:TENEX:*:*)
+ echo pdp10-${VENDOR}-tenex
+ exit ;;
+ KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*)
+ echo pdp10-dec-tops20
+ exit ;;
+ XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*)
+ echo pdp10-xkl-tops20
+ exit ;;
+ *:TOPS-20:*:*)
+ echo pdp10-${VENDOR}-tops20
+ exit ;;
+ *:ITS:*:*)
+ echo pdp10-${VENDOR}-its
+ exit ;;
+ SEI:*:*:SEIUX)
+ echo mips-sei-seiux${UNAME_RELEASE}
+ exit ;;
+ *:DragonFly:*:*)
+ echo ${UNAME_MACHINE}-${VENDOR}-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
+ exit ;;
+ *:*VMS:*:*)
+ UNAME_MACHINE=`(uname -p) 2>/dev/null`
+ case "${UNAME_MACHINE}" in
+ A*) echo alpha-dec-vms ; exit ;;
+ I*) echo ia64-dec-vms ; exit ;;
+ V*) echo vax-dec-vms ; exit ;;
+ esac ;;
+ *:XENIX:*:SysV)
+ echo i386-pc-xenix
+ exit ;;
+ i*86:skyos:*:*)
+ echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//'
+ exit ;;
+ i*86:rdos:*:*)
+ echo ${UNAME_MACHINE}-pc-rdos
+ exit ;;
+ i*86:AROS:*:*)
+ echo ${UNAME_MACHINE}-pc-aros
+ exit ;;
+esac
+
+#echo '(No uname command or uname output not recognized.)' 1>&2
+#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2
+
+eval $set_cc_for_build
+cat >$dummy.c <<EOF
+#ifdef _SEQUENT_
+# include <sys/types.h>
+# include <sys/utsname.h>
+#endif
+main ()
+{
+#if defined (sony)
+#if defined (MIPSEB)
+ /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,
+ I don't know.... */
+ printf ("mips-sony-bsd\n"); exit (0);
+#else
+#include <sys/param.h>
+ printf ("m68k-sony-newsos%s\n",
+#ifdef NEWSOS4
+ "4"
+#else
+ ""
+#endif
+ ); exit (0);
+#endif
+#endif
+
+#if defined (__arm) && defined (__acorn) && defined (__unix)
+ printf ("arm-acorn-riscix\n"); exit (0);
+#endif
+
+#if defined (hp300) && !defined (hpux)
+ printf ("m68k-hp-bsd\n"); exit (0);
+#endif
+
+#if defined (NeXT)
+#if !defined (__ARCHITECTURE__)
+#define __ARCHITECTURE__ "m68k"
+#endif
+ int version;
+ version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
+ if (version < 4)
+ printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);
+ else
+ printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version);
+ exit (0);
+#endif
+
+#if defined (MULTIMAX) || defined (n16)
+#if defined (UMAXV)
+ printf ("ns32k-encore-sysv\n"); exit (0);
+#else
+#if defined (CMU)
+ printf ("ns32k-encore-mach\n"); exit (0);
+#else
+ printf ("ns32k-encore-bsd\n"); exit (0);
+#endif
+#endif
+#endif
+
+#if defined (__386BSD__)
+ printf ("i386-pc-bsd\n"); exit (0);
+#endif
+
+#if defined (sequent)
+#if defined (i386)
+ printf ("i386-sequent-dynix\n"); exit (0);
+#endif
+#if defined (ns32000)
+ printf ("ns32k-sequent-dynix\n"); exit (0);
+#endif
+#endif
+
+#if defined (_SEQUENT_)
+ struct utsname un;
+
+ uname(&un);
+
+ if (strncmp(un.version, "V2", 2) == 0) {
+ printf ("i386-sequent-ptx2\n"); exit (0);
+ }
+ if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */
+ printf ("i386-sequent-ptx1\n"); exit (0);
+ }
+ printf ("i386-sequent-ptx\n"); exit (0);
+
+#endif
+
+#if defined (vax)
+# if !defined (ultrix)
+# include <sys/param.h>
+# if defined (BSD)
+# if BSD == 43
+ printf ("vax-dec-bsd4.3\n"); exit (0);
+# else
+# if BSD == 199006
+ printf ("vax-dec-bsd4.3reno\n"); exit (0);
+# else
+ printf ("vax-dec-bsd\n"); exit (0);
+# endif
+# endif
+# else
+ printf ("vax-dec-bsd\n"); exit (0);
+# endif
+# else
+ printf ("vax-dec-ultrix\n"); exit (0);
+# endif
+#endif
+
+#if defined (alliant) && defined (i860)
+ printf ("i860-alliant-bsd\n"); exit (0);
+#endif
+
+ exit (1);
+}
+EOF
+
+$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` &&
+ { echo "$SYSTEM_NAME"; exit; }
+
+# Apollos put the system type in the environment.
+
+test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; }
+
+# Convex versions that predate uname can use getsysinfo(1)
+
+if [ -x /usr/convex/getsysinfo ]
+then
+ case `getsysinfo -f cpu_type` in
+ c1*)
+ echo c1-convex-bsd
+ exit ;;
+ c2*)
+ if getsysinfo -f scalar_acc
+ then echo c32-convex-bsd
+ else echo c2-convex-bsd
+ fi
+ exit ;;
+ c34*)
+ echo c34-convex-bsd
+ exit ;;
+ c38*)
+ echo c38-convex-bsd
+ exit ;;
+ c4*)
+ echo c4-convex-bsd
+ exit ;;
+ esac
+fi
+
+cat >&2 <<EOF
+$0: unable to guess system type
+
+This script, last modified $timestamp, has failed to recognize
+the operating system you are using. It is advised that you
+download the most up to date version of the config scripts from
+
+ http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD
+and
+ http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD
+
+If the version you run ($0) is already up to date, please
+send the following data and any information you think might be
+pertinent to <config-patches@gnu.org> in order to provide the needed
+information to handle your system.
+
+config.guess timestamp = $timestamp
+
+uname -m = `(uname -m) 2>/dev/null || echo unknown`
+uname -r = `(uname -r) 2>/dev/null || echo unknown`
+uname -s = `(uname -s) 2>/dev/null || echo unknown`
+uname -v = `(uname -v) 2>/dev/null || echo unknown`
+
+/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null`
+/bin/uname -X = `(/bin/uname -X) 2>/dev/null`
+
+hostinfo = `(hostinfo) 2>/dev/null`
+/bin/universe = `(/bin/universe) 2>/dev/null`
+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null`
+/bin/arch = `(/bin/arch) 2>/dev/null`
+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null`
+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null`
+
+UNAME_MACHINE = ${UNAME_MACHINE}
+UNAME_RELEASE = ${UNAME_RELEASE}
+UNAME_SYSTEM = ${UNAME_SYSTEM}
+UNAME_VERSION = ${UNAME_VERSION}
+EOF
+
+exit 1
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "timestamp='"
+# time-stamp-format: "%:y-%02m-%02d"
+# time-stamp-end: "'"
+# End:
diff --git a/config.aux/config.sub b/config.aux/config.sub
new file mode 100755
index 0000000..2a55a50
--- /dev/null
+++ b/config.aux/config.sub
@@ -0,0 +1,1705 @@
+#! /bin/sh
+# Configuration validation subroutine script.
+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+# Free Software Foundation, Inc.
+
+timestamp='2009-11-20'
+
+# This file is (in principle) common to ALL GNU software.
+# The presence of a machine in this file suggests that SOME GNU software
+# can handle that machine. It does not imply ALL GNU software can.
+#
+# This file is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
+# 02110-1301, USA.
+#
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+
+# Please send patches to <config-patches@gnu.org>. Submit a context
+# diff and a properly formatted GNU ChangeLog entry.
+#
+# Configuration subroutine to validate and canonicalize a configuration type.
+# Supply the specified configuration type as an argument.
+# If it is invalid, we print an error message on stderr and exit with code 1.
+# Otherwise, we print the canonical config type on stdout and succeed.
+
+# You can get the latest version of this script from:
+# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD
+
+# This file is supposed to be the same for all GNU packages
+# and recognize all the CPU types, system types and aliases
+# that are meaningful with *any* GNU software.
+# Each package is responsible for reporting which valid configurations
+# it does not support. The user should be able to distinguish
+# a failure to support a valid configuration from a meaningless
+# configuration.
+
+# The goal of this file is to map all the various variations of a given
+# machine specification into a single specification in the form:
+# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
+# or in some cases, the newer four-part form:
+# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
+# It is wrong to echo any other type of specification.
+
+me=`echo "$0" | sed -e 's,.*/,,'`
+
+usage="\
+Usage: $0 [OPTION] CPU-MFR-OPSYS
+ $0 [OPTION] ALIAS
+
+Canonicalize a configuration name.
+
+Operation modes:
+ -h, --help print this help, then exit
+ -t, --time-stamp print date of last modification, then exit
+ -v, --version print version number, then exit
+
+Report bugs and patches to <config-patches@gnu.org>."
+
+version="\
+GNU config.sub ($timestamp)
+
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+
+This is free software; see the source for copying conditions. There is NO
+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
+
+help="
+Try \`$me --help' for more information."
+
+# Parse command line
+while test $# -gt 0 ; do
+ case $1 in
+ --time-stamp | --time* | -t )
+ echo "$timestamp" ; exit ;;
+ --version | -v )
+ echo "$version" ; exit ;;
+ --help | --h* | -h )
+ echo "$usage"; exit ;;
+ -- ) # Stop option processing
+ shift; break ;;
+ - ) # Use stdin as input.
+ break ;;
+ -* )
+ echo "$me: invalid option $1$help"
+ exit 1 ;;
+
+ *local*)
+ # First pass through any local machine types.
+ echo $1
+ exit ;;
+
+ * )
+ break ;;
+ esac
+done
+
+case $# in
+ 0) echo "$me: missing argument$help" >&2
+ exit 1;;
+ 1) ;;
+ *) echo "$me: too many arguments$help" >&2
+ exit 1;;
+esac
+
+# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).
+# Here we must recognize all the valid KERNEL-OS combinations.
+maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
+case $maybe_os in
+ nto-qnx* | linux-gnu* | linux-dietlibc | linux-newlib* | linux-uclibc* | \
+ uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | \
+ kopensolaris*-gnu* | \
+ storm-chaos* | os2-emx* | rtmk-nova*)
+ os=-$maybe_os
+ basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
+ ;;
+ *)
+ basic_machine=`echo $1 | sed 's/-[^-]*$//'`
+ if [ $basic_machine != $1 ]
+ then os=`echo $1 | sed 's/.*-/-/'`
+ else os=; fi
+ ;;
+esac
+
+### Let's recognize common machines as not being operating systems so
+### that things like config.sub decstation-3100 work. We also
+### recognize some manufacturers as not being operating systems, so we
+### can provide default operating systems below.
+case $os in
+ -sun*os*)
+ # Prevent following clause from handling this invalid input.
+ ;;
+ -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \
+ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \
+ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
+ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
+ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
+ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
+ -apple | -axis | -knuth | -cray | -microblaze)
+ os=
+ basic_machine=$1
+ ;;
+ -bluegene*)
+ os=-cnk
+ ;;
+ -sim | -cisco | -oki | -wec | -winbond)
+ os=
+ basic_machine=$1
+ ;;
+ -scout)
+ ;;
+ -wrs)
+ os=-vxworks
+ basic_machine=$1
+ ;;
+ -chorusos*)
+ os=-chorusos
+ basic_machine=$1
+ ;;
+ -chorusrdb)
+ os=-chorusrdb
+ basic_machine=$1
+ ;;
+ -hiux*)
+ os=-hiuxwe2
+ ;;
+ -sco6)
+ os=-sco5v6
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco5)
+ os=-sco3.2v5
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco4)
+ os=-sco3.2v4
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco3.2.[4-9]*)
+ os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco3.2v[4-9]*)
+ # Don't forget version if it is 3.2v4 or newer.
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco5v6*)
+ # Don't forget version if it is 3.2v4 or newer.
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco*)
+ os=-sco3.2v2
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -udk*)
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -isc)
+ os=-isc2.2
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -clix*)
+ basic_machine=clipper-intergraph
+ ;;
+ -isc*)
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -lynx*)
+ os=-lynxos
+ ;;
+ -ptx*)
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`
+ ;;
+ -windowsnt*)
+ os=`echo $os | sed -e 's/windowsnt/winnt/'`
+ ;;
+ -psos*)
+ os=-psos
+ ;;
+ -mint | -mint[0-9]*)
+ basic_machine=m68k-atari
+ os=-mint
+ ;;
+esac
+
+# Decode aliases for certain CPU-COMPANY combinations.
+case $basic_machine in
+ # Recognize the basic CPU types without company name.
+ # Some are omitted here because they have special meanings below.
+ 1750a | 580 \
+ | a29k \
+ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \
+ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \
+ | am33_2.0 \
+ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \
+ | bfin \
+ | c4x | clipper \
+ | d10v | d30v | dlx | dsp16xx \
+ | fido | fr30 | frv \
+ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
+ | i370 | i860 | i960 | ia64 \
+ | ip2k | iq2000 \
+ | lm32 \
+ | m32c | m32r | m32rle | m68000 | m68k | m88k \
+ | maxq | mb | microblaze | mcore | mep | metag \
+ | mips | mipsbe | mipseb | mipsel | mipsle \
+ | mips16 \
+ | mips64 | mips64el \
+ | mips64octeon | mips64octeonel \
+ | mips64orion | mips64orionel \
+ | mips64r5900 | mips64r5900el \
+ | mips64vr | mips64vrel \
+ | mips64vr4100 | mips64vr4100el \
+ | mips64vr4300 | mips64vr4300el \
+ | mips64vr5000 | mips64vr5000el \
+ | mips64vr5900 | mips64vr5900el \
+ | mipsisa32 | mipsisa32el \
+ | mipsisa32r2 | mipsisa32r2el \
+ | mipsisa64 | mipsisa64el \
+ | mipsisa64r2 | mipsisa64r2el \
+ | mipsisa64sb1 | mipsisa64sb1el \
+ | mipsisa64sr71k | mipsisa64sr71kel \
+ | mipstx39 | mipstx39el \
+ | mn10200 | mn10300 \
+ | moxie \
+ | mt \
+ | msp430 \
+ | nios | nios2 \
+ | ns16k | ns32k \
+ | or32 \
+ | pdp10 | pdp11 | pj | pjl \
+ | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \
+ | pyramid \
+ | rx \
+ | score \
+ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \
+ | sh64 | sh64le \
+ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \
+ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \
+ | spu | strongarm \
+ | tahoe | thumb | tic4x | tic80 | tron \
+ | ubicom32 \
+ | v850 | v850e \
+ | we32k \
+ | x86 | xc16x | xscale | xscalee[bl] | xstormy16 | xtensa \
+ | z8k | z80)
+ basic_machine=$basic_machine-unknown
+ ;;
+ m6811 | m68hc11 | m6812 | m68hc12 | picochip)
+ # Motorola 68HC11/12.
+ basic_machine=$basic_machine-unknown
+ os=-none
+ ;;
+ m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
+ ;;
+ ms1)
+ basic_machine=mt-unknown
+ ;;
+
+ # We use `pc' rather than `unknown'
+ # because (1) that's what they normally are, and
+ # (2) the word "unknown" tends to confuse beginning users.
+ i*86 | x86_64)
+ basic_machine=$basic_machine-pc
+ ;;
+ # Object if more than one company name word.
+ *-*-*)
+ echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
+ exit 1
+ ;;
+ # Recognize the basic CPU types with company name.
+ 580-* \
+ | a29k-* \
+ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \
+ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \
+ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \
+ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \
+ | avr-* | avr32-* \
+ | bfin-* | bs2000-* \
+ | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \
+ | clipper-* | craynv-* | cydra-* \
+ | d10v-* | d30v-* | dlx-* \
+ | elxsi-* \
+ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \
+ | h8300-* | h8500-* \
+ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \
+ | i*86-* | i860-* | i960-* | ia64-* \
+ | ip2k-* | iq2000-* \
+ | lm32-* \
+ | m32c-* | m32r-* | m32rle-* \
+ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \
+ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \
+ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \
+ | mips16-* \
+ | mips64-* | mips64el-* \
+ | mips64octeon-* | mips64octeonel-* \
+ | mips64orion-* | mips64orionel-* \
+ | mips64r5900-* | mips64r5900el-* \
+ | mips64vr-* | mips64vrel-* \
+ | mips64vr4100-* | mips64vr4100el-* \
+ | mips64vr4300-* | mips64vr4300el-* \
+ | mips64vr5000-* | mips64vr5000el-* \
+ | mips64vr5900-* | mips64vr5900el-* \
+ | mipsisa32-* | mipsisa32el-* \
+ | mipsisa32r2-* | mipsisa32r2el-* \
+ | mipsisa64-* | mipsisa64el-* \
+ | mipsisa64r2-* | mipsisa64r2el-* \
+ | mipsisa64sb1-* | mipsisa64sb1el-* \
+ | mipsisa64sr71k-* | mipsisa64sr71kel-* \
+ | mipstx39-* | mipstx39el-* \
+ | mmix-* \
+ | mt-* \
+ | msp430-* \
+ | nios-* | nios2-* \
+ | none-* | np1-* | ns16k-* | ns32k-* \
+ | orion-* \
+ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \
+ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \
+ | pyramid-* \
+ | romp-* | rs6000-* | rx-* \
+ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \
+ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \
+ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \
+ | sparclite-* \
+ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | strongarm-* | sv1-* | sx?-* \
+ | tahoe-* | thumb-* \
+ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* | tile-* \
+ | tron-* \
+ | ubicom32-* \
+ | v850-* | v850e-* | vax-* \
+ | we32k-* \
+ | x86-* | x86_64-* | xc16x-* | xps100-* | xscale-* | xscalee[bl]-* \
+ | xstormy16-* | xtensa*-* \
+ | ymp-* \
+ | z8k-* | z80-*)
+ ;;
+ # Recognize the basic CPU types without company name, with glob match.
+ xtensa*)
+ basic_machine=$basic_machine-unknown
+ ;;
+ # Recognize the various machine names and aliases which stand
+ # for a CPU type and a company and sometimes even an OS.
+ 386bsd)
+ basic_machine=i386-unknown
+ os=-bsd
+ ;;
+ 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)
+ basic_machine=m68000-att
+ ;;
+ 3b*)
+ basic_machine=we32k-att
+ ;;
+ a29khif)
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
+ abacus)
+ basic_machine=abacus-unknown
+ ;;
+ adobe68k)
+ basic_machine=m68010-adobe
+ os=-scout
+ ;;
+ alliant | fx80)
+ basic_machine=fx80-alliant
+ ;;
+ altos | altos3068)
+ basic_machine=m68k-altos
+ ;;
+ am29k)
+ basic_machine=a29k-none
+ os=-bsd
+ ;;
+ amd64)
+ basic_machine=x86_64-pc
+ ;;
+ amd64-*)
+ basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ amdahl)
+ basic_machine=580-amdahl
+ os=-sysv
+ ;;
+ amiga | amiga-*)
+ basic_machine=m68k-unknown
+ ;;
+ amigaos | amigados)
+ basic_machine=m68k-unknown
+ os=-amigaos
+ ;;
+ amigaunix | amix)
+ basic_machine=m68k-unknown
+ os=-sysv4
+ ;;
+ apollo68)
+ basic_machine=m68k-apollo
+ os=-sysv
+ ;;
+ apollo68bsd)
+ basic_machine=m68k-apollo
+ os=-bsd
+ ;;
+ aros)
+ basic_machine=i386-pc
+ os=-aros
+ ;;
+ aux)
+ basic_machine=m68k-apple
+ os=-aux
+ ;;
+ balance)
+ basic_machine=ns32k-sequent
+ os=-dynix
+ ;;
+ blackfin)
+ basic_machine=bfin-unknown
+ os=-linux
+ ;;
+ blackfin-*)
+ basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'`
+ os=-linux
+ ;;
+ bluegene*)
+ basic_machine=powerpc-ibm
+ os=-cnk
+ ;;
+ c90)
+ basic_machine=c90-cray
+ os=-unicos
+ ;;
+ cegcc)
+ basic_machine=arm-unknown
+ os=-cegcc
+ ;;
+ convex-c1)
+ basic_machine=c1-convex
+ os=-bsd
+ ;;
+ convex-c2)
+ basic_machine=c2-convex
+ os=-bsd
+ ;;
+ convex-c32)
+ basic_machine=c32-convex
+ os=-bsd
+ ;;
+ convex-c34)
+ basic_machine=c34-convex
+ os=-bsd
+ ;;
+ convex-c38)
+ basic_machine=c38-convex
+ os=-bsd
+ ;;
+ cray | j90)
+ basic_machine=j90-cray
+ os=-unicos
+ ;;
+ craynv)
+ basic_machine=craynv-cray
+ os=-unicosmp
+ ;;
+ cr16)
+ basic_machine=cr16-unknown
+ os=-elf
+ ;;
+ crds | unos)
+ basic_machine=m68k-crds
+ ;;
+ crisv32 | crisv32-* | etraxfs*)
+ basic_machine=crisv32-axis
+ ;;
+ cris | cris-* | etrax*)
+ basic_machine=cris-axis
+ ;;
+ crx)
+ basic_machine=crx-unknown
+ os=-elf
+ ;;
+ da30 | da30-*)
+ basic_machine=m68k-da30
+ ;;
+ decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
+ basic_machine=mips-dec
+ ;;
+ decsystem10* | dec10*)
+ basic_machine=pdp10-dec
+ os=-tops10
+ ;;
+ decsystem20* | dec20*)
+ basic_machine=pdp10-dec
+ os=-tops20
+ ;;
+ delta | 3300 | motorola-3300 | motorola-delta \
+ | 3300-motorola | delta-motorola)
+ basic_machine=m68k-motorola
+ ;;
+ delta88)
+ basic_machine=m88k-motorola
+ os=-sysv3
+ ;;
+ dicos)
+ basic_machine=i686-pc
+ os=-dicos
+ ;;
+ djgpp)
+ basic_machine=i586-pc
+ os=-msdosdjgpp
+ ;;
+ dpx20 | dpx20-*)
+ basic_machine=rs6000-bull
+ os=-bosx
+ ;;
+ dpx2* | dpx2*-bull)
+ basic_machine=m68k-bull
+ os=-sysv3
+ ;;
+ ebmon29k)
+ basic_machine=a29k-amd
+ os=-ebmon
+ ;;
+ elxsi)
+ basic_machine=elxsi-elxsi
+ os=-bsd
+ ;;
+ encore | umax | mmax)
+ basic_machine=ns32k-encore
+ ;;
+ es1800 | OSE68k | ose68k | ose | OSE)
+ basic_machine=m68k-ericsson
+ os=-ose
+ ;;
+ fx2800)
+ basic_machine=i860-alliant
+ ;;
+ genix)
+ basic_machine=ns32k-ns
+ ;;
+ gmicro)
+ basic_machine=tron-gmicro
+ os=-sysv
+ ;;
+ go32)
+ basic_machine=i386-pc
+ os=-go32
+ ;;
+ h3050r* | hiux*)
+ basic_machine=hppa1.1-hitachi
+ os=-hiuxwe2
+ ;;
+ h8300hms)
+ basic_machine=h8300-hitachi
+ os=-hms
+ ;;
+ h8300xray)
+ basic_machine=h8300-hitachi
+ os=-xray
+ ;;
+ h8500hms)
+ basic_machine=h8500-hitachi
+ os=-hms
+ ;;
+ harris)
+ basic_machine=m88k-harris
+ os=-sysv3
+ ;;
+ hp300-*)
+ basic_machine=m68k-hp
+ ;;
+ hp300bsd)
+ basic_machine=m68k-hp
+ os=-bsd
+ ;;
+ hp300hpux)
+ basic_machine=m68k-hp
+ os=-hpux
+ ;;
+ hp3k9[0-9][0-9] | hp9[0-9][0-9])
+ basic_machine=hppa1.0-hp
+ ;;
+ hp9k2[0-9][0-9] | hp9k31[0-9])
+ basic_machine=m68000-hp
+ ;;
+ hp9k3[2-9][0-9])
+ basic_machine=m68k-hp
+ ;;
+ hp9k6[0-9][0-9] | hp6[0-9][0-9])
+ basic_machine=hppa1.0-hp
+ ;;
+ hp9k7[0-79][0-9] | hp7[0-79][0-9])
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k78[0-9] | hp78[0-9])
+ # FIXME: really hppa2.0-hp
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893)
+ # FIXME: really hppa2.0-hp
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k8[0-9][13679] | hp8[0-9][13679])
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k8[0-9][0-9] | hp8[0-9][0-9])
+ basic_machine=hppa1.0-hp
+ ;;
+ hppa-next)
+ os=-nextstep3
+ ;;
+ hppaosf)
+ basic_machine=hppa1.1-hp
+ os=-osf
+ ;;
+ hppro)
+ basic_machine=hppa1.1-hp
+ os=-proelf
+ ;;
+ i370-ibm* | ibm*)
+ basic_machine=i370-ibm
+ ;;
+# I'm not sure what "Sysv32" means. Should this be sysv3.2?
+ i*86v32)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-sysv32
+ ;;
+ i*86v4*)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-sysv4
+ ;;
+ i*86v)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-sysv
+ ;;
+ i*86sol2)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-solaris2
+ ;;
+ i386mach)
+ basic_machine=i386-mach
+ os=-mach
+ ;;
+ i386-vsta | vsta)
+ basic_machine=i386-unknown
+ os=-vsta
+ ;;
+ iris | iris4d)
+ basic_machine=mips-sgi
+ case $os in
+ -irix*)
+ ;;
+ *)
+ os=-irix4
+ ;;
+ esac
+ ;;
+ isi68 | isi)
+ basic_machine=m68k-isi
+ os=-sysv
+ ;;
+ m68knommu)
+ basic_machine=m68k-unknown
+ os=-linux
+ ;;
+ m68knommu-*)
+ basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'`
+ os=-linux
+ ;;
+ m88k-omron*)
+ basic_machine=m88k-omron
+ ;;
+ magnum | m3230)
+ basic_machine=mips-mips
+ os=-sysv
+ ;;
+ merlin)
+ basic_machine=ns32k-utek
+ os=-sysv
+ ;;
+ microblaze)
+ basic_machine=microblaze-xilinx
+ ;;
+ mingw32)
+ basic_machine=i386-pc
+ os=-mingw32
+ ;;
+ mingw32ce)
+ basic_machine=arm-unknown
+ os=-mingw32ce
+ ;;
+ miniframe)
+ basic_machine=m68000-convergent
+ ;;
+ *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*)
+ basic_machine=m68k-atari
+ os=-mint
+ ;;
+ mips3*-*)
+ basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
+ ;;
+ mips3*)
+ basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
+ ;;
+ monitor)
+ basic_machine=m68k-rom68k
+ os=-coff
+ ;;
+ morphos)
+ basic_machine=powerpc-unknown
+ os=-morphos
+ ;;
+ msdos)
+ basic_machine=i386-pc
+ os=-msdos
+ ;;
+ ms1-*)
+ basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'`
+ ;;
+ mvs)
+ basic_machine=i370-ibm
+ os=-mvs
+ ;;
+ ncr3000)
+ basic_machine=i486-ncr
+ os=-sysv4
+ ;;
+ netbsd386)
+ basic_machine=i386-unknown
+ os=-netbsd
+ ;;
+ netwinder)
+ basic_machine=armv4l-rebel
+ os=-linux
+ ;;
+ news | news700 | news800 | news900)
+ basic_machine=m68k-sony
+ os=-newsos
+ ;;
+ news1000)
+ basic_machine=m68030-sony
+ os=-newsos
+ ;;
+ news-3600 | risc-news)
+ basic_machine=mips-sony
+ os=-newsos
+ ;;
+ necv70)
+ basic_machine=v70-nec
+ os=-sysv
+ ;;
+ next | m*-next )
+ basic_machine=m68k-next
+ case $os in
+ -nextstep* )
+ ;;
+ -ns2*)
+ os=-nextstep2
+ ;;
+ *)
+ os=-nextstep3
+ ;;
+ esac
+ ;;
+ nh3000)
+ basic_machine=m68k-harris
+ os=-cxux
+ ;;
+ nh[45]000)
+ basic_machine=m88k-harris
+ os=-cxux
+ ;;
+ nindy960)
+ basic_machine=i960-intel
+ os=-nindy
+ ;;
+ mon960)
+ basic_machine=i960-intel
+ os=-mon960
+ ;;
+ nonstopux)
+ basic_machine=mips-compaq
+ os=-nonstopux
+ ;;
+ np1)
+ basic_machine=np1-gould
+ ;;
+ nsr-tandem)
+ basic_machine=nsr-tandem
+ ;;
+ op50n-* | op60c-*)
+ basic_machine=hppa1.1-oki
+ os=-proelf
+ ;;
+ openrisc | openrisc-*)
+ basic_machine=or32-unknown
+ ;;
+ os400)
+ basic_machine=powerpc-ibm
+ os=-os400
+ ;;
+ OSE68000 | ose68000)
+ basic_machine=m68000-ericsson
+ os=-ose
+ ;;
+ os68k)
+ basic_machine=m68k-none
+ os=-os68k
+ ;;
+ pa-hitachi)
+ basic_machine=hppa1.1-hitachi
+ os=-hiuxwe2
+ ;;
+ paragon)
+ basic_machine=i860-intel
+ os=-osf
+ ;;
+ parisc)
+ basic_machine=hppa-unknown
+ os=-linux
+ ;;
+ parisc-*)
+ basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'`
+ os=-linux
+ ;;
+ pbd)
+ basic_machine=sparc-tti
+ ;;
+ pbb)
+ basic_machine=m68k-tti
+ ;;
+ pc532 | pc532-*)
+ basic_machine=ns32k-pc532
+ ;;
+ pc98)
+ basic_machine=i386-pc
+ ;;
+ pc98-*)
+ basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentium | p5 | k5 | k6 | nexgen | viac3)
+ basic_machine=i586-pc
+ ;;
+ pentiumpro | p6 | 6x86 | athlon | athlon_*)
+ basic_machine=i686-pc
+ ;;
+ pentiumii | pentium2 | pentiumiii | pentium3)
+ basic_machine=i686-pc
+ ;;
+ pentium4)
+ basic_machine=i786-pc
+ ;;
+ pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)
+ basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentiumpro-* | p6-* | 6x86-* | athlon-*)
+ basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)
+ basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentium4-*)
+ basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pn)
+ basic_machine=pn-gould
+ ;;
+ power) basic_machine=power-ibm
+ ;;
+ ppc) basic_machine=powerpc-unknown
+ ;;
+ ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppcle | powerpclittle | ppc-le | powerpc-little)
+ basic_machine=powerpcle-unknown
+ ;;
+ ppcle-* | powerpclittle-*)
+ basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppc64) basic_machine=powerpc64-unknown
+ ;;
+ ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppc64le | powerpc64little | ppc64-le | powerpc64-little)
+ basic_machine=powerpc64le-unknown
+ ;;
+ ppc64le-* | powerpc64little-*)
+ basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ps2)
+ basic_machine=i386-ibm
+ ;;
+ pw32)
+ basic_machine=i586-unknown
+ os=-pw32
+ ;;
+ rdos)
+ basic_machine=i386-pc
+ os=-rdos
+ ;;
+ rom68k)
+ basic_machine=m68k-rom68k
+ os=-coff
+ ;;
+ rm[46]00)
+ basic_machine=mips-siemens
+ ;;
+ rtpc | rtpc-*)
+ basic_machine=romp-ibm
+ ;;
+ s390 | s390-*)
+ basic_machine=s390-ibm
+ ;;
+ s390x | s390x-*)
+ basic_machine=s390x-ibm
+ ;;
+ sa29200)
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
+ sb1)
+ basic_machine=mipsisa64sb1-unknown
+ ;;
+ sb1el)
+ basic_machine=mipsisa64sb1el-unknown
+ ;;
+ sde)
+ basic_machine=mipsisa32-sde
+ os=-elf
+ ;;
+ sei)
+ basic_machine=mips-sei
+ os=-seiux
+ ;;
+ sequent)
+ basic_machine=i386-sequent
+ ;;
+ sh)
+ basic_machine=sh-hitachi
+ os=-hms
+ ;;
+ sh5el)
+ basic_machine=sh5le-unknown
+ ;;
+ sh64)
+ basic_machine=sh64-unknown
+ ;;
+ sparclite-wrs | simso-wrs)
+ basic_machine=sparclite-wrs
+ os=-vxworks
+ ;;
+ sps7)
+ basic_machine=m68k-bull
+ os=-sysv2
+ ;;
+ spur)
+ basic_machine=spur-unknown
+ ;;
+ st2000)
+ basic_machine=m68k-tandem
+ ;;
+ stratus)
+ basic_machine=i860-stratus
+ os=-sysv4
+ ;;
+ sun2)
+ basic_machine=m68000-sun
+ ;;
+ sun2os3)
+ basic_machine=m68000-sun
+ os=-sunos3
+ ;;
+ sun2os4)
+ basic_machine=m68000-sun
+ os=-sunos4
+ ;;
+ sun3os3)
+ basic_machine=m68k-sun
+ os=-sunos3
+ ;;
+ sun3os4)
+ basic_machine=m68k-sun
+ os=-sunos4
+ ;;
+ sun4os3)
+ basic_machine=sparc-sun
+ os=-sunos3
+ ;;
+ sun4os4)
+ basic_machine=sparc-sun
+ os=-sunos4
+ ;;
+ sun4sol2)
+ basic_machine=sparc-sun
+ os=-solaris2
+ ;;
+ sun3 | sun3-*)
+ basic_machine=m68k-sun
+ ;;
+ sun4)
+ basic_machine=sparc-sun
+ ;;
+ sun386 | sun386i | roadrunner)
+ basic_machine=i386-sun
+ ;;
+ sv1)
+ basic_machine=sv1-cray
+ os=-unicos
+ ;;
+ symmetry)
+ basic_machine=i386-sequent
+ os=-dynix
+ ;;
+ t3e)
+ basic_machine=alphaev5-cray
+ os=-unicos
+ ;;
+ t90)
+ basic_machine=t90-cray
+ os=-unicos
+ ;;
+ tic54x | c54x*)
+ basic_machine=tic54x-unknown
+ os=-coff
+ ;;
+ tic55x | c55x*)
+ basic_machine=tic55x-unknown
+ os=-coff
+ ;;
+ tic6x | c6x*)
+ basic_machine=tic6x-unknown
+ os=-coff
+ ;;
+ tile*)
+ basic_machine=tile-unknown
+ os=-linux-gnu
+ ;;
+ tx39)
+ basic_machine=mipstx39-unknown
+ ;;
+ tx39el)
+ basic_machine=mipstx39el-unknown
+ ;;
+ toad1)
+ basic_machine=pdp10-xkl
+ os=-tops20
+ ;;
+ tower | tower-32)
+ basic_machine=m68k-ncr
+ ;;
+ tpf)
+ basic_machine=s390x-ibm
+ os=-tpf
+ ;;
+ udi29k)
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
+ ultra3)
+ basic_machine=a29k-nyu
+ os=-sym1
+ ;;
+ v810 | necv810)
+ basic_machine=v810-nec
+ os=-none
+ ;;
+ vaxv)
+ basic_machine=vax-dec
+ os=-sysv
+ ;;
+ vms)
+ basic_machine=vax-dec
+ os=-vms
+ ;;
+ vpp*|vx|vx-*)
+ basic_machine=f301-fujitsu
+ ;;
+ vxworks960)
+ basic_machine=i960-wrs
+ os=-vxworks
+ ;;
+ vxworks68)
+ basic_machine=m68k-wrs
+ os=-vxworks
+ ;;
+ vxworks29k)
+ basic_machine=a29k-wrs
+ os=-vxworks
+ ;;
+ w65*)
+ basic_machine=w65-wdc
+ os=-none
+ ;;
+ w89k-*)
+ basic_machine=hppa1.1-winbond
+ os=-proelf
+ ;;
+ xbox)
+ basic_machine=i686-pc
+ os=-mingw32
+ ;;
+ xps | xps100)
+ basic_machine=xps100-honeywell
+ ;;
+ ymp)
+ basic_machine=ymp-cray
+ os=-unicos
+ ;;
+ z8k-*-coff)
+ basic_machine=z8k-unknown
+ os=-sim
+ ;;
+ z80-*-coff)
+ basic_machine=z80-unknown
+ os=-sim
+ ;;
+ none)
+ basic_machine=none-none
+ os=-none
+ ;;
+
+# Here we handle the default manufacturer of certain CPU types. It is in
+# some cases the only manufacturer, in others, it is the most popular.
+ w89k)
+ basic_machine=hppa1.1-winbond
+ ;;
+ op50n)
+ basic_machine=hppa1.1-oki
+ ;;
+ op60c)
+ basic_machine=hppa1.1-oki
+ ;;
+ romp)
+ basic_machine=romp-ibm
+ ;;
+ mmix)
+ basic_machine=mmix-knuth
+ ;;
+ rs6000)
+ basic_machine=rs6000-ibm
+ ;;
+ vax)
+ basic_machine=vax-dec
+ ;;
+ pdp10)
+ # there are many clones, so DEC is not a safe bet
+ basic_machine=pdp10-unknown
+ ;;
+ pdp11)
+ basic_machine=pdp11-dec
+ ;;
+ we32k)
+ basic_machine=we32k-att
+ ;;
+ sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele)
+ basic_machine=sh-unknown
+ ;;
+ sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v)
+ basic_machine=sparc-sun
+ ;;
+ cydra)
+ basic_machine=cydra-cydrome
+ ;;
+ orion)
+ basic_machine=orion-highlevel
+ ;;
+ orion105)
+ basic_machine=clipper-highlevel
+ ;;
+ mac | mpw | mac-mpw)
+ basic_machine=m68k-apple
+ ;;
+ pmac | pmac-mpw)
+ basic_machine=powerpc-apple
+ ;;
+ *-unknown)
+ # Make sure to match an already-canonicalized machine name.
+ ;;
+ *)
+ echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
+ exit 1
+ ;;
+esac
+
+# Here we canonicalize certain aliases for manufacturers.
+case $basic_machine in
+ *-digital*)
+ basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`
+ ;;
+ *-commodore*)
+ basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`
+ ;;
+ *)
+ ;;
+esac
+
+# Decode manufacturer-specific aliases for certain operating systems.
+
+if [ x"$os" != x"" ]
+then
+case $os in
+ # First match some system type aliases
+ # that might get confused with valid system types.
+ # -solaris* is a basic system type, with this one exception.
+ -auroraux)
+ os=-auroraux
+ ;;
+ -solaris1 | -solaris1.*)
+ os=`echo $os | sed -e 's|solaris1|sunos4|'`
+ ;;
+ -solaris)
+ os=-solaris2
+ ;;
+ -svr4*)
+ os=-sysv4
+ ;;
+ -unixware*)
+ os=-sysv4.2uw
+ ;;
+ -gnu/linux*)
+ os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`
+ ;;
+ # First accept the basic system types.
+ # The portable systems comes first.
+ # Each alternative MUST END IN A *, to match a version number.
+ # -sysv* is not here because it comes later, after sysvr4.
+ -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
+ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\
+ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \
+ | -sym* | -kopensolaris* \
+ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \
+ | -aos* | -aros* \
+ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
+ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
+ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \
+ | -openbsd* | -solidbsd* \
+ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \
+ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
+ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
+ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
+ | -chorusos* | -chorusrdb* | -cegcc* \
+ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
+ | -mingw32* | -linux-gnu* | -linux-newlib* | -linux-uclibc* \
+ | -uxpv* | -beos* | -mpeix* | -udk* \
+ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \
+ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
+ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \
+ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \
+ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \
+ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \
+ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*)
+ # Remember, each alternative MUST END IN *, to match a version number.
+ ;;
+ -qnx*)
+ case $basic_machine in
+ x86-* | i*86-*)
+ ;;
+ *)
+ os=-nto$os
+ ;;
+ esac
+ ;;
+ -nto-qnx*)
+ ;;
+ -nto*)
+ os=`echo $os | sed -e 's|nto|nto-qnx|'`
+ ;;
+ -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
+ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \
+ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)
+ ;;
+ -mac*)
+ os=`echo $os | sed -e 's|mac|macos|'`
+ ;;
+ -linux-dietlibc)
+ os=-linux-dietlibc
+ ;;
+ -linux*)
+ os=`echo $os | sed -e 's|linux|linux-gnu|'`
+ ;;
+ -sunos5*)
+ os=`echo $os | sed -e 's|sunos5|solaris2|'`
+ ;;
+ -sunos6*)
+ os=`echo $os | sed -e 's|sunos6|solaris3|'`
+ ;;
+ -opened*)
+ os=-openedition
+ ;;
+ -os400*)
+ os=-os400
+ ;;
+ -wince*)
+ os=-wince
+ ;;
+ -osfrose*)
+ os=-osfrose
+ ;;
+ -osf*)
+ os=-osf
+ ;;
+ -utek*)
+ os=-bsd
+ ;;
+ -dynix*)
+ os=-bsd
+ ;;
+ -acis*)
+ os=-aos
+ ;;
+ -atheos*)
+ os=-atheos
+ ;;
+ -syllable*)
+ os=-syllable
+ ;;
+ -386bsd)
+ os=-bsd
+ ;;
+ -ctix* | -uts*)
+ os=-sysv
+ ;;
+ -nova*)
+ os=-rtmk-nova
+ ;;
+ -ns2 )
+ os=-nextstep2
+ ;;
+ -nsk*)
+ os=-nsk
+ ;;
+ # Preserve the version number of sinix5.
+ -sinix5.*)
+ os=`echo $os | sed -e 's|sinix|sysv|'`
+ ;;
+ -sinix*)
+ os=-sysv4
+ ;;
+ -tpf*)
+ os=-tpf
+ ;;
+ -triton*)
+ os=-sysv3
+ ;;
+ -oss*)
+ os=-sysv3
+ ;;
+ -svr4)
+ os=-sysv4
+ ;;
+ -svr3)
+ os=-sysv3
+ ;;
+ -sysvr4)
+ os=-sysv4
+ ;;
+ # This must come after -sysvr4.
+ -sysv*)
+ ;;
+ -ose*)
+ os=-ose
+ ;;
+ -es1800*)
+ os=-ose
+ ;;
+ -xenix)
+ os=-xenix
+ ;;
+ -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
+ os=-mint
+ ;;
+ -aros*)
+ os=-aros
+ ;;
+ -kaos*)
+ os=-kaos
+ ;;
+ -zvmoe)
+ os=-zvmoe
+ ;;
+ -dicos*)
+ os=-dicos
+ ;;
+ -none)
+ ;;
+ *)
+ # Get rid of the `-' at the beginning of $os.
+ os=`echo $os | sed 's/[^-]*-//'`
+ echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2
+ exit 1
+ ;;
+esac
+else
+
+# Here we handle the default operating systems that come with various machines.
+# The value should be what the vendor currently ships out the door with their
+# machine or put another way, the most popular os provided with the machine.
+
+# Note that if you're going to try to match "-MANUFACTURER" here (say,
+# "-sun"), then you have to tell the case statement up towards the top
+# that MANUFACTURER isn't an operating system. Otherwise, code above
+# will signal an error saying that MANUFACTURER isn't an operating
+# system, and we'll never get to this point.
+
+case $basic_machine in
+ score-*)
+ os=-elf
+ ;;
+ spu-*)
+ os=-elf
+ ;;
+ *-acorn)
+ os=-riscix1.2
+ ;;
+ arm*-rebel)
+ os=-linux
+ ;;
+ arm*-semi)
+ os=-aout
+ ;;
+ c4x-* | tic4x-*)
+ os=-coff
+ ;;
+ # This must come before the *-dec entry.
+ pdp10-*)
+ os=-tops20
+ ;;
+ pdp11-*)
+ os=-none
+ ;;
+ *-dec | vax-*)
+ os=-ultrix4.2
+ ;;
+ m68*-apollo)
+ os=-domain
+ ;;
+ i386-sun)
+ os=-sunos4.0.2
+ ;;
+ m68000-sun)
+ os=-sunos3
+ # This also exists in the configure program, but was not the
+ # default.
+ # os=-sunos4
+ ;;
+ m68*-cisco)
+ os=-aout
+ ;;
+ mep-*)
+ os=-elf
+ ;;
+ mips*-cisco)
+ os=-elf
+ ;;
+ mips*-*)
+ os=-elf
+ ;;
+ or32-*)
+ os=-coff
+ ;;
+ *-tti) # must be before sparc entry or we get the wrong os.
+ os=-sysv3
+ ;;
+ sparc-* | *-sun)
+ os=-sunos4.1.1
+ ;;
+ *-be)
+ os=-beos
+ ;;
+ *-haiku)
+ os=-haiku
+ ;;
+ *-ibm)
+ os=-aix
+ ;;
+ *-knuth)
+ os=-mmixware
+ ;;
+ *-wec)
+ os=-proelf
+ ;;
+ *-winbond)
+ os=-proelf
+ ;;
+ *-oki)
+ os=-proelf
+ ;;
+ *-hp)
+ os=-hpux
+ ;;
+ *-hitachi)
+ os=-hiux
+ ;;
+ i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)
+ os=-sysv
+ ;;
+ *-cbm)
+ os=-amigaos
+ ;;
+ *-dg)
+ os=-dgux
+ ;;
+ *-dolphin)
+ os=-sysv3
+ ;;
+ m68k-ccur)
+ os=-rtu
+ ;;
+ m88k-omron*)
+ os=-luna
+ ;;
+ *-next )
+ os=-nextstep
+ ;;
+ *-sequent)
+ os=-ptx
+ ;;
+ *-crds)
+ os=-unos
+ ;;
+ *-ns)
+ os=-genix
+ ;;
+ i370-*)
+ os=-mvs
+ ;;
+ *-next)
+ os=-nextstep3
+ ;;
+ *-gould)
+ os=-sysv
+ ;;
+ *-highlevel)
+ os=-bsd
+ ;;
+ *-encore)
+ os=-bsd
+ ;;
+ *-sgi)
+ os=-irix
+ ;;
+ *-siemens)
+ os=-sysv4
+ ;;
+ *-masscomp)
+ os=-rtu
+ ;;
+ f30[01]-fujitsu | f700-fujitsu)
+ os=-uxpv
+ ;;
+ *-rom68k)
+ os=-coff
+ ;;
+ *-*bug)
+ os=-coff
+ ;;
+ *-apple)
+ os=-macos
+ ;;
+ *-atari*)
+ os=-mint
+ ;;
+ *)
+ os=-none
+ ;;
+esac
+fi
+
+# Here we handle the case where we know the os, and the CPU type, but not the
+# manufacturer. We pick the logical manufacturer.
+vendor=unknown
+case $basic_machine in
+ *-unknown)
+ case $os in
+ -riscix*)
+ vendor=acorn
+ ;;
+ -sunos*)
+ vendor=sun
+ ;;
+ -cnk*|-aix*)
+ vendor=ibm
+ ;;
+ -beos*)
+ vendor=be
+ ;;
+ -hpux*)
+ vendor=hp
+ ;;
+ -mpeix*)
+ vendor=hp
+ ;;
+ -hiux*)
+ vendor=hitachi
+ ;;
+ -unos*)
+ vendor=crds
+ ;;
+ -dgux*)
+ vendor=dg
+ ;;
+ -luna*)
+ vendor=omron
+ ;;
+ -genix*)
+ vendor=ns
+ ;;
+ -mvs* | -opened*)
+ vendor=ibm
+ ;;
+ -os400*)
+ vendor=ibm
+ ;;
+ -ptx*)
+ vendor=sequent
+ ;;
+ -tpf*)
+ vendor=ibm
+ ;;
+ -vxsim* | -vxworks* | -windiss*)
+ vendor=wrs
+ ;;
+ -aux*)
+ vendor=apple
+ ;;
+ -hms*)
+ vendor=hitachi
+ ;;
+ -mpw* | -macos*)
+ vendor=apple
+ ;;
+ -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
+ vendor=atari
+ ;;
+ -vos*)
+ vendor=stratus
+ ;;
+ esac
+ basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
+ ;;
+esac
+
+echo $basic_machine$os
+exit
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "timestamp='"
+# time-stamp-format: "%:y-%02m-%02d"
+# time-stamp-end: "'"
+# End:
diff --git a/config.aux/install-sh b/config.aux/install-sh
new file mode 100755
index 0000000..6781b98
--- /dev/null
+++ b/config.aux/install-sh
@@ -0,0 +1,520 @@
+#!/bin/sh
+# install - install a program, script, or datafile
+
+scriptversion=2009-04-28.21; # UTC
+
+# This originates from X11R5 (mit/util/scripts/install.sh), which was
+# later released in X11R6 (xc/config/util/install.sh) with the
+# following copyright and license.
+#
+# Copyright (C) 1994 X Consortium
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to
+# deal in the Software without restriction, including without limitation the
+# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+# sell copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in
+# all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
+# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC-
+# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+#
+# Except as contained in this notice, the name of the X Consortium shall not
+# be used in advertising or otherwise to promote the sale, use or other deal-
+# ings in this Software without prior written authorization from the X Consor-
+# tium.
+#
+#
+# FSF changes to this file are in the public domain.
+#
+# Calling this script install-sh is preferred over install.sh, to prevent
+# `make' implicit rules from creating a file called install from it
+# when there is no Makefile.
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch.
+
+nl='
+'
+IFS=" "" $nl"
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit=${DOITPROG-}
+if test -z "$doit"; then
+ doit_exec=exec
+else
+ doit_exec=$doit
+fi
+
+# Put in absolute file names if you don't have them in your path;
+# or use environment vars.
+
+chgrpprog=${CHGRPPROG-chgrp}
+chmodprog=${CHMODPROG-chmod}
+chownprog=${CHOWNPROG-chown}
+cmpprog=${CMPPROG-cmp}
+cpprog=${CPPROG-cp}
+mkdirprog=${MKDIRPROG-mkdir}
+mvprog=${MVPROG-mv}
+rmprog=${RMPROG-rm}
+stripprog=${STRIPPROG-strip}
+
+posix_glob='?'
+initialize_posix_glob='
+ test "$posix_glob" != "?" || {
+ if (set -f) 2>/dev/null; then
+ posix_glob=
+ else
+ posix_glob=:
+ fi
+ }
+'
+
+posix_mkdir=
+
+# Desired mode of installed file.
+mode=0755
+
+chgrpcmd=
+chmodcmd=$chmodprog
+chowncmd=
+mvcmd=$mvprog
+rmcmd="$rmprog -f"
+stripcmd=
+
+src=
+dst=
+dir_arg=
+dst_arg=
+
+copy_on_change=false
+no_target_directory=
+
+usage="\
+Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE
+ or: $0 [OPTION]... SRCFILES... DIRECTORY
+ or: $0 [OPTION]... -t DIRECTORY SRCFILES...
+ or: $0 [OPTION]... -d DIRECTORIES...
+
+In the 1st form, copy SRCFILE to DSTFILE.
+In the 2nd and 3rd, copy all SRCFILES to DIRECTORY.
+In the 4th, create DIRECTORIES.
+
+Options:
+ --help display this help and exit.
+ --version display version info and exit.
+
+ -c (ignored)
+ -C install only if different (preserve the last data modification time)
+ -d create directories instead of installing files.
+ -g GROUP $chgrpprog installed files to GROUP.
+ -m MODE $chmodprog installed files to MODE.
+ -o USER $chownprog installed files to USER.
+ -s $stripprog installed files.
+ -t DIRECTORY install into DIRECTORY.
+ -T report an error if DSTFILE is a directory.
+
+Environment variables override the default commands:
+ CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG
+ RMPROG STRIPPROG
+"
+
+while test $# -ne 0; do
+ case $1 in
+ -c) ;;
+
+ -C) copy_on_change=true;;
+
+ -d) dir_arg=true;;
+
+ -g) chgrpcmd="$chgrpprog $2"
+ shift;;
+
+ --help) echo "$usage"; exit $?;;
+
+ -m) mode=$2
+ case $mode in
+ *' '* | *' '* | *'
+'* | *'*'* | *'?'* | *'['*)
+ echo "$0: invalid mode: $mode" >&2
+ exit 1;;
+ esac
+ shift;;
+
+ -o) chowncmd="$chownprog $2"
+ shift;;
+
+ -s) stripcmd=$stripprog;;
+
+ -t) dst_arg=$2
+ shift;;
+
+ -T) no_target_directory=true;;
+
+ --version) echo "$0 $scriptversion"; exit $?;;
+
+ --) shift
+ break;;
+
+ -*) echo "$0: invalid option: $1" >&2
+ exit 1;;
+
+ *) break;;
+ esac
+ shift
+done
+
+if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then
+ # When -d is used, all remaining arguments are directories to create.
+ # When -t is used, the destination is already specified.
+ # Otherwise, the last argument is the destination. Remove it from $@.
+ for arg
+ do
+ if test -n "$dst_arg"; then
+ # $@ is not empty: it contains at least $arg.
+ set fnord "$@" "$dst_arg"
+ shift # fnord
+ fi
+ shift # arg
+ dst_arg=$arg
+ done
+fi
+
+if test $# -eq 0; then
+ if test -z "$dir_arg"; then
+ echo "$0: no input file specified." >&2
+ exit 1
+ fi
+ # It's OK to call `install-sh -d' without argument.
+ # This can happen when creating conditional directories.
+ exit 0
+fi
+
+if test -z "$dir_arg"; then
+ trap '(exit $?); exit' 1 2 13 15
+
+ # Set umask so as not to create temps with too-generous modes.
+ # However, 'strip' requires both read and write access to temps.
+ case $mode in
+ # Optimize common cases.
+ *644) cp_umask=133;;
+ *755) cp_umask=22;;
+
+ *[0-7])
+ if test -z "$stripcmd"; then
+ u_plus_rw=
+ else
+ u_plus_rw='% 200'
+ fi
+ cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;;
+ *)
+ if test -z "$stripcmd"; then
+ u_plus_rw=
+ else
+ u_plus_rw=,u+rw
+ fi
+ cp_umask=$mode$u_plus_rw;;
+ esac
+fi
+
+for src
+do
+ # Protect names starting with `-'.
+ case $src in
+ -*) src=./$src;;
+ esac
+
+ if test -n "$dir_arg"; then
+ dst=$src
+ dstdir=$dst
+ test -d "$dstdir"
+ dstdir_status=$?
+ else
+
+ # Waiting for this to be detected by the "$cpprog $src $dsttmp" command
+ # might cause directories to be created, which would be especially bad
+ # if $src (and thus $dsttmp) contains '*'.
+ if test ! -f "$src" && test ! -d "$src"; then
+ echo "$0: $src does not exist." >&2
+ exit 1
+ fi
+
+ if test -z "$dst_arg"; then
+ echo "$0: no destination specified." >&2
+ exit 1
+ fi
+
+ dst=$dst_arg
+ # Protect names starting with `-'.
+ case $dst in
+ -*) dst=./$dst;;
+ esac
+
+ # If destination is a directory, append the input filename; won't work
+ # if double slashes aren't ignored.
+ if test -d "$dst"; then
+ if test -n "$no_target_directory"; then
+ echo "$0: $dst_arg: Is a directory" >&2
+ exit 1
+ fi
+ dstdir=$dst
+ dst=$dstdir/`basename "$src"`
+ dstdir_status=0
+ else
+ # Prefer dirname, but fall back on a substitute if dirname fails.
+ dstdir=`
+ (dirname "$dst") 2>/dev/null ||
+ expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$dst" : 'X\(//\)[^/]' \| \
+ X"$dst" : 'X\(//\)$' \| \
+ X"$dst" : 'X\(/\)' \| . 2>/dev/null ||
+ echo X"$dst" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'
+ `
+
+ test -d "$dstdir"
+ dstdir_status=$?
+ fi
+ fi
+
+ obsolete_mkdir_used=false
+
+ if test $dstdir_status != 0; then
+ case $posix_mkdir in
+ '')
+ # Create intermediate dirs using mode 755 as modified by the umask.
+ # This is like FreeBSD 'install' as of 1997-10-28.
+ umask=`umask`
+ case $stripcmd.$umask in
+ # Optimize common cases.
+ *[2367][2367]) mkdir_umask=$umask;;
+ .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;;
+
+ *[0-7])
+ mkdir_umask=`expr $umask + 22 \
+ - $umask % 100 % 40 + $umask % 20 \
+ - $umask % 10 % 4 + $umask % 2
+ `;;
+ *) mkdir_umask=$umask,go-w;;
+ esac
+
+ # With -d, create the new directory with the user-specified mode.
+ # Otherwise, rely on $mkdir_umask.
+ if test -n "$dir_arg"; then
+ mkdir_mode=-m$mode
+ else
+ mkdir_mode=
+ fi
+
+ posix_mkdir=false
+ case $umask in
+ *[123567][0-7][0-7])
+ # POSIX mkdir -p sets u+wx bits regardless of umask, which
+ # is incompatible with FreeBSD 'install' when (umask & 300) != 0.
+ ;;
+ *)
+ tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$
+ trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0
+
+ if (umask $mkdir_umask &&
+ exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1
+ then
+ if test -z "$dir_arg" || {
+ # Check for POSIX incompatibilities with -m.
+ # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or
+ # other-writeable bit of parent directory when it shouldn't.
+ # FreeBSD 6.1 mkdir -m -p sets mode of existing directory.
+ ls_ld_tmpdir=`ls -ld "$tmpdir"`
+ case $ls_ld_tmpdir in
+ d????-?r-*) different_mode=700;;
+ d????-?--*) different_mode=755;;
+ *) false;;
+ esac &&
+ $mkdirprog -m$different_mode -p -- "$tmpdir" && {
+ ls_ld_tmpdir_1=`ls -ld "$tmpdir"`
+ test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1"
+ }
+ }
+ then posix_mkdir=:
+ fi
+ rmdir "$tmpdir/d" "$tmpdir"
+ else
+ # Remove any dirs left behind by ancient mkdir implementations.
+ rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null
+ fi
+ trap '' 0;;
+ esac;;
+ esac
+
+ if
+ $posix_mkdir && (
+ umask $mkdir_umask &&
+ $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir"
+ )
+ then :
+ else
+
+ # The umask is ridiculous, or mkdir does not conform to POSIX,
+ # or it failed possibly due to a race condition. Create the
+ # directory the slow way, step by step, checking for races as we go.
+
+ case $dstdir in
+ /*) prefix='/';;
+ -*) prefix='./';;
+ *) prefix='';;
+ esac
+
+ eval "$initialize_posix_glob"
+
+ oIFS=$IFS
+ IFS=/
+ $posix_glob set -f
+ set fnord $dstdir
+ shift
+ $posix_glob set +f
+ IFS=$oIFS
+
+ prefixes=
+
+ for d
+ do
+ test -z "$d" && continue
+
+ prefix=$prefix$d
+ if test -d "$prefix"; then
+ prefixes=
+ else
+ if $posix_mkdir; then
+ (umask=$mkdir_umask &&
+ $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break
+ # Don't fail if two instances are running concurrently.
+ test -d "$prefix" || exit 1
+ else
+ case $prefix in
+ *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;;
+ *) qprefix=$prefix;;
+ esac
+ prefixes="$prefixes '$qprefix'"
+ fi
+ fi
+ prefix=$prefix/
+ done
+
+ if test -n "$prefixes"; then
+ # Don't fail if two instances are running concurrently.
+ (umask $mkdir_umask &&
+ eval "\$doit_exec \$mkdirprog $prefixes") ||
+ test -d "$dstdir" || exit 1
+ obsolete_mkdir_used=true
+ fi
+ fi
+ fi
+
+ if test -n "$dir_arg"; then
+ { test -z "$chowncmd" || $doit $chowncmd "$dst"; } &&
+ { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } &&
+ { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false ||
+ test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1
+ else
+
+ # Make a couple of temp file names in the proper directory.
+ dsttmp=$dstdir/_inst.$$_
+ rmtmp=$dstdir/_rm.$$_
+
+ # Trap to clean up those temp files at exit.
+ trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0
+
+ # Copy the file name to the temp name.
+ (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") &&
+
+ # and set any options; do chmod last to preserve setuid bits.
+ #
+ # If any of these fail, we abort the whole thing. If we want to
+ # ignore errors from any of these, just make sure not to ignore
+ # errors from the above "$doit $cpprog $src $dsttmp" command.
+ #
+ { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } &&
+ { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } &&
+ { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } &&
+ { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } &&
+
+ # If -C, don't bother to copy if it wouldn't change the file.
+ if $copy_on_change &&
+ old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` &&
+ new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` &&
+
+ eval "$initialize_posix_glob" &&
+ $posix_glob set -f &&
+ set X $old && old=:$2:$4:$5:$6 &&
+ set X $new && new=:$2:$4:$5:$6 &&
+ $posix_glob set +f &&
+
+ test "$old" = "$new" &&
+ $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1
+ then
+ rm -f "$dsttmp"
+ else
+ # Rename the file to the real destination.
+ $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null ||
+
+ # The rename failed, perhaps because mv can't rename something else
+ # to itself, or perhaps because mv is so ancient that it does not
+ # support -f.
+ {
+ # Now remove or move aside any old file at destination location.
+ # We try this two ways since rm can't unlink itself on some
+ # systems and the destination file might be busy for other
+ # reasons. In this case, the final cleanup might fail but the new
+ # file should still install successfully.
+ {
+ test ! -f "$dst" ||
+ $doit $rmcmd -f "$dst" 2>/dev/null ||
+ { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null &&
+ { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }
+ } ||
+ { echo "$0: cannot unlink or rename $dst" >&2
+ (exit 1); exit 1
+ }
+ } &&
+
+ # Now rename the file to the real destination.
+ $doit $mvcmd "$dsttmp" "$dst"
+ }
+ fi || exit 1
+
+ trap '' 0
+ fi
+done
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "scriptversion="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-time-zone: "UTC"
+# time-stamp-end: "; # UTC"
+# End:
diff --git a/config.aux/ltmain.sh b/config.aux/ltmain.sh
new file mode 100755
index 0000000..3061e3c
--- /dev/null
+++ b/config.aux/ltmain.sh
@@ -0,0 +1,9636 @@
+
+# libtool (GNU libtool) 2.4
+# Written by Gordon Matzigkeit <gord@gnu.ai.mit.edu>, 1996
+
+# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2005, 2006,
+# 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+# This is free software; see the source for copying conditions. There is NO
+# warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+# GNU Libtool is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# As a special exception to the GNU General Public License,
+# if you distribute this file as part of a program or library that
+# is built using GNU Libtool, you may include this file under the
+# same distribution terms that you use for the rest of that program.
+#
+# GNU Libtool is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GNU Libtool; see the file COPYING. If not, a copy
+# can be downloaded from http://www.gnu.org/licenses/gpl.html,
+# or obtained by writing to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+# Usage: $progname [OPTION]... [MODE-ARG]...
+#
+# Provide generalized library-building support services.
+#
+# --config show all configuration variables
+# --debug enable verbose shell tracing
+# -n, --dry-run display commands without modifying any files
+# --features display basic configuration information and exit
+# --mode=MODE use operation mode MODE
+# --preserve-dup-deps don't remove duplicate dependency libraries
+# --quiet, --silent don't print informational messages
+# --no-quiet, --no-silent
+# print informational messages (default)
+# --tag=TAG use configuration variables from tag TAG
+# -v, --verbose print more informational messages than default
+# --no-verbose don't print the extra informational messages
+# --version print version information
+# -h, --help, --help-all print short, long, or detailed help message
+#
+# MODE must be one of the following:
+#
+# clean remove files from the build directory
+# compile compile a source file into a libtool object
+# execute automatically set library path, then run a program
+# finish complete the installation of libtool libraries
+# install install libraries or executables
+# link create a library or an executable
+# uninstall remove libraries from an installed directory
+#
+# MODE-ARGS vary depending on the MODE. When passed as first option,
+# `--mode=MODE' may be abbreviated as `MODE' or a unique abbreviation of that.
+# Try `$progname --help --mode=MODE' for a more detailed description of MODE.
+#
+# When reporting a bug, please describe a test case to reproduce it and
+# include the following information:
+#
+# host-triplet: $host
+# shell: $SHELL
+# compiler: $LTCC
+# compiler flags: $LTCFLAGS
+# linker: $LD (gnu? $with_gnu_ld)
+# $progname: (GNU libtool) 2.4
+# automake: $automake_version
+# autoconf: $autoconf_version
+#
+# Report bugs to <bug-libtool@gnu.org>.
+# GNU libtool home page: <http://www.gnu.org/software/libtool/>.
+# General help using GNU software: <http://www.gnu.org/gethelp/>.
+
+PROGRAM=libtool
+PACKAGE=libtool
+VERSION=2.4
+TIMESTAMP=""
+package_revision=1.3293
+
+# Be Bourne compatible
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in *posix*) set -o posix;; esac
+fi
+BIN_SH=xpg4; export BIN_SH # for Tru64
+DUALCASE=1; export DUALCASE # for MKS sh
+
+# A function that is used when there is no print builtin or printf.
+func_fallback_echo ()
+{
+ eval 'cat <<_LTECHO_EOF
+$1
+_LTECHO_EOF'
+}
+
+# NLS nuisances: We save the old values to restore during execute mode.
+lt_user_locale=
+lt_safe_locale=
+for lt_var in LANG LANGUAGE LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES
+do
+ eval "if test \"\${$lt_var+set}\" = set; then
+ save_$lt_var=\$$lt_var
+ $lt_var=C
+ export $lt_var
+ lt_user_locale=\"$lt_var=\\\$save_\$lt_var; \$lt_user_locale\"
+ lt_safe_locale=\"$lt_var=C; \$lt_safe_locale\"
+ fi"
+done
+LC_ALL=C
+LANGUAGE=C
+export LANGUAGE LC_ALL
+
+$lt_unset CDPATH
+
+
+# Work around backward compatibility issue on IRIX 6.5. On IRIX 6.4+, sh
+# is ksh but when the shell is invoked as "sh" and the current value of
+# the _XPG environment variable is not equal to 1 (one), the special
+# positional parameter $0, within a function call, is the name of the
+# function.
+progpath="$0"
+
+
+
+: ${CP="cp -f"}
+test "${ECHO+set}" = set || ECHO=${as_echo-'printf %s\n'}
+: ${EGREP="grep -E"}
+: ${FGREP="grep -F"}
+: ${GREP="grep"}
+: ${LN_S="ln -s"}
+: ${MAKE="make"}
+: ${MKDIR="mkdir"}
+: ${MV="mv -f"}
+: ${RM="rm -f"}
+: ${SED="sed"}
+: ${SHELL="${CONFIG_SHELL-/bin/sh}"}
+: ${Xsed="$SED -e 1s/^X//"}
+
+# Global variables:
+EXIT_SUCCESS=0
+EXIT_FAILURE=1
+EXIT_MISMATCH=63 # $? = 63 is used to indicate version mismatch to missing.
+EXIT_SKIP=77 # $? = 77 is used to indicate a skipped test to automake.
+
+exit_status=$EXIT_SUCCESS
+
+# Make sure IFS has a sensible default
+lt_nl='
+'
+IFS=" $lt_nl"
+
+dirname="s,/[^/]*$,,"
+basename="s,^.*/,,"
+
+# func_dirname file append nondir_replacement
+# Compute the dirname of FILE. If nonempty, add APPEND to the result,
+# otherwise set result to NONDIR_REPLACEMENT.
+func_dirname ()
+{
+ func_dirname_result=`$ECHO "${1}" | $SED "$dirname"`
+ if test "X$func_dirname_result" = "X${1}"; then
+ func_dirname_result="${3}"
+ else
+ func_dirname_result="$func_dirname_result${2}"
+ fi
+} # func_dirname may be replaced by extended shell implementation
+
+
+# func_basename file
+func_basename ()
+{
+ func_basename_result=`$ECHO "${1}" | $SED "$basename"`
+} # func_basename may be replaced by extended shell implementation
+
+
+# func_dirname_and_basename file append nondir_replacement
+# perform func_basename and func_dirname in a single function
+# call:
+# dirname: Compute the dirname of FILE. If nonempty,
+# add APPEND to the result, otherwise set result
+# to NONDIR_REPLACEMENT.
+# value returned in "$func_dirname_result"
+# basename: Compute filename of FILE.
+# value retuned in "$func_basename_result"
+# Implementation must be kept synchronized with func_dirname
+# and func_basename. For efficiency, we do not delegate to
+# those functions but instead duplicate the functionality here.
+func_dirname_and_basename ()
+{
+ # Extract subdirectory from the argument.
+ func_dirname_result=`$ECHO "${1}" | $SED -e "$dirname"`
+ if test "X$func_dirname_result" = "X${1}"; then
+ func_dirname_result="${3}"
+ else
+ func_dirname_result="$func_dirname_result${2}"
+ fi
+ func_basename_result=`$ECHO "${1}" | $SED -e "$basename"`
+} # func_dirname_and_basename may be replaced by extended shell implementation
+
+
+# func_stripname prefix suffix name
+# strip PREFIX and SUFFIX off of NAME.
+# PREFIX and SUFFIX must not contain globbing or regex special
+# characters, hashes, percent signs, but SUFFIX may contain a leading
+# dot (in which case that matches only a dot).
+# func_strip_suffix prefix name
+func_stripname ()
+{
+ case ${2} in
+ .*) func_stripname_result=`$ECHO "${3}" | $SED "s%^${1}%%; s%\\\\${2}\$%%"`;;
+ *) func_stripname_result=`$ECHO "${3}" | $SED "s%^${1}%%; s%${2}\$%%"`;;
+ esac
+} # func_stripname may be replaced by extended shell implementation
+
+
+# These SED scripts presuppose an absolute path with a trailing slash.
+pathcar='s,^/\([^/]*\).*$,\1,'
+pathcdr='s,^/[^/]*,,'
+removedotparts=':dotsl
+ s@/\./@/@g
+ t dotsl
+ s,/\.$,/,'
+collapseslashes='s@/\{1,\}@/@g'
+finalslash='s,/*$,/,'
+
+# func_normal_abspath PATH
+# Remove doubled-up and trailing slashes, "." path components,
+# and cancel out any ".." path components in PATH after making
+# it an absolute path.
+# value returned in "$func_normal_abspath_result"
+func_normal_abspath ()
+{
+ # Start from root dir and reassemble the path.
+ func_normal_abspath_result=
+ func_normal_abspath_tpath=$1
+ func_normal_abspath_altnamespace=
+ case $func_normal_abspath_tpath in
+ "")
+ # Empty path, that just means $cwd.
+ func_stripname '' '/' "`pwd`"
+ func_normal_abspath_result=$func_stripname_result
+ return
+ ;;
+ # The next three entries are used to spot a run of precisely
+ # two leading slashes without using negated character classes;
+ # we take advantage of case's first-match behaviour.
+ ///*)
+ # Unusual form of absolute path, do nothing.
+ ;;
+ //*)
+ # Not necessarily an ordinary path; POSIX reserves leading '//'
+ # and for example Cygwin uses it to access remote file shares
+ # over CIFS/SMB, so we conserve a leading double slash if found.
+ func_normal_abspath_altnamespace=/
+ ;;
+ /*)
+ # Absolute path, do nothing.
+ ;;
+ *)
+ # Relative path, prepend $cwd.
+ func_normal_abspath_tpath=`pwd`/$func_normal_abspath_tpath
+ ;;
+ esac
+ # Cancel out all the simple stuff to save iterations. We also want
+ # the path to end with a slash for ease of parsing, so make sure
+ # there is one (and only one) here.
+ func_normal_abspath_tpath=`$ECHO "$func_normal_abspath_tpath" | $SED \
+ -e "$removedotparts" -e "$collapseslashes" -e "$finalslash"`
+ while :; do
+ # Processed it all yet?
+ if test "$func_normal_abspath_tpath" = / ; then
+ # If we ascended to the root using ".." the result may be empty now.
+ if test -z "$func_normal_abspath_result" ; then
+ func_normal_abspath_result=/
+ fi
+ break
+ fi
+ func_normal_abspath_tcomponent=`$ECHO "$func_normal_abspath_tpath" | $SED \
+ -e "$pathcar"`
+ func_normal_abspath_tpath=`$ECHO "$func_normal_abspath_tpath" | $SED \
+ -e "$pathcdr"`
+ # Figure out what to do with it
+ case $func_normal_abspath_tcomponent in
+ "")
+ # Trailing empty path component, ignore it.
+ ;;
+ ..)
+ # Parent dir; strip last assembled component from result.
+ func_dirname "$func_normal_abspath_result"
+ func_normal_abspath_result=$func_dirname_result
+ ;;
+ *)
+ # Actual path component, append it.
+ func_normal_abspath_result=$func_normal_abspath_result/$func_normal_abspath_tcomponent
+ ;;
+ esac
+ done
+ # Restore leading double-slash if one was found on entry.
+ func_normal_abspath_result=$func_normal_abspath_altnamespace$func_normal_abspath_result
+}
+
+# func_relative_path SRCDIR DSTDIR
+# generates a relative path from SRCDIR to DSTDIR, with a trailing
+# slash if non-empty, suitable for immediately appending a filename
+# without needing to append a separator.
+# value returned in "$func_relative_path_result"
+func_relative_path ()
+{
+ func_relative_path_result=
+ func_normal_abspath "$1"
+ func_relative_path_tlibdir=$func_normal_abspath_result
+ func_normal_abspath "$2"
+ func_relative_path_tbindir=$func_normal_abspath_result
+
+ # Ascend the tree starting from libdir
+ while :; do
+ # check if we have found a prefix of bindir
+ case $func_relative_path_tbindir in
+ $func_relative_path_tlibdir)
+ # found an exact match
+ func_relative_path_tcancelled=
+ break
+ ;;
+ $func_relative_path_tlibdir*)
+ # found a matching prefix
+ func_stripname "$func_relative_path_tlibdir" '' "$func_relative_path_tbindir"
+ func_relative_path_tcancelled=$func_stripname_result
+ if test -z "$func_relative_path_result"; then
+ func_relative_path_result=.
+ fi
+ break
+ ;;
+ *)
+ func_dirname $func_relative_path_tlibdir
+ func_relative_path_tlibdir=${func_dirname_result}
+ if test "x$func_relative_path_tlibdir" = x ; then
+ # Have to descend all the way to the root!
+ func_relative_path_result=../$func_relative_path_result
+ func_relative_path_tcancelled=$func_relative_path_tbindir
+ break
+ fi
+ func_relative_path_result=../$func_relative_path_result
+ ;;
+ esac
+ done
+
+ # Now calculate path; take care to avoid doubling-up slashes.
+ func_stripname '' '/' "$func_relative_path_result"
+ func_relative_path_result=$func_stripname_result
+ func_stripname '/' '/' "$func_relative_path_tcancelled"
+ if test "x$func_stripname_result" != x ; then
+ func_relative_path_result=${func_relative_path_result}/${func_stripname_result}
+ fi
+
+ # Normalisation. If bindir is libdir, return empty string,
+ # else relative path ending with a slash; either way, target
+ # file name can be directly appended.
+ if test ! -z "$func_relative_path_result"; then
+ func_stripname './' '' "$func_relative_path_result/"
+ func_relative_path_result=$func_stripname_result
+ fi
+}
+
+# The name of this program:
+func_dirname_and_basename "$progpath"
+progname=$func_basename_result
+
+# Make sure we have an absolute path for reexecution:
+case $progpath in
+ [\\/]*|[A-Za-z]:\\*) ;;
+ *[\\/]*)
+ progdir=$func_dirname_result
+ progdir=`cd "$progdir" && pwd`
+ progpath="$progdir/$progname"
+ ;;
+ *)
+ save_IFS="$IFS"
+ IFS=:
+ for progdir in $PATH; do
+ IFS="$save_IFS"
+ test -x "$progdir/$progname" && break
+ done
+ IFS="$save_IFS"
+ test -n "$progdir" || progdir=`pwd`
+ progpath="$progdir/$progname"
+ ;;
+esac
+
+# Sed substitution that helps us do robust quoting. It backslashifies
+# metacharacters that are still active within double-quoted strings.
+Xsed="${SED}"' -e 1s/^X//'
+sed_quote_subst='s/\([`"$\\]\)/\\\1/g'
+
+# Same as above, but do not quote variable references.
+double_quote_subst='s/\(["`\\]\)/\\\1/g'
+
+# Sed substitution that turns a string into a regex matching for the
+# string literally.
+sed_make_literal_regex='s,[].[^$\\*\/],\\&,g'
+
+# Sed substitution that converts a w32 file name or path
+# which contains forward slashes, into one that contains
+# (escaped) backslashes. A very naive implementation.
+lt_sed_naive_backslashify='s|\\\\*|\\|g;s|/|\\|g;s|\\|\\\\|g'
+
+# Re-`\' parameter expansions in output of double_quote_subst that were
+# `\'-ed in input to the same. If an odd number of `\' preceded a '$'
+# in input to double_quote_subst, that '$' was protected from expansion.
+# Since each input `\' is now two `\'s, look for any number of runs of
+# four `\'s followed by two `\'s and then a '$'. `\' that '$'.
+bs='\\'
+bs2='\\\\'
+bs4='\\\\\\\\'
+dollar='\$'
+sed_double_backslash="\
+ s/$bs4/&\\
+/g
+ s/^$bs2$dollar/$bs&/
+ s/\\([^$bs]\\)$bs2$dollar/\\1$bs2$bs$dollar/g
+ s/\n//g"
+
+# Standard options:
+opt_dry_run=false
+opt_help=false
+opt_quiet=false
+opt_verbose=false
+opt_warning=:
+
+# func_echo arg...
+# Echo program name prefixed message, along with the current mode
+# name if it has been set yet.
+func_echo ()
+{
+ $ECHO "$progname: ${opt_mode+$opt_mode: }$*"
+}
+
+# func_verbose arg...
+# Echo program name prefixed message in verbose mode only.
+func_verbose ()
+{
+ $opt_verbose && func_echo ${1+"$@"}
+
+ # A bug in bash halts the script if the last line of a function
+ # fails when set -e is in force, so we need another command to
+ # work around that:
+ :
+}
+
+# func_echo_all arg...
+# Invoke $ECHO with all args, space-separated.
+func_echo_all ()
+{
+ $ECHO "$*"
+}
+
+# func_error arg...
+# Echo program name prefixed message to standard error.
+func_error ()
+{
+ $ECHO "$progname: ${opt_mode+$opt_mode: }"${1+"$@"} 1>&2
+}
+
+# func_warning arg...
+# Echo program name prefixed warning message to standard error.
+func_warning ()
+{
+ $opt_warning && $ECHO "$progname: ${opt_mode+$opt_mode: }warning: "${1+"$@"} 1>&2
+
+ # bash bug again:
+ :
+}
+
+# func_fatal_error arg...
+# Echo program name prefixed message to standard error, and exit.
+func_fatal_error ()
+{
+ func_error ${1+"$@"}
+ exit $EXIT_FAILURE
+}
+
+# func_fatal_help arg...
+# Echo program name prefixed message to standard error, followed by
+# a help hint, and exit.
+func_fatal_help ()
+{
+ func_error ${1+"$@"}
+ func_fatal_error "$help"
+}
+help="Try \`$progname --help' for more information." ## default
+
+
+# func_grep expression filename
+# Check whether EXPRESSION matches any line of FILENAME, without output.
+func_grep ()
+{
+ $GREP "$1" "$2" >/dev/null 2>&1
+}
+
+
+# func_mkdir_p directory-path
+# Make sure the entire path to DIRECTORY-PATH is available.
+func_mkdir_p ()
+{
+ my_directory_path="$1"
+ my_dir_list=
+
+ if test -n "$my_directory_path" && test "$opt_dry_run" != ":"; then
+
+ # Protect directory names starting with `-'
+ case $my_directory_path in
+ -*) my_directory_path="./$my_directory_path" ;;
+ esac
+
+ # While some portion of DIR does not yet exist...
+ while test ! -d "$my_directory_path"; do
+ # ...make a list in topmost first order. Use a colon delimited
+ # list incase some portion of path contains whitespace.
+ my_dir_list="$my_directory_path:$my_dir_list"
+
+ # If the last portion added has no slash in it, the list is done
+ case $my_directory_path in */*) ;; *) break ;; esac
+
+ # ...otherwise throw away the child directory and loop
+ my_directory_path=`$ECHO "$my_directory_path" | $SED -e "$dirname"`
+ done
+ my_dir_list=`$ECHO "$my_dir_list" | $SED 's,:*$,,'`
+
+ save_mkdir_p_IFS="$IFS"; IFS=':'
+ for my_dir in $my_dir_list; do
+ IFS="$save_mkdir_p_IFS"
+ # mkdir can fail with a `File exist' error if two processes
+ # try to create one of the directories concurrently. Don't
+ # stop in that case!
+ $MKDIR "$my_dir" 2>/dev/null || :
+ done
+ IFS="$save_mkdir_p_IFS"
+
+ # Bail out if we (or some other process) failed to create a directory.
+ test -d "$my_directory_path" || \
+ func_fatal_error "Failed to create \`$1'"
+ fi
+}
+
+
+# func_mktempdir [string]
+# Make a temporary directory that won't clash with other running
+# libtool processes, and avoids race conditions if possible. If
+# given, STRING is the basename for that directory.
+func_mktempdir ()
+{
+ my_template="${TMPDIR-/tmp}/${1-$progname}"
+
+ if test "$opt_dry_run" = ":"; then
+ # Return a directory name, but don't create it in dry-run mode
+ my_tmpdir="${my_template}-$$"
+ else
+
+ # If mktemp works, use that first and foremost
+ my_tmpdir=`mktemp -d "${my_template}-XXXXXXXX" 2>/dev/null`
+
+ if test ! -d "$my_tmpdir"; then
+ # Failing that, at least try and use $RANDOM to avoid a race
+ my_tmpdir="${my_template}-${RANDOM-0}$$"
+
+ save_mktempdir_umask=`umask`
+ umask 0077
+ $MKDIR "$my_tmpdir"
+ umask $save_mktempdir_umask
+ fi
+
+ # If we're not in dry-run mode, bomb out on failure
+ test -d "$my_tmpdir" || \
+ func_fatal_error "cannot create temporary directory \`$my_tmpdir'"
+ fi
+
+ $ECHO "$my_tmpdir"
+}
+
+
+# func_quote_for_eval arg
+# Aesthetically quote ARG to be evaled later.
+# This function returns two values: FUNC_QUOTE_FOR_EVAL_RESULT
+# is double-quoted, suitable for a subsequent eval, whereas
+# FUNC_QUOTE_FOR_EVAL_UNQUOTED_RESULT has merely all characters
+# which are still active within double quotes backslashified.
+func_quote_for_eval ()
+{
+ case $1 in
+ *[\\\`\"\$]*)
+ func_quote_for_eval_unquoted_result=`$ECHO "$1" | $SED "$sed_quote_subst"` ;;
+ *)
+ func_quote_for_eval_unquoted_result="$1" ;;
+ esac
+
+ case $func_quote_for_eval_unquoted_result in
+ # Double-quote args containing shell metacharacters to delay
+ # word splitting, command substitution and and variable
+ # expansion for a subsequent eval.
+ # Many Bourne shells cannot handle close brackets correctly
+ # in scan sets, so we specify it separately.
+ *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"")
+ func_quote_for_eval_result="\"$func_quote_for_eval_unquoted_result\""
+ ;;
+ *)
+ func_quote_for_eval_result="$func_quote_for_eval_unquoted_result"
+ esac
+}
+
+
+# func_quote_for_expand arg
+# Aesthetically quote ARG to be evaled later; same as above,
+# but do not quote variable references.
+func_quote_for_expand ()
+{
+ case $1 in
+ *[\\\`\"]*)
+ my_arg=`$ECHO "$1" | $SED \
+ -e "$double_quote_subst" -e "$sed_double_backslash"` ;;
+ *)
+ my_arg="$1" ;;
+ esac
+
+ case $my_arg in
+ # Double-quote args containing shell metacharacters to delay
+ # word splitting and command substitution for a subsequent eval.
+ # Many Bourne shells cannot handle close brackets correctly
+ # in scan sets, so we specify it separately.
+ *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"")
+ my_arg="\"$my_arg\""
+ ;;
+ esac
+
+ func_quote_for_expand_result="$my_arg"
+}
+
+
+# func_show_eval cmd [fail_exp]
+# Unless opt_silent is true, then output CMD. Then, if opt_dryrun is
+# not true, evaluate CMD. If the evaluation of CMD fails, and FAIL_EXP
+# is given, then evaluate it.
+func_show_eval ()
+{
+ my_cmd="$1"
+ my_fail_exp="${2-:}"
+
+ ${opt_silent-false} || {
+ func_quote_for_expand "$my_cmd"
+ eval "func_echo $func_quote_for_expand_result"
+ }
+
+ if ${opt_dry_run-false}; then :; else
+ eval "$my_cmd"
+ my_status=$?
+ if test "$my_status" -eq 0; then :; else
+ eval "(exit $my_status); $my_fail_exp"
+ fi
+ fi
+}
+
+
+# func_show_eval_locale cmd [fail_exp]
+# Unless opt_silent is true, then output CMD. Then, if opt_dryrun is
+# not true, evaluate CMD. If the evaluation of CMD fails, and FAIL_EXP
+# is given, then evaluate it. Use the saved locale for evaluation.
+func_show_eval_locale ()
+{
+ my_cmd="$1"
+ my_fail_exp="${2-:}"
+
+ ${opt_silent-false} || {
+ func_quote_for_expand "$my_cmd"
+ eval "func_echo $func_quote_for_expand_result"
+ }
+
+ if ${opt_dry_run-false}; then :; else
+ eval "$lt_user_locale
+ $my_cmd"
+ my_status=$?
+ eval "$lt_safe_locale"
+ if test "$my_status" -eq 0; then :; else
+ eval "(exit $my_status); $my_fail_exp"
+ fi
+ fi
+}
+
+# func_tr_sh
+# Turn $1 into a string suitable for a shell variable name.
+# Result is stored in $func_tr_sh_result. All characters
+# not in the set a-zA-Z0-9_ are replaced with '_'. Further,
+# if $1 begins with a digit, a '_' is prepended as well.
+func_tr_sh ()
+{
+ case $1 in
+ [0-9]* | *[!a-zA-Z0-9_]*)
+ func_tr_sh_result=`$ECHO "$1" | $SED 's/^\([0-9]\)/_\1/; s/[^a-zA-Z0-9_]/_/g'`
+ ;;
+ * )
+ func_tr_sh_result=$1
+ ;;
+ esac
+}
+
+
+# func_version
+# Echo version message to standard output and exit.
+func_version ()
+{
+ $opt_debug
+
+ $SED -n '/(C)/!b go
+ :more
+ /\./!{
+ N
+ s/\n# / /
+ b more
+ }
+ :go
+ /^# '$PROGRAM' (GNU /,/# warranty; / {
+ s/^# //
+ s/^# *$//
+ s/\((C)\)[ 0-9,-]*\( [1-9][0-9]*\)/\1\2/
+ p
+ }' < "$progpath"
+ exit $?
+}
+
+# func_usage
+# Echo short help message to standard output and exit.
+func_usage ()
+{
+ $opt_debug
+
+ $SED -n '/^# Usage:/,/^# *.*--help/ {
+ s/^# //
+ s/^# *$//
+ s/\$progname/'$progname'/
+ p
+ }' < "$progpath"
+ echo
+ $ECHO "run \`$progname --help | more' for full usage"
+ exit $?
+}
+
+# func_help [NOEXIT]
+# Echo long help message to standard output and exit,
+# unless 'noexit' is passed as argument.
+func_help ()
+{
+ $opt_debug
+
+ $SED -n '/^# Usage:/,/# Report bugs to/ {
+ :print
+ s/^# //
+ s/^# *$//
+ s*\$progname*'$progname'*
+ s*\$host*'"$host"'*
+ s*\$SHELL*'"$SHELL"'*
+ s*\$LTCC*'"$LTCC"'*
+ s*\$LTCFLAGS*'"$LTCFLAGS"'*
+ s*\$LD*'"$LD"'*
+ s/\$with_gnu_ld/'"$with_gnu_ld"'/
+ s/\$automake_version/'"`(automake --version) 2>/dev/null |$SED 1q`"'/
+ s/\$autoconf_version/'"`(autoconf --version) 2>/dev/null |$SED 1q`"'/
+ p
+ d
+ }
+ /^# .* home page:/b print
+ /^# General help using/b print
+ ' < "$progpath"
+ ret=$?
+ if test -z "$1"; then
+ exit $ret
+ fi
+}
+
+# func_missing_arg argname
+# Echo program name prefixed message to standard error and set global
+# exit_cmd.
+func_missing_arg ()
+{
+ $opt_debug
+
+ func_error "missing argument for $1."
+ exit_cmd=exit
+}
+
+
+# func_split_short_opt shortopt
+# Set func_split_short_opt_name and func_split_short_opt_arg shell
+# variables after splitting SHORTOPT after the 2nd character.
+func_split_short_opt ()
+{
+ my_sed_short_opt='1s/^\(..\).*$/\1/;q'
+ my_sed_short_rest='1s/^..\(.*\)$/\1/;q'
+
+ func_split_short_opt_name=`$ECHO "$1" | $SED "$my_sed_short_opt"`
+ func_split_short_opt_arg=`$ECHO "$1" | $SED "$my_sed_short_rest"`
+} # func_split_short_opt may be replaced by extended shell implementation
+
+
+# func_split_long_opt longopt
+# Set func_split_long_opt_name and func_split_long_opt_arg shell
+# variables after splitting LONGOPT at the `=' sign.
+func_split_long_opt ()
+{
+ my_sed_long_opt='1s/^\(--[^=]*\)=.*/\1/;q'
+ my_sed_long_arg='1s/^--[^=]*=//'
+
+ func_split_long_opt_name=`$ECHO "$1" | $SED "$my_sed_long_opt"`
+ func_split_long_opt_arg=`$ECHO "$1" | $SED "$my_sed_long_arg"`
+} # func_split_long_opt may be replaced by extended shell implementation
+
+exit_cmd=:
+
+
+
+
+
+magic="%%%MAGIC variable%%%"
+magic_exe="%%%MAGIC EXE variable%%%"
+
+# Global variables.
+nonopt=
+preserve_args=
+lo2o="s/\\.lo\$/.${objext}/"
+o2lo="s/\\.${objext}\$/.lo/"
+extracted_archives=
+extracted_serial=0
+
+# If this variable is set in any of the actions, the command in it
+# will be execed at the end. This prevents here-documents from being
+# left over by shells.
+exec_cmd=
+
+# func_append var value
+# Append VALUE to the end of shell variable VAR.
+func_append ()
+{
+ eval "${1}=\$${1}\${2}"
+} # func_append may be replaced by extended shell implementation
+
+# func_append_quoted var value
+# Quote VALUE and append to the end of shell variable VAR, separated
+# by a space.
+func_append_quoted ()
+{
+ func_quote_for_eval "${2}"
+ eval "${1}=\$${1}\\ \$func_quote_for_eval_result"
+} # func_append_quoted may be replaced by extended shell implementation
+
+
+# func_arith arithmetic-term...
+func_arith ()
+{
+ func_arith_result=`expr "${@}"`
+} # func_arith may be replaced by extended shell implementation
+
+
+# func_len string
+# STRING may not start with a hyphen.
+func_len ()
+{
+ func_len_result=`expr "${1}" : ".*" 2>/dev/null || echo $max_cmd_len`
+} # func_len may be replaced by extended shell implementation
+
+
+# func_lo2o object
+func_lo2o ()
+{
+ func_lo2o_result=`$ECHO "${1}" | $SED "$lo2o"`
+} # func_lo2o may be replaced by extended shell implementation
+
+
+# func_xform libobj-or-source
+func_xform ()
+{
+ func_xform_result=`$ECHO "${1}" | $SED 's/\.[^.]*$/.lo/'`
+} # func_xform may be replaced by extended shell implementation
+
+
+# func_fatal_configuration arg...
+# Echo program name prefixed message to standard error, followed by
+# a configuration failure hint, and exit.
+func_fatal_configuration ()
+{
+ func_error ${1+"$@"}
+ func_error "See the $PACKAGE documentation for more information."
+ func_fatal_error "Fatal configuration error."
+}
+
+
+# func_config
+# Display the configuration for all the tags in this script.
+func_config ()
+{
+ re_begincf='^# ### BEGIN LIBTOOL'
+ re_endcf='^# ### END LIBTOOL'
+
+ # Default configuration.
+ $SED "1,/$re_begincf CONFIG/d;/$re_endcf CONFIG/,\$d" < "$progpath"
+
+ # Now print the configurations for the tags.
+ for tagname in $taglist; do
+ $SED -n "/$re_begincf TAG CONFIG: $tagname\$/,/$re_endcf TAG CONFIG: $tagname\$/p" < "$progpath"
+ done
+
+ exit $?
+}
+
+# func_features
+# Display the features supported by this script.
+func_features ()
+{
+ echo "host: $host"
+ if test "$build_libtool_libs" = yes; then
+ echo "enable shared libraries"
+ else
+ echo "disable shared libraries"
+ fi
+ if test "$build_old_libs" = yes; then
+ echo "enable static libraries"
+ else
+ echo "disable static libraries"
+ fi
+
+ exit $?
+}
+
+# func_enable_tag tagname
+# Verify that TAGNAME is valid, and either flag an error and exit, or
+# enable the TAGNAME tag. We also add TAGNAME to the global $taglist
+# variable here.
+func_enable_tag ()
+{
+ # Global variable:
+ tagname="$1"
+
+ re_begincf="^# ### BEGIN LIBTOOL TAG CONFIG: $tagname\$"
+ re_endcf="^# ### END LIBTOOL TAG CONFIG: $tagname\$"
+ sed_extractcf="/$re_begincf/,/$re_endcf/p"
+
+ # Validate tagname.
+ case $tagname in
+ *[!-_A-Za-z0-9,/]*)
+ func_fatal_error "invalid tag name: $tagname"
+ ;;
+ esac
+
+ # Don't test for the "default" C tag, as we know it's
+ # there but not specially marked.
+ case $tagname in
+ CC) ;;
+ *)
+ if $GREP "$re_begincf" "$progpath" >/dev/null 2>&1; then
+ taglist="$taglist $tagname"
+
+ # Evaluate the configuration. Be careful to quote the path
+ # and the sed script, to avoid splitting on whitespace, but
+ # also don't use non-portable quotes within backquotes within
+ # quotes we have to do it in 2 steps:
+ extractedcf=`$SED -n -e "$sed_extractcf" < "$progpath"`
+ eval "$extractedcf"
+ else
+ func_error "ignoring unknown tag $tagname"
+ fi
+ ;;
+ esac
+}
+
+# func_check_version_match
+# Ensure that we are using m4 macros, and libtool script from the same
+# release of libtool.
+func_check_version_match ()
+{
+ if test "$package_revision" != "$macro_revision"; then
+ if test "$VERSION" != "$macro_version"; then
+ if test -z "$macro_version"; then
+ cat >&2 <<_LT_EOF
+$progname: Version mismatch error. This is $PACKAGE $VERSION, but the
+$progname: definition of this LT_INIT comes from an older release.
+$progname: You should recreate aclocal.m4 with macros from $PACKAGE $VERSION
+$progname: and run autoconf again.
+_LT_EOF
+ else
+ cat >&2 <<_LT_EOF
+$progname: Version mismatch error. This is $PACKAGE $VERSION, but the
+$progname: definition of this LT_INIT comes from $PACKAGE $macro_version.
+$progname: You should recreate aclocal.m4 with macros from $PACKAGE $VERSION
+$progname: and run autoconf again.
+_LT_EOF
+ fi
+ else
+ cat >&2 <<_LT_EOF
+$progname: Version mismatch error. This is $PACKAGE $VERSION, revision $package_revision,
+$progname: but the definition of this LT_INIT comes from revision $macro_revision.
+$progname: You should recreate aclocal.m4 with macros from revision $package_revision
+$progname: of $PACKAGE $VERSION and run autoconf again.
+_LT_EOF
+ fi
+
+ exit $EXIT_MISMATCH
+ fi
+}
+
+
+# Shorthand for --mode=foo, only valid as the first argument
+case $1 in
+clean|clea|cle|cl)
+ shift; set dummy --mode clean ${1+"$@"}; shift
+ ;;
+compile|compil|compi|comp|com|co|c)
+ shift; set dummy --mode compile ${1+"$@"}; shift
+ ;;
+execute|execut|execu|exec|exe|ex|e)
+ shift; set dummy --mode execute ${1+"$@"}; shift
+ ;;
+finish|finis|fini|fin|fi|f)
+ shift; set dummy --mode finish ${1+"$@"}; shift
+ ;;
+install|instal|insta|inst|ins|in|i)
+ shift; set dummy --mode install ${1+"$@"}; shift
+ ;;
+link|lin|li|l)
+ shift; set dummy --mode link ${1+"$@"}; shift
+ ;;
+uninstall|uninstal|uninsta|uninst|unins|unin|uni|un|u)
+ shift; set dummy --mode uninstall ${1+"$@"}; shift
+ ;;
+esac
+
+
+
+# Option defaults:
+opt_debug=:
+opt_dry_run=false
+opt_config=false
+opt_preserve_dup_deps=false
+opt_features=false
+opt_finish=false
+opt_help=false
+opt_help_all=false
+opt_silent=:
+opt_verbose=:
+opt_silent=false
+opt_verbose=false
+
+
+# Parse options once, thoroughly. This comes as soon as possible in the
+# script to make things like `--version' happen as quickly as we can.
+{
+ # this just eases exit handling
+ while test $# -gt 0; do
+ opt="$1"
+ shift
+ case $opt in
+ --debug|-x) opt_debug='set -x'
+ func_echo "enabling shell trace mode"
+ $opt_debug
+ ;;
+ --dry-run|--dryrun|-n)
+ opt_dry_run=:
+ ;;
+ --config)
+ opt_config=:
+func_config
+ ;;
+ --dlopen|-dlopen)
+ optarg="$1"
+ opt_dlopen="${opt_dlopen+$opt_dlopen
+}$optarg"
+ shift
+ ;;
+ --preserve-dup-deps)
+ opt_preserve_dup_deps=:
+ ;;
+ --features)
+ opt_features=:
+func_features
+ ;;
+ --finish)
+ opt_finish=:
+set dummy --mode finish ${1+"$@"}; shift
+ ;;
+ --help)
+ opt_help=:
+ ;;
+ --help-all)
+ opt_help_all=:
+opt_help=': help-all'
+ ;;
+ --mode)
+ test $# = 0 && func_missing_arg $opt && break
+ optarg="$1"
+ opt_mode="$optarg"
+case $optarg in
+ # Valid mode arguments:
+ clean|compile|execute|finish|install|link|relink|uninstall) ;;
+
+ # Catch anything else as an error
+ *) func_error "invalid argument for $opt"
+ exit_cmd=exit
+ break
+ ;;
+esac
+ shift
+ ;;
+ --no-silent|--no-quiet)
+ opt_silent=false
+func_append preserve_args " $opt"
+ ;;
+ --no-verbose)
+ opt_verbose=false
+func_append preserve_args " $opt"
+ ;;
+ --silent|--quiet)
+ opt_silent=:
+func_append preserve_args " $opt"
+ opt_verbose=false
+ ;;
+ --verbose|-v)
+ opt_verbose=:
+func_append preserve_args " $opt"
+opt_silent=false
+ ;;
+ --tag)
+ test $# = 0 && func_missing_arg $opt && break
+ optarg="$1"
+ opt_tag="$optarg"
+func_append preserve_args " $opt $optarg"
+func_enable_tag "$optarg"
+ shift
+ ;;
+
+ -\?|-h) func_usage ;;
+ --help) func_help ;;
+ --version) func_version ;;
+
+ # Separate optargs to long options:
+ --*=*)
+ func_split_long_opt "$opt"
+ set dummy "$func_split_long_opt_name" "$func_split_long_opt_arg" ${1+"$@"}
+ shift
+ ;;
+
+ # Separate non-argument short options:
+ -\?*|-h*|-n*|-v*)
+ func_split_short_opt "$opt"
+ set dummy "$func_split_short_opt_name" "-$func_split_short_opt_arg" ${1+"$@"}
+ shift
+ ;;
+
+ --) break ;;
+ -*) func_fatal_help "unrecognized option \`$opt'" ;;
+ *) set dummy "$opt" ${1+"$@"}; shift; break ;;
+ esac
+ done
+
+ # Validate options:
+
+ # save first non-option argument
+ if test "$#" -gt 0; then
+ nonopt="$opt"
+ shift
+ fi
+
+ # preserve --debug
+ test "$opt_debug" = : || func_append preserve_args " --debug"
+
+ case $host in
+ *cygwin* | *mingw* | *pw32* | *cegcc*)
+ # don't eliminate duplications in $postdeps and $predeps
+ opt_duplicate_compiler_generated_deps=:
+ ;;
+ *)
+ opt_duplicate_compiler_generated_deps=$opt_preserve_dup_deps
+ ;;
+ esac
+
+ $opt_help || {
+ # Sanity checks first:
+ func_check_version_match
+
+ if test "$build_libtool_libs" != yes && test "$build_old_libs" != yes; then
+ func_fatal_configuration "not configured to build any kind of library"
+ fi
+
+ # Darwin sucks
+ eval std_shrext=\"$shrext_cmds\"
+
+ # Only execute mode is allowed to have -dlopen flags.
+ if test -n "$opt_dlopen" && test "$opt_mode" != execute; then
+ func_error "unrecognized option \`-dlopen'"
+ $ECHO "$help" 1>&2
+ exit $EXIT_FAILURE
+ fi
+
+ # Change the help message to a mode-specific one.
+ generic_help="$help"
+ help="Try \`$progname --help --mode=$opt_mode' for more information."
+ }
+
+
+ # Bail if the options were screwed
+ $exit_cmd $EXIT_FAILURE
+}
+
+
+
+
+## ----------- ##
+## Main. ##
+## ----------- ##
+
+# func_lalib_p file
+# True iff FILE is a libtool `.la' library or `.lo' object file.
+# This function is only a basic sanity check; it will hardly flush out
+# determined imposters.
+func_lalib_p ()
+{
+ test -f "$1" &&
+ $SED -e 4q "$1" 2>/dev/null \
+ | $GREP "^# Generated by .*$PACKAGE" > /dev/null 2>&1
+}
+
+# func_lalib_unsafe_p file
+# True iff FILE is a libtool `.la' library or `.lo' object file.
+# This function implements the same check as func_lalib_p without
+# resorting to external programs. To this end, it redirects stdin and
+# closes it afterwards, without saving the original file descriptor.
+# As a safety measure, use it only where a negative result would be
+# fatal anyway. Works if `file' does not exist.
+func_lalib_unsafe_p ()
+{
+ lalib_p=no
+ if test -f "$1" && test -r "$1" && exec 5<&0 <"$1"; then
+ for lalib_p_l in 1 2 3 4
+ do
+ read lalib_p_line
+ case "$lalib_p_line" in
+ \#\ Generated\ by\ *$PACKAGE* ) lalib_p=yes; break;;
+ esac
+ done
+ exec 0<&5 5<&-
+ fi
+ test "$lalib_p" = yes
+}
+
+# func_ltwrapper_script_p file
+# True iff FILE is a libtool wrapper script
+# This function is only a basic sanity check; it will hardly flush out
+# determined imposters.
+func_ltwrapper_script_p ()
+{
+ func_lalib_p "$1"
+}
+
+# func_ltwrapper_executable_p file
+# True iff FILE is a libtool wrapper executable
+# This function is only a basic sanity check; it will hardly flush out
+# determined imposters.
+func_ltwrapper_executable_p ()
+{
+ func_ltwrapper_exec_suffix=
+ case $1 in
+ *.exe) ;;
+ *) func_ltwrapper_exec_suffix=.exe ;;
+ esac
+ $GREP "$magic_exe" "$1$func_ltwrapper_exec_suffix" >/dev/null 2>&1
+}
+
+# func_ltwrapper_scriptname file
+# Assumes file is an ltwrapper_executable
+# uses $file to determine the appropriate filename for a
+# temporary ltwrapper_script.
+func_ltwrapper_scriptname ()
+{
+ func_dirname_and_basename "$1" "" "."
+ func_stripname '' '.exe' "$func_basename_result"
+ func_ltwrapper_scriptname_result="$func_dirname_result/$objdir/${func_stripname_result}_ltshwrapper"
+}
+
+# func_ltwrapper_p file
+# True iff FILE is a libtool wrapper script or wrapper executable
+# This function is only a basic sanity check; it will hardly flush out
+# determined imposters.
+func_ltwrapper_p ()
+{
+ func_ltwrapper_script_p "$1" || func_ltwrapper_executable_p "$1"
+}
+
+
+# func_execute_cmds commands fail_cmd
+# Execute tilde-delimited COMMANDS.
+# If FAIL_CMD is given, eval that upon failure.
+# FAIL_CMD may read-access the current command in variable CMD!
+func_execute_cmds ()
+{
+ $opt_debug
+ save_ifs=$IFS; IFS='~'
+ for cmd in $1; do
+ IFS=$save_ifs
+ eval cmd=\"$cmd\"
+ func_show_eval "$cmd" "${2-:}"
+ done
+ IFS=$save_ifs
+}
+
+
+# func_source file
+# Source FILE, adding directory component if necessary.
+# Note that it is not necessary on cygwin/mingw to append a dot to
+# FILE even if both FILE and FILE.exe exist: automatic-append-.exe
+# behavior happens only for exec(3), not for open(2)! Also, sourcing
+# `FILE.' does not work on cygwin managed mounts.
+func_source ()
+{
+ $opt_debug
+ case $1 in
+ */* | *\\*) . "$1" ;;
+ *) . "./$1" ;;
+ esac
+}
+
+
+# func_resolve_sysroot PATH
+# Replace a leading = in PATH with a sysroot. Store the result into
+# func_resolve_sysroot_result
+func_resolve_sysroot ()
+{
+ func_resolve_sysroot_result=$1
+ case $func_resolve_sysroot_result in
+ =*)
+ func_stripname '=' '' "$func_resolve_sysroot_result"
+ func_resolve_sysroot_result=$lt_sysroot$func_stripname_result
+ ;;
+ esac
+}
+
+# func_replace_sysroot PATH
+# If PATH begins with the sysroot, replace it with = and
+# store the result into func_replace_sysroot_result.
+func_replace_sysroot ()
+{
+ case "$lt_sysroot:$1" in
+ ?*:"$lt_sysroot"*)
+ func_stripname "$lt_sysroot" '' "$1"
+ func_replace_sysroot_result="=$func_stripname_result"
+ ;;
+ *)
+ # Including no sysroot.
+ func_replace_sysroot_result=$1
+ ;;
+ esac
+}
+
+# func_infer_tag arg
+# Infer tagged configuration to use if any are available and
+# if one wasn't chosen via the "--tag" command line option.
+# Only attempt this if the compiler in the base compile
+# command doesn't match the default compiler.
+# arg is usually of the form 'gcc ...'
+func_infer_tag ()
+{
+ $opt_debug
+ if test -n "$available_tags" && test -z "$tagname"; then
+ CC_quoted=
+ for arg in $CC; do
+ func_append_quoted CC_quoted "$arg"
+ done
+ CC_expanded=`func_echo_all $CC`
+ CC_quoted_expanded=`func_echo_all $CC_quoted`
+ case $@ in
+ # Blanks in the command may have been stripped by the calling shell,
+ # but not from the CC environment variable when configure was run.
+ " $CC "* | "$CC "* | " $CC_expanded "* | "$CC_expanded "* | \
+ " $CC_quoted"* | "$CC_quoted "* | " $CC_quoted_expanded "* | "$CC_quoted_expanded "*) ;;
+ # Blanks at the start of $base_compile will cause this to fail
+ # if we don't check for them as well.
+ *)
+ for z in $available_tags; do
+ if $GREP "^# ### BEGIN LIBTOOL TAG CONFIG: $z$" < "$progpath" > /dev/null; then
+ # Evaluate the configuration.
+ eval "`${SED} -n -e '/^# ### BEGIN LIBTOOL TAG CONFIG: '$z'$/,/^# ### END LIBTOOL TAG CONFIG: '$z'$/p' < $progpath`"
+ CC_quoted=
+ for arg in $CC; do
+ # Double-quote args containing other shell metacharacters.
+ func_append_quoted CC_quoted "$arg"
+ done
+ CC_expanded=`func_echo_all $CC`
+ CC_quoted_expanded=`func_echo_all $CC_quoted`
+ case "$@ " in
+ " $CC "* | "$CC "* | " $CC_expanded "* | "$CC_expanded "* | \
+ " $CC_quoted"* | "$CC_quoted "* | " $CC_quoted_expanded "* | "$CC_quoted_expanded "*)
+ # The compiler in the base compile command matches
+ # the one in the tagged configuration.
+ # Assume this is the tagged configuration we want.
+ tagname=$z
+ break
+ ;;
+ esac
+ fi
+ done
+ # If $tagname still isn't set, then no tagged configuration
+ # was found and let the user know that the "--tag" command
+ # line option must be used.
+ if test -z "$tagname"; then
+ func_echo "unable to infer tagged configuration"
+ func_fatal_error "specify a tag with \`--tag'"
+# else
+# func_verbose "using $tagname tagged configuration"
+ fi
+ ;;
+ esac
+ fi
+}
+
+
+
+# func_write_libtool_object output_name pic_name nonpic_name
+# Create a libtool object file (analogous to a ".la" file),
+# but don't create it if we're doing a dry run.
+func_write_libtool_object ()
+{
+ write_libobj=${1}
+ if test "$build_libtool_libs" = yes; then
+ write_lobj=\'${2}\'
+ else
+ write_lobj=none
+ fi
+
+ if test "$build_old_libs" = yes; then
+ write_oldobj=\'${3}\'
+ else
+ write_oldobj=none
+ fi
+
+ $opt_dry_run || {
+ cat >${write_libobj}T <<EOF
+# $write_libobj - a libtool object file
+# Generated by $PROGRAM (GNU $PACKAGE$TIMESTAMP) $VERSION
+#
+# Please DO NOT delete this file!
+# It is necessary for linking the library.
+
+# Name of the PIC object.
+pic_object=$write_lobj
+
+# Name of the non-PIC object
+non_pic_object=$write_oldobj
+
+EOF
+ $MV "${write_libobj}T" "${write_libobj}"
+ }
+}
+
+
+##################################################
+# FILE NAME AND PATH CONVERSION HELPER FUNCTIONS #
+##################################################
+
+# func_convert_core_file_wine_to_w32 ARG
+# Helper function used by file name conversion functions when $build is *nix,
+# and $host is mingw, cygwin, or some other w32 environment. Relies on a
+# correctly configured wine environment available, with the winepath program
+# in $build's $PATH.
+#
+# ARG is the $build file name to be converted to w32 format.
+# Result is available in $func_convert_core_file_wine_to_w32_result, and will
+# be empty on error (or when ARG is empty)
+func_convert_core_file_wine_to_w32 ()
+{
+ $opt_debug
+ func_convert_core_file_wine_to_w32_result="$1"
+ if test -n "$1"; then
+ # Unfortunately, winepath does not exit with a non-zero error code, so we
+ # are forced to check the contents of stdout. On the other hand, if the
+ # command is not found, the shell will set an exit code of 127 and print
+ # *an error message* to stdout. So we must check for both error code of
+ # zero AND non-empty stdout, which explains the odd construction:
+ func_convert_core_file_wine_to_w32_tmp=`winepath -w "$1" 2>/dev/null`
+ if test "$?" -eq 0 && test -n "${func_convert_core_file_wine_to_w32_tmp}"; then
+ func_convert_core_file_wine_to_w32_result=`$ECHO "$func_convert_core_file_wine_to_w32_tmp" |
+ $SED -e "$lt_sed_naive_backslashify"`
+ else
+ func_convert_core_file_wine_to_w32_result=
+ fi
+ fi
+}
+# end: func_convert_core_file_wine_to_w32
+
+
+# func_convert_core_path_wine_to_w32 ARG
+# Helper function used by path conversion functions when $build is *nix, and
+# $host is mingw, cygwin, or some other w32 environment. Relies on a correctly
+# configured wine environment available, with the winepath program in $build's
+# $PATH. Assumes ARG has no leading or trailing path separator characters.
+#
+# ARG is path to be converted from $build format to win32.
+# Result is available in $func_convert_core_path_wine_to_w32_result.
+# Unconvertible file (directory) names in ARG are skipped; if no directory names
+# are convertible, then the result may be empty.
+func_convert_core_path_wine_to_w32 ()
+{
+ $opt_debug
+ # unfortunately, winepath doesn't convert paths, only file names
+ func_convert_core_path_wine_to_w32_result=""
+ if test -n "$1"; then
+ oldIFS=$IFS
+ IFS=:
+ for func_convert_core_path_wine_to_w32_f in $1; do
+ IFS=$oldIFS
+ func_convert_core_file_wine_to_w32 "$func_convert_core_path_wine_to_w32_f"
+ if test -n "$func_convert_core_file_wine_to_w32_result" ; then
+ if test -z "$func_convert_core_path_wine_to_w32_result"; then
+ func_convert_core_path_wine_to_w32_result="$func_convert_core_file_wine_to_w32_result"
+ else
+ func_append func_convert_core_path_wine_to_w32_result ";$func_convert_core_file_wine_to_w32_result"
+ fi
+ fi
+ done
+ IFS=$oldIFS
+ fi
+}
+# end: func_convert_core_path_wine_to_w32
+
+
+# func_cygpath ARGS...
+# Wrapper around calling the cygpath program via LT_CYGPATH. This is used when
+# when (1) $build is *nix and Cygwin is hosted via a wine environment; or (2)
+# $build is MSYS and $host is Cygwin, or (3) $build is Cygwin. In case (1) or
+# (2), returns the Cygwin file name or path in func_cygpath_result (input
+# file name or path is assumed to be in w32 format, as previously converted
+# from $build's *nix or MSYS format). In case (3), returns the w32 file name
+# or path in func_cygpath_result (input file name or path is assumed to be in
+# Cygwin format). Returns an empty string on error.
+#
+# ARGS are passed to cygpath, with the last one being the file name or path to
+# be converted.
+#
+# Specify the absolute *nix (or w32) name to cygpath in the LT_CYGPATH
+# environment variable; do not put it in $PATH.
+func_cygpath ()
+{
+ $opt_debug
+ if test -n "$LT_CYGPATH" && test -f "$LT_CYGPATH"; then
+ func_cygpath_result=`$LT_CYGPATH "$@" 2>/dev/null`
+ if test "$?" -ne 0; then
+ # on failure, ensure result is empty
+ func_cygpath_result=
+ fi
+ else
+ func_cygpath_result=
+ func_error "LT_CYGPATH is empty or specifies non-existent file: \`$LT_CYGPATH'"
+ fi
+}
+#end: func_cygpath
+
+
+# func_convert_core_msys_to_w32 ARG
+# Convert file name or path ARG from MSYS format to w32 format. Return
+# result in func_convert_core_msys_to_w32_result.
+func_convert_core_msys_to_w32 ()
+{
+ $opt_debug
+ # awkward: cmd appends spaces to result
+ func_convert_core_msys_to_w32_result=`( cmd //c echo "$1" ) 2>/dev/null |
+ $SED -e 's/[ ]*$//' -e "$lt_sed_naive_backslashify"`
+}
+#end: func_convert_core_msys_to_w32
+
+
+# func_convert_file_check ARG1 ARG2
+# Verify that ARG1 (a file name in $build format) was converted to $host
+# format in ARG2. Otherwise, emit an error message, but continue (resetting
+# func_to_host_file_result to ARG1).
+func_convert_file_check ()
+{
+ $opt_debug
+ if test -z "$2" && test -n "$1" ; then
+ func_error "Could not determine host file name corresponding to"
+ func_error " \`$1'"
+ func_error "Continuing, but uninstalled executables may not work."
+ # Fallback:
+ func_to_host_file_result="$1"
+ fi
+}
+# end func_convert_file_check
+
+
+# func_convert_path_check FROM_PATHSEP TO_PATHSEP FROM_PATH TO_PATH
+# Verify that FROM_PATH (a path in $build format) was converted to $host
+# format in TO_PATH. Otherwise, emit an error message, but continue, resetting
+# func_to_host_file_result to a simplistic fallback value (see below).
+func_convert_path_check ()
+{
+ $opt_debug
+ if test -z "$4" && test -n "$3"; then
+ func_error "Could not determine the host path corresponding to"
+ func_error " \`$3'"
+ func_error "Continuing, but uninstalled executables may not work."
+ # Fallback. This is a deliberately simplistic "conversion" and
+ # should not be "improved". See libtool.info.
+ if test "x$1" != "x$2"; then
+ lt_replace_pathsep_chars="s|$1|$2|g"
+ func_to_host_path_result=`echo "$3" |
+ $SED -e "$lt_replace_pathsep_chars"`
+ else
+ func_to_host_path_result="$3"
+ fi
+ fi
+}
+# end func_convert_path_check
+
+
+# func_convert_path_front_back_pathsep FRONTPAT BACKPAT REPL ORIG
+# Modifies func_to_host_path_result by prepending REPL if ORIG matches FRONTPAT
+# and appending REPL if ORIG matches BACKPAT.
+func_convert_path_front_back_pathsep ()
+{
+ $opt_debug
+ case $4 in
+ $1 ) func_to_host_path_result="$3$func_to_host_path_result"
+ ;;
+ esac
+ case $4 in
+ $2 ) func_append func_to_host_path_result "$3"
+ ;;
+ esac
+}
+# end func_convert_path_front_back_pathsep
+
+
+##################################################
+# $build to $host FILE NAME CONVERSION FUNCTIONS #
+##################################################
+# invoked via `$to_host_file_cmd ARG'
+#
+# In each case, ARG is the path to be converted from $build to $host format.
+# Result will be available in $func_to_host_file_result.
+
+
+# func_to_host_file ARG
+# Converts the file name ARG from $build format to $host format. Return result
+# in func_to_host_file_result.
+func_to_host_file ()
+{
+ $opt_debug
+ $to_host_file_cmd "$1"
+}
+# end func_to_host_file
+
+
+# func_to_tool_file ARG LAZY
+# converts the file name ARG from $build format to toolchain format. Return
+# result in func_to_tool_file_result. If the conversion in use is listed
+# in (the comma separated) LAZY, no conversion takes place.
+func_to_tool_file ()
+{
+ $opt_debug
+ case ,$2, in
+ *,"$to_tool_file_cmd",*)
+ func_to_tool_file_result=$1
+ ;;
+ *)
+ $to_tool_file_cmd "$1"
+ func_to_tool_file_result=$func_to_host_file_result
+ ;;
+ esac
+}
+# end func_to_tool_file
+
+
+# func_convert_file_noop ARG
+# Copy ARG to func_to_host_file_result.
+func_convert_file_noop ()
+{
+ func_to_host_file_result="$1"
+}
+# end func_convert_file_noop
+
+
+# func_convert_file_msys_to_w32 ARG
+# Convert file name ARG from (mingw) MSYS to (mingw) w32 format; automatic
+# conversion to w32 is not available inside the cwrapper. Returns result in
+# func_to_host_file_result.
+func_convert_file_msys_to_w32 ()
+{
+ $opt_debug
+ func_to_host_file_result="$1"
+ if test -n "$1"; then
+ func_convert_core_msys_to_w32 "$1"
+ func_to_host_file_result="$func_convert_core_msys_to_w32_result"
+ fi
+ func_convert_file_check "$1" "$func_to_host_file_result"
+}
+# end func_convert_file_msys_to_w32
+
+
+# func_convert_file_cygwin_to_w32 ARG
+# Convert file name ARG from Cygwin to w32 format. Returns result in
+# func_to_host_file_result.
+func_convert_file_cygwin_to_w32 ()
+{
+ $opt_debug
+ func_to_host_file_result="$1"
+ if test -n "$1"; then
+ # because $build is cygwin, we call "the" cygpath in $PATH; no need to use
+ # LT_CYGPATH in this case.
+ func_to_host_file_result=`cygpath -m "$1"`
+ fi
+ func_convert_file_check "$1" "$func_to_host_file_result"
+}
+# end func_convert_file_cygwin_to_w32
+
+
+# func_convert_file_nix_to_w32 ARG
+# Convert file name ARG from *nix to w32 format. Requires a wine environment
+# and a working winepath. Returns result in func_to_host_file_result.
+func_convert_file_nix_to_w32 ()
+{
+ $opt_debug
+ func_to_host_file_result="$1"
+ if test -n "$1"; then
+ func_convert_core_file_wine_to_w32 "$1"
+ func_to_host_file_result="$func_convert_core_file_wine_to_w32_result"
+ fi
+ func_convert_file_check "$1" "$func_to_host_file_result"
+}
+# end func_convert_file_nix_to_w32
+
+
+# func_convert_file_msys_to_cygwin ARG
+# Convert file name ARG from MSYS to Cygwin format. Requires LT_CYGPATH set.
+# Returns result in func_to_host_file_result.
+func_convert_file_msys_to_cygwin ()
+{
+ $opt_debug
+ func_to_host_file_result="$1"
+ if test -n "$1"; then
+ func_convert_core_msys_to_w32 "$1"
+ func_cygpath -u "$func_convert_core_msys_to_w32_result"
+ func_to_host_file_result="$func_cygpath_result"
+ fi
+ func_convert_file_check "$1" "$func_to_host_file_result"
+}
+# end func_convert_file_msys_to_cygwin
+
+
+# func_convert_file_nix_to_cygwin ARG
+# Convert file name ARG from *nix to Cygwin format. Requires Cygwin installed
+# in a wine environment, working winepath, and LT_CYGPATH set. Returns result
+# in func_to_host_file_result.
+func_convert_file_nix_to_cygwin ()
+{
+ $opt_debug
+ func_to_host_file_result="$1"
+ if test -n "$1"; then
+ # convert from *nix to w32, then use cygpath to convert from w32 to cygwin.
+ func_convert_core_file_wine_to_w32 "$1"
+ func_cygpath -u "$func_convert_core_file_wine_to_w32_result"
+ func_to_host_file_result="$func_cygpath_result"
+ fi
+ func_convert_file_check "$1" "$func_to_host_file_result"
+}
+# end func_convert_file_nix_to_cygwin
+
+
+#############################################
+# $build to $host PATH CONVERSION FUNCTIONS #
+#############################################
+# invoked via `$to_host_path_cmd ARG'
+#
+# In each case, ARG is the path to be converted from $build to $host format.
+# The result will be available in $func_to_host_path_result.
+#
+# Path separators are also converted from $build format to $host format. If
+# ARG begins or ends with a path separator character, it is preserved (but
+# converted to $host format) on output.
+#
+# All path conversion functions are named using the following convention:
+# file name conversion function : func_convert_file_X_to_Y ()
+# path conversion function : func_convert_path_X_to_Y ()
+# where, for any given $build/$host combination the 'X_to_Y' value is the
+# same. If conversion functions are added for new $build/$host combinations,
+# the two new functions must follow this pattern, or func_init_to_host_path_cmd
+# will break.
+
+
+# func_init_to_host_path_cmd
+# Ensures that function "pointer" variable $to_host_path_cmd is set to the
+# appropriate value, based on the value of $to_host_file_cmd.
+to_host_path_cmd=
+func_init_to_host_path_cmd ()
+{
+ $opt_debug
+ if test -z "$to_host_path_cmd"; then
+ func_stripname 'func_convert_file_' '' "$to_host_file_cmd"
+ to_host_path_cmd="func_convert_path_${func_stripname_result}"
+ fi
+}
+
+
+# func_to_host_path ARG
+# Converts the path ARG from $build format to $host format. Return result
+# in func_to_host_path_result.
+func_to_host_path ()
+{
+ $opt_debug
+ func_init_to_host_path_cmd
+ $to_host_path_cmd "$1"
+}
+# end func_to_host_path
+
+
+# func_convert_path_noop ARG
+# Copy ARG to func_to_host_path_result.
+func_convert_path_noop ()
+{
+ func_to_host_path_result="$1"
+}
+# end func_convert_path_noop
+
+
+# func_convert_path_msys_to_w32 ARG
+# Convert path ARG from (mingw) MSYS to (mingw) w32 format; automatic
+# conversion to w32 is not available inside the cwrapper. Returns result in
+# func_to_host_path_result.
+func_convert_path_msys_to_w32 ()
+{
+ $opt_debug
+ func_to_host_path_result="$1"
+ if test -n "$1"; then
+ # Remove leading and trailing path separator characters from ARG. MSYS
+ # behavior is inconsistent here; cygpath turns them into '.;' and ';.';
+ # and winepath ignores them completely.
+ func_stripname : : "$1"
+ func_to_host_path_tmp1=$func_stripname_result
+ func_convert_core_msys_to_w32 "$func_to_host_path_tmp1"
+ func_to_host_path_result="$func_convert_core_msys_to_w32_result"
+ func_convert_path_check : ";" \
+ "$func_to_host_path_tmp1" "$func_to_host_path_result"
+ func_convert_path_front_back_pathsep ":*" "*:" ";" "$1"
+ fi
+}
+# end func_convert_path_msys_to_w32
+
+
+# func_convert_path_cygwin_to_w32 ARG
+# Convert path ARG from Cygwin to w32 format. Returns result in
+# func_to_host_file_result.
+func_convert_path_cygwin_to_w32 ()
+{
+ $opt_debug
+ func_to_host_path_result="$1"
+ if test -n "$1"; then
+ # See func_convert_path_msys_to_w32:
+ func_stripname : : "$1"
+ func_to_host_path_tmp1=$func_stripname_result
+ func_to_host_path_result=`cygpath -m -p "$func_to_host_path_tmp1"`
+ func_convert_path_check : ";" \
+ "$func_to_host_path_tmp1" "$func_to_host_path_result"
+ func_convert_path_front_back_pathsep ":*" "*:" ";" "$1"
+ fi
+}
+# end func_convert_path_cygwin_to_w32
+
+
+# func_convert_path_nix_to_w32 ARG
+# Convert path ARG from *nix to w32 format. Requires a wine environment and
+# a working winepath. Returns result in func_to_host_file_result.
+func_convert_path_nix_to_w32 ()
+{
+ $opt_debug
+ func_to_host_path_result="$1"
+ if test -n "$1"; then
+ # See func_convert_path_msys_to_w32:
+ func_stripname : : "$1"
+ func_to_host_path_tmp1=$func_stripname_result
+ func_convert_core_path_wine_to_w32 "$func_to_host_path_tmp1"
+ func_to_host_path_result="$func_convert_core_path_wine_to_w32_result"
+ func_convert_path_check : ";" \
+ "$func_to_host_path_tmp1" "$func_to_host_path_result"
+ func_convert_path_front_back_pathsep ":*" "*:" ";" "$1"
+ fi
+}
+# end func_convert_path_nix_to_w32
+
+
+# func_convert_path_msys_to_cygwin ARG
+# Convert path ARG from MSYS to Cygwin format. Requires LT_CYGPATH set.
+# Returns result in func_to_host_file_result.
+func_convert_path_msys_to_cygwin ()
+{
+ $opt_debug
+ func_to_host_path_result="$1"
+ if test -n "$1"; then
+ # See func_convert_path_msys_to_w32:
+ func_stripname : : "$1"
+ func_to_host_path_tmp1=$func_stripname_result
+ func_convert_core_msys_to_w32 "$func_to_host_path_tmp1"
+ func_cygpath -u -p "$func_convert_core_msys_to_w32_result"
+ func_to_host_path_result="$func_cygpath_result"
+ func_convert_path_check : : \
+ "$func_to_host_path_tmp1" "$func_to_host_path_result"
+ func_convert_path_front_back_pathsep ":*" "*:" : "$1"
+ fi
+}
+# end func_convert_path_msys_to_cygwin
+
+
+# func_convert_path_nix_to_cygwin ARG
+# Convert path ARG from *nix to Cygwin format. Requires Cygwin installed in a
+# a wine environment, working winepath, and LT_CYGPATH set. Returns result in
+# func_to_host_file_result.
+func_convert_path_nix_to_cygwin ()
+{
+ $opt_debug
+ func_to_host_path_result="$1"
+ if test -n "$1"; then
+ # Remove leading and trailing path separator characters from
+ # ARG. msys behavior is inconsistent here, cygpath turns them
+ # into '.;' and ';.', and winepath ignores them completely.
+ func_stripname : : "$1"
+ func_to_host_path_tmp1=$func_stripname_result
+ func_convert_core_path_wine_to_w32 "$func_to_host_path_tmp1"
+ func_cygpath -u -p "$func_convert_core_path_wine_to_w32_result"
+ func_to_host_path_result="$func_cygpath_result"
+ func_convert_path_check : : \
+ "$func_to_host_path_tmp1" "$func_to_host_path_result"
+ func_convert_path_front_back_pathsep ":*" "*:" : "$1"
+ fi
+}
+# end func_convert_path_nix_to_cygwin
+
+
+# func_mode_compile arg...
+func_mode_compile ()
+{
+ $opt_debug
+ # Get the compilation command and the source file.
+ base_compile=
+ srcfile="$nonopt" # always keep a non-empty value in "srcfile"
+ suppress_opt=yes
+ suppress_output=
+ arg_mode=normal
+ libobj=
+ later=
+ pie_flag=
+
+ for arg
+ do
+ case $arg_mode in
+ arg )
+ # do not "continue". Instead, add this to base_compile
+ lastarg="$arg"
+ arg_mode=normal
+ ;;
+
+ target )
+ libobj="$arg"
+ arg_mode=normal
+ continue
+ ;;
+
+ normal )
+ # Accept any command-line options.
+ case $arg in
+ -o)
+ test -n "$libobj" && \
+ func_fatal_error "you cannot specify \`-o' more than once"
+ arg_mode=target
+ continue
+ ;;
+
+ -pie | -fpie | -fPIE)
+ func_append pie_flag " $arg"
+ continue
+ ;;
+
+ -shared | -static | -prefer-pic | -prefer-non-pic)
+ func_append later " $arg"
+ continue
+ ;;
+
+ -no-suppress)
+ suppress_opt=no
+ continue
+ ;;
+
+ -Xcompiler)
+ arg_mode=arg # the next one goes into the "base_compile" arg list
+ continue # The current "srcfile" will either be retained or
+ ;; # replaced later. I would guess that would be a bug.
+
+ -Wc,*)
+ func_stripname '-Wc,' '' "$arg"
+ args=$func_stripname_result
+ lastarg=
+ save_ifs="$IFS"; IFS=','
+ for arg in $args; do
+ IFS="$save_ifs"
+ func_append_quoted lastarg "$arg"
+ done
+ IFS="$save_ifs"
+ func_stripname ' ' '' "$lastarg"
+ lastarg=$func_stripname_result
+
+ # Add the arguments to base_compile.
+ func_append base_compile " $lastarg"
+ continue
+ ;;
+
+ *)
+ # Accept the current argument as the source file.
+ # The previous "srcfile" becomes the current argument.
+ #
+ lastarg="$srcfile"
+ srcfile="$arg"
+ ;;
+ esac # case $arg
+ ;;
+ esac # case $arg_mode
+
+ # Aesthetically quote the previous argument.
+ func_append_quoted base_compile "$lastarg"
+ done # for arg
+
+ case $arg_mode in
+ arg)
+ func_fatal_error "you must specify an argument for -Xcompile"
+ ;;
+ target)
+ func_fatal_error "you must specify a target with \`-o'"
+ ;;
+ *)
+ # Get the name of the library object.
+ test -z "$libobj" && {
+ func_basename "$srcfile"
+ libobj="$func_basename_result"
+ }
+ ;;
+ esac
+
+ # Recognize several different file suffixes.
+ # If the user specifies -o file.o, it is replaced with file.lo
+ case $libobj in
+ *.[cCFSifmso] | \
+ *.ada | *.adb | *.ads | *.asm | \
+ *.c++ | *.cc | *.ii | *.class | *.cpp | *.cxx | \
+ *.[fF][09]? | *.for | *.java | *.obj | *.sx | *.cu | *.cup)
+ func_xform "$libobj"
+ libobj=$func_xform_result
+ ;;
+ esac
+
+ case $libobj in
+ *.lo) func_lo2o "$libobj"; obj=$func_lo2o_result ;;
+ *)
+ func_fatal_error "cannot determine name of library object from \`$libobj'"
+ ;;
+ esac
+
+ func_infer_tag $base_compile
+
+ for arg in $later; do
+ case $arg in
+ -shared)
+ test "$build_libtool_libs" != yes && \
+ func_fatal_configuration "can not build a shared library"
+ build_old_libs=no
+ continue
+ ;;
+
+ -static)
+ build_libtool_libs=no
+ build_old_libs=yes
+ continue
+ ;;
+
+ -prefer-pic)
+ pic_mode=yes
+ continue
+ ;;
+
+ -prefer-non-pic)
+ pic_mode=no
+ continue
+ ;;
+ esac
+ done
+
+ func_quote_for_eval "$libobj"
+ test "X$libobj" != "X$func_quote_for_eval_result" \
+ && $ECHO "X$libobj" | $GREP '[]~#^*{};<>?"'"'"' &()|`$[]' \
+ && func_warning "libobj name \`$libobj' may not contain shell special characters."
+ func_dirname_and_basename "$obj" "/" ""
+ objname="$func_basename_result"
+ xdir="$func_dirname_result"
+ lobj=${xdir}$objdir/$objname
+
+ test -z "$base_compile" && \
+ func_fatal_help "you must specify a compilation command"
+
+ # Delete any leftover library objects.
+ if test "$build_old_libs" = yes; then
+ removelist="$obj $lobj $libobj ${libobj}T"
+ else
+ removelist="$lobj $libobj ${libobj}T"
+ fi
+
+ # On Cygwin there's no "real" PIC flag so we must build both object types
+ case $host_os in
+ cygwin* | mingw* | pw32* | os2* | cegcc*)
+ pic_mode=default
+ ;;
+ esac
+ if test "$pic_mode" = no && test "$deplibs_check_method" != pass_all; then
+ # non-PIC code in shared libraries is not supported
+ pic_mode=default
+ fi
+
+ # Calculate the filename of the output object if compiler does
+ # not support -o with -c
+ if test "$compiler_c_o" = no; then
+ output_obj=`$ECHO "$srcfile" | $SED 's%^.*/%%; s%\.[^.]*$%%'`.${objext}
+ lockfile="$output_obj.lock"
+ else
+ output_obj=
+ need_locks=no
+ lockfile=
+ fi
+
+ # Lock this critical section if it is needed
+ # We use this script file to make the link, it avoids creating a new file
+ if test "$need_locks" = yes; then
+ until $opt_dry_run || ln "$progpath" "$lockfile" 2>/dev/null; do
+ func_echo "Waiting for $lockfile to be removed"
+ sleep 2
+ done
+ elif test "$need_locks" = warn; then
+ if test -f "$lockfile"; then
+ $ECHO "\
+*** ERROR, $lockfile exists and contains:
+`cat $lockfile 2>/dev/null`
+
+This indicates that another process is trying to use the same
+temporary object file, and libtool could not work around it because
+your compiler does not support \`-c' and \`-o' together. If you
+repeat this compilation, it may succeed, by chance, but you had better
+avoid parallel builds (make -j) in this platform, or get a better
+compiler."
+
+ $opt_dry_run || $RM $removelist
+ exit $EXIT_FAILURE
+ fi
+ func_append removelist " $output_obj"
+ $ECHO "$srcfile" > "$lockfile"
+ fi
+
+ $opt_dry_run || $RM $removelist
+ func_append removelist " $lockfile"
+ trap '$opt_dry_run || $RM $removelist; exit $EXIT_FAILURE' 1 2 15
+
+ func_to_tool_file "$srcfile" func_convert_file_msys_to_w32
+ srcfile=$func_to_tool_file_result
+ func_quote_for_eval "$srcfile"
+ qsrcfile=$func_quote_for_eval_result
+
+ # Only build a PIC object if we are building libtool libraries.
+ if test "$build_libtool_libs" = yes; then
+ # Without this assignment, base_compile gets emptied.
+ fbsd_hideous_sh_bug=$base_compile
+
+ if test "$pic_mode" != no; then
+ command="$base_compile $qsrcfile $pic_flag"
+ else
+ # Don't build PIC code
+ command="$base_compile $qsrcfile"
+ fi
+
+ func_mkdir_p "$xdir$objdir"
+
+ if test -z "$output_obj"; then
+ # Place PIC objects in $objdir
+ func_append command " -o $lobj"
+ fi
+
+ func_show_eval_locale "$command" \
+ 'test -n "$output_obj" && $RM $removelist; exit $EXIT_FAILURE'
+
+ if test "$need_locks" = warn &&
+ test "X`cat $lockfile 2>/dev/null`" != "X$srcfile"; then
+ $ECHO "\
+*** ERROR, $lockfile contains:
+`cat $lockfile 2>/dev/null`
+
+but it should contain:
+$srcfile
+
+This indicates that another process is trying to use the same
+temporary object file, and libtool could not work around it because
+your compiler does not support \`-c' and \`-o' together. If you
+repeat this compilation, it may succeed, by chance, but you had better
+avoid parallel builds (make -j) in this platform, or get a better
+compiler."
+
+ $opt_dry_run || $RM $removelist
+ exit $EXIT_FAILURE
+ fi
+
+ # Just move the object if needed, then go on to compile the next one
+ if test -n "$output_obj" && test "X$output_obj" != "X$lobj"; then
+ func_show_eval '$MV "$output_obj" "$lobj"' \
+ 'error=$?; $opt_dry_run || $RM $removelist; exit $error'
+ fi
+
+ # Allow error messages only from the first compilation.
+ if test "$suppress_opt" = yes; then
+ suppress_output=' >/dev/null 2>&1'
+ fi
+ fi
+
+ # Only build a position-dependent object if we build old libraries.
+ if test "$build_old_libs" = yes; then
+ if test "$pic_mode" != yes; then
+ # Don't build PIC code
+ command="$base_compile $qsrcfile$pie_flag"
+ else
+ command="$base_compile $qsrcfile $pic_flag"
+ fi
+ if test "$compiler_c_o" = yes; then
+ func_append command " -o $obj"
+ fi
+
+ # Suppress compiler output if we already did a PIC compilation.
+ func_append command "$suppress_output"
+ func_show_eval_locale "$command" \
+ '$opt_dry_run || $RM $removelist; exit $EXIT_FAILURE'
+
+ if test "$need_locks" = warn &&
+ test "X`cat $lockfile 2>/dev/null`" != "X$srcfile"; then
+ $ECHO "\
+*** ERROR, $lockfile contains:
+`cat $lockfile 2>/dev/null`
+
+but it should contain:
+$srcfile
+
+This indicates that another process is trying to use the same
+temporary object file, and libtool could not work around it because
+your compiler does not support \`-c' and \`-o' together. If you
+repeat this compilation, it may succeed, by chance, but you had better
+avoid parallel builds (make -j) in this platform, or get a better
+compiler."
+
+ $opt_dry_run || $RM $removelist
+ exit $EXIT_FAILURE
+ fi
+
+ # Just move the object if needed
+ if test -n "$output_obj" && test "X$output_obj" != "X$obj"; then
+ func_show_eval '$MV "$output_obj" "$obj"' \
+ 'error=$?; $opt_dry_run || $RM $removelist; exit $error'
+ fi
+ fi
+
+ $opt_dry_run || {
+ func_write_libtool_object "$libobj" "$objdir/$objname" "$objname"
+
+ # Unlock the critical section if it was locked
+ if test "$need_locks" != no; then
+ removelist=$lockfile
+ $RM "$lockfile"
+ fi
+ }
+
+ exit $EXIT_SUCCESS
+}
+
+$opt_help || {
+ test "$opt_mode" = compile && func_mode_compile ${1+"$@"}
+}
+
+func_mode_help ()
+{
+ # We need to display help for each of the modes.
+ case $opt_mode in
+ "")
+ # Generic help is extracted from the usage comments
+ # at the start of this file.
+ func_help
+ ;;
+
+ clean)
+ $ECHO \
+"Usage: $progname [OPTION]... --mode=clean RM [RM-OPTION]... FILE...
+
+Remove files from the build directory.
+
+RM is the name of the program to use to delete files associated with each FILE
+(typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed
+to RM.
+
+If FILE is a libtool library, object or program, all the files associated
+with it are deleted. Otherwise, only FILE itself is deleted using RM."
+ ;;
+
+ compile)
+ $ECHO \
+"Usage: $progname [OPTION]... --mode=compile COMPILE-COMMAND... SOURCEFILE
+
+Compile a source file into a libtool library object.
+
+This mode accepts the following additional options:
+
+ -o OUTPUT-FILE set the output file name to OUTPUT-FILE
+ -no-suppress do not suppress compiler output for multiple passes
+ -prefer-pic try to build PIC objects only
+ -prefer-non-pic try to build non-PIC objects only
+ -shared do not build a \`.o' file suitable for static linking
+ -static only build a \`.o' file suitable for static linking
+ -Wc,FLAG pass FLAG directly to the compiler
+
+COMPILE-COMMAND is a command to be used in creating a \`standard' object file
+from the given SOURCEFILE.
+
+The output file name is determined by removing the directory component from
+SOURCEFILE, then substituting the C source code suffix \`.c' with the
+library object suffix, \`.lo'."
+ ;;
+
+ execute)
+ $ECHO \
+"Usage: $progname [OPTION]... --mode=execute COMMAND [ARGS]...
+
+Automatically set library path, then run a program.
+
+This mode accepts the following additional options:
+
+ -dlopen FILE add the directory containing FILE to the library path
+
+This mode sets the library path environment variable according to \`-dlopen'
+flags.
+
+If any of the ARGS are libtool executable wrappers, then they are translated
+into their corresponding uninstalled binary, and any of their required library
+directories are added to the library path.
+
+Then, COMMAND is executed, with ARGS as arguments."
+ ;;
+
+ finish)
+ $ECHO \
+"Usage: $progname [OPTION]... --mode=finish [LIBDIR]...
+
+Complete the installation of libtool libraries.
+
+Each LIBDIR is a directory that contains libtool libraries.
+
+The commands that this mode executes may require superuser privileges. Use
+the \`--dry-run' option if you just want to see what would be executed."
+ ;;
+
+ install)
+ $ECHO \
+"Usage: $progname [OPTION]... --mode=install INSTALL-COMMAND...
+
+Install executables or libraries.
+
+INSTALL-COMMAND is the installation command. The first component should be
+either the \`install' or \`cp' program.
+
+The following components of INSTALL-COMMAND are treated specially:
+
+ -inst-prefix-dir PREFIX-DIR Use PREFIX-DIR as a staging area for installation
+
+The rest of the components are interpreted as arguments to that command (only
+BSD-compatible install options are recognized)."
+ ;;
+
+ link)
+ $ECHO \
+"Usage: $progname [OPTION]... --mode=link LINK-COMMAND...
+
+Link object files or libraries together to form another library, or to
+create an executable program.
+
+LINK-COMMAND is a command using the C compiler that you would use to create
+a program from several object files.
+
+The following components of LINK-COMMAND are treated specially:
+
+ -all-static do not do any dynamic linking at all
+ -avoid-version do not add a version suffix if possible
+ -bindir BINDIR specify path to binaries directory (for systems where
+ libraries must be found in the PATH setting at runtime)
+ -dlopen FILE \`-dlpreopen' FILE if it cannot be dlopened at runtime
+ -dlpreopen FILE link in FILE and add its symbols to lt_preloaded_symbols
+ -export-dynamic allow symbols from OUTPUT-FILE to be resolved with dlsym(3)
+ -export-symbols SYMFILE
+ try to export only the symbols listed in SYMFILE
+ -export-symbols-regex REGEX
+ try to export only the symbols matching REGEX
+ -LLIBDIR search LIBDIR for required installed libraries
+ -lNAME OUTPUT-FILE requires the installed library libNAME
+ -module build a library that can dlopened
+ -no-fast-install disable the fast-install mode
+ -no-install link a not-installable executable
+ -no-undefined declare that a library does not refer to external symbols
+ -o OUTPUT-FILE create OUTPUT-FILE from the specified objects
+ -objectlist FILE Use a list of object files found in FILE to specify objects
+ -precious-files-regex REGEX
+ don't remove output files matching REGEX
+ -release RELEASE specify package release information
+ -rpath LIBDIR the created library will eventually be installed in LIBDIR
+ -R[ ]LIBDIR add LIBDIR to the runtime path of programs and libraries
+ -shared only do dynamic linking of libtool libraries
+ -shrext SUFFIX override the standard shared library file extension
+ -static do not do any dynamic linking of uninstalled libtool libraries
+ -static-libtool-libs
+ do not do any dynamic linking of libtool libraries
+ -version-info CURRENT[:REVISION[:AGE]]
+ specify library version info [each variable defaults to 0]
+ -weak LIBNAME declare that the target provides the LIBNAME interface
+ -Wc,FLAG
+ -Xcompiler FLAG pass linker-specific FLAG directly to the compiler
+ -Wl,FLAG
+ -Xlinker FLAG pass linker-specific FLAG directly to the linker
+ -XCClinker FLAG pass link-specific FLAG to the compiler driver (CC)
+
+All other options (arguments beginning with \`-') are ignored.
+
+Every other argument is treated as a filename. Files ending in \`.la' are
+treated as uninstalled libtool libraries, other files are standard or library
+object files.
+
+If the OUTPUT-FILE ends in \`.la', then a libtool library is created,
+only library objects (\`.lo' files) may be specified, and \`-rpath' is
+required, except when creating a convenience library.
+
+If OUTPUT-FILE ends in \`.a' or \`.lib', then a standard library is created
+using \`ar' and \`ranlib', or on Windows using \`lib'.
+
+If OUTPUT-FILE ends in \`.lo' or \`.${objext}', then a reloadable object file
+is created, otherwise an executable program is created."
+ ;;
+
+ uninstall)
+ $ECHO \
+"Usage: $progname [OPTION]... --mode=uninstall RM [RM-OPTION]... FILE...
+
+Remove libraries from an installation directory.
+
+RM is the name of the program to use to delete files associated with each FILE
+(typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed
+to RM.
+
+If FILE is a libtool library, all the files associated with it are deleted.
+Otherwise, only FILE itself is deleted using RM."
+ ;;
+
+ *)
+ func_fatal_help "invalid operation mode \`$opt_mode'"
+ ;;
+ esac
+
+ echo
+ $ECHO "Try \`$progname --help' for more information about other modes."
+}
+
+# Now that we've collected a possible --mode arg, show help if necessary
+if $opt_help; then
+ if test "$opt_help" = :; then
+ func_mode_help
+ else
+ {
+ func_help noexit
+ for opt_mode in compile link execute install finish uninstall clean; do
+ func_mode_help
+ done
+ } | sed -n '1p; 2,$s/^Usage:/ or: /p'
+ {
+ func_help noexit
+ for opt_mode in compile link execute install finish uninstall clean; do
+ echo
+ func_mode_help
+ done
+ } |
+ sed '1d
+ /^When reporting/,/^Report/{
+ H
+ d
+ }
+ $x
+ /information about other modes/d
+ /more detailed .*MODE/d
+ s/^Usage:.*--mode=\([^ ]*\) .*/Description of \1 mode:/'
+ fi
+ exit $?
+fi
+
+
+# func_mode_execute arg...
+func_mode_execute ()
+{
+ $opt_debug
+ # The first argument is the command name.
+ cmd="$nonopt"
+ test -z "$cmd" && \
+ func_fatal_help "you must specify a COMMAND"
+
+ # Handle -dlopen flags immediately.
+ for file in $opt_dlopen; do
+ test -f "$file" \
+ || func_fatal_help "\`$file' is not a file"
+
+ dir=
+ case $file in
+ *.la)
+ func_resolve_sysroot "$file"
+ file=$func_resolve_sysroot_result
+
+ # Check to see that this really is a libtool archive.
+ func_lalib_unsafe_p "$file" \
+ || func_fatal_help "\`$lib' is not a valid libtool archive"
+
+ # Read the libtool library.
+ dlname=
+ library_names=
+ func_source "$file"
+
+ # Skip this library if it cannot be dlopened.
+ if test -z "$dlname"; then
+ # Warn if it was a shared library.
+ test -n "$library_names" && \
+ func_warning "\`$file' was not linked with \`-export-dynamic'"
+ continue
+ fi
+
+ func_dirname "$file" "" "."
+ dir="$func_dirname_result"
+
+ if test -f "$dir/$objdir/$dlname"; then
+ func_append dir "/$objdir"
+ else
+ if test ! -f "$dir/$dlname"; then
+ func_fatal_error "cannot find \`$dlname' in \`$dir' or \`$dir/$objdir'"
+ fi
+ fi
+ ;;
+
+ *.lo)
+ # Just add the directory containing the .lo file.
+ func_dirname "$file" "" "."
+ dir="$func_dirname_result"
+ ;;
+
+ *)
+ func_warning "\`-dlopen' is ignored for non-libtool libraries and objects"
+ continue
+ ;;
+ esac
+
+ # Get the absolute pathname.
+ absdir=`cd "$dir" && pwd`
+ test -n "$absdir" && dir="$absdir"
+
+ # Now add the directory to shlibpath_var.
+ if eval "test -z \"\$$shlibpath_var\""; then
+ eval "$shlibpath_var=\"\$dir\""
+ else
+ eval "$shlibpath_var=\"\$dir:\$$shlibpath_var\""
+ fi
+ done
+
+ # This variable tells wrapper scripts just to set shlibpath_var
+ # rather than running their programs.
+ libtool_execute_magic="$magic"
+
+ # Check if any of the arguments is a wrapper script.
+ args=
+ for file
+ do
+ case $file in
+ -* | *.la | *.lo ) ;;
+ *)
+ # Do a test to see if this is really a libtool program.
+ if func_ltwrapper_script_p "$file"; then
+ func_source "$file"
+ # Transform arg to wrapped name.
+ file="$progdir/$program"
+ elif func_ltwrapper_executable_p "$file"; then
+ func_ltwrapper_scriptname "$file"
+ func_source "$func_ltwrapper_scriptname_result"
+ # Transform arg to wrapped name.
+ file="$progdir/$program"
+ fi
+ ;;
+ esac
+ # Quote arguments (to preserve shell metacharacters).
+ func_append_quoted args "$file"
+ done
+
+ if test "X$opt_dry_run" = Xfalse; then
+ if test -n "$shlibpath_var"; then
+ # Export the shlibpath_var.
+ eval "export $shlibpath_var"
+ fi
+
+ # Restore saved environment variables
+ for lt_var in LANG LANGUAGE LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES
+ do
+ eval "if test \"\${save_$lt_var+set}\" = set; then
+ $lt_var=\$save_$lt_var; export $lt_var
+ else
+ $lt_unset $lt_var
+ fi"
+ done
+
+ # Now prepare to actually exec the command.
+ exec_cmd="\$cmd$args"
+ else
+ # Display what would be done.
+ if test -n "$shlibpath_var"; then
+ eval "\$ECHO \"\$shlibpath_var=\$$shlibpath_var\""
+ echo "export $shlibpath_var"
+ fi
+ $ECHO "$cmd$args"
+ exit $EXIT_SUCCESS
+ fi
+}
+
+test "$opt_mode" = execute && func_mode_execute ${1+"$@"}
+
+
+# func_mode_finish arg...
+func_mode_finish ()
+{
+ $opt_debug
+ libs=
+ libdirs=
+ admincmds=
+
+ for opt in "$nonopt" ${1+"$@"}
+ do
+ if test -d "$opt"; then
+ func_append libdirs " $opt"
+
+ elif test -f "$opt"; then
+ if func_lalib_unsafe_p "$opt"; then
+ func_append libs " $opt"
+ else
+ func_warning "\`$opt' is not a valid libtool archive"
+ fi
+
+ else
+ func_fatal_error "invalid argument \`$opt'"
+ fi
+ done
+
+ if test -n "$libs"; then
+ if test -n "$lt_sysroot"; then
+ sysroot_regex=`$ECHO "$lt_sysroot" | $SED "$sed_make_literal_regex"`
+ sysroot_cmd="s/\([ ']\)$sysroot_regex/\1/g;"
+ else
+ sysroot_cmd=
+ fi
+
+ # Remove sysroot references
+ if $opt_dry_run; then
+ for lib in $libs; do
+ echo "removing references to $lt_sysroot and \`=' prefixes from $lib"
+ done
+ else
+ tmpdir=`func_mktempdir`
+ for lib in $libs; do
+ sed -e "${sysroot_cmd} s/\([ ']-[LR]\)=/\1/g; s/\([ ']\)=/\1/g" $lib \
+ > $tmpdir/tmp-la
+ mv -f $tmpdir/tmp-la $lib
+ done
+ ${RM}r "$tmpdir"
+ fi
+ fi
+
+ if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then
+ for libdir in $libdirs; do
+ if test -n "$finish_cmds"; then
+ # Do each command in the finish commands.
+ func_execute_cmds "$finish_cmds" 'admincmds="$admincmds
+'"$cmd"'"'
+ fi
+ if test -n "$finish_eval"; then
+ # Do the single finish_eval.
+ eval cmds=\"$finish_eval\"
+ $opt_dry_run || eval "$cmds" || func_append admincmds "
+ $cmds"
+ fi
+ done
+ fi
+
+ # Exit here if they wanted silent mode.
+ $opt_silent && exit $EXIT_SUCCESS
+
+ if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then
+ echo "----------------------------------------------------------------------"
+ echo "Libraries have been installed in:"
+ for libdir in $libdirs; do
+ $ECHO " $libdir"
+ done
+ echo
+ echo "If you ever happen to want to link against installed libraries"
+ echo "in a given directory, LIBDIR, you must either use libtool, and"
+ echo "specify the full pathname of the library, or use the \`-LLIBDIR'"
+ echo "flag during linking and do at least one of the following:"
+ if test -n "$shlibpath_var"; then
+ echo " - add LIBDIR to the \`$shlibpath_var' environment variable"
+ echo " during execution"
+ fi
+ if test -n "$runpath_var"; then
+ echo " - add LIBDIR to the \`$runpath_var' environment variable"
+ echo " during linking"
+ fi
+ if test -n "$hardcode_libdir_flag_spec"; then
+ libdir=LIBDIR
+ eval flag=\"$hardcode_libdir_flag_spec\"
+
+ $ECHO " - use the \`$flag' linker flag"
+ fi
+ if test -n "$admincmds"; then
+ $ECHO " - have your system administrator run these commands:$admincmds"
+ fi
+ if test -f /etc/ld.so.conf; then
+ echo " - have your system administrator add LIBDIR to \`/etc/ld.so.conf'"
+ fi
+ echo
+
+ echo "See any operating system documentation about shared libraries for"
+ case $host in
+ solaris2.[6789]|solaris2.1[0-9])
+ echo "more information, such as the ld(1), crle(1) and ld.so(8) manual"
+ echo "pages."
+ ;;
+ *)
+ echo "more information, such as the ld(1) and ld.so(8) manual pages."
+ ;;
+ esac
+ echo "----------------------------------------------------------------------"
+ fi
+ exit $EXIT_SUCCESS
+}
+
+test "$opt_mode" = finish && func_mode_finish ${1+"$@"}
+
+
+# func_mode_install arg...
+func_mode_install ()
+{
+ $opt_debug
+ # There may be an optional sh(1) argument at the beginning of
+ # install_prog (especially on Windows NT).
+ if test "$nonopt" = "$SHELL" || test "$nonopt" = /bin/sh ||
+ # Allow the use of GNU shtool's install command.
+ case $nonopt in *shtool*) :;; *) false;; esac; then
+ # Aesthetically quote it.
+ func_quote_for_eval "$nonopt"
+ install_prog="$func_quote_for_eval_result "
+ arg=$1
+ shift
+ else
+ install_prog=
+ arg=$nonopt
+ fi
+
+ # The real first argument should be the name of the installation program.
+ # Aesthetically quote it.
+ func_quote_for_eval "$arg"
+ func_append install_prog "$func_quote_for_eval_result"
+ install_shared_prog=$install_prog
+ case " $install_prog " in
+ *[\\\ /]cp\ *) install_cp=: ;;
+ *) install_cp=false ;;
+ esac
+
+ # We need to accept at least all the BSD install flags.
+ dest=
+ files=
+ opts=
+ prev=
+ install_type=
+ isdir=no
+ stripme=
+ no_mode=:
+ for arg
+ do
+ arg2=
+ if test -n "$dest"; then
+ func_append files " $dest"
+ dest=$arg
+ continue
+ fi
+
+ case $arg in
+ -d) isdir=yes ;;
+ -f)
+ if $install_cp; then :; else
+ prev=$arg
+ fi
+ ;;
+ -g | -m | -o)
+ prev=$arg
+ ;;
+ -s)
+ stripme=" -s"
+ continue
+ ;;
+ -*)
+ ;;
+ *)
+ # If the previous option needed an argument, then skip it.
+ if test -n "$prev"; then
+ if test "x$prev" = x-m && test -n "$install_override_mode"; then
+ arg2=$install_override_mode
+ no_mode=false
+ fi
+ prev=
+ else
+ dest=$arg
+ continue
+ fi
+ ;;
+ esac
+
+ # Aesthetically quote the argument.
+ func_quote_for_eval "$arg"
+ func_append install_prog " $func_quote_for_eval_result"
+ if test -n "$arg2"; then
+ func_quote_for_eval "$arg2"
+ fi
+ func_append install_shared_prog " $func_quote_for_eval_result"
+ done
+
+ test -z "$install_prog" && \
+ func_fatal_help "you must specify an install program"
+
+ test -n "$prev" && \
+ func_fatal_help "the \`$prev' option requires an argument"
+
+ if test -n "$install_override_mode" && $no_mode; then
+ if $install_cp; then :; else
+ func_quote_for_eval "$install_override_mode"
+ func_append install_shared_prog " -m $func_quote_for_eval_result"
+ fi
+ fi
+
+ if test -z "$files"; then
+ if test -z "$dest"; then
+ func_fatal_help "no file or destination specified"
+ else
+ func_fatal_help "you must specify a destination"
+ fi
+ fi
+
+ # Strip any trailing slash from the destination.
+ func_stripname '' '/' "$dest"
+ dest=$func_stripname_result
+
+ # Check to see that the destination is a directory.
+ test -d "$dest" && isdir=yes
+ if test "$isdir" = yes; then
+ destdir="$dest"
+ destname=
+ else
+ func_dirname_and_basename "$dest" "" "."
+ destdir="$func_dirname_result"
+ destname="$func_basename_result"
+
+ # Not a directory, so check to see that there is only one file specified.
+ set dummy $files; shift
+ test "$#" -gt 1 && \
+ func_fatal_help "\`$dest' is not a directory"
+ fi
+ case $destdir in
+ [\\/]* | [A-Za-z]:[\\/]*) ;;
+ *)
+ for file in $files; do
+ case $file in
+ *.lo) ;;
+ *)
+ func_fatal_help "\`$destdir' must be an absolute directory name"
+ ;;
+ esac
+ done
+ ;;
+ esac
+
+ # This variable tells wrapper scripts just to set variables rather
+ # than running their programs.
+ libtool_install_magic="$magic"
+
+ staticlibs=
+ future_libdirs=
+ current_libdirs=
+ for file in $files; do
+
+ # Do each installation.
+ case $file in
+ *.$libext)
+ # Do the static libraries later.
+ func_append staticlibs " $file"
+ ;;
+
+ *.la)
+ func_resolve_sysroot "$file"
+ file=$func_resolve_sysroot_result
+
+ # Check to see that this really is a libtool archive.
+ func_lalib_unsafe_p "$file" \
+ || func_fatal_help "\`$file' is not a valid libtool archive"
+
+ library_names=
+ old_library=
+ relink_command=
+ func_source "$file"
+
+ # Add the libdir to current_libdirs if it is the destination.
+ if test "X$destdir" = "X$libdir"; then
+ case "$current_libdirs " in
+ *" $libdir "*) ;;
+ *) func_append current_libdirs " $libdir" ;;
+ esac
+ else
+ # Note the libdir as a future libdir.
+ case "$future_libdirs " in
+ *" $libdir "*) ;;
+ *) func_append future_libdirs " $libdir" ;;
+ esac
+ fi
+
+ func_dirname "$file" "/" ""
+ dir="$func_dirname_result"
+ func_append dir "$objdir"
+
+ if test -n "$relink_command"; then
+ # Determine the prefix the user has applied to our future dir.
+ inst_prefix_dir=`$ECHO "$destdir" | $SED -e "s%$libdir\$%%"`
+
+ # Don't allow the user to place us outside of our expected
+ # location b/c this prevents finding dependent libraries that
+ # are installed to the same prefix.
+ # At present, this check doesn't affect windows .dll's that
+ # are installed into $libdir/../bin (currently, that works fine)
+ # but it's something to keep an eye on.
+ test "$inst_prefix_dir" = "$destdir" && \
+ func_fatal_error "error: cannot install \`$file' to a directory not ending in $libdir"
+
+ if test -n "$inst_prefix_dir"; then
+ # Stick the inst_prefix_dir data into the link command.
+ relink_command=`$ECHO "$relink_command" | $SED "s%@inst_prefix_dir@%-inst-prefix-dir $inst_prefix_dir%"`
+ else
+ relink_command=`$ECHO "$relink_command" | $SED "s%@inst_prefix_dir@%%"`
+ fi
+
+ func_warning "relinking \`$file'"
+ func_show_eval "$relink_command" \
+ 'func_fatal_error "error: relink \`$file'\'' with the above command before installing it"'
+ fi
+
+ # See the names of the shared library.
+ set dummy $library_names; shift
+ if test -n "$1"; then
+ realname="$1"
+ shift
+
+ srcname="$realname"
+ test -n "$relink_command" && srcname="$realname"T
+
+ # Install the shared library and build the symlinks.
+ func_show_eval "$install_shared_prog $dir/$srcname $destdir/$realname" \
+ 'exit $?'
+ tstripme="$stripme"
+ case $host_os in
+ cygwin* | mingw* | pw32* | cegcc*)
+ case $realname in
+ *.dll.a)
+ tstripme=""
+ ;;
+ esac
+ ;;
+ esac
+ if test -n "$tstripme" && test -n "$striplib"; then
+ func_show_eval "$striplib $destdir/$realname" 'exit $?'
+ fi
+
+ if test "$#" -gt 0; then
+ # Delete the old symlinks, and create new ones.
+ # Try `ln -sf' first, because the `ln' binary might depend on
+ # the symlink we replace! Solaris /bin/ln does not understand -f,
+ # so we also need to try rm && ln -s.
+ for linkname
+ do
+ test "$linkname" != "$realname" \
+ && func_show_eval "(cd $destdir && { $LN_S -f $realname $linkname || { $RM $linkname && $LN_S $realname $linkname; }; })"
+ done
+ fi
+
+ # Do each command in the postinstall commands.
+ lib="$destdir/$realname"
+ func_execute_cmds "$postinstall_cmds" 'exit $?'
+ fi
+
+ # Install the pseudo-library for information purposes.
+ func_basename "$file"
+ name="$func_basename_result"
+ instname="$dir/$name"i
+ func_show_eval "$install_prog $instname $destdir/$name" 'exit $?'
+
+ # Maybe install the static library, too.
+ test -n "$old_library" && func_append staticlibs " $dir/$old_library"
+ ;;
+
+ *.lo)
+ # Install (i.e. copy) a libtool object.
+
+ # Figure out destination file name, if it wasn't already specified.
+ if test -n "$destname"; then
+ destfile="$destdir/$destname"
+ else
+ func_basename "$file"
+ destfile="$func_basename_result"
+ destfile="$destdir/$destfile"
+ fi
+
+ # Deduce the name of the destination old-style object file.
+ case $destfile in
+ *.lo)
+ func_lo2o "$destfile"
+ staticdest=$func_lo2o_result
+ ;;
+ *.$objext)
+ staticdest="$destfile"
+ destfile=
+ ;;
+ *)
+ func_fatal_help "cannot copy a libtool object to \`$destfile'"
+ ;;
+ esac
+
+ # Install the libtool object if requested.
+ test -n "$destfile" && \
+ func_show_eval "$install_prog $file $destfile" 'exit $?'
+
+ # Install the old object if enabled.
+ if test "$build_old_libs" = yes; then
+ # Deduce the name of the old-style object file.
+ func_lo2o "$file"
+ staticobj=$func_lo2o_result
+ func_show_eval "$install_prog \$staticobj \$staticdest" 'exit $?'
+ fi
+ exit $EXIT_SUCCESS
+ ;;
+
+ *)
+ # Figure out destination file name, if it wasn't already specified.
+ if test -n "$destname"; then
+ destfile="$destdir/$destname"
+ else
+ func_basename "$file"
+ destfile="$func_basename_result"
+ destfile="$destdir/$destfile"
+ fi
+
+ # If the file is missing, and there is a .exe on the end, strip it
+ # because it is most likely a libtool script we actually want to
+ # install
+ stripped_ext=""
+ case $file in
+ *.exe)
+ if test ! -f "$file"; then
+ func_stripname '' '.exe' "$file"
+ file=$func_stripname_result
+ stripped_ext=".exe"
+ fi
+ ;;
+ esac
+
+ # Do a test to see if this is really a libtool program.
+ case $host in
+ *cygwin* | *mingw*)
+ if func_ltwrapper_executable_p "$file"; then
+ func_ltwrapper_scriptname "$file"
+ wrapper=$func_ltwrapper_scriptname_result
+ else
+ func_stripname '' '.exe' "$file"
+ wrapper=$func_stripname_result
+ fi
+ ;;
+ *)
+ wrapper=$file
+ ;;
+ esac
+ if func_ltwrapper_script_p "$wrapper"; then
+ notinst_deplibs=
+ relink_command=
+
+ func_source "$wrapper"
+
+ # Check the variables that should have been set.
+ test -z "$generated_by_libtool_version" && \
+ func_fatal_error "invalid libtool wrapper script \`$wrapper'"
+
+ finalize=yes
+ for lib in $notinst_deplibs; do
+ # Check to see that each library is installed.
+ libdir=
+ if test -f "$lib"; then
+ func_source "$lib"
+ fi
+ libfile="$libdir/"`$ECHO "$lib" | $SED 's%^.*/%%g'` ### testsuite: skip nested quoting test
+ if test -n "$libdir" && test ! -f "$libfile"; then
+ func_warning "\`$lib' has not been installed in \`$libdir'"
+ finalize=no
+ fi
+ done
+
+ relink_command=
+ func_source "$wrapper"
+
+ outputname=
+ if test "$fast_install" = no && test -n "$relink_command"; then
+ $opt_dry_run || {
+ if test "$finalize" = yes; then
+ tmpdir=`func_mktempdir`
+ func_basename "$file$stripped_ext"
+ file="$func_basename_result"
+ outputname="$tmpdir/$file"
+ # Replace the output file specification.
+ relink_command=`$ECHO "$relink_command" | $SED 's%@OUTPUT@%'"$outputname"'%g'`
+
+ $opt_silent || {
+ func_quote_for_expand "$relink_command"
+ eval "func_echo $func_quote_for_expand_result"
+ }
+ if eval "$relink_command"; then :
+ else
+ func_error "error: relink \`$file' with the above command before installing it"
+ $opt_dry_run || ${RM}r "$tmpdir"
+ continue
+ fi
+ file="$outputname"
+ else
+ func_warning "cannot relink \`$file'"
+ fi
+ }
+ else
+ # Install the binary that we compiled earlier.
+ file=`$ECHO "$file$stripped_ext" | $SED "s%\([^/]*\)$%$objdir/\1%"`
+ fi
+ fi
+
+ # remove .exe since cygwin /usr/bin/install will append another
+ # one anyway
+ case $install_prog,$host in
+ */usr/bin/install*,*cygwin*)
+ case $file:$destfile in
+ *.exe:*.exe)
+ # this is ok
+ ;;
+ *.exe:*)
+ destfile=$destfile.exe
+ ;;
+ *:*.exe)
+ func_stripname '' '.exe' "$destfile"
+ destfile=$func_stripname_result
+ ;;
+ esac
+ ;;
+ esac
+ func_show_eval "$install_prog\$stripme \$file \$destfile" 'exit $?'
+ $opt_dry_run || if test -n "$outputname"; then
+ ${RM}r "$tmpdir"
+ fi
+ ;;
+ esac
+ done
+
+ for file in $staticlibs; do
+ func_basename "$file"
+ name="$func_basename_result"
+
+ # Set up the ranlib parameters.
+ oldlib="$destdir/$name"
+
+ func_show_eval "$install_prog \$file \$oldlib" 'exit $?'
+
+ if test -n "$stripme" && test -n "$old_striplib"; then
+ func_show_eval "$old_striplib $oldlib" 'exit $?'
+ fi
+
+ # Do each command in the postinstall commands.
+ func_execute_cmds "$old_postinstall_cmds" 'exit $?'
+ done
+
+ test -n "$future_libdirs" && \
+ func_warning "remember to run \`$progname --finish$future_libdirs'"
+
+ if test -n "$current_libdirs"; then
+ # Maybe just do a dry run.
+ $opt_dry_run && current_libdirs=" -n$current_libdirs"
+ exec_cmd='$SHELL $progpath $preserve_args --finish$current_libdirs'
+ else
+ exit $EXIT_SUCCESS
+ fi
+}
+
+test "$opt_mode" = install && func_mode_install ${1+"$@"}
+
+
+# func_generate_dlsyms outputname originator pic_p
+# Extract symbols from dlprefiles and create ${outputname}S.o with
+# a dlpreopen symbol table.
+func_generate_dlsyms ()
+{
+ $opt_debug
+ my_outputname="$1"
+ my_originator="$2"
+ my_pic_p="${3-no}"
+ my_prefix=`$ECHO "$my_originator" | sed 's%[^a-zA-Z0-9]%_%g'`
+ my_dlsyms=
+
+ if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then
+ if test -n "$NM" && test -n "$global_symbol_pipe"; then
+ my_dlsyms="${my_outputname}S.c"
+ else
+ func_error "not configured to extract global symbols from dlpreopened files"
+ fi
+ fi
+
+ if test -n "$my_dlsyms"; then
+ case $my_dlsyms in
+ "") ;;
+ *.c)
+ # Discover the nlist of each of the dlfiles.
+ nlist="$output_objdir/${my_outputname}.nm"
+
+ func_show_eval "$RM $nlist ${nlist}S ${nlist}T"
+
+ # Parse the name list into a source file.
+ func_verbose "creating $output_objdir/$my_dlsyms"
+
+ $opt_dry_run || $ECHO > "$output_objdir/$my_dlsyms" "\
+/* $my_dlsyms - symbol resolution table for \`$my_outputname' dlsym emulation. */
+/* Generated by $PROGRAM (GNU $PACKAGE$TIMESTAMP) $VERSION */
+
+#ifdef __cplusplus
+extern \"C\" {
+#endif
+
+#if defined(__GNUC__) && (((__GNUC__ == 4) && (__GNUC_MINOR__ >= 4)) || (__GNUC__ > 4))
+#pragma GCC diagnostic ignored \"-Wstrict-prototypes\"
+#endif
+
+/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */
+#if defined(_WIN32) || defined(__CYGWIN__) || defined(_WIN32_WCE)
+/* DATA imports from DLLs on WIN32 con't be const, because runtime
+ relocations are performed -- see ld's documentation on pseudo-relocs. */
+# define LT_DLSYM_CONST
+#elif defined(__osf__)
+/* This system does not cope well with relocations in const data. */
+# define LT_DLSYM_CONST
+#else
+# define LT_DLSYM_CONST const
+#endif
+
+/* External symbol declarations for the compiler. */\
+"
+
+ if test "$dlself" = yes; then
+ func_verbose "generating symbol list for \`$output'"
+
+ $opt_dry_run || echo ': @PROGRAM@ ' > "$nlist"
+
+ # Add our own program objects to the symbol list.
+ progfiles=`$ECHO "$objs$old_deplibs" | $SP2NL | $SED "$lo2o" | $NL2SP`
+ for progfile in $progfiles; do
+ func_to_tool_file "$progfile" func_convert_file_msys_to_w32
+ func_verbose "extracting global C symbols from \`$func_to_tool_file_result'"
+ $opt_dry_run || eval "$NM $func_to_tool_file_result | $global_symbol_pipe >> '$nlist'"
+ done
+
+ if test -n "$exclude_expsyms"; then
+ $opt_dry_run || {
+ eval '$EGREP -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T'
+ eval '$MV "$nlist"T "$nlist"'
+ }
+ fi
+
+ if test -n "$export_symbols_regex"; then
+ $opt_dry_run || {
+ eval '$EGREP -e "$export_symbols_regex" "$nlist" > "$nlist"T'
+ eval '$MV "$nlist"T "$nlist"'
+ }
+ fi
+
+ # Prepare the list of exported symbols
+ if test -z "$export_symbols"; then
+ export_symbols="$output_objdir/$outputname.exp"
+ $opt_dry_run || {
+ $RM $export_symbols
+ eval "${SED} -n -e '/^: @PROGRAM@ $/d' -e 's/^.* \(.*\)$/\1/p' "'< "$nlist" > "$export_symbols"'
+ case $host in
+ *cygwin* | *mingw* | *cegcc* )
+ eval "echo EXPORTS "'> "$output_objdir/$outputname.def"'
+ eval 'cat "$export_symbols" >> "$output_objdir/$outputname.def"'
+ ;;
+ esac
+ }
+ else
+ $opt_dry_run || {
+ eval "${SED} -e 's/\([].[*^$]\)/\\\\\1/g' -e 's/^/ /' -e 's/$/$/'"' < "$export_symbols" > "$output_objdir/$outputname.exp"'
+ eval '$GREP -f "$output_objdir/$outputname.exp" < "$nlist" > "$nlist"T'
+ eval '$MV "$nlist"T "$nlist"'
+ case $host in
+ *cygwin* | *mingw* | *cegcc* )
+ eval "echo EXPORTS "'> "$output_objdir/$outputname.def"'
+ eval 'cat "$nlist" >> "$output_objdir/$outputname.def"'
+ ;;
+ esac
+ }
+ fi
+ fi
+
+ for dlprefile in $dlprefiles; do
+ func_verbose "extracting global C symbols from \`$dlprefile'"
+ func_basename "$dlprefile"
+ name="$func_basename_result"
+ case $host in
+ *cygwin* | *mingw* | *cegcc* )
+ # if an import library, we need to obtain dlname
+ if func_win32_import_lib_p "$dlprefile"; then
+ func_tr_sh "$dlprefile"
+ eval "curr_lafile=\$libfile_$func_tr_sh_result"
+ dlprefile_dlbasename=""
+ if test -n "$curr_lafile" && func_lalib_p "$curr_lafile"; then
+ # Use subshell, to avoid clobbering current variable values
+ dlprefile_dlname=`source "$curr_lafile" && echo "$dlname"`
+ if test -n "$dlprefile_dlname" ; then
+ func_basename "$dlprefile_dlname"
+ dlprefile_dlbasename="$func_basename_result"
+ else
+ # no lafile. user explicitly requested -dlpreopen <import library>.
+ $sharedlib_from_linklib_cmd "$dlprefile"
+ dlprefile_dlbasename=$sharedlib_from_linklib_result
+ fi
+ fi
+ $opt_dry_run || {
+ if test -n "$dlprefile_dlbasename" ; then
+ eval '$ECHO ": $dlprefile_dlbasename" >> "$nlist"'
+ else
+ func_warning "Could not compute DLL name from $name"
+ eval '$ECHO ": $name " >> "$nlist"'
+ fi
+ func_to_tool_file "$dlprefile" func_convert_file_msys_to_w32
+ eval "$NM \"$func_to_tool_file_result\" 2>/dev/null | $global_symbol_pipe |
+ $SED -e '/I __imp/d' -e 's/I __nm_/D /;s/_nm__//' >> '$nlist'"
+ }
+ else # not an import lib
+ $opt_dry_run || {
+ eval '$ECHO ": $name " >> "$nlist"'
+ func_to_tool_file "$dlprefile" func_convert_file_msys_to_w32
+ eval "$NM \"$func_to_tool_file_result\" 2>/dev/null | $global_symbol_pipe >> '$nlist'"
+ }
+ fi
+ ;;
+ *)
+ $opt_dry_run || {
+ eval '$ECHO ": $name " >> "$nlist"'
+ func_to_tool_file "$dlprefile" func_convert_file_msys_to_w32
+ eval "$NM \"$func_to_tool_file_result\" 2>/dev/null | $global_symbol_pipe >> '$nlist'"
+ }
+ ;;
+ esac
+ done
+
+ $opt_dry_run || {
+ # Make sure we have at least an empty file.
+ test -f "$nlist" || : > "$nlist"
+
+ if test -n "$exclude_expsyms"; then
+ $EGREP -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T
+ $MV "$nlist"T "$nlist"
+ fi
+
+ # Try sorting and uniquifying the output.
+ if $GREP -v "^: " < "$nlist" |
+ if sort -k 3 </dev/null >/dev/null 2>&1; then
+ sort -k 3
+ else
+ sort +2
+ fi |
+ uniq > "$nlist"S; then
+ :
+ else
+ $GREP -v "^: " < "$nlist" > "$nlist"S
+ fi
+
+ if test -f "$nlist"S; then
+ eval "$global_symbol_to_cdecl"' < "$nlist"S >> "$output_objdir/$my_dlsyms"'
+ else
+ echo '/* NONE */' >> "$output_objdir/$my_dlsyms"
+ fi
+
+ echo >> "$output_objdir/$my_dlsyms" "\
+
+/* The mapping between symbol names and symbols. */
+typedef struct {
+ const char *name;
+ void *address;
+} lt_dlsymlist;
+extern LT_DLSYM_CONST lt_dlsymlist
+lt_${my_prefix}_LTX_preloaded_symbols[];
+LT_DLSYM_CONST lt_dlsymlist
+lt_${my_prefix}_LTX_preloaded_symbols[] =
+{\
+ { \"$my_originator\", (void *) 0 },"
+
+ case $need_lib_prefix in
+ no)
+ eval "$global_symbol_to_c_name_address" < "$nlist" >> "$output_objdir/$my_dlsyms"
+ ;;
+ *)
+ eval "$global_symbol_to_c_name_address_lib_prefix" < "$nlist" >> "$output_objdir/$my_dlsyms"
+ ;;
+ esac
+ echo >> "$output_objdir/$my_dlsyms" "\
+ {0, (void *) 0}
+};
+
+/* This works around a problem in FreeBSD linker */
+#ifdef FREEBSD_WORKAROUND
+static const void *lt_preloaded_setup() {
+ return lt_${my_prefix}_LTX_preloaded_symbols;
+}
+#endif
+
+#ifdef __cplusplus
+}
+#endif\
+"
+ } # !$opt_dry_run
+
+ pic_flag_for_symtable=
+ case "$compile_command " in
+ *" -static "*) ;;
+ *)
+ case $host in
+ # compiling the symbol table file with pic_flag works around
+ # a FreeBSD bug that causes programs to crash when -lm is
+ # linked before any other PIC object. But we must not use
+ # pic_flag when linking with -static. The problem exists in
+ # FreeBSD 2.2.6 and is fixed in FreeBSD 3.1.
+ *-*-freebsd2*|*-*-freebsd3.0*|*-*-freebsdelf3.0*)
+ pic_flag_for_symtable=" $pic_flag -DFREEBSD_WORKAROUND" ;;
+ *-*-hpux*)
+ pic_flag_for_symtable=" $pic_flag" ;;
+ *)
+ if test "X$my_pic_p" != Xno; then
+ pic_flag_for_symtable=" $pic_flag"
+ fi
+ ;;
+ esac
+ ;;
+ esac
+ symtab_cflags=
+ for arg in $LTCFLAGS; do
+ case $arg in
+ -pie | -fpie | -fPIE) ;;
+ *) func_append symtab_cflags " $arg" ;;
+ esac
+ done
+
+ # Now compile the dynamic symbol file.
+ func_show_eval '(cd $output_objdir && $LTCC$symtab_cflags -c$no_builtin_flag$pic_flag_for_symtable "$my_dlsyms")' 'exit $?'
+
+ # Clean up the generated files.
+ func_show_eval '$RM "$output_objdir/$my_dlsyms" "$nlist" "${nlist}S" "${nlist}T"'
+
+ # Transform the symbol file into the correct name.
+ symfileobj="$output_objdir/${my_outputname}S.$objext"
+ case $host in
+ *cygwin* | *mingw* | *cegcc* )
+ if test -f "$output_objdir/$my_outputname.def"; then
+ compile_command=`$ECHO "$compile_command" | $SED "s%@SYMFILE@%$output_objdir/$my_outputname.def $symfileobj%"`
+ finalize_command=`$ECHO "$finalize_command" | $SED "s%@SYMFILE@%$output_objdir/$my_outputname.def $symfileobj%"`
+ else
+ compile_command=`$ECHO "$compile_command" | $SED "s%@SYMFILE@%$symfileobj%"`
+ finalize_command=`$ECHO "$finalize_command" | $SED "s%@SYMFILE@%$symfileobj%"`
+ fi
+ ;;
+ *)
+ compile_command=`$ECHO "$compile_command" | $SED "s%@SYMFILE@%$symfileobj%"`
+ finalize_command=`$ECHO "$finalize_command" | $SED "s%@SYMFILE@%$symfileobj%"`
+ ;;
+ esac
+ ;;
+ *)
+ func_fatal_error "unknown suffix for \`$my_dlsyms'"
+ ;;
+ esac
+ else
+ # We keep going just in case the user didn't refer to
+ # lt_preloaded_symbols. The linker will fail if global_symbol_pipe
+ # really was required.
+
+ # Nullify the symbol file.
+ compile_command=`$ECHO "$compile_command" | $SED "s% @SYMFILE@%%"`
+ finalize_command=`$ECHO "$finalize_command" | $SED "s% @SYMFILE@%%"`
+ fi
+}
+
+# func_win32_libid arg
+# return the library type of file 'arg'
+#
+# Need a lot of goo to handle *both* DLLs and import libs
+# Has to be a shell function in order to 'eat' the argument
+# that is supplied when $file_magic_command is called.
+# Despite the name, also deal with 64 bit binaries.
+func_win32_libid ()
+{
+ $opt_debug
+ win32_libid_type="unknown"
+ win32_fileres=`file -L $1 2>/dev/null`
+ case $win32_fileres in
+ *ar\ archive\ import\ library*) # definitely import
+ win32_libid_type="x86 archive import"
+ ;;
+ *ar\ archive*) # could be an import, or static
+ # Keep the egrep pattern in sync with the one in _LT_CHECK_MAGIC_METHOD.
+ if eval $OBJDUMP -f $1 | $SED -e '10q' 2>/dev/null |
+ $EGREP 'file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)' >/dev/null; then
+ func_to_tool_file "$1" func_convert_file_msys_to_w32
+ win32_nmres=`eval $NM -f posix -A \"$func_to_tool_file_result\" |
+ $SED -n -e '
+ 1,100{
+ / I /{
+ s,.*,import,
+ p
+ q
+ }
+ }'`
+ case $win32_nmres in
+ import*) win32_libid_type="x86 archive import";;
+ *) win32_libid_type="x86 archive static";;
+ esac
+ fi
+ ;;
+ *DLL*)
+ win32_libid_type="x86 DLL"
+ ;;
+ *executable*) # but shell scripts are "executable" too...
+ case $win32_fileres in
+ *MS\ Windows\ PE\ Intel*)
+ win32_libid_type="x86 DLL"
+ ;;
+ esac
+ ;;
+ esac
+ $ECHO "$win32_libid_type"
+}
+
+# func_cygming_dll_for_implib ARG
+#
+# Platform-specific function to extract the
+# name of the DLL associated with the specified
+# import library ARG.
+# Invoked by eval'ing the libtool variable
+# $sharedlib_from_linklib_cmd
+# Result is available in the variable
+# $sharedlib_from_linklib_result
+func_cygming_dll_for_implib ()
+{
+ $opt_debug
+ sharedlib_from_linklib_result=`$DLLTOOL --identify-strict --identify "$1"`
+}
+
+# func_cygming_dll_for_implib_fallback_core SECTION_NAME LIBNAMEs
+#
+# The is the core of a fallback implementation of a
+# platform-specific function to extract the name of the
+# DLL associated with the specified import library LIBNAME.
+#
+# SECTION_NAME is either .idata$6 or .idata$7, depending
+# on the platform and compiler that created the implib.
+#
+# Echos the name of the DLL associated with the
+# specified import library.
+func_cygming_dll_for_implib_fallback_core ()
+{
+ $opt_debug
+ match_literal=`$ECHO "$1" | $SED "$sed_make_literal_regex"`
+ $OBJDUMP -s --section "$1" "$2" 2>/dev/null |
+ $SED '/^Contents of section '"$match_literal"':/{
+ # Place marker at beginning of archive member dllname section
+ s/.*/====MARK====/
+ p
+ d
+ }
+ # These lines can sometimes be longer than 43 characters, but
+ # are always uninteresting
+ /:[ ]*file format pe[i]\{,1\}-/d
+ /^In archive [^:]*:/d
+ # Ensure marker is printed
+ /^====MARK====/p
+ # Remove all lines with less than 43 characters
+ /^.\{43\}/!d
+ # From remaining lines, remove first 43 characters
+ s/^.\{43\}//' |
+ $SED -n '
+ # Join marker and all lines until next marker into a single line
+ /^====MARK====/ b para
+ H
+ $ b para
+ b
+ :para
+ x
+ s/\n//g
+ # Remove the marker
+ s/^====MARK====//
+ # Remove trailing dots and whitespace
+ s/[\. \t]*$//
+ # Print
+ /./p' |
+ # we now have a list, one entry per line, of the stringified
+ # contents of the appropriate section of all members of the
+ # archive which possess that section. Heuristic: eliminate
+ # all those which have a first or second character that is
+ # a '.' (that is, objdump's representation of an unprintable
+ # character.) This should work for all archives with less than
+ # 0x302f exports -- but will fail for DLLs whose name actually
+ # begins with a literal '.' or a single character followed by
+ # a '.'.
+ #
+ # Of those that remain, print the first one.
+ $SED -e '/^\./d;/^.\./d;q'
+}
+
+# func_cygming_gnu_implib_p ARG
+# This predicate returns with zero status (TRUE) if
+# ARG is a GNU/binutils-style import library. Returns
+# with nonzero status (FALSE) otherwise.
+func_cygming_gnu_implib_p ()
+{
+ $opt_debug
+ func_to_tool_file "$1" func_convert_file_msys_to_w32
+ func_cygming_gnu_implib_tmp=`$NM "$func_to_tool_file_result" | eval "$global_symbol_pipe" | $EGREP ' (_head_[A-Za-z0-9_]+_[ad]l*|[A-Za-z0-9_]+_[ad]l*_iname)$'`
+ test -n "$func_cygming_gnu_implib_tmp"
+}
+
+# func_cygming_ms_implib_p ARG
+# This predicate returns with zero status (TRUE) if
+# ARG is an MS-style import library. Returns
+# with nonzero status (FALSE) otherwise.
+func_cygming_ms_implib_p ()
+{
+ $opt_debug
+ func_to_tool_file "$1" func_convert_file_msys_to_w32
+ func_cygming_ms_implib_tmp=`$NM "$func_to_tool_file_result" | eval "$global_symbol_pipe" | $GREP '_NULL_IMPORT_DESCRIPTOR'`
+ test -n "$func_cygming_ms_implib_tmp"
+}
+
+# func_cygming_dll_for_implib_fallback ARG
+# Platform-specific function to extract the
+# name of the DLL associated with the specified
+# import library ARG.
+#
+# This fallback implementation is for use when $DLLTOOL
+# does not support the --identify-strict option.
+# Invoked by eval'ing the libtool variable
+# $sharedlib_from_linklib_cmd
+# Result is available in the variable
+# $sharedlib_from_linklib_result
+func_cygming_dll_for_implib_fallback ()
+{
+ $opt_debug
+ if func_cygming_gnu_implib_p "$1" ; then
+ # binutils import library
+ sharedlib_from_linklib_result=`func_cygming_dll_for_implib_fallback_core '.idata$7' "$1"`
+ elif func_cygming_ms_implib_p "$1" ; then
+ # ms-generated import library
+ sharedlib_from_linklib_result=`func_cygming_dll_for_implib_fallback_core '.idata$6' "$1"`
+ else
+ # unknown
+ sharedlib_from_linklib_result=""
+ fi
+}
+
+
+# func_extract_an_archive dir oldlib
+func_extract_an_archive ()
+{
+ $opt_debug
+ f_ex_an_ar_dir="$1"; shift
+ f_ex_an_ar_oldlib="$1"
+ if test "$lock_old_archive_extraction" = yes; then
+ lockfile=$f_ex_an_ar_oldlib.lock
+ until $opt_dry_run || ln "$progpath" "$lockfile" 2>/dev/null; do
+ func_echo "Waiting for $lockfile to be removed"
+ sleep 2
+ done
+ fi
+ func_show_eval "(cd \$f_ex_an_ar_dir && $AR x \"\$f_ex_an_ar_oldlib\")" \
+ 'stat=$?; rm -f "$lockfile"; exit $stat'
+ if test "$lock_old_archive_extraction" = yes; then
+ $opt_dry_run || rm -f "$lockfile"
+ fi
+ if ($AR t "$f_ex_an_ar_oldlib" | sort | sort -uc >/dev/null 2>&1); then
+ :
+ else
+ func_fatal_error "object name conflicts in archive: $f_ex_an_ar_dir/$f_ex_an_ar_oldlib"
+ fi
+}
+
+
+# func_extract_archives gentop oldlib ...
+func_extract_archives ()
+{
+ $opt_debug
+ my_gentop="$1"; shift
+ my_oldlibs=${1+"$@"}
+ my_oldobjs=""
+ my_xlib=""
+ my_xabs=""
+ my_xdir=""
+
+ for my_xlib in $my_oldlibs; do
+ # Extract the objects.
+ case $my_xlib in
+ [\\/]* | [A-Za-z]:[\\/]*) my_xabs="$my_xlib" ;;
+ *) my_xabs=`pwd`"/$my_xlib" ;;
+ esac
+ func_basename "$my_xlib"
+ my_xlib="$func_basename_result"
+ my_xlib_u=$my_xlib
+ while :; do
+ case " $extracted_archives " in
+ *" $my_xlib_u "*)
+ func_arith $extracted_serial + 1
+ extracted_serial=$func_arith_result
+ my_xlib_u=lt$extracted_serial-$my_xlib ;;
+ *) break ;;
+ esac
+ done
+ extracted_archives="$extracted_archives $my_xlib_u"
+ my_xdir="$my_gentop/$my_xlib_u"
+
+ func_mkdir_p "$my_xdir"
+
+ case $host in
+ *-darwin*)
+ func_verbose "Extracting $my_xabs"
+ # Do not bother doing anything if just a dry run
+ $opt_dry_run || {
+ darwin_orig_dir=`pwd`
+ cd $my_xdir || exit $?
+ darwin_archive=$my_xabs
+ darwin_curdir=`pwd`
+ darwin_base_archive=`basename "$darwin_archive"`
+ darwin_arches=`$LIPO -info "$darwin_archive" 2>/dev/null | $GREP Architectures 2>/dev/null || true`
+ if test -n "$darwin_arches"; then
+ darwin_arches=`$ECHO "$darwin_arches" | $SED -e 's/.*are://'`
+ darwin_arch=
+ func_verbose "$darwin_base_archive has multiple architectures $darwin_arches"
+ for darwin_arch in $darwin_arches ; do
+ func_mkdir_p "unfat-$$/${darwin_base_archive}-${darwin_arch}"
+ $LIPO -thin $darwin_arch -output "unfat-$$/${darwin_base_archive}-${darwin_arch}/${darwin_base_archive}" "${darwin_archive}"
+ cd "unfat-$$/${darwin_base_archive}-${darwin_arch}"
+ func_extract_an_archive "`pwd`" "${darwin_base_archive}"
+ cd "$darwin_curdir"
+ $RM "unfat-$$/${darwin_base_archive}-${darwin_arch}/${darwin_base_archive}"
+ done # $darwin_arches
+ ## Okay now we've a bunch of thin objects, gotta fatten them up :)
+ darwin_filelist=`find unfat-$$ -type f -name \*.o -print -o -name \*.lo -print | $SED -e "$basename" | sort -u`
+ darwin_file=
+ darwin_files=
+ for darwin_file in $darwin_filelist; do
+ darwin_files=`find unfat-$$ -name $darwin_file -print | sort | $NL2SP`
+ $LIPO -create -output "$darwin_file" $darwin_files
+ done # $darwin_filelist
+ $RM -rf unfat-$$
+ cd "$darwin_orig_dir"
+ else
+ cd $darwin_orig_dir
+ func_extract_an_archive "$my_xdir" "$my_xabs"
+ fi # $darwin_arches
+ } # !$opt_dry_run
+ ;;
+ *)
+ func_extract_an_archive "$my_xdir" "$my_xabs"
+ ;;
+ esac
+ my_oldobjs="$my_oldobjs "`find $my_xdir -name \*.$objext -print -o -name \*.lo -print | sort | $NL2SP`
+ done
+
+ func_extract_archives_result="$my_oldobjs"
+}
+
+
+# func_emit_wrapper [arg=no]
+#
+# Emit a libtool wrapper script on stdout.
+# Don't directly open a file because we may want to
+# incorporate the script contents within a cygwin/mingw
+# wrapper executable. Must ONLY be called from within
+# func_mode_link because it depends on a number of variables
+# set therein.
+#
+# ARG is the value that the WRAPPER_SCRIPT_BELONGS_IN_OBJDIR
+# variable will take. If 'yes', then the emitted script
+# will assume that the directory in which it is stored is
+# the $objdir directory. This is a cygwin/mingw-specific
+# behavior.
+func_emit_wrapper ()
+{
+ func_emit_wrapper_arg1=${1-no}
+
+ $ECHO "\
+#! $SHELL
+
+# $output - temporary wrapper script for $objdir/$outputname
+# Generated by $PROGRAM (GNU $PACKAGE$TIMESTAMP) $VERSION
+#
+# The $output program cannot be directly executed until all the libtool
+# libraries that it depends on are installed.
+#
+# This wrapper script should never be moved out of the build directory.
+# If it is, it will not operate correctly.
+
+# Sed substitution that helps us do robust quoting. It backslashifies
+# metacharacters that are still active within double-quoted strings.
+sed_quote_subst='$sed_quote_subst'
+
+# Be Bourne compatible
+if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on \${1+\"\$@\"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '\${1+\"\$@\"}'='\"\$@\"'
+ setopt NO_GLOB_SUBST
+else
+ case \`(set -o) 2>/dev/null\` in *posix*) set -o posix;; esac
+fi
+BIN_SH=xpg4; export BIN_SH # for Tru64
+DUALCASE=1; export DUALCASE # for MKS sh
+
+# The HP-UX ksh and POSIX shell print the target directory to stdout
+# if CDPATH is set.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+relink_command=\"$relink_command\"
+
+# This environment variable determines our operation mode.
+if test \"\$libtool_install_magic\" = \"$magic\"; then
+ # install mode needs the following variables:
+ generated_by_libtool_version='$macro_version'
+ notinst_deplibs='$notinst_deplibs'
+else
+ # When we are sourced in execute mode, \$file and \$ECHO are already set.
+ if test \"\$libtool_execute_magic\" != \"$magic\"; then
+ file=\"\$0\""
+
+ qECHO=`$ECHO "$ECHO" | $SED "$sed_quote_subst"`
+ $ECHO "\
+
+# A function that is used when there is no print builtin or printf.
+func_fallback_echo ()
+{
+ eval 'cat <<_LTECHO_EOF
+\$1
+_LTECHO_EOF'
+}
+ ECHO=\"$qECHO\"
+ fi
+
+# Very basic option parsing. These options are (a) specific to
+# the libtool wrapper, (b) are identical between the wrapper
+# /script/ and the wrapper /executable/ which is used only on
+# windows platforms, and (c) all begin with the string "--lt-"
+# (application programs are unlikely to have options which match
+# this pattern).
+#
+# There are only two supported options: --lt-debug and
+# --lt-dump-script. There is, deliberately, no --lt-help.
+#
+# The first argument to this parsing function should be the
+# script's $0 value, followed by "$@".
+lt_option_debug=
+func_parse_lt_options ()
+{
+ lt_script_arg0=\$0
+ shift
+ for lt_opt
+ do
+ case \"\$lt_opt\" in
+ --lt-debug) lt_option_debug=1 ;;
+ --lt-dump-script)
+ lt_dump_D=\`\$ECHO \"X\$lt_script_arg0\" | $SED -e 's/^X//' -e 's%/[^/]*$%%'\`
+ test \"X\$lt_dump_D\" = \"X\$lt_script_arg0\" && lt_dump_D=.
+ lt_dump_F=\`\$ECHO \"X\$lt_script_arg0\" | $SED -e 's/^X//' -e 's%^.*/%%'\`
+ cat \"\$lt_dump_D/\$lt_dump_F\"
+ exit 0
+ ;;
+ --lt-*)
+ \$ECHO \"Unrecognized --lt- option: '\$lt_opt'\" 1>&2
+ exit 1
+ ;;
+ esac
+ done
+
+ # Print the debug banner immediately:
+ if test -n \"\$lt_option_debug\"; then
+ echo \"${outputname}:${output}:\${LINENO}: libtool wrapper (GNU $PACKAGE$TIMESTAMP) $VERSION\" 1>&2
+ fi
+}
+
+# Used when --lt-debug. Prints its arguments to stdout
+# (redirection is the responsibility of the caller)
+func_lt_dump_args ()
+{
+ lt_dump_args_N=1;
+ for lt_arg
+ do
+ \$ECHO \"${outputname}:${output}:\${LINENO}: newargv[\$lt_dump_args_N]: \$lt_arg\"
+ lt_dump_args_N=\`expr \$lt_dump_args_N + 1\`
+ done
+}
+
+# Core function for launching the target application
+func_exec_program_core ()
+{
+"
+ case $host in
+ # Backslashes separate directories on plain windows
+ *-*-mingw | *-*-os2* | *-cegcc*)
+ $ECHO "\
+ if test -n \"\$lt_option_debug\"; then
+ \$ECHO \"${outputname}:${output}:\${LINENO}: newargv[0]: \$progdir\\\\\$program\" 1>&2
+ func_lt_dump_args \${1+\"\$@\"} 1>&2
+ fi
+ exec \"\$progdir\\\\\$program\" \${1+\"\$@\"}
+"
+ ;;
+
+ *)
+ $ECHO "\
+ if test -n \"\$lt_option_debug\"; then
+ \$ECHO \"${outputname}:${output}:\${LINENO}: newargv[0]: \$progdir/\$program\" 1>&2
+ func_lt_dump_args \${1+\"\$@\"} 1>&2
+ fi
+ exec \"\$progdir/\$program\" \${1+\"\$@\"}
+"
+ ;;
+ esac
+ $ECHO "\
+ \$ECHO \"\$0: cannot exec \$program \$*\" 1>&2
+ exit 1
+}
+
+# A function to encapsulate launching the target application
+# Strips options in the --lt-* namespace from \$@ and
+# launches target application with the remaining arguments.
+func_exec_program ()
+{
+ for lt_wr_arg
+ do
+ case \$lt_wr_arg in
+ --lt-*) ;;
+ *) set x \"\$@\" \"\$lt_wr_arg\"; shift;;
+ esac
+ shift
+ done
+ func_exec_program_core \${1+\"\$@\"}
+}
+
+ # Parse options
+ func_parse_lt_options \"\$0\" \${1+\"\$@\"}
+
+ # Find the directory that this script lives in.
+ thisdir=\`\$ECHO \"\$file\" | $SED 's%/[^/]*$%%'\`
+ test \"x\$thisdir\" = \"x\$file\" && thisdir=.
+
+ # Follow symbolic links until we get to the real thisdir.
+ file=\`ls -ld \"\$file\" | $SED -n 's/.*-> //p'\`
+ while test -n \"\$file\"; do
+ destdir=\`\$ECHO \"\$file\" | $SED 's%/[^/]*\$%%'\`
+
+ # If there was a directory component, then change thisdir.
+ if test \"x\$destdir\" != \"x\$file\"; then
+ case \"\$destdir\" in
+ [\\\\/]* | [A-Za-z]:[\\\\/]*) thisdir=\"\$destdir\" ;;
+ *) thisdir=\"\$thisdir/\$destdir\" ;;
+ esac
+ fi
+
+ file=\`\$ECHO \"\$file\" | $SED 's%^.*/%%'\`
+ file=\`ls -ld \"\$thisdir/\$file\" | $SED -n 's/.*-> //p'\`
+ done
+
+ # Usually 'no', except on cygwin/mingw when embedded into
+ # the cwrapper.
+ WRAPPER_SCRIPT_BELONGS_IN_OBJDIR=$func_emit_wrapper_arg1
+ if test \"\$WRAPPER_SCRIPT_BELONGS_IN_OBJDIR\" = \"yes\"; then
+ # special case for '.'
+ if test \"\$thisdir\" = \".\"; then
+ thisdir=\`pwd\`
+ fi
+ # remove .libs from thisdir
+ case \"\$thisdir\" in
+ *[\\\\/]$objdir ) thisdir=\`\$ECHO \"\$thisdir\" | $SED 's%[\\\\/][^\\\\/]*$%%'\` ;;
+ $objdir ) thisdir=. ;;
+ esac
+ fi
+
+ # Try to get the absolute directory name.
+ absdir=\`cd \"\$thisdir\" && pwd\`
+ test -n \"\$absdir\" && thisdir=\"\$absdir\"
+"
+
+ if test "$fast_install" = yes; then
+ $ECHO "\
+ program=lt-'$outputname'$exeext
+ progdir=\"\$thisdir/$objdir\"
+
+ if test ! -f \"\$progdir/\$program\" ||
+ { file=\`ls -1dt \"\$progdir/\$program\" \"\$progdir/../\$program\" 2>/dev/null | ${SED} 1q\`; \\
+ test \"X\$file\" != \"X\$progdir/\$program\"; }; then
+
+ file=\"\$\$-\$program\"
+
+ if test ! -d \"\$progdir\"; then
+ $MKDIR \"\$progdir\"
+ else
+ $RM \"\$progdir/\$file\"
+ fi"
+
+ $ECHO "\
+
+ # relink executable if necessary
+ if test -n \"\$relink_command\"; then
+ if relink_command_output=\`eval \$relink_command 2>&1\`; then :
+ else
+ $ECHO \"\$relink_command_output\" >&2
+ $RM \"\$progdir/\$file\"
+ exit 1
+ fi
+ fi
+
+ $MV \"\$progdir/\$file\" \"\$progdir/\$program\" 2>/dev/null ||
+ { $RM \"\$progdir/\$program\";
+ $MV \"\$progdir/\$file\" \"\$progdir/\$program\"; }
+ $RM \"\$progdir/\$file\"
+ fi"
+ else
+ $ECHO "\
+ program='$outputname'
+ progdir=\"\$thisdir/$objdir\"
+"
+ fi
+
+ $ECHO "\
+
+ if test -f \"\$progdir/\$program\"; then"
+
+ # fixup the dll searchpath if we need to.
+ #
+ # Fix the DLL searchpath if we need to. Do this before prepending
+ # to shlibpath, because on Windows, both are PATH and uninstalled
+ # libraries must come first.
+ if test -n "$dllsearchpath"; then
+ $ECHO "\
+ # Add the dll search path components to the executable PATH
+ PATH=$dllsearchpath:\$PATH
+"
+ fi
+
+ # Export our shlibpath_var if we have one.
+ if test "$shlibpath_overrides_runpath" = yes && test -n "$shlibpath_var" && test -n "$temp_rpath"; then
+ $ECHO "\
+ # Add our own library path to $shlibpath_var
+ $shlibpath_var=\"$temp_rpath\$$shlibpath_var\"
+
+ # Some systems cannot cope with colon-terminated $shlibpath_var
+ # The second colon is a workaround for a bug in BeOS R4 sed
+ $shlibpath_var=\`\$ECHO \"\$$shlibpath_var\" | $SED 's/::*\$//'\`
+
+ export $shlibpath_var
+"
+ fi
+
+ $ECHO "\
+ if test \"\$libtool_execute_magic\" != \"$magic\"; then
+ # Run the actual program with our arguments.
+ func_exec_program \${1+\"\$@\"}
+ fi
+ else
+ # The program doesn't exist.
+ \$ECHO \"\$0: error: \\\`\$progdir/\$program' does not exist\" 1>&2
+ \$ECHO \"This script is just a wrapper for \$program.\" 1>&2
+ \$ECHO \"See the $PACKAGE documentation for more information.\" 1>&2
+ exit 1
+ fi
+fi\
+"
+}
+
+
+# func_emit_cwrapperexe_src
+# emit the source code for a wrapper executable on stdout
+# Must ONLY be called from within func_mode_link because
+# it depends on a number of variable set therein.
+func_emit_cwrapperexe_src ()
+{
+ cat <<EOF
+
+/* $cwrappersource - temporary wrapper executable for $objdir/$outputname
+ Generated by $PROGRAM (GNU $PACKAGE$TIMESTAMP) $VERSION
+
+ The $output program cannot be directly executed until all the libtool
+ libraries that it depends on are installed.
+
+ This wrapper executable should never be moved out of the build directory.
+ If it is, it will not operate correctly.
+*/
+EOF
+ cat <<"EOF"
+#ifdef _MSC_VER
+# define _CRT_SECURE_NO_DEPRECATE 1
+#endif
+#include <stdio.h>
+#include <stdlib.h>
+#ifdef _MSC_VER
+# include <direct.h>
+# include <process.h>
+# include <io.h>
+#else
+# include <unistd.h>
+# include <stdint.h>
+# ifdef __CYGWIN__
+# include <io.h>
+# endif
+#endif
+#include <malloc.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <string.h>
+#include <ctype.h>
+#include <errno.h>
+#include <fcntl.h>
+#include <sys/stat.h>
+
+/* declarations of non-ANSI functions */
+#if defined(__MINGW32__)
+# ifdef __STRICT_ANSI__
+int _putenv (const char *);
+# endif
+#elif defined(__CYGWIN__)
+# ifdef __STRICT_ANSI__
+char *realpath (const char *, char *);
+int putenv (char *);
+int setenv (const char *, const char *, int);
+# endif
+/* #elif defined (other platforms) ... */
+#endif
+
+/* portability defines, excluding path handling macros */
+#if defined(_MSC_VER)
+# define setmode _setmode
+# define stat _stat
+# define chmod _chmod
+# define getcwd _getcwd
+# define putenv _putenv
+# define S_IXUSR _S_IEXEC
+# ifndef _INTPTR_T_DEFINED
+# define _INTPTR_T_DEFINED
+# define intptr_t int
+# endif
+#elif defined(__MINGW32__)
+# define setmode _setmode
+# define stat _stat
+# define chmod _chmod
+# define getcwd _getcwd
+# define putenv _putenv
+#elif defined(__CYGWIN__)
+# define HAVE_SETENV
+# define FOPEN_WB "wb"
+/* #elif defined (other platforms) ... */
+#endif
+
+#if defined(PATH_MAX)
+# define LT_PATHMAX PATH_MAX
+#elif defined(MAXPATHLEN)
+# define LT_PATHMAX MAXPATHLEN
+#else
+# define LT_PATHMAX 1024
+#endif
+
+#ifndef S_IXOTH
+# define S_IXOTH 0
+#endif
+#ifndef S_IXGRP
+# define S_IXGRP 0
+#endif
+
+/* path handling portability macros */
+#ifndef DIR_SEPARATOR
+# define DIR_SEPARATOR '/'
+# define PATH_SEPARATOR ':'
+#endif
+
+#if defined (_WIN32) || defined (__MSDOS__) || defined (__DJGPP__) || \
+ defined (__OS2__)
+# define HAVE_DOS_BASED_FILE_SYSTEM
+# define FOPEN_WB "wb"
+# ifndef DIR_SEPARATOR_2
+# define DIR_SEPARATOR_2 '\\'
+# endif
+# ifndef PATH_SEPARATOR_2
+# define PATH_SEPARATOR_2 ';'
+# endif
+#endif
+
+#ifndef DIR_SEPARATOR_2
+# define IS_DIR_SEPARATOR(ch) ((ch) == DIR_SEPARATOR)
+#else /* DIR_SEPARATOR_2 */
+# define IS_DIR_SEPARATOR(ch) \
+ (((ch) == DIR_SEPARATOR) || ((ch) == DIR_SEPARATOR_2))
+#endif /* DIR_SEPARATOR_2 */
+
+#ifndef PATH_SEPARATOR_2
+# define IS_PATH_SEPARATOR(ch) ((ch) == PATH_SEPARATOR)
+#else /* PATH_SEPARATOR_2 */
+# define IS_PATH_SEPARATOR(ch) ((ch) == PATH_SEPARATOR_2)
+#endif /* PATH_SEPARATOR_2 */
+
+#ifndef FOPEN_WB
+# define FOPEN_WB "w"
+#endif
+#ifndef _O_BINARY
+# define _O_BINARY 0
+#endif
+
+#define XMALLOC(type, num) ((type *) xmalloc ((num) * sizeof(type)))
+#define XFREE(stale) do { \
+ if (stale) { free ((void *) stale); stale = 0; } \
+} while (0)
+
+#if defined(LT_DEBUGWRAPPER)
+static int lt_debug = 1;
+#else
+static int lt_debug = 0;
+#endif
+
+const char *program_name = "libtool-wrapper"; /* in case xstrdup fails */
+
+void *xmalloc (size_t num);
+char *xstrdup (const char *string);
+const char *base_name (const char *name);
+char *find_executable (const char *wrapper);
+char *chase_symlinks (const char *pathspec);
+int make_executable (const char *path);
+int check_executable (const char *path);
+char *strendzap (char *str, const char *pat);
+void lt_debugprintf (const char *file, int line, const char *fmt, ...);
+void lt_fatal (const char *file, int line, const char *message, ...);
+static const char *nonnull (const char *s);
+static const char *nonempty (const char *s);
+void lt_setenv (const char *name, const char *value);
+char *lt_extend_str (const char *orig_value, const char *add, int to_end);
+void lt_update_exe_path (const char *name, const char *value);
+void lt_update_lib_path (const char *name, const char *value);
+char **prepare_spawn (char **argv);
+void lt_dump_script (FILE *f);
+EOF
+
+ cat <<EOF
+volatile const char * MAGIC_EXE = "$magic_exe";
+const char * LIB_PATH_VARNAME = "$shlibpath_var";
+EOF
+
+ if test "$shlibpath_overrides_runpath" = yes && test -n "$shlibpath_var" && test -n "$temp_rpath"; then
+ func_to_host_path "$temp_rpath"
+ cat <<EOF
+const char * LIB_PATH_VALUE = "$func_to_host_path_result";
+EOF
+ else
+ cat <<"EOF"
+const char * LIB_PATH_VALUE = "";
+EOF
+ fi
+
+ if test -n "$dllsearchpath"; then
+ func_to_host_path "$dllsearchpath:"
+ cat <<EOF
+const char * EXE_PATH_VARNAME = "PATH";
+const char * EXE_PATH_VALUE = "$func_to_host_path_result";
+EOF
+ else
+ cat <<"EOF"
+const char * EXE_PATH_VARNAME = "";
+const char * EXE_PATH_VALUE = "";
+EOF
+ fi
+
+ if test "$fast_install" = yes; then
+ cat <<EOF
+const char * TARGET_PROGRAM_NAME = "lt-$outputname"; /* hopefully, no .exe */
+EOF
+ else
+ cat <<EOF
+const char * TARGET_PROGRAM_NAME = "$outputname"; /* hopefully, no .exe */
+EOF
+ fi
+
+
+ cat <<"EOF"
+
+#define LTWRAPPER_OPTION_PREFIX "--lt-"
+
+static const char *ltwrapper_option_prefix = LTWRAPPER_OPTION_PREFIX;
+static const char *dumpscript_opt = LTWRAPPER_OPTION_PREFIX "dump-script";
+static const char *debug_opt = LTWRAPPER_OPTION_PREFIX "debug";
+
+int
+main (int argc, char *argv[])
+{
+ char **newargz;
+ int newargc;
+ char *tmp_pathspec;
+ char *actual_cwrapper_path;
+ char *actual_cwrapper_name;
+ char *target_name;
+ char *lt_argv_zero;
+ intptr_t rval = 127;
+
+ int i;
+
+ program_name = (char *) xstrdup (base_name (argv[0]));
+ newargz = XMALLOC (char *, argc + 1);
+
+ /* very simple arg parsing; don't want to rely on getopt
+ * also, copy all non cwrapper options to newargz, except
+ * argz[0], which is handled differently
+ */
+ newargc=0;
+ for (i = 1; i < argc; i++)
+ {
+ if (strcmp (argv[i], dumpscript_opt) == 0)
+ {
+EOF
+ case "$host" in
+ *mingw* | *cygwin* )
+ # make stdout use "unix" line endings
+ echo " setmode(1,_O_BINARY);"
+ ;;
+ esac
+
+ cat <<"EOF"
+ lt_dump_script (stdout);
+ return 0;
+ }
+ if (strcmp (argv[i], debug_opt) == 0)
+ {
+ lt_debug = 1;
+ continue;
+ }
+ if (strcmp (argv[i], ltwrapper_option_prefix) == 0)
+ {
+ /* however, if there is an option in the LTWRAPPER_OPTION_PREFIX
+ namespace, but it is not one of the ones we know about and
+ have already dealt with, above (inluding dump-script), then
+ report an error. Otherwise, targets might begin to believe
+ they are allowed to use options in the LTWRAPPER_OPTION_PREFIX
+ namespace. The first time any user complains about this, we'll
+ need to make LTWRAPPER_OPTION_PREFIX a configure-time option
+ or a configure.ac-settable value.
+ */
+ lt_fatal (__FILE__, __LINE__,
+ "unrecognized %s option: '%s'",
+ ltwrapper_option_prefix, argv[i]);
+ }
+ /* otherwise ... */
+ newargz[++newargc] = xstrdup (argv[i]);
+ }
+ newargz[++newargc] = NULL;
+
+EOF
+ cat <<EOF
+ /* The GNU banner must be the first non-error debug message */
+ lt_debugprintf (__FILE__, __LINE__, "libtool wrapper (GNU $PACKAGE$TIMESTAMP) $VERSION\n");
+EOF
+ cat <<"EOF"
+ lt_debugprintf (__FILE__, __LINE__, "(main) argv[0]: %s\n", argv[0]);
+ lt_debugprintf (__FILE__, __LINE__, "(main) program_name: %s\n", program_name);
+
+ tmp_pathspec = find_executable (argv[0]);
+ if (tmp_pathspec == NULL)
+ lt_fatal (__FILE__, __LINE__, "couldn't find %s", argv[0]);
+ lt_debugprintf (__FILE__, __LINE__,
+ "(main) found exe (before symlink chase) at: %s\n",
+ tmp_pathspec);
+
+ actual_cwrapper_path = chase_symlinks (tmp_pathspec);
+ lt_debugprintf (__FILE__, __LINE__,
+ "(main) found exe (after symlink chase) at: %s\n",
+ actual_cwrapper_path);
+ XFREE (tmp_pathspec);
+
+ actual_cwrapper_name = xstrdup (base_name (actual_cwrapper_path));
+ strendzap (actual_cwrapper_path, actual_cwrapper_name);
+
+ /* wrapper name transforms */
+ strendzap (actual_cwrapper_name, ".exe");
+ tmp_pathspec = lt_extend_str (actual_cwrapper_name, ".exe", 1);
+ XFREE (actual_cwrapper_name);
+ actual_cwrapper_name = tmp_pathspec;
+ tmp_pathspec = 0;
+
+ /* target_name transforms -- use actual target program name; might have lt- prefix */
+ target_name = xstrdup (base_name (TARGET_PROGRAM_NAME));
+ strendzap (target_name, ".exe");
+ tmp_pathspec = lt_extend_str (target_name, ".exe", 1);
+ XFREE (target_name);
+ target_name = tmp_pathspec;
+ tmp_pathspec = 0;
+
+ lt_debugprintf (__FILE__, __LINE__,
+ "(main) libtool target name: %s\n",
+ target_name);
+EOF
+
+ cat <<EOF
+ newargz[0] =
+ XMALLOC (char, (strlen (actual_cwrapper_path) +
+ strlen ("$objdir") + 1 + strlen (actual_cwrapper_name) + 1));
+ strcpy (newargz[0], actual_cwrapper_path);
+ strcat (newargz[0], "$objdir");
+ strcat (newargz[0], "/");
+EOF
+
+ cat <<"EOF"
+ /* stop here, and copy so we don't have to do this twice */
+ tmp_pathspec = xstrdup (newargz[0]);
+
+ /* do NOT want the lt- prefix here, so use actual_cwrapper_name */
+ strcat (newargz[0], actual_cwrapper_name);
+
+ /* DO want the lt- prefix here if it exists, so use target_name */
+ lt_argv_zero = lt_extend_str (tmp_pathspec, target_name, 1);
+ XFREE (tmp_pathspec);
+ tmp_pathspec = NULL;
+EOF
+
+ case $host_os in
+ mingw*)
+ cat <<"EOF"
+ {
+ char* p;
+ while ((p = strchr (newargz[0], '\\')) != NULL)
+ {
+ *p = '/';
+ }
+ while ((p = strchr (lt_argv_zero, '\\')) != NULL)
+ {
+ *p = '/';
+ }
+ }
+EOF
+ ;;
+ esac
+
+ cat <<"EOF"
+ XFREE (target_name);
+ XFREE (actual_cwrapper_path);
+ XFREE (actual_cwrapper_name);
+
+ lt_setenv ("BIN_SH", "xpg4"); /* for Tru64 */
+ lt_setenv ("DUALCASE", "1"); /* for MSK sh */
+ /* Update the DLL searchpath. EXE_PATH_VALUE ($dllsearchpath) must
+ be prepended before (that is, appear after) LIB_PATH_VALUE ($temp_rpath)
+ because on Windows, both *_VARNAMEs are PATH but uninstalled
+ libraries must come first. */
+ lt_update_exe_path (EXE_PATH_VARNAME, EXE_PATH_VALUE);
+ lt_update_lib_path (LIB_PATH_VARNAME, LIB_PATH_VALUE);
+
+ lt_debugprintf (__FILE__, __LINE__, "(main) lt_argv_zero: %s\n",
+ nonnull (lt_argv_zero));
+ for (i = 0; i < newargc; i++)
+ {
+ lt_debugprintf (__FILE__, __LINE__, "(main) newargz[%d]: %s\n",
+ i, nonnull (newargz[i]));
+ }
+
+EOF
+
+ case $host_os in
+ mingw*)
+ cat <<"EOF"
+ /* execv doesn't actually work on mingw as expected on unix */
+ newargz = prepare_spawn (newargz);
+ rval = _spawnv (_P_WAIT, lt_argv_zero, (const char * const *) newargz);
+ if (rval == -1)
+ {
+ /* failed to start process */
+ lt_debugprintf (__FILE__, __LINE__,
+ "(main) failed to launch target \"%s\": %s\n",
+ lt_argv_zero, nonnull (strerror (errno)));
+ return 127;
+ }
+ return rval;
+EOF
+ ;;
+ *)
+ cat <<"EOF"
+ execv (lt_argv_zero, newargz);
+ return rval; /* =127, but avoids unused variable warning */
+EOF
+ ;;
+ esac
+
+ cat <<"EOF"
+}
+
+void *
+xmalloc (size_t num)
+{
+ void *p = (void *) malloc (num);
+ if (!p)
+ lt_fatal (__FILE__, __LINE__, "memory exhausted");
+
+ return p;
+}
+
+char *
+xstrdup (const char *string)
+{
+ return string ? strcpy ((char *) xmalloc (strlen (string) + 1),
+ string) : NULL;
+}
+
+const char *
+base_name (const char *name)
+{
+ const char *base;
+
+#if defined (HAVE_DOS_BASED_FILE_SYSTEM)
+ /* Skip over the disk name in MSDOS pathnames. */
+ if (isalpha ((unsigned char) name[0]) && name[1] == ':')
+ name += 2;
+#endif
+
+ for (base = name; *name; name++)
+ if (IS_DIR_SEPARATOR (*name))
+ base = name + 1;
+ return base;
+}
+
+int
+check_executable (const char *path)
+{
+ struct stat st;
+
+ lt_debugprintf (__FILE__, __LINE__, "(check_executable): %s\n",
+ nonempty (path));
+ if ((!path) || (!*path))
+ return 0;
+
+ if ((stat (path, &st) >= 0)
+ && (st.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH)))
+ return 1;
+ else
+ return 0;
+}
+
+int
+make_executable (const char *path)
+{
+ int rval = 0;
+ struct stat st;
+
+ lt_debugprintf (__FILE__, __LINE__, "(make_executable): %s\n",
+ nonempty (path));
+ if ((!path) || (!*path))
+ return 0;
+
+ if (stat (path, &st) >= 0)
+ {
+ rval = chmod (path, st.st_mode | S_IXOTH | S_IXGRP | S_IXUSR);
+ }
+ return rval;
+}
+
+/* Searches for the full path of the wrapper. Returns
+ newly allocated full path name if found, NULL otherwise
+ Does not chase symlinks, even on platforms that support them.
+*/
+char *
+find_executable (const char *wrapper)
+{
+ int has_slash = 0;
+ const char *p;
+ const char *p_next;
+ /* static buffer for getcwd */
+ char tmp[LT_PATHMAX + 1];
+ int tmp_len;
+ char *concat_name;
+
+ lt_debugprintf (__FILE__, __LINE__, "(find_executable): %s\n",
+ nonempty (wrapper));
+
+ if ((wrapper == NULL) || (*wrapper == '\0'))
+ return NULL;
+
+ /* Absolute path? */
+#if defined (HAVE_DOS_BASED_FILE_SYSTEM)
+ if (isalpha ((unsigned char) wrapper[0]) && wrapper[1] == ':')
+ {
+ concat_name = xstrdup (wrapper);
+ if (check_executable (concat_name))
+ return concat_name;
+ XFREE (concat_name);
+ }
+ else
+ {
+#endif
+ if (IS_DIR_SEPARATOR (wrapper[0]))
+ {
+ concat_name = xstrdup (wrapper);
+ if (check_executable (concat_name))
+ return concat_name;
+ XFREE (concat_name);
+ }
+#if defined (HAVE_DOS_BASED_FILE_SYSTEM)
+ }
+#endif
+
+ for (p = wrapper; *p; p++)
+ if (*p == '/')
+ {
+ has_slash = 1;
+ break;
+ }
+ if (!has_slash)
+ {
+ /* no slashes; search PATH */
+ const char *path = getenv ("PATH");
+ if (path != NULL)
+ {
+ for (p = path; *p; p = p_next)
+ {
+ const char *q;
+ size_t p_len;
+ for (q = p; *q; q++)
+ if (IS_PATH_SEPARATOR (*q))
+ break;
+ p_len = q - p;
+ p_next = (*q == '\0' ? q : q + 1);
+ if (p_len == 0)
+ {
+ /* empty path: current directory */
+ if (getcwd (tmp, LT_PATHMAX) == NULL)
+ lt_fatal (__FILE__, __LINE__, "getcwd failed: %s",
+ nonnull (strerror (errno)));
+ tmp_len = strlen (tmp);
+ concat_name =
+ XMALLOC (char, tmp_len + 1 + strlen (wrapper) + 1);
+ memcpy (concat_name, tmp, tmp_len);
+ concat_name[tmp_len] = '/';
+ strcpy (concat_name + tmp_len + 1, wrapper);
+ }
+ else
+ {
+ concat_name =
+ XMALLOC (char, p_len + 1 + strlen (wrapper) + 1);
+ memcpy (concat_name, p, p_len);
+ concat_name[p_len] = '/';
+ strcpy (concat_name + p_len + 1, wrapper);
+ }
+ if (check_executable (concat_name))
+ return concat_name;
+ XFREE (concat_name);
+ }
+ }
+ /* not found in PATH; assume curdir */
+ }
+ /* Relative path | not found in path: prepend cwd */
+ if (getcwd (tmp, LT_PATHMAX) == NULL)
+ lt_fatal (__FILE__, __LINE__, "getcwd failed: %s",
+ nonnull (strerror (errno)));
+ tmp_len = strlen (tmp);
+ concat_name = XMALLOC (char, tmp_len + 1 + strlen (wrapper) + 1);
+ memcpy (concat_name, tmp, tmp_len);
+ concat_name[tmp_len] = '/';
+ strcpy (concat_name + tmp_len + 1, wrapper);
+
+ if (check_executable (concat_name))
+ return concat_name;
+ XFREE (concat_name);
+ return NULL;
+}
+
+char *
+chase_symlinks (const char *pathspec)
+{
+#ifndef S_ISLNK
+ return xstrdup (pathspec);
+#else
+ char buf[LT_PATHMAX];
+ struct stat s;
+ char *tmp_pathspec = xstrdup (pathspec);
+ char *p;
+ int has_symlinks = 0;
+ while (strlen (tmp_pathspec) && !has_symlinks)
+ {
+ lt_debugprintf (__FILE__, __LINE__,
+ "checking path component for symlinks: %s\n",
+ tmp_pathspec);
+ if (lstat (tmp_pathspec, &s) == 0)
+ {
+ if (S_ISLNK (s.st_mode) != 0)
+ {
+ has_symlinks = 1;
+ break;
+ }
+
+ /* search backwards for last DIR_SEPARATOR */
+ p = tmp_pathspec + strlen (tmp_pathspec) - 1;
+ while ((p > tmp_pathspec) && (!IS_DIR_SEPARATOR (*p)))
+ p--;
+ if ((p == tmp_pathspec) && (!IS_DIR_SEPARATOR (*p)))
+ {
+ /* no more DIR_SEPARATORS left */
+ break;
+ }
+ *p = '\0';
+ }
+ else
+ {
+ lt_fatal (__FILE__, __LINE__,
+ "error accessing file \"%s\": %s",
+ tmp_pathspec, nonnull (strerror (errno)));
+ }
+ }
+ XFREE (tmp_pathspec);
+
+ if (!has_symlinks)
+ {
+ return xstrdup (pathspec);
+ }
+
+ tmp_pathspec = realpath (pathspec, buf);
+ if (tmp_pathspec == 0)
+ {
+ lt_fatal (__FILE__, __LINE__,
+ "could not follow symlinks for %s", pathspec);
+ }
+ return xstrdup (tmp_pathspec);
+#endif
+}
+
+char *
+strendzap (char *str, const char *pat)
+{
+ size_t len, patlen;
+
+ assert (str != NULL);
+ assert (pat != NULL);
+
+ len = strlen (str);
+ patlen = strlen (pat);
+
+ if (patlen <= len)
+ {
+ str += len - patlen;
+ if (strcmp (str, pat) == 0)
+ *str = '\0';
+ }
+ return str;
+}
+
+void
+lt_debugprintf (const char *file, int line, const char *fmt, ...)
+{
+ va_list args;
+ if (lt_debug)
+ {
+ (void) fprintf (stderr, "%s:%s:%d: ", program_name, file, line);
+ va_start (args, fmt);
+ (void) vfprintf (stderr, fmt, args);
+ va_end (args);
+ }
+}
+
+static void
+lt_error_core (int exit_status, const char *file,
+ int line, const char *mode,
+ const char *message, va_list ap)
+{
+ fprintf (stderr, "%s:%s:%d: %s: ", program_name, file, line, mode);
+ vfprintf (stderr, message, ap);
+ fprintf (stderr, ".\n");
+
+ if (exit_status >= 0)
+ exit (exit_status);
+}
+
+void
+lt_fatal (const char *file, int line, const char *message, ...)
+{
+ va_list ap;
+ va_start (ap, message);
+ lt_error_core (EXIT_FAILURE, file, line, "FATAL", message, ap);
+ va_end (ap);
+}
+
+static const char *
+nonnull (const char *s)
+{
+ return s ? s : "(null)";
+}
+
+static const char *
+nonempty (const char *s)
+{
+ return (s && !*s) ? "(empty)" : nonnull (s);
+}
+
+void
+lt_setenv (const char *name, const char *value)
+{
+ lt_debugprintf (__FILE__, __LINE__,
+ "(lt_setenv) setting '%s' to '%s'\n",
+ nonnull (name), nonnull (value));
+ {
+#ifdef HAVE_SETENV
+ /* always make a copy, for consistency with !HAVE_SETENV */
+ char *str = xstrdup (value);
+ setenv (name, str, 1);
+#else
+ int len = strlen (name) + 1 + strlen (value) + 1;
+ char *str = XMALLOC (char, len);
+ sprintf (str, "%s=%s", name, value);
+ if (putenv (str) != EXIT_SUCCESS)
+ {
+ XFREE (str);
+ }
+#endif
+ }
+}
+
+char *
+lt_extend_str (const char *orig_value, const char *add, int to_end)
+{
+ char *new_value;
+ if (orig_value && *orig_value)
+ {
+ int orig_value_len = strlen (orig_value);
+ int add_len = strlen (add);
+ new_value = XMALLOC (char, add_len + orig_value_len + 1);
+ if (to_end)
+ {
+ strcpy (new_value, orig_value);
+ strcpy (new_value + orig_value_len, add);
+ }
+ else
+ {
+ strcpy (new_value, add);
+ strcpy (new_value + add_len, orig_value);
+ }
+ }
+ else
+ {
+ new_value = xstrdup (add);
+ }
+ return new_value;
+}
+
+void
+lt_update_exe_path (const char *name, const char *value)
+{
+ lt_debugprintf (__FILE__, __LINE__,
+ "(lt_update_exe_path) modifying '%s' by prepending '%s'\n",
+ nonnull (name), nonnull (value));
+
+ if (name && *name && value && *value)
+ {
+ char *new_value = lt_extend_str (getenv (name), value, 0);
+ /* some systems can't cope with a ':'-terminated path #' */
+ int len = strlen (new_value);
+ while (((len = strlen (new_value)) > 0) && IS_PATH_SEPARATOR (new_value[len-1]))
+ {
+ new_value[len-1] = '\0';
+ }
+ lt_setenv (name, new_value);
+ XFREE (new_value);
+ }
+}
+
+void
+lt_update_lib_path (const char *name, const char *value)
+{
+ lt_debugprintf (__FILE__, __LINE__,
+ "(lt_update_lib_path) modifying '%s' by prepending '%s'\n",
+ nonnull (name), nonnull (value));
+
+ if (name && *name && value && *value)
+ {
+ char *new_value = lt_extend_str (getenv (name), value, 0);
+ lt_setenv (name, new_value);
+ XFREE (new_value);
+ }
+}
+
+EOF
+ case $host_os in
+ mingw*)
+ cat <<"EOF"
+
+/* Prepares an argument vector before calling spawn().
+ Note that spawn() does not by itself call the command interpreter
+ (getenv ("COMSPEC") != NULL ? getenv ("COMSPEC") :
+ ({ OSVERSIONINFO v; v.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+ GetVersionEx(&v);
+ v.dwPlatformId == VER_PLATFORM_WIN32_NT;
+ }) ? "cmd.exe" : "command.com").
+ Instead it simply concatenates the arguments, separated by ' ', and calls
+ CreateProcess(). We must quote the arguments since Win32 CreateProcess()
+ interprets characters like ' ', '\t', '\\', '"' (but not '<' and '>') in a
+ special way:
+ - Space and tab are interpreted as delimiters. They are not treated as
+ delimiters if they are surrounded by double quotes: "...".
+ - Unescaped double quotes are removed from the input. Their only effect is
+ that within double quotes, space and tab are treated like normal
+ characters.
+ - Backslashes not followed by double quotes are not special.
+ - But 2*n+1 backslashes followed by a double quote become
+ n backslashes followed by a double quote (n >= 0):
+ \" -> "
+ \\\" -> \"
+ \\\\\" -> \\"
+ */
+#define SHELL_SPECIAL_CHARS "\"\\ \001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037"
+#define SHELL_SPACE_CHARS " \001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037"
+char **
+prepare_spawn (char **argv)
+{
+ size_t argc;
+ char **new_argv;
+ size_t i;
+
+ /* Count number of arguments. */
+ for (argc = 0; argv[argc] != NULL; argc++)
+ ;
+
+ /* Allocate new argument vector. */
+ new_argv = XMALLOC (char *, argc + 1);
+
+ /* Put quoted arguments into the new argument vector. */
+ for (i = 0; i < argc; i++)
+ {
+ const char *string = argv[i];
+
+ if (string[0] == '\0')
+ new_argv[i] = xstrdup ("\"\"");
+ else if (strpbrk (string, SHELL_SPECIAL_CHARS) != NULL)
+ {
+ int quote_around = (strpbrk (string, SHELL_SPACE_CHARS) != NULL);
+ size_t length;
+ unsigned int backslashes;
+ const char *s;
+ char *quoted_string;
+ char *p;
+
+ length = 0;
+ backslashes = 0;
+ if (quote_around)
+ length++;
+ for (s = string; *s != '\0'; s++)
+ {
+ char c = *s;
+ if (c == '"')
+ length += backslashes + 1;
+ length++;
+ if (c == '\\')
+ backslashes++;
+ else
+ backslashes = 0;
+ }
+ if (quote_around)
+ length += backslashes + 1;
+
+ quoted_string = XMALLOC (char, length + 1);
+
+ p = quoted_string;
+ backslashes = 0;
+ if (quote_around)
+ *p++ = '"';
+ for (s = string; *s != '\0'; s++)
+ {
+ char c = *s;
+ if (c == '"')
+ {
+ unsigned int j;
+ for (j = backslashes + 1; j > 0; j--)
+ *p++ = '\\';
+ }
+ *p++ = c;
+ if (c == '\\')
+ backslashes++;
+ else
+ backslashes = 0;
+ }
+ if (quote_around)
+ {
+ unsigned int j;
+ for (j = backslashes; j > 0; j--)
+ *p++ = '\\';
+ *p++ = '"';
+ }
+ *p = '\0';
+
+ new_argv[i] = quoted_string;
+ }
+ else
+ new_argv[i] = (char *) string;
+ }
+ new_argv[argc] = NULL;
+
+ return new_argv;
+}
+EOF
+ ;;
+ esac
+
+ cat <<"EOF"
+void lt_dump_script (FILE* f)
+{
+EOF
+ func_emit_wrapper yes |
+ $SED -e 's/\([\\"]\)/\\\1/g' \
+ -e 's/^/ fputs ("/' -e 's/$/\\n", f);/'
+
+ cat <<"EOF"
+}
+EOF
+}
+# end: func_emit_cwrapperexe_src
+
+# func_win32_import_lib_p ARG
+# True if ARG is an import lib, as indicated by $file_magic_cmd
+func_win32_import_lib_p ()
+{
+ $opt_debug
+ case `eval $file_magic_cmd \"\$1\" 2>/dev/null | $SED -e 10q` in
+ *import*) : ;;
+ *) false ;;
+ esac
+}
+
+# func_mode_link arg...
+func_mode_link ()
+{
+ $opt_debug
+ case $host in
+ *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*)
+ # It is impossible to link a dll without this setting, and
+ # we shouldn't force the makefile maintainer to figure out
+ # which system we are compiling for in order to pass an extra
+ # flag for every libtool invocation.
+ # allow_undefined=no
+
+ # FIXME: Unfortunately, there are problems with the above when trying
+ # to make a dll which has undefined symbols, in which case not
+ # even a static library is built. For now, we need to specify
+ # -no-undefined on the libtool link line when we can be certain
+ # that all symbols are satisfied, otherwise we get a static library.
+ allow_undefined=yes
+ ;;
+ *)
+ allow_undefined=yes
+ ;;
+ esac
+ libtool_args=$nonopt
+ base_compile="$nonopt $@"
+ compile_command=$nonopt
+ finalize_command=$nonopt
+
+ compile_rpath=
+ finalize_rpath=
+ compile_shlibpath=
+ finalize_shlibpath=
+ convenience=
+ old_convenience=
+ deplibs=
+ old_deplibs=
+ compiler_flags=
+ linker_flags=
+ dllsearchpath=
+ lib_search_path=`pwd`
+ inst_prefix_dir=
+ new_inherited_linker_flags=
+
+ avoid_version=no
+ bindir=
+ dlfiles=
+ dlprefiles=
+ dlself=no
+ export_dynamic=no
+ export_symbols=
+ export_symbols_regex=
+ generated=
+ libobjs=
+ ltlibs=
+ module=no
+ no_install=no
+ objs=
+ non_pic_objects=
+ precious_files_regex=
+ prefer_static_libs=no
+ preload=no
+ prev=
+ prevarg=
+ release=
+ rpath=
+ xrpath=
+ perm_rpath=
+ temp_rpath=
+ thread_safe=no
+ vinfo=
+ vinfo_number=no
+ weak_libs=
+ single_module="${wl}-single_module"
+ func_infer_tag $base_compile
+
+ # We need to know -static, to get the right output filenames.
+ for arg
+ do
+ case $arg in
+ -shared)
+ test "$build_libtool_libs" != yes && \
+ func_fatal_configuration "can not build a shared library"
+ build_old_libs=no
+ break
+ ;;
+ -all-static | -static | -static-libtool-libs)
+ case $arg in
+ -all-static)
+ if test "$build_libtool_libs" = yes && test -z "$link_static_flag"; then
+ func_warning "complete static linking is impossible in this configuration"
+ fi
+ if test -n "$link_static_flag"; then
+ dlopen_self=$dlopen_self_static
+ fi
+ prefer_static_libs=yes
+ ;;
+ -static)
+ if test -z "$pic_flag" && test -n "$link_static_flag"; then
+ dlopen_self=$dlopen_self_static
+ fi
+ prefer_static_libs=built
+ ;;
+ -static-libtool-libs)
+ if test -z "$pic_flag" && test -n "$link_static_flag"; then
+ dlopen_self=$dlopen_self_static
+ fi
+ prefer_static_libs=yes
+ ;;
+ esac
+ build_libtool_libs=no
+ build_old_libs=yes
+ break
+ ;;
+ esac
+ done
+
+ # See if our shared archives depend on static archives.
+ test -n "$old_archive_from_new_cmds" && build_old_libs=yes
+
+ # Go through the arguments, transforming them on the way.
+ while test "$#" -gt 0; do
+ arg="$1"
+ shift
+ func_quote_for_eval "$arg"
+ qarg=$func_quote_for_eval_unquoted_result
+ func_append libtool_args " $func_quote_for_eval_result"
+
+ # If the previous option needs an argument, assign it.
+ if test -n "$prev"; then
+ case $prev in
+ output)
+ func_append compile_command " @OUTPUT@"
+ func_append finalize_command " @OUTPUT@"
+ ;;
+ esac
+
+ case $prev in
+ bindir)
+ bindir="$arg"
+ prev=
+ continue
+ ;;
+ dlfiles|dlprefiles)
+ if test "$preload" = no; then
+ # Add the symbol object into the linking commands.
+ func_append compile_command " @SYMFILE@"
+ func_append finalize_command " @SYMFILE@"
+ preload=yes
+ fi
+ case $arg in
+ *.la | *.lo) ;; # We handle these cases below.
+ force)
+ if test "$dlself" = no; then
+ dlself=needless
+ export_dynamic=yes
+ fi
+ prev=
+ continue
+ ;;
+ self)
+ if test "$prev" = dlprefiles; then
+ dlself=yes
+ elif test "$prev" = dlfiles && test "$dlopen_self" != yes; then
+ dlself=yes
+ else
+ dlself=needless
+ export_dynamic=yes
+ fi
+ prev=
+ continue
+ ;;
+ *)
+ if test "$prev" = dlfiles; then
+ func_append dlfiles " $arg"
+ else
+ func_append dlprefiles " $arg"
+ fi
+ prev=
+ continue
+ ;;
+ esac
+ ;;
+ expsyms)
+ export_symbols="$arg"
+ test -f "$arg" \
+ || func_fatal_error "symbol file \`$arg' does not exist"
+ prev=
+ continue
+ ;;
+ expsyms_regex)
+ export_symbols_regex="$arg"
+ prev=
+ continue
+ ;;
+ framework)
+ case $host in
+ *-*-darwin*)
+ case "$deplibs " in
+ *" $qarg.ltframework "*) ;;
+ *) func_append deplibs " $qarg.ltframework" # this is fixed later
+ ;;
+ esac
+ ;;
+ esac
+ prev=
+ continue
+ ;;
+ inst_prefix)
+ inst_prefix_dir="$arg"
+ prev=
+ continue
+ ;;
+ objectlist)
+ if test -f "$arg"; then
+ save_arg=$arg
+ moreargs=
+ for fil in `cat "$save_arg"`
+ do
+# func_append moreargs " $fil"
+ arg=$fil
+ # A libtool-controlled object.
+
+ # Check to see that this really is a libtool object.
+ if func_lalib_unsafe_p "$arg"; then
+ pic_object=
+ non_pic_object=
+
+ # Read the .lo file
+ func_source "$arg"
+
+ if test -z "$pic_object" ||
+ test -z "$non_pic_object" ||
+ test "$pic_object" = none &&
+ test "$non_pic_object" = none; then
+ func_fatal_error "cannot find name of object for \`$arg'"
+ fi
+
+ # Extract subdirectory from the argument.
+ func_dirname "$arg" "/" ""
+ xdir="$func_dirname_result"
+
+ if test "$pic_object" != none; then
+ # Prepend the subdirectory the object is found in.
+ pic_object="$xdir$pic_object"
+
+ if test "$prev" = dlfiles; then
+ if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then
+ func_append dlfiles " $pic_object"
+ prev=
+ continue
+ else
+ # If libtool objects are unsupported, then we need to preload.
+ prev=dlprefiles
+ fi
+ fi
+
+ # CHECK ME: I think I busted this. -Ossama
+ if test "$prev" = dlprefiles; then
+ # Preload the old-style object.
+ func_append dlprefiles " $pic_object"
+ prev=
+ fi
+
+ # A PIC object.
+ func_append libobjs " $pic_object"
+ arg="$pic_object"
+ fi
+
+ # Non-PIC object.
+ if test "$non_pic_object" != none; then
+ # Prepend the subdirectory the object is found in.
+ non_pic_object="$xdir$non_pic_object"
+
+ # A standard non-PIC object
+ func_append non_pic_objects " $non_pic_object"
+ if test -z "$pic_object" || test "$pic_object" = none ; then
+ arg="$non_pic_object"
+ fi
+ else
+ # If the PIC object exists, use it instead.
+ # $xdir was prepended to $pic_object above.
+ non_pic_object="$pic_object"
+ func_append non_pic_objects " $non_pic_object"
+ fi
+ else
+ # Only an error if not doing a dry-run.
+ if $opt_dry_run; then
+ # Extract subdirectory from the argument.
+ func_dirname "$arg" "/" ""
+ xdir="$func_dirname_result"
+
+ func_lo2o "$arg"
+ pic_object=$xdir$objdir/$func_lo2o_result
+ non_pic_object=$xdir$func_lo2o_result
+ func_append libobjs " $pic_object"
+ func_append non_pic_objects " $non_pic_object"
+ else
+ func_fatal_error "\`$arg' is not a valid libtool object"
+ fi
+ fi
+ done
+ else
+ func_fatal_error "link input file \`$arg' does not exist"
+ fi
+ arg=$save_arg
+ prev=
+ continue
+ ;;
+ precious_regex)
+ precious_files_regex="$arg"
+ prev=
+ continue
+ ;;
+ release)
+ release="-$arg"
+ prev=
+ continue
+ ;;
+ rpath | xrpath)
+ # We need an absolute path.
+ case $arg in
+ [\\/]* | [A-Za-z]:[\\/]*) ;;
+ *)
+ func_fatal_error "only absolute run-paths are allowed"
+ ;;
+ esac
+ if test "$prev" = rpath; then
+ case "$rpath " in
+ *" $arg "*) ;;
+ *) func_append rpath " $arg" ;;
+ esac
+ else
+ case "$xrpath " in
+ *" $arg "*) ;;
+ *) func_append xrpath " $arg" ;;
+ esac
+ fi
+ prev=
+ continue
+ ;;
+ shrext)
+ shrext_cmds="$arg"
+ prev=
+ continue
+ ;;
+ weak)
+ func_append weak_libs " $arg"
+ prev=
+ continue
+ ;;
+ xcclinker)
+ func_append linker_flags " $qarg"
+ func_append compiler_flags " $qarg"
+ prev=
+ func_append compile_command " $qarg"
+ func_append finalize_command " $qarg"
+ continue
+ ;;
+ xcompiler)
+ func_append compiler_flags " $qarg"
+ prev=
+ func_append compile_command " $qarg"
+ func_append finalize_command " $qarg"
+ continue
+ ;;
+ xlinker)
+ func_append linker_flags " $qarg"
+ func_append compiler_flags " $wl$qarg"
+ prev=
+ func_append compile_command " $wl$qarg"
+ func_append finalize_command " $wl$qarg"
+ continue
+ ;;
+ *)
+ eval "$prev=\"\$arg\""
+ prev=
+ continue
+ ;;
+ esac
+ fi # test -n "$prev"
+
+ prevarg="$arg"
+
+ case $arg in
+ -all-static)
+ if test -n "$link_static_flag"; then
+ # See comment for -static flag below, for more details.
+ func_append compile_command " $link_static_flag"
+ func_append finalize_command " $link_static_flag"
+ fi
+ continue
+ ;;
+
+ -allow-undefined)
+ # FIXME: remove this flag sometime in the future.
+ func_fatal_error "\`-allow-undefined' must not be used because it is the default"
+ ;;
+
+ -avoid-version)
+ avoid_version=yes
+ continue
+ ;;
+
+ -bindir)
+ prev=bindir
+ continue
+ ;;
+
+ -dlopen)
+ prev=dlfiles
+ continue
+ ;;
+
+ -dlpreopen)
+ prev=dlprefiles
+ continue
+ ;;
+
+ -export-dynamic)
+ export_dynamic=yes
+ continue
+ ;;
+
+ -export-symbols | -export-symbols-regex)
+ if test -n "$export_symbols" || test -n "$export_symbols_regex"; then
+ func_fatal_error "more than one -exported-symbols argument is not allowed"
+ fi
+ if test "X$arg" = "X-export-symbols"; then
+ prev=expsyms
+ else
+ prev=expsyms_regex
+ fi
+ continue
+ ;;
+
+ -framework)
+ prev=framework
+ continue
+ ;;
+
+ -inst-prefix-dir)
+ prev=inst_prefix
+ continue
+ ;;
+
+ # The native IRIX linker understands -LANG:*, -LIST:* and -LNO:*
+ # so, if we see these flags be careful not to treat them like -L
+ -L[A-Z][A-Z]*:*)
+ case $with_gcc/$host in
+ no/*-*-irix* | /*-*-irix*)
+ func_append compile_command " $arg"
+ func_append finalize_command " $arg"
+ ;;
+ esac
+ continue
+ ;;
+
+ -L*)
+ func_stripname "-L" '' "$arg"
+ if test -z "$func_stripname_result"; then
+ if test "$#" -gt 0; then
+ func_fatal_error "require no space between \`-L' and \`$1'"
+ else
+ func_fatal_error "need path for \`-L' option"
+ fi
+ fi
+ func_resolve_sysroot "$func_stripname_result"
+ dir=$func_resolve_sysroot_result
+ # We need an absolute path.
+ case $dir in
+ [\\/]* | [A-Za-z]:[\\/]*) ;;
+ *)
+ absdir=`cd "$dir" && pwd`
+ test -z "$absdir" && \
+ func_fatal_error "cannot determine absolute directory name of \`$dir'"
+ dir="$absdir"
+ ;;
+ esac
+ case "$deplibs " in
+ *" -L$dir "* | *" $arg "*)
+ # Will only happen for absolute or sysroot arguments
+ ;;
+ *)
+ # Preserve sysroot, but never include relative directories
+ case $dir in
+ [\\/]* | [A-Za-z]:[\\/]* | =*) func_append deplibs " $arg" ;;
+ *) func_append deplibs " -L$dir" ;;
+ esac
+ func_append lib_search_path " $dir"
+ ;;
+ esac
+ case $host in
+ *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*)
+ testbindir=`$ECHO "$dir" | $SED 's*/lib$*/bin*'`
+ case :$dllsearchpath: in
+ *":$dir:"*) ;;
+ ::) dllsearchpath=$dir;;
+ *) func_append dllsearchpath ":$dir";;
+ esac
+ case :$dllsearchpath: in
+ *":$testbindir:"*) ;;
+ ::) dllsearchpath=$testbindir;;
+ *) func_append dllsearchpath ":$testbindir";;
+ esac
+ ;;
+ esac
+ continue
+ ;;
+
+ -l*)
+ if test "X$arg" = "X-lc" || test "X$arg" = "X-lm"; then
+ case $host in
+ *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-beos* | *-cegcc* | *-*-haiku*)
+ # These systems don't actually have a C or math library (as such)
+ continue
+ ;;
+ *-*-os2*)
+ # These systems don't actually have a C library (as such)
+ test "X$arg" = "X-lc" && continue
+ ;;
+ *-*-openbsd* | *-*-freebsd* | *-*-dragonfly*)
+ # Do not include libc due to us having libc/libc_r.
+ test "X$arg" = "X-lc" && continue
+ ;;
+ *-*-rhapsody* | *-*-darwin1.[012])
+ # Rhapsody C and math libraries are in the System framework
+ func_append deplibs " System.ltframework"
+ continue
+ ;;
+ *-*-sco3.2v5* | *-*-sco5v6*)
+ # Causes problems with __ctype
+ test "X$arg" = "X-lc" && continue
+ ;;
+ *-*-sysv4.2uw2* | *-*-sysv5* | *-*-unixware* | *-*-OpenUNIX*)
+ # Compiler inserts libc in the correct place for threads to work
+ test "X$arg" = "X-lc" && continue
+ ;;
+ esac
+ elif test "X$arg" = "X-lc_r"; then
+ case $host in
+ *-*-openbsd* | *-*-freebsd* | *-*-dragonfly*)
+ # Do not include libc_r directly, use -pthread flag.
+ continue
+ ;;
+ esac
+ fi
+ func_append deplibs " $arg"
+ continue
+ ;;
+
+ -module)
+ module=yes
+ continue
+ ;;
+
+ # Tru64 UNIX uses -model [arg] to determine the layout of C++
+ # classes, name mangling, and exception handling.
+ # Darwin uses the -arch flag to determine output architecture.
+ -model|-arch|-isysroot|--sysroot)
+ func_append compiler_flags " $arg"
+ func_append compile_command " $arg"
+ func_append finalize_command " $arg"
+ prev=xcompiler
+ continue
+ ;;
+
+ -mt|-mthreads|-kthread|-Kthread|-pthread|-pthreads|--thread-safe|-threads)
+ func_append compiler_flags " $arg"
+ func_append compile_command " $arg"
+ func_append finalize_command " $arg"
+ case "$new_inherited_linker_flags " in
+ *" $arg "*) ;;
+ * ) func_append new_inherited_linker_flags " $arg" ;;
+ esac
+ continue
+ ;;
+
+ -multi_module)
+ single_module="${wl}-multi_module"
+ continue
+ ;;
+
+ -no-fast-install)
+ fast_install=no
+ continue
+ ;;
+
+ -no-install)
+ case $host in
+ *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-darwin* | *-cegcc*)
+ # The PATH hackery in wrapper scripts is required on Windows
+ # and Darwin in order for the loader to find any dlls it needs.
+ func_warning "\`-no-install' is ignored for $host"
+ func_warning "assuming \`-no-fast-install' instead"
+ fast_install=no
+ ;;
+ *) no_install=yes ;;
+ esac
+ continue
+ ;;
+
+ -no-undefined)
+ allow_undefined=no
+ continue
+ ;;
+
+ -objectlist)
+ prev=objectlist
+ continue
+ ;;
+
+ -o) prev=output ;;
+
+ -precious-files-regex)
+ prev=precious_regex
+ continue
+ ;;
+
+ -release)
+ prev=release
+ continue
+ ;;
+
+ -rpath)
+ prev=rpath
+ continue
+ ;;
+
+ -R)
+ prev=xrpath
+ continue
+ ;;
+
+ -R*)
+ func_stripname '-R' '' "$arg"
+ dir=$func_stripname_result
+ # We need an absolute path.
+ case $dir in
+ [\\/]* | [A-Za-z]:[\\/]*) ;;
+ =*)
+ func_stripname '=' '' "$dir"
+ dir=$lt_sysroot$func_stripname_result
+ ;;
+ *)
+ func_fatal_error "only absolute run-paths are allowed"
+ ;;
+ esac
+ case "$xrpath " in
+ *" $dir "*) ;;
+ *) func_append xrpath " $dir" ;;
+ esac
+ continue
+ ;;
+
+ -shared)
+ # The effects of -shared are defined in a previous loop.
+ continue
+ ;;
+
+ -shrext)
+ prev=shrext
+ continue
+ ;;
+
+ -static | -static-libtool-libs)
+ # The effects of -static are defined in a previous loop.
+ # We used to do the same as -all-static on platforms that
+ # didn't have a PIC flag, but the assumption that the effects
+ # would be equivalent was wrong. It would break on at least
+ # Digital Unix and AIX.
+ continue
+ ;;
+
+ -thread-safe)
+ thread_safe=yes
+ continue
+ ;;
+
+ -version-info)
+ prev=vinfo
+ continue
+ ;;
+
+ -version-number)
+ prev=vinfo
+ vinfo_number=yes
+ continue
+ ;;
+
+ -weak)
+ prev=weak
+ continue
+ ;;
+
+ -Wc,*)
+ func_stripname '-Wc,' '' "$arg"
+ args=$func_stripname_result
+ arg=
+ save_ifs="$IFS"; IFS=','
+ for flag in $args; do
+ IFS="$save_ifs"
+ func_quote_for_eval "$flag"
+ func_append arg " $func_quote_for_eval_result"
+ func_append compiler_flags " $func_quote_for_eval_result"
+ done
+ IFS="$save_ifs"
+ func_stripname ' ' '' "$arg"
+ arg=$func_stripname_result
+ ;;
+
+ -Wl,*)
+ func_stripname '-Wl,' '' "$arg"
+ args=$func_stripname_result
+ arg=
+ save_ifs="$IFS"; IFS=','
+ for flag in $args; do
+ IFS="$save_ifs"
+ func_quote_for_eval "$flag"
+ func_append arg " $wl$func_quote_for_eval_result"
+ func_append compiler_flags " $wl$func_quote_for_eval_result"
+ func_append linker_flags " $func_quote_for_eval_result"
+ done
+ IFS="$save_ifs"
+ func_stripname ' ' '' "$arg"
+ arg=$func_stripname_result
+ ;;
+
+ -Xcompiler)
+ prev=xcompiler
+ continue
+ ;;
+
+ -Xlinker)
+ prev=xlinker
+ continue
+ ;;
+
+ -XCClinker)
+ prev=xcclinker
+ continue
+ ;;
+
+ # -msg_* for osf cc
+ -msg_*)
+ func_quote_for_eval "$arg"
+ arg="$func_quote_for_eval_result"
+ ;;
+
+ # Flags to be passed through unchanged, with rationale:
+ # -64, -mips[0-9] enable 64-bit mode for the SGI compiler
+ # -r[0-9][0-9]* specify processor for the SGI compiler
+ # -xarch=*, -xtarget=* enable 64-bit mode for the Sun compiler
+ # +DA*, +DD* enable 64-bit mode for the HP compiler
+ # -q* compiler args for the IBM compiler
+ # -m*, -t[45]*, -txscale* architecture-specific flags for GCC
+ # -F/path path to uninstalled frameworks, gcc on darwin
+ # -p, -pg, --coverage, -fprofile-* profiling flags for GCC
+ # @file GCC response files
+ # -tp=* Portland pgcc target processor selection
+ # --sysroot=* for sysroot support
+ # -O*, -flto*, -fwhopr*, -fuse-linker-plugin GCC link-time optimization
+ -64|-mips[0-9]|-r[0-9][0-9]*|-xarch=*|-xtarget=*|+DA*|+DD*|-q*|-m*| \
+ -t[45]*|-txscale*|-p|-pg|--coverage|-fprofile-*|-F*|@*|-tp=*|--sysroot=*| \
+ -O*|-flto*|-fwhopr*|-fuse-linker-plugin)
+ func_quote_for_eval "$arg"
+ arg="$func_quote_for_eval_result"
+ func_append compile_command " $arg"
+ func_append finalize_command " $arg"
+ func_append compiler_flags " $arg"
+ continue
+ ;;
+
+ # Some other compiler flag.
+ -* | +*)
+ func_quote_for_eval "$arg"
+ arg="$func_quote_for_eval_result"
+ ;;
+
+ *.$objext)
+ # A standard object.
+ func_append objs " $arg"
+ ;;
+
+ *.lo)
+ # A libtool-controlled object.
+
+ # Check to see that this really is a libtool object.
+ if func_lalib_unsafe_p "$arg"; then
+ pic_object=
+ non_pic_object=
+
+ # Read the .lo file
+ func_source "$arg"
+
+ if test -z "$pic_object" ||
+ test -z "$non_pic_object" ||
+ test "$pic_object" = none &&
+ test "$non_pic_object" = none; then
+ func_fatal_error "cannot find name of object for \`$arg'"
+ fi
+
+ # Extract subdirectory from the argument.
+ func_dirname "$arg" "/" ""
+ xdir="$func_dirname_result"
+
+ if test "$pic_object" != none; then
+ # Prepend the subdirectory the object is found in.
+ pic_object="$xdir$pic_object"
+
+ if test "$prev" = dlfiles; then
+ if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then
+ func_append dlfiles " $pic_object"
+ prev=
+ continue
+ else
+ # If libtool objects are unsupported, then we need to preload.
+ prev=dlprefiles
+ fi
+ fi
+
+ # CHECK ME: I think I busted this. -Ossama
+ if test "$prev" = dlprefiles; then
+ # Preload the old-style object.
+ func_append dlprefiles " $pic_object"
+ prev=
+ fi
+
+ # A PIC object.
+ func_append libobjs " $pic_object"
+ arg="$pic_object"
+ fi
+
+ # Non-PIC object.
+ if test "$non_pic_object" != none; then
+ # Prepend the subdirectory the object is found in.
+ non_pic_object="$xdir$non_pic_object"
+
+ # A standard non-PIC object
+ func_append non_pic_objects " $non_pic_object"
+ if test -z "$pic_object" || test "$pic_object" = none ; then
+ arg="$non_pic_object"
+ fi
+ else
+ # If the PIC object exists, use it instead.
+ # $xdir was prepended to $pic_object above.
+ non_pic_object="$pic_object"
+ func_append non_pic_objects " $non_pic_object"
+ fi
+ else
+ # Only an error if not doing a dry-run.
+ if $opt_dry_run; then
+ # Extract subdirectory from the argument.
+ func_dirname "$arg" "/" ""
+ xdir="$func_dirname_result"
+
+ func_lo2o "$arg"
+ pic_object=$xdir$objdir/$func_lo2o_result
+ non_pic_object=$xdir$func_lo2o_result
+ func_append libobjs " $pic_object"
+ func_append non_pic_objects " $non_pic_object"
+ else
+ func_fatal_error "\`$arg' is not a valid libtool object"
+ fi
+ fi
+ ;;
+
+ *.$libext)
+ # An archive.
+ func_append deplibs " $arg"
+ func_append old_deplibs " $arg"
+ continue
+ ;;
+
+ *.la)
+ # A libtool-controlled library.
+
+ func_resolve_sysroot "$arg"
+ if test "$prev" = dlfiles; then
+ # This library was specified with -dlopen.
+ func_append dlfiles " $func_resolve_sysroot_result"
+ prev=
+ elif test "$prev" = dlprefiles; then
+ # The library was specified with -dlpreopen.
+ func_append dlprefiles " $func_resolve_sysroot_result"
+ prev=
+ else
+ func_append deplibs " $func_resolve_sysroot_result"
+ fi
+ continue
+ ;;
+
+ # Some other compiler argument.
+ *)
+ # Unknown arguments in both finalize_command and compile_command need
+ # to be aesthetically quoted because they are evaled later.
+ func_quote_for_eval "$arg"
+ arg="$func_quote_for_eval_result"
+ ;;
+ esac # arg
+
+ # Now actually substitute the argument into the commands.
+ if test -n "$arg"; then
+ func_append compile_command " $arg"
+ func_append finalize_command " $arg"
+ fi
+ done # argument parsing loop
+
+ test -n "$prev" && \
+ func_fatal_help "the \`$prevarg' option requires an argument"
+
+ if test "$export_dynamic" = yes && test -n "$export_dynamic_flag_spec"; then
+ eval arg=\"$export_dynamic_flag_spec\"
+ func_append compile_command " $arg"
+ func_append finalize_command " $arg"
+ fi
+
+ oldlibs=
+ # calculate the name of the file, without its directory
+ func_basename "$output"
+ outputname="$func_basename_result"
+ libobjs_save="$libobjs"
+
+ if test -n "$shlibpath_var"; then
+ # get the directories listed in $shlibpath_var
+ eval shlib_search_path=\`\$ECHO \"\${$shlibpath_var}\" \| \$SED \'s/:/ /g\'\`
+ else
+ shlib_search_path=
+ fi
+ eval sys_lib_search_path=\"$sys_lib_search_path_spec\"
+ eval sys_lib_dlsearch_path=\"$sys_lib_dlsearch_path_spec\"
+
+ func_dirname "$output" "/" ""
+ output_objdir="$func_dirname_result$objdir"
+ func_to_tool_file "$output_objdir/"
+ tool_output_objdir=$func_to_tool_file_result
+ # Create the object directory.
+ func_mkdir_p "$output_objdir"
+
+ # Determine the type of output
+ case $output in
+ "")
+ func_fatal_help "you must specify an output file"
+ ;;
+ *.$libext) linkmode=oldlib ;;
+ *.lo | *.$objext) linkmode=obj ;;
+ *.la) linkmode=lib ;;
+ *) linkmode=prog ;; # Anything else should be a program.
+ esac
+
+ specialdeplibs=
+
+ libs=
+ # Find all interdependent deplibs by searching for libraries
+ # that are linked more than once (e.g. -la -lb -la)
+ for deplib in $deplibs; do
+ if $opt_preserve_dup_deps ; then
+ case "$libs " in
+ *" $deplib "*) func_append specialdeplibs " $deplib" ;;
+ esac
+ fi
+ func_append libs " $deplib"
+ done
+
+ if test "$linkmode" = lib; then
+ libs="$predeps $libs $compiler_lib_search_path $postdeps"
+
+ # Compute libraries that are listed more than once in $predeps
+ # $postdeps and mark them as special (i.e., whose duplicates are
+ # not to be eliminated).
+ pre_post_deps=
+ if $opt_duplicate_compiler_generated_deps; then
+ for pre_post_dep in $predeps $postdeps; do
+ case "$pre_post_deps " in
+ *" $pre_post_dep "*) func_append specialdeplibs " $pre_post_deps" ;;
+ esac
+ func_append pre_post_deps " $pre_post_dep"
+ done
+ fi
+ pre_post_deps=
+ fi
+
+ deplibs=
+ newdependency_libs=
+ newlib_search_path=
+ need_relink=no # whether we're linking any uninstalled libtool libraries
+ notinst_deplibs= # not-installed libtool libraries
+ notinst_path= # paths that contain not-installed libtool libraries
+
+ case $linkmode in
+ lib)
+ passes="conv dlpreopen link"
+ for file in $dlfiles $dlprefiles; do
+ case $file in
+ *.la) ;;
+ *)
+ func_fatal_help "libraries can \`-dlopen' only libtool libraries: $file"
+ ;;
+ esac
+ done
+ ;;
+ prog)
+ compile_deplibs=
+ finalize_deplibs=
+ alldeplibs=no
+ newdlfiles=
+ newdlprefiles=
+ passes="conv scan dlopen dlpreopen link"
+ ;;
+ *) passes="conv"
+ ;;
+ esac
+
+ for pass in $passes; do
+ # The preopen pass in lib mode reverses $deplibs; put it back here
+ # so that -L comes before libs that need it for instance...
+ if test "$linkmode,$pass" = "lib,link"; then
+ ## FIXME: Find the place where the list is rebuilt in the wrong
+ ## order, and fix it there properly
+ tmp_deplibs=
+ for deplib in $deplibs; do
+ tmp_deplibs="$deplib $tmp_deplibs"
+ done
+ deplibs="$tmp_deplibs"
+ fi
+
+ if test "$linkmode,$pass" = "lib,link" ||
+ test "$linkmode,$pass" = "prog,scan"; then
+ libs="$deplibs"
+ deplibs=
+ fi
+ if test "$linkmode" = prog; then
+ case $pass in
+ dlopen) libs="$dlfiles" ;;
+ dlpreopen) libs="$dlprefiles" ;;
+ link) libs="$deplibs %DEPLIBS% $dependency_libs" ;;
+ esac
+ fi
+ if test "$linkmode,$pass" = "lib,dlpreopen"; then
+ # Collect and forward deplibs of preopened libtool libs
+ for lib in $dlprefiles; do
+ # Ignore non-libtool-libs
+ dependency_libs=
+ func_resolve_sysroot "$lib"
+ case $lib in
+ *.la) func_source "$func_resolve_sysroot_result" ;;
+ esac
+
+ # Collect preopened libtool deplibs, except any this library
+ # has declared as weak libs
+ for deplib in $dependency_libs; do
+ func_basename "$deplib"
+ deplib_base=$func_basename_result
+ case " $weak_libs " in
+ *" $deplib_base "*) ;;
+ *) func_append deplibs " $deplib" ;;
+ esac
+ done
+ done
+ libs="$dlprefiles"
+ fi
+ if test "$pass" = dlopen; then
+ # Collect dlpreopened libraries
+ save_deplibs="$deplibs"
+ deplibs=
+ fi
+
+ for deplib in $libs; do
+ lib=
+ found=no
+ case $deplib in
+ -mt|-mthreads|-kthread|-Kthread|-pthread|-pthreads|--thread-safe|-threads)
+ if test "$linkmode,$pass" = "prog,link"; then
+ compile_deplibs="$deplib $compile_deplibs"
+ finalize_deplibs="$deplib $finalize_deplibs"
+ else
+ func_append compiler_flags " $deplib"
+ if test "$linkmode" = lib ; then
+ case "$new_inherited_linker_flags " in
+ *" $deplib "*) ;;
+ * ) func_append new_inherited_linker_flags " $deplib" ;;
+ esac
+ fi
+ fi
+ continue
+ ;;
+ -l*)
+ if test "$linkmode" != lib && test "$linkmode" != prog; then
+ func_warning "\`-l' is ignored for archives/objects"
+ continue
+ fi
+ func_stripname '-l' '' "$deplib"
+ name=$func_stripname_result
+ if test "$linkmode" = lib; then
+ searchdirs="$newlib_search_path $lib_search_path $compiler_lib_search_dirs $sys_lib_search_path $shlib_search_path"
+ else
+ searchdirs="$newlib_search_path $lib_search_path $sys_lib_search_path $shlib_search_path"
+ fi
+ for searchdir in $searchdirs; do
+ for search_ext in .la $std_shrext .so .a; do
+ # Search the libtool library
+ lib="$searchdir/lib${name}${search_ext}"
+ if test -f "$lib"; then
+ if test "$search_ext" = ".la"; then
+ found=yes
+ else
+ found=no
+ fi
+ break 2
+ fi
+ done
+ done
+ if test "$found" != yes; then
+ # deplib doesn't seem to be a libtool library
+ if test "$linkmode,$pass" = "prog,link"; then
+ compile_deplibs="$deplib $compile_deplibs"
+ finalize_deplibs="$deplib $finalize_deplibs"
+ else
+ deplibs="$deplib $deplibs"
+ test "$linkmode" = lib && newdependency_libs="$deplib $newdependency_libs"
+ fi
+ continue
+ else # deplib is a libtool library
+ # If $allow_libtool_libs_with_static_runtimes && $deplib is a stdlib,
+ # We need to do some special things here, and not later.
+ if test "X$allow_libtool_libs_with_static_runtimes" = "Xyes" ; then
+ case " $predeps $postdeps " in
+ *" $deplib "*)
+ if func_lalib_p "$lib"; then
+ library_names=
+ old_library=
+ func_source "$lib"
+ for l in $old_library $library_names; do
+ ll="$l"
+ done
+ if test "X$ll" = "X$old_library" ; then # only static version available
+ found=no
+ func_dirname "$lib" "" "."
+ ladir="$func_dirname_result"
+ lib=$ladir/$old_library
+ if test "$linkmode,$pass" = "prog,link"; then
+ compile_deplibs="$deplib $compile_deplibs"
+ finalize_deplibs="$deplib $finalize_deplibs"
+ else
+ deplibs="$deplib $deplibs"
+ test "$linkmode" = lib && newdependency_libs="$deplib $newdependency_libs"
+ fi
+ continue
+ fi
+ fi
+ ;;
+ *) ;;
+ esac
+ fi
+ fi
+ ;; # -l
+ *.ltframework)
+ if test "$linkmode,$pass" = "prog,link"; then
+ compile_deplibs="$deplib $compile_deplibs"
+ finalize_deplibs="$deplib $finalize_deplibs"
+ else
+ deplibs="$deplib $deplibs"
+ if test "$linkmode" = lib ; then
+ case "$new_inherited_linker_flags " in
+ *" $deplib "*) ;;
+ * ) func_append new_inherited_linker_flags " $deplib" ;;
+ esac
+ fi
+ fi
+ continue
+ ;;
+ -L*)
+ case $linkmode in
+ lib)
+ deplibs="$deplib $deplibs"
+ test "$pass" = conv && continue
+ newdependency_libs="$deplib $newdependency_libs"
+ func_stripname '-L' '' "$deplib"
+ func_resolve_sysroot "$func_stripname_result"
+ func_append newlib_search_path " $func_resolve_sysroot_result"
+ ;;
+ prog)
+ if test "$pass" = conv; then
+ deplibs="$deplib $deplibs"
+ continue
+ fi
+ if test "$pass" = scan; then
+ deplibs="$deplib $deplibs"
+ else
+ compile_deplibs="$deplib $compile_deplibs"
+ finalize_deplibs="$deplib $finalize_deplibs"
+ fi
+ func_stripname '-L' '' "$deplib"
+ func_resolve_sysroot "$func_stripname_result"
+ func_append newlib_search_path " $func_resolve_sysroot_result"
+ ;;
+ *)
+ func_warning "\`-L' is ignored for archives/objects"
+ ;;
+ esac # linkmode
+ continue
+ ;; # -L
+ -R*)
+ if test "$pass" = link; then
+ func_stripname '-R' '' "$deplib"
+ func_resolve_sysroot "$func_stripname_result"
+ dir=$func_resolve_sysroot_result
+ # Make sure the xrpath contains only unique directories.
+ case "$xrpath " in
+ *" $dir "*) ;;
+ *) func_append xrpath " $dir" ;;
+ esac
+ fi
+ deplibs="$deplib $deplibs"
+ continue
+ ;;
+ *.la)
+ func_resolve_sysroot "$deplib"
+ lib=$func_resolve_sysroot_result
+ ;;
+ *.$libext)
+ if test "$pass" = conv; then
+ deplibs="$deplib $deplibs"
+ continue
+ fi
+ case $linkmode in
+ lib)
+ # Linking convenience modules into shared libraries is allowed,
+ # but linking other static libraries is non-portable.
+ case " $dlpreconveniencelibs " in
+ *" $deplib "*) ;;
+ *)
+ valid_a_lib=no
+ case $deplibs_check_method in
+ match_pattern*)
+ set dummy $deplibs_check_method; shift
+ match_pattern_regex=`expr "$deplibs_check_method" : "$1 \(.*\)"`
+ if eval "\$ECHO \"$deplib\"" 2>/dev/null | $SED 10q \
+ | $EGREP "$match_pattern_regex" > /dev/null; then
+ valid_a_lib=yes
+ fi
+ ;;
+ pass_all)
+ valid_a_lib=yes
+ ;;
+ esac
+ if test "$valid_a_lib" != yes; then
+ echo
+ $ECHO "*** Warning: Trying to link with static lib archive $deplib."
+ echo "*** I have the capability to make that library automatically link in when"
+ echo "*** you link to this library. But I can only do this if you have a"
+ echo "*** shared version of the library, which you do not appear to have"
+ echo "*** because the file extensions .$libext of this argument makes me believe"
+ echo "*** that it is just a static archive that I should not use here."
+ else
+ echo
+ $ECHO "*** Warning: Linking the shared library $output against the"
+ $ECHO "*** static library $deplib is not portable!"
+ deplibs="$deplib $deplibs"
+ fi
+ ;;
+ esac
+ continue
+ ;;
+ prog)
+ if test "$pass" != link; then
+ deplibs="$deplib $deplibs"
+ else
+ compile_deplibs="$deplib $compile_deplibs"
+ finalize_deplibs="$deplib $finalize_deplibs"
+ fi
+ continue
+ ;;
+ esac # linkmode
+ ;; # *.$libext
+ *.lo | *.$objext)
+ if test "$pass" = conv; then
+ deplibs="$deplib $deplibs"
+ elif test "$linkmode" = prog; then
+ if test "$pass" = dlpreopen || test "$dlopen_support" != yes || test "$build_libtool_libs" = no; then
+ # If there is no dlopen support or we're linking statically,
+ # we need to preload.
+ func_append newdlprefiles " $deplib"
+ compile_deplibs="$deplib $compile_deplibs"
+ finalize_deplibs="$deplib $finalize_deplibs"
+ else
+ func_append newdlfiles " $deplib"
+ fi
+ fi
+ continue
+ ;;
+ %DEPLIBS%)
+ alldeplibs=yes
+ continue
+ ;;
+ esac # case $deplib
+
+ if test "$found" = yes || test -f "$lib"; then :
+ else
+ func_fatal_error "cannot find the library \`$lib' or unhandled argument \`$deplib'"
+ fi
+
+ # Check to see that this really is a libtool archive.
+ func_lalib_unsafe_p "$lib" \
+ || func_fatal_error "\`$lib' is not a valid libtool archive"
+
+ func_dirname "$lib" "" "."
+ ladir="$func_dirname_result"
+
+ dlname=
+ dlopen=
+ dlpreopen=
+ libdir=
+ library_names=
+ old_library=
+ inherited_linker_flags=
+ # If the library was installed with an old release of libtool,
+ # it will not redefine variables installed, or shouldnotlink
+ installed=yes
+ shouldnotlink=no
+ avoidtemprpath=
+
+
+ # Read the .la file
+ func_source "$lib"
+
+ # Convert "-framework foo" to "foo.ltframework"
+ if test -n "$inherited_linker_flags"; then
+ tmp_inherited_linker_flags=`$ECHO "$inherited_linker_flags" | $SED 's/-framework \([^ $]*\)/\1.ltframework/g'`
+ for tmp_inherited_linker_flag in $tmp_inherited_linker_flags; do
+ case " $new_inherited_linker_flags " in
+ *" $tmp_inherited_linker_flag "*) ;;
+ *) func_append new_inherited_linker_flags " $tmp_inherited_linker_flag";;
+ esac
+ done
+ fi
+ dependency_libs=`$ECHO " $dependency_libs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'`
+ if test "$linkmode,$pass" = "lib,link" ||
+ test "$linkmode,$pass" = "prog,scan" ||
+ { test "$linkmode" != prog && test "$linkmode" != lib; }; then
+ test -n "$dlopen" && func_append dlfiles " $dlopen"
+ test -n "$dlpreopen" && func_append dlprefiles " $dlpreopen"
+ fi
+
+ if test "$pass" = conv; then
+ # Only check for convenience libraries
+ deplibs="$lib $deplibs"
+ if test -z "$libdir"; then
+ if test -z "$old_library"; then
+ func_fatal_error "cannot find name of link library for \`$lib'"
+ fi
+ # It is a libtool convenience library, so add in its objects.
+ func_append convenience " $ladir/$objdir/$old_library"
+ func_append old_convenience " $ladir/$objdir/$old_library"
+ elif test "$linkmode" != prog && test "$linkmode" != lib; then
+ func_fatal_error "\`$lib' is not a convenience library"
+ fi
+ tmp_libs=
+ for deplib in $dependency_libs; do
+ deplibs="$deplib $deplibs"
+ if $opt_preserve_dup_deps ; then
+ case "$tmp_libs " in
+ *" $deplib "*) func_append specialdeplibs " $deplib" ;;
+ esac
+ fi
+ func_append tmp_libs " $deplib"
+ done
+ continue
+ fi # $pass = conv
+
+
+ # Get the name of the library we link against.
+ linklib=
+ if test -n "$old_library" &&
+ { test "$prefer_static_libs" = yes ||
+ test "$prefer_static_libs,$installed" = "built,no"; }; then
+ linklib=$old_library
+ else
+ for l in $old_library $library_names; do
+ linklib="$l"
+ done
+ fi
+ if test -z "$linklib"; then
+ func_fatal_error "cannot find name of link library for \`$lib'"
+ fi
+
+ # This library was specified with -dlopen.
+ if test "$pass" = dlopen; then
+ if test -z "$libdir"; then
+ func_fatal_error "cannot -dlopen a convenience library: \`$lib'"
+ fi
+ if test -z "$dlname" ||
+ test "$dlopen_support" != yes ||
+ test "$build_libtool_libs" = no; then
+ # If there is no dlname, no dlopen support or we're linking
+ # statically, we need to preload. We also need to preload any
+ # dependent libraries so libltdl's deplib preloader doesn't
+ # bomb out in the load deplibs phase.
+ func_append dlprefiles " $lib $dependency_libs"
+ else
+ func_append newdlfiles " $lib"
+ fi
+ continue
+ fi # $pass = dlopen
+
+ # We need an absolute path.
+ case $ladir in
+ [\\/]* | [A-Za-z]:[\\/]*) abs_ladir="$ladir" ;;
+ *)
+ abs_ladir=`cd "$ladir" && pwd`
+ if test -z "$abs_ladir"; then
+ func_warning "cannot determine absolute directory name of \`$ladir'"
+ func_warning "passing it literally to the linker, although it might fail"
+ abs_ladir="$ladir"
+ fi
+ ;;
+ esac
+ func_basename "$lib"
+ laname="$func_basename_result"
+
+ # Find the relevant object directory and library name.
+ if test "X$installed" = Xyes; then
+ if test ! -f "$lt_sysroot$libdir/$linklib" && test -f "$abs_ladir/$linklib"; then
+ func_warning "library \`$lib' was moved."
+ dir="$ladir"
+ absdir="$abs_ladir"
+ libdir="$abs_ladir"
+ else
+ dir="$lt_sysroot$libdir"
+ absdir="$lt_sysroot$libdir"
+ fi
+ test "X$hardcode_automatic" = Xyes && avoidtemprpath=yes
+ else
+ if test ! -f "$ladir/$objdir/$linklib" && test -f "$abs_ladir/$linklib"; then
+ dir="$ladir"
+ absdir="$abs_ladir"
+ # Remove this search path later
+ func_append notinst_path " $abs_ladir"
+ else
+ dir="$ladir/$objdir"
+ absdir="$abs_ladir/$objdir"
+ # Remove this search path later
+ func_append notinst_path " $abs_ladir"
+ fi
+ fi # $installed = yes
+ func_stripname 'lib' '.la' "$laname"
+ name=$func_stripname_result
+
+ # This library was specified with -dlpreopen.
+ if test "$pass" = dlpreopen; then
+ if test -z "$libdir" && test "$linkmode" = prog; then
+ func_fatal_error "only libraries may -dlpreopen a convenience library: \`$lib'"
+ fi
+ case "$host" in
+ # special handling for platforms with PE-DLLs.
+ *cygwin* | *mingw* | *cegcc* )
+ # Linker will automatically link against shared library if both
+ # static and shared are present. Therefore, ensure we extract
+ # symbols from the import library if a shared library is present
+ # (otherwise, the dlopen module name will be incorrect). We do
+ # this by putting the import library name into $newdlprefiles.
+ # We recover the dlopen module name by 'saving' the la file
+ # name in a special purpose variable, and (later) extracting the
+ # dlname from the la file.
+ if test -n "$dlname"; then
+ func_tr_sh "$dir/$linklib"
+ eval "libfile_$func_tr_sh_result=\$abs_ladir/\$laname"
+ func_append newdlprefiles " $dir/$linklib"
+ else
+ func_append newdlprefiles " $dir/$old_library"
+ # Keep a list of preopened convenience libraries to check
+ # that they are being used correctly in the link pass.
+ test -z "$libdir" && \
+ func_append dlpreconveniencelibs " $dir/$old_library"
+ fi
+ ;;
+ * )
+ # Prefer using a static library (so that no silly _DYNAMIC symbols
+ # are required to link).
+ if test -n "$old_library"; then
+ func_append newdlprefiles " $dir/$old_library"
+ # Keep a list of preopened convenience libraries to check
+ # that they are being used correctly in the link pass.
+ test -z "$libdir" && \
+ func_append dlpreconveniencelibs " $dir/$old_library"
+ # Otherwise, use the dlname, so that lt_dlopen finds it.
+ elif test -n "$dlname"; then
+ func_append newdlprefiles " $dir/$dlname"
+ else
+ func_append newdlprefiles " $dir/$linklib"
+ fi
+ ;;
+ esac
+ fi # $pass = dlpreopen
+
+ if test -z "$libdir"; then
+ # Link the convenience library
+ if test "$linkmode" = lib; then
+ deplibs="$dir/$old_library $deplibs"
+ elif test "$linkmode,$pass" = "prog,link"; then
+ compile_deplibs="$dir/$old_library $compile_deplibs"
+ finalize_deplibs="$dir/$old_library $finalize_deplibs"
+ else
+ deplibs="$lib $deplibs" # used for prog,scan pass
+ fi
+ continue
+ fi
+
+
+ if test "$linkmode" = prog && test "$pass" != link; then
+ func_append newlib_search_path " $ladir"
+ deplibs="$lib $deplibs"
+
+ linkalldeplibs=no
+ if test "$link_all_deplibs" != no || test -z "$library_names" ||
+ test "$build_libtool_libs" = no; then
+ linkalldeplibs=yes
+ fi
+
+ tmp_libs=
+ for deplib in $dependency_libs; do
+ case $deplib in
+ -L*) func_stripname '-L' '' "$deplib"
+ func_resolve_sysroot "$func_stripname_result"
+ func_append newlib_search_path " $func_resolve_sysroot_result"
+ ;;
+ esac
+ # Need to link against all dependency_libs?
+ if test "$linkalldeplibs" = yes; then
+ deplibs="$deplib $deplibs"
+ else
+ # Need to hardcode shared library paths
+ # or/and link against static libraries
+ newdependency_libs="$deplib $newdependency_libs"
+ fi
+ if $opt_preserve_dup_deps ; then
+ case "$tmp_libs " in
+ *" $deplib "*) func_append specialdeplibs " $deplib" ;;
+ esac
+ fi
+ func_append tmp_libs " $deplib"
+ done # for deplib
+ continue
+ fi # $linkmode = prog...
+
+ if test "$linkmode,$pass" = "prog,link"; then
+ if test -n "$library_names" &&
+ { { test "$prefer_static_libs" = no ||
+ test "$prefer_static_libs,$installed" = "built,yes"; } ||
+ test -z "$old_library"; }; then
+ # We need to hardcode the library path
+ if test -n "$shlibpath_var" && test -z "$avoidtemprpath" ; then
+ # Make sure the rpath contains only unique directories.
+ case "$temp_rpath:" in
+ *"$absdir:"*) ;;
+ *) func_append temp_rpath "$absdir:" ;;
+ esac
+ fi
+
+ # Hardcode the library path.
+ # Skip directories that are in the system default run-time
+ # search path.
+ case " $sys_lib_dlsearch_path " in
+ *" $absdir "*) ;;
+ *)
+ case "$compile_rpath " in
+ *" $absdir "*) ;;
+ *) func_append compile_rpath " $absdir" ;;
+ esac
+ ;;
+ esac
+ case " $sys_lib_dlsearch_path " in
+ *" $libdir "*) ;;
+ *)
+ case "$finalize_rpath " in
+ *" $libdir "*) ;;
+ *) func_append finalize_rpath " $libdir" ;;
+ esac
+ ;;
+ esac
+ fi # $linkmode,$pass = prog,link...
+
+ if test "$alldeplibs" = yes &&
+ { test "$deplibs_check_method" = pass_all ||
+ { test "$build_libtool_libs" = yes &&
+ test -n "$library_names"; }; }; then
+ # We only need to search for static libraries
+ continue
+ fi
+ fi
+
+ link_static=no # Whether the deplib will be linked statically
+ use_static_libs=$prefer_static_libs
+ if test "$use_static_libs" = built && test "$installed" = yes; then
+ use_static_libs=no
+ fi
+ if test -n "$library_names" &&
+ { test "$use_static_libs" = no || test -z "$old_library"; }; then
+ case $host in
+ *cygwin* | *mingw* | *cegcc*)
+ # No point in relinking DLLs because paths are not encoded
+ func_append notinst_deplibs " $lib"
+ need_relink=no
+ ;;
+ *)
+ if test "$installed" = no; then
+ func_append notinst_deplibs " $lib"
+ need_relink=yes
+ fi
+ ;;
+ esac
+ # This is a shared library
+
+ # Warn about portability, can't link against -module's on some
+ # systems (darwin). Don't bleat about dlopened modules though!
+ dlopenmodule=""
+ for dlpremoduletest in $dlprefiles; do
+ if test "X$dlpremoduletest" = "X$lib"; then
+ dlopenmodule="$dlpremoduletest"
+ break
+ fi
+ done
+ if test -z "$dlopenmodule" && test "$shouldnotlink" = yes && test "$pass" = link; then
+ echo
+ if test "$linkmode" = prog; then
+ $ECHO "*** Warning: Linking the executable $output against the loadable module"
+ else
+ $ECHO "*** Warning: Linking the shared library $output against the loadable module"
+ fi
+ $ECHO "*** $linklib is not portable!"
+ fi
+ if test "$linkmode" = lib &&
+ test "$hardcode_into_libs" = yes; then
+ # Hardcode the library path.
+ # Skip directories that are in the system default run-time
+ # search path.
+ case " $sys_lib_dlsearch_path " in
+ *" $absdir "*) ;;
+ *)
+ case "$compile_rpath " in
+ *" $absdir "*) ;;
+ *) func_append compile_rpath " $absdir" ;;
+ esac
+ ;;
+ esac
+ case " $sys_lib_dlsearch_path " in
+ *" $libdir "*) ;;
+ *)
+ case "$finalize_rpath " in
+ *" $libdir "*) ;;
+ *) func_append finalize_rpath " $libdir" ;;
+ esac
+ ;;
+ esac
+ fi
+
+ if test -n "$old_archive_from_expsyms_cmds"; then
+ # figure out the soname
+ set dummy $library_names
+ shift
+ realname="$1"
+ shift
+ libname=`eval "\\$ECHO \"$libname_spec\""`
+ # use dlname if we got it. it's perfectly good, no?
+ if test -n "$dlname"; then
+ soname="$dlname"
+ elif test -n "$soname_spec"; then
+ # bleh windows
+ case $host in
+ *cygwin* | mingw* | *cegcc*)
+ func_arith $current - $age
+ major=$func_arith_result
+ versuffix="-$major"
+ ;;
+ esac
+ eval soname=\"$soname_spec\"
+ else
+ soname="$realname"
+ fi
+
+ # Make a new name for the extract_expsyms_cmds to use
+ soroot="$soname"
+ func_basename "$soroot"
+ soname="$func_basename_result"
+ func_stripname 'lib' '.dll' "$soname"
+ newlib=libimp-$func_stripname_result.a
+
+ # If the library has no export list, then create one now
+ if test -f "$output_objdir/$soname-def"; then :
+ else
+ func_verbose "extracting exported symbol list from \`$soname'"
+ func_execute_cmds "$extract_expsyms_cmds" 'exit $?'
+ fi
+
+ # Create $newlib
+ if test -f "$output_objdir/$newlib"; then :; else
+ func_verbose "generating import library for \`$soname'"
+ func_execute_cmds "$old_archive_from_expsyms_cmds" 'exit $?'
+ fi
+ # make sure the library variables are pointing to the new library
+ dir=$output_objdir
+ linklib=$newlib
+ fi # test -n "$old_archive_from_expsyms_cmds"
+
+ if test "$linkmode" = prog || test "$opt_mode" != relink; then
+ add_shlibpath=
+ add_dir=
+ add=
+ lib_linked=yes
+ case $hardcode_action in
+ immediate | unsupported)
+ if test "$hardcode_direct" = no; then
+ add="$dir/$linklib"
+ case $host in
+ *-*-sco3.2v5.0.[024]*) add_dir="-L$dir" ;;
+ *-*-sysv4*uw2*) add_dir="-L$dir" ;;
+ *-*-sysv5OpenUNIX* | *-*-sysv5UnixWare7.[01].[10]* | \
+ *-*-unixware7*) add_dir="-L$dir" ;;
+ *-*-darwin* )
+ # if the lib is a (non-dlopened) module then we can not
+ # link against it, someone is ignoring the earlier warnings
+ if /usr/bin/file -L $add 2> /dev/null |
+ $GREP ": [^:]* bundle" >/dev/null ; then
+ if test "X$dlopenmodule" != "X$lib"; then
+ $ECHO "*** Warning: lib $linklib is a module, not a shared library"
+ if test -z "$old_library" ; then
+ echo
+ echo "*** And there doesn't seem to be a static archive available"
+ echo "*** The link will probably fail, sorry"
+ else
+ add="$dir/$old_library"
+ fi
+ elif test -n "$old_library"; then
+ add="$dir/$old_library"
+ fi
+ fi
+ esac
+ elif test "$hardcode_minus_L" = no; then
+ case $host in
+ *-*-sunos*) add_shlibpath="$dir" ;;
+ esac
+ add_dir="-L$dir"
+ add="-l$name"
+ elif test "$hardcode_shlibpath_var" = no; then
+ add_shlibpath="$dir"
+ add="-l$name"
+ else
+ lib_linked=no
+ fi
+ ;;
+ relink)
+ if test "$hardcode_direct" = yes &&
+ test "$hardcode_direct_absolute" = no; then
+ add="$dir/$linklib"
+ elif test "$hardcode_minus_L" = yes; then
+ add_dir="-L$dir"
+ # Try looking first in the location we're being installed to.
+ if test -n "$inst_prefix_dir"; then
+ case $libdir in
+ [\\/]*)
+ func_append add_dir " -L$inst_prefix_dir$libdir"
+ ;;
+ esac
+ fi
+ add="-l$name"
+ elif test "$hardcode_shlibpath_var" = yes; then
+ add_shlibpath="$dir"
+ add="-l$name"
+ else
+ lib_linked=no
+ fi
+ ;;
+ *) lib_linked=no ;;
+ esac
+
+ if test "$lib_linked" != yes; then
+ func_fatal_configuration "unsupported hardcode properties"
+ fi
+
+ if test -n "$add_shlibpath"; then
+ case :$compile_shlibpath: in
+ *":$add_shlibpath:"*) ;;
+ *) func_append compile_shlibpath "$add_shlibpath:" ;;
+ esac
+ fi
+ if test "$linkmode" = prog; then
+ test -n "$add_dir" && compile_deplibs="$add_dir $compile_deplibs"
+ test -n "$add" && compile_deplibs="$add $compile_deplibs"
+ else
+ test -n "$add_dir" && deplibs="$add_dir $deplibs"
+ test -n "$add" && deplibs="$add $deplibs"
+ if test "$hardcode_direct" != yes &&
+ test "$hardcode_minus_L" != yes &&
+ test "$hardcode_shlibpath_var" = yes; then
+ case :$finalize_shlibpath: in
+ *":$libdir:"*) ;;
+ *) func_append finalize_shlibpath "$libdir:" ;;
+ esac
+ fi
+ fi
+ fi
+
+ if test "$linkmode" = prog || test "$opt_mode" = relink; then
+ add_shlibpath=
+ add_dir=
+ add=
+ # Finalize command for both is simple: just hardcode it.
+ if test "$hardcode_direct" = yes &&
+ test "$hardcode_direct_absolute" = no; then
+ add="$libdir/$linklib"
+ elif test "$hardcode_minus_L" = yes; then
+ add_dir="-L$libdir"
+ add="-l$name"
+ elif test "$hardcode_shlibpath_var" = yes; then
+ case :$finalize_shlibpath: in
+ *":$libdir:"*) ;;
+ *) func_append finalize_shlibpath "$libdir:" ;;
+ esac
+ add="-l$name"
+ elif test "$hardcode_automatic" = yes; then
+ if test -n "$inst_prefix_dir" &&
+ test -f "$inst_prefix_dir$libdir/$linklib" ; then
+ add="$inst_prefix_dir$libdir/$linklib"
+ else
+ add="$libdir/$linklib"
+ fi
+ else
+ # We cannot seem to hardcode it, guess we'll fake it.
+ add_dir="-L$libdir"
+ # Try looking first in the location we're being installed to.
+ if test -n "$inst_prefix_dir"; then
+ case $libdir in
+ [\\/]*)
+ func_append add_dir " -L$inst_prefix_dir$libdir"
+ ;;
+ esac
+ fi
+ add="-l$name"
+ fi
+
+ if test "$linkmode" = prog; then
+ test -n "$add_dir" && finalize_deplibs="$add_dir $finalize_deplibs"
+ test -n "$add" && finalize_deplibs="$add $finalize_deplibs"
+ else
+ test -n "$add_dir" && deplibs="$add_dir $deplibs"
+ test -n "$add" && deplibs="$add $deplibs"
+ fi
+ fi
+ elif test "$linkmode" = prog; then
+ # Here we assume that one of hardcode_direct or hardcode_minus_L
+ # is not unsupported. This is valid on all known static and
+ # shared platforms.
+ if test "$hardcode_direct" != unsupported; then
+ test -n "$old_library" && linklib="$old_library"
+ compile_deplibs="$dir/$linklib $compile_deplibs"
+ finalize_deplibs="$dir/$linklib $finalize_deplibs"
+ else
+ compile_deplibs="-l$name -L$dir $compile_deplibs"
+ finalize_deplibs="-l$name -L$dir $finalize_deplibs"
+ fi
+ elif test "$build_libtool_libs" = yes; then
+ # Not a shared library
+ if test "$deplibs_check_method" != pass_all; then
+ # We're trying link a shared library against a static one
+ # but the system doesn't support it.
+
+ # Just print a warning and add the library to dependency_libs so
+ # that the program can be linked against the static library.
+ echo
+ $ECHO "*** Warning: This system can not link to static lib archive $lib."
+ echo "*** I have the capability to make that library automatically link in when"
+ echo "*** you link to this library. But I can only do this if you have a"
+ echo "*** shared version of the library, which you do not appear to have."
+ if test "$module" = yes; then
+ echo "*** But as you try to build a module library, libtool will still create "
+ echo "*** a static module, that should work as long as the dlopening application"
+ echo "*** is linked with the -dlopen flag to resolve symbols at runtime."
+ if test -z "$global_symbol_pipe"; then
+ echo
+ echo "*** However, this would only work if libtool was able to extract symbol"
+ echo "*** lists from a program, using \`nm' or equivalent, but libtool could"
+ echo "*** not find such a program. So, this module is probably useless."
+ echo "*** \`nm' from GNU binutils and a full rebuild may help."
+ fi
+ if test "$build_old_libs" = no; then
+ build_libtool_libs=module
+ build_old_libs=yes
+ else
+ build_libtool_libs=no
+ fi
+ fi
+ else
+ deplibs="$dir/$old_library $deplibs"
+ link_static=yes
+ fi
+ fi # link shared/static library?
+
+ if test "$linkmode" = lib; then
+ if test -n "$dependency_libs" &&
+ { test "$hardcode_into_libs" != yes ||
+ test "$build_old_libs" = yes ||
+ test "$link_static" = yes; }; then
+ # Extract -R from dependency_libs
+ temp_deplibs=
+ for libdir in $dependency_libs; do
+ case $libdir in
+ -R*) func_stripname '-R' '' "$libdir"
+ temp_xrpath=$func_stripname_result
+ case " $xrpath " in
+ *" $temp_xrpath "*) ;;
+ *) func_append xrpath " $temp_xrpath";;
+ esac;;
+ *) func_append temp_deplibs " $libdir";;
+ esac
+ done
+ dependency_libs="$temp_deplibs"
+ fi
+
+ func_append newlib_search_path " $absdir"
+ # Link against this library
+ test "$link_static" = no && newdependency_libs="$abs_ladir/$laname $newdependency_libs"
+ # ... and its dependency_libs
+ tmp_libs=
+ for deplib in $dependency_libs; do
+ newdependency_libs="$deplib $newdependency_libs"
+ case $deplib in
+ -L*) func_stripname '-L' '' "$deplib"
+ func_resolve_sysroot "$func_stripname_result";;
+ *) func_resolve_sysroot "$deplib" ;;
+ esac
+ if $opt_preserve_dup_deps ; then
+ case "$tmp_libs " in
+ *" $func_resolve_sysroot_result "*)
+ func_append specialdeplibs " $func_resolve_sysroot_result" ;;
+ esac
+ fi
+ func_append tmp_libs " $func_resolve_sysroot_result"
+ done
+
+ if test "$link_all_deplibs" != no; then
+ # Add the search paths of all dependency libraries
+ for deplib in $dependency_libs; do
+ path=
+ case $deplib in
+ -L*) path="$deplib" ;;
+ *.la)
+ func_resolve_sysroot "$deplib"
+ deplib=$func_resolve_sysroot_result
+ func_dirname "$deplib" "" "."
+ dir=$func_dirname_result
+ # We need an absolute path.
+ case $dir in
+ [\\/]* | [A-Za-z]:[\\/]*) absdir="$dir" ;;
+ *)
+ absdir=`cd "$dir" && pwd`
+ if test -z "$absdir"; then
+ func_warning "cannot determine absolute directory name of \`$dir'"
+ absdir="$dir"
+ fi
+ ;;
+ esac
+ if $GREP "^installed=no" $deplib > /dev/null; then
+ case $host in
+ *-*-darwin*)
+ depdepl=
+ eval deplibrary_names=`${SED} -n -e 's/^library_names=\(.*\)$/\1/p' $deplib`
+ if test -n "$deplibrary_names" ; then
+ for tmp in $deplibrary_names ; do
+ depdepl=$tmp
+ done
+ if test -f "$absdir/$objdir/$depdepl" ; then
+ depdepl="$absdir/$objdir/$depdepl"
+ darwin_install_name=`${OTOOL} -L $depdepl | awk '{if (NR == 2) {print $1;exit}}'`
+ if test -z "$darwin_install_name"; then
+ darwin_install_name=`${OTOOL64} -L $depdepl | awk '{if (NR == 2) {print $1;exit}}'`
+ fi
+ func_append compiler_flags " ${wl}-dylib_file ${wl}${darwin_install_name}:${depdepl}"
+ func_append linker_flags " -dylib_file ${darwin_install_name}:${depdepl}"
+ path=
+ fi
+ fi
+ ;;
+ *)
+ path="-L$absdir/$objdir"
+ ;;
+ esac
+ else
+ eval libdir=`${SED} -n -e 's/^libdir=\(.*\)$/\1/p' $deplib`
+ test -z "$libdir" && \
+ func_fatal_error "\`$deplib' is not a valid libtool archive"
+ test "$absdir" != "$libdir" && \
+ func_warning "\`$deplib' seems to be moved"
+
+ path="-L$absdir"
+ fi
+ ;;
+ esac
+ case " $deplibs " in
+ *" $path "*) ;;
+ *) deplibs="$path $deplibs" ;;
+ esac
+ done
+ fi # link_all_deplibs != no
+ fi # linkmode = lib
+ done # for deplib in $libs
+ if test "$pass" = link; then
+ if test "$linkmode" = "prog"; then
+ compile_deplibs="$new_inherited_linker_flags $compile_deplibs"
+ finalize_deplibs="$new_inherited_linker_flags $finalize_deplibs"
+ else
+ compiler_flags="$compiler_flags "`$ECHO " $new_inherited_linker_flags" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'`
+ fi
+ fi
+ dependency_libs="$newdependency_libs"
+ if test "$pass" = dlpreopen; then
+ # Link the dlpreopened libraries before other libraries
+ for deplib in $save_deplibs; do
+ deplibs="$deplib $deplibs"
+ done
+ fi
+ if test "$pass" != dlopen; then
+ if test "$pass" != conv; then
+ # Make sure lib_search_path contains only unique directories.
+ lib_search_path=
+ for dir in $newlib_search_path; do
+ case "$lib_search_path " in
+ *" $dir "*) ;;
+ *) func_append lib_search_path " $dir" ;;
+ esac
+ done
+ newlib_search_path=
+ fi
+
+ if test "$linkmode,$pass" != "prog,link"; then
+ vars="deplibs"
+ else
+ vars="compile_deplibs finalize_deplibs"
+ fi
+ for var in $vars dependency_libs; do
+ # Add libraries to $var in reverse order
+ eval tmp_libs=\"\$$var\"
+ new_libs=
+ for deplib in $tmp_libs; do
+ # FIXME: Pedantically, this is the right thing to do, so
+ # that some nasty dependency loop isn't accidentally
+ # broken:
+ #new_libs="$deplib $new_libs"
+ # Pragmatically, this seems to cause very few problems in
+ # practice:
+ case $deplib in
+ -L*) new_libs="$deplib $new_libs" ;;
+ -R*) ;;
+ *)
+ # And here is the reason: when a library appears more
+ # than once as an explicit dependence of a library, or
+ # is implicitly linked in more than once by the
+ # compiler, it is considered special, and multiple
+ # occurrences thereof are not removed. Compare this
+ # with having the same library being listed as a
+ # dependency of multiple other libraries: in this case,
+ # we know (pedantically, we assume) the library does not
+ # need to be listed more than once, so we keep only the
+ # last copy. This is not always right, but it is rare
+ # enough that we require users that really mean to play
+ # such unportable linking tricks to link the library
+ # using -Wl,-lname, so that libtool does not consider it
+ # for duplicate removal.
+ case " $specialdeplibs " in
+ *" $deplib "*) new_libs="$deplib $new_libs" ;;
+ *)
+ case " $new_libs " in
+ *" $deplib "*) ;;
+ *) new_libs="$deplib $new_libs" ;;
+ esac
+ ;;
+ esac
+ ;;
+ esac
+ done
+ tmp_libs=
+ for deplib in $new_libs; do
+ case $deplib in
+ -L*)
+ case " $tmp_libs " in
+ *" $deplib "*) ;;
+ *) func_append tmp_libs " $deplib" ;;
+ esac
+ ;;
+ *) func_append tmp_libs " $deplib" ;;
+ esac
+ done
+ eval $var=\"$tmp_libs\"
+ done # for var
+ fi
+ # Last step: remove runtime libs from dependency_libs
+ # (they stay in deplibs)
+ tmp_libs=
+ for i in $dependency_libs ; do
+ case " $predeps $postdeps $compiler_lib_search_path " in
+ *" $i "*)
+ i=""
+ ;;
+ esac
+ if test -n "$i" ; then
+ func_append tmp_libs " $i"
+ fi
+ done
+ dependency_libs=$tmp_libs
+ done # for pass
+ if test "$linkmode" = prog; then
+ dlfiles="$newdlfiles"
+ fi
+ if test "$linkmode" = prog || test "$linkmode" = lib; then
+ dlprefiles="$newdlprefiles"
+ fi
+
+ case $linkmode in
+ oldlib)
+ if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then
+ func_warning "\`-dlopen' is ignored for archives"
+ fi
+
+ case " $deplibs" in
+ *\ -l* | *\ -L*)
+ func_warning "\`-l' and \`-L' are ignored for archives" ;;
+ esac
+
+ test -n "$rpath" && \
+ func_warning "\`-rpath' is ignored for archives"
+
+ test -n "$xrpath" && \
+ func_warning "\`-R' is ignored for archives"
+
+ test -n "$vinfo" && \
+ func_warning "\`-version-info/-version-number' is ignored for archives"
+
+ test -n "$release" && \
+ func_warning "\`-release' is ignored for archives"
+
+ test -n "$export_symbols$export_symbols_regex" && \
+ func_warning "\`-export-symbols' is ignored for archives"
+
+ # Now set the variables for building old libraries.
+ build_libtool_libs=no
+ oldlibs="$output"
+ func_append objs "$old_deplibs"
+ ;;
+
+ lib)
+ # Make sure we only generate libraries of the form `libNAME.la'.
+ case $outputname in
+ lib*)
+ func_stripname 'lib' '.la' "$outputname"
+ name=$func_stripname_result
+ eval shared_ext=\"$shrext_cmds\"
+ eval libname=\"$libname_spec\"
+ ;;
+ *)
+ test "$module" = no && \
+ func_fatal_help "libtool library \`$output' must begin with \`lib'"
+
+ if test "$need_lib_prefix" != no; then
+ # Add the "lib" prefix for modules if required
+ func_stripname '' '.la' "$outputname"
+ name=$func_stripname_result
+ eval shared_ext=\"$shrext_cmds\"
+ eval libname=\"$libname_spec\"
+ else
+ func_stripname '' '.la' "$outputname"
+ libname=$func_stripname_result
+ fi
+ ;;
+ esac
+
+ if test -n "$objs"; then
+ if test "$deplibs_check_method" != pass_all; then
+ func_fatal_error "cannot build libtool library \`$output' from non-libtool objects on this host:$objs"
+ else
+ echo
+ $ECHO "*** Warning: Linking the shared library $output against the non-libtool"
+ $ECHO "*** objects $objs is not portable!"
+ func_append libobjs " $objs"
+ fi
+ fi
+
+ test "$dlself" != no && \
+ func_warning "\`-dlopen self' is ignored for libtool libraries"
+
+ set dummy $rpath
+ shift
+ test "$#" -gt 1 && \
+ func_warning "ignoring multiple \`-rpath's for a libtool library"
+
+ install_libdir="$1"
+
+ oldlibs=
+ if test -z "$rpath"; then
+ if test "$build_libtool_libs" = yes; then
+ # Building a libtool convenience library.
+ # Some compilers have problems with a `.al' extension so
+ # convenience libraries should have the same extension an
+ # archive normally would.
+ oldlibs="$output_objdir/$libname.$libext $oldlibs"
+ build_libtool_libs=convenience
+ build_old_libs=yes
+ fi
+
+ test -n "$vinfo" && \
+ func_warning "\`-version-info/-version-number' is ignored for convenience libraries"
+
+ test -n "$release" && \
+ func_warning "\`-release' is ignored for convenience libraries"
+ else
+
+ # Parse the version information argument.
+ save_ifs="$IFS"; IFS=':'
+ set dummy $vinfo 0 0 0
+ shift
+ IFS="$save_ifs"
+
+ test -n "$7" && \
+ func_fatal_help "too many parameters to \`-version-info'"
+
+ # convert absolute version numbers to libtool ages
+ # this retains compatibility with .la files and attempts
+ # to make the code below a bit more comprehensible
+
+ case $vinfo_number in
+ yes)
+ number_major="$1"
+ number_minor="$2"
+ number_revision="$3"
+ #
+ # There are really only two kinds -- those that
+ # use the current revision as the major version
+ # and those that subtract age and use age as
+ # a minor version. But, then there is irix
+ # which has an extra 1 added just for fun
+ #
+ case $version_type in
+ darwin|linux|osf|windows|none)
+ func_arith $number_major + $number_minor
+ current=$func_arith_result
+ age="$number_minor"
+ revision="$number_revision"
+ ;;
+ freebsd-aout|freebsd-elf|qnx|sunos)
+ current="$number_major"
+ revision="$number_minor"
+ age="0"
+ ;;
+ irix|nonstopux)
+ func_arith $number_major + $number_minor
+ current=$func_arith_result
+ age="$number_minor"
+ revision="$number_minor"
+ lt_irix_increment=no
+ ;;
+ esac
+ ;;
+ no)
+ current="$1"
+ revision="$2"
+ age="$3"
+ ;;
+ esac
+
+ # Check that each of the things are valid numbers.
+ case $current in
+ 0|[1-9]|[1-9][0-9]|[1-9][0-9][0-9]|[1-9][0-9][0-9][0-9]|[1-9][0-9][0-9][0-9][0-9]) ;;
+ *)
+ func_error "CURRENT \`$current' must be a nonnegative integer"
+ func_fatal_error "\`$vinfo' is not valid version information"
+ ;;
+ esac
+
+ case $revision in
+ 0|[1-9]|[1-9][0-9]|[1-9][0-9][0-9]|[1-9][0-9][0-9][0-9]|[1-9][0-9][0-9][0-9][0-9]) ;;
+ *)
+ func_error "REVISION \`$revision' must be a nonnegative integer"
+ func_fatal_error "\`$vinfo' is not valid version information"
+ ;;
+ esac
+
+ case $age in
+ 0|[1-9]|[1-9][0-9]|[1-9][0-9][0-9]|[1-9][0-9][0-9][0-9]|[1-9][0-9][0-9][0-9][0-9]) ;;
+ *)
+ func_error "AGE \`$age' must be a nonnegative integer"
+ func_fatal_error "\`$vinfo' is not valid version information"
+ ;;
+ esac
+
+ if test "$age" -gt "$current"; then
+ func_error "AGE \`$age' is greater than the current interface number \`$current'"
+ func_fatal_error "\`$vinfo' is not valid version information"
+ fi
+
+ # Calculate the version variables.
+ major=
+ versuffix=
+ verstring=
+ case $version_type in
+ none) ;;
+
+ darwin)
+ # Like Linux, but with the current version available in
+ # verstring for coding it into the library header
+ func_arith $current - $age
+ major=.$func_arith_result
+ versuffix="$major.$age.$revision"
+ # Darwin ld doesn't like 0 for these options...
+ func_arith $current + 1
+ minor_current=$func_arith_result
+ xlcverstring="${wl}-compatibility_version ${wl}$minor_current ${wl}-current_version ${wl}$minor_current.$revision"
+ verstring="-compatibility_version $minor_current -current_version $minor_current.$revision"
+ ;;
+
+ freebsd-aout)
+ major=".$current"
+ versuffix=".$current.$revision";
+ ;;
+
+ freebsd-elf)
+ major=".$current"
+ versuffix=".$current"
+ ;;
+
+ irix | nonstopux)
+ if test "X$lt_irix_increment" = "Xno"; then
+ func_arith $current - $age
+ else
+ func_arith $current - $age + 1
+ fi
+ major=$func_arith_result
+
+ case $version_type in
+ nonstopux) verstring_prefix=nonstopux ;;
+ *) verstring_prefix=sgi ;;
+ esac
+ verstring="$verstring_prefix$major.$revision"
+
+ # Add in all the interfaces that we are compatible with.
+ loop=$revision
+ while test "$loop" -ne 0; do
+ func_arith $revision - $loop
+ iface=$func_arith_result
+ func_arith $loop - 1
+ loop=$func_arith_result
+ verstring="$verstring_prefix$major.$iface:$verstring"
+ done
+
+ # Before this point, $major must not contain `.'.
+ major=.$major
+ versuffix="$major.$revision"
+ ;;
+
+ linux)
+ func_arith $current - $age
+ major=.$func_arith_result
+ versuffix="$major.$age.$revision"
+ ;;
+
+ osf)
+ func_arith $current - $age
+ major=.$func_arith_result
+ versuffix=".$current.$age.$revision"
+ verstring="$current.$age.$revision"
+
+ # Add in all the interfaces that we are compatible with.
+ loop=$age
+ while test "$loop" -ne 0; do
+ func_arith $current - $loop
+ iface=$func_arith_result
+ func_arith $loop - 1
+ loop=$func_arith_result
+ verstring="$verstring:${iface}.0"
+ done
+
+ # Make executables depend on our current version.
+ func_append verstring ":${current}.0"
+ ;;
+
+ qnx)
+ major=".$current"
+ versuffix=".$current"
+ ;;
+
+ sunos)
+ major=".$current"
+ versuffix=".$current.$revision"
+ ;;
+
+ windows)
+ # Use '-' rather than '.', since we only want one
+ # extension on DOS 8.3 filesystems.
+ func_arith $current - $age
+ major=$func_arith_result
+ versuffix="-$major"
+ ;;
+
+ *)
+ func_fatal_configuration "unknown library version type \`$version_type'"
+ ;;
+ esac
+
+ # Clear the version info if we defaulted, and they specified a release.
+ if test -z "$vinfo" && test -n "$release"; then
+ major=
+ case $version_type in
+ darwin)
+ # we can't check for "0.0" in archive_cmds due to quoting
+ # problems, so we reset it completely
+ verstring=
+ ;;
+ *)
+ verstring="0.0"
+ ;;
+ esac
+ if test "$need_version" = no; then
+ versuffix=
+ else
+ versuffix=".0.0"
+ fi
+ fi
+
+ # Remove version info from name if versioning should be avoided
+ if test "$avoid_version" = yes && test "$need_version" = no; then
+ major=
+ versuffix=
+ verstring=""
+ fi
+
+ # Check to see if the archive will have undefined symbols.
+ if test "$allow_undefined" = yes; then
+ if test "$allow_undefined_flag" = unsupported; then
+ func_warning "undefined symbols not allowed in $host shared libraries"
+ build_libtool_libs=no
+ build_old_libs=yes
+ fi
+ else
+ # Don't allow undefined symbols.
+ allow_undefined_flag="$no_undefined_flag"
+ fi
+
+ fi
+
+ func_generate_dlsyms "$libname" "$libname" "yes"
+ func_append libobjs " $symfileobj"
+ test "X$libobjs" = "X " && libobjs=
+
+ if test "$opt_mode" != relink; then
+ # Remove our outputs, but don't remove object files since they
+ # may have been created when compiling PIC objects.
+ removelist=
+ tempremovelist=`$ECHO "$output_objdir/*"`
+ for p in $tempremovelist; do
+ case $p in
+ *.$objext | *.gcno)
+ ;;
+ $output_objdir/$outputname | $output_objdir/$libname.* | $output_objdir/${libname}${release}.*)
+ if test "X$precious_files_regex" != "X"; then
+ if $ECHO "$p" | $EGREP -e "$precious_files_regex" >/dev/null 2>&1
+ then
+ continue
+ fi
+ fi
+ func_append removelist " $p"
+ ;;
+ *) ;;
+ esac
+ done
+ test -n "$removelist" && \
+ func_show_eval "${RM}r \$removelist"
+ fi
+
+ # Now set the variables for building old libraries.
+ if test "$build_old_libs" = yes && test "$build_libtool_libs" != convenience ; then
+ func_append oldlibs " $output_objdir/$libname.$libext"
+
+ # Transform .lo files to .o files.
+ oldobjs="$objs "`$ECHO "$libobjs" | $SP2NL | $SED "/\.${libext}$/d; $lo2o" | $NL2SP`
+ fi
+
+ # Eliminate all temporary directories.
+ #for path in $notinst_path; do
+ # lib_search_path=`$ECHO "$lib_search_path " | $SED "s% $path % %g"`
+ # deplibs=`$ECHO "$deplibs " | $SED "s% -L$path % %g"`
+ # dependency_libs=`$ECHO "$dependency_libs " | $SED "s% -L$path % %g"`
+ #done
+
+ if test -n "$xrpath"; then
+ # If the user specified any rpath flags, then add them.
+ temp_xrpath=
+ for libdir in $xrpath; do
+ func_replace_sysroot "$libdir"
+ func_append temp_xrpath " -R$func_replace_sysroot_result"
+ case "$finalize_rpath " in
+ *" $libdir "*) ;;
+ *) func_append finalize_rpath " $libdir" ;;
+ esac
+ done
+ if test "$hardcode_into_libs" != yes || test "$build_old_libs" = yes; then
+ dependency_libs="$temp_xrpath $dependency_libs"
+ fi
+ fi
+
+ # Make sure dlfiles contains only unique files that won't be dlpreopened
+ old_dlfiles="$dlfiles"
+ dlfiles=
+ for lib in $old_dlfiles; do
+ case " $dlprefiles $dlfiles " in
+ *" $lib "*) ;;
+ *) func_append dlfiles " $lib" ;;
+ esac
+ done
+
+ # Make sure dlprefiles contains only unique files
+ old_dlprefiles="$dlprefiles"
+ dlprefiles=
+ for lib in $old_dlprefiles; do
+ case "$dlprefiles " in
+ *" $lib "*) ;;
+ *) func_append dlprefiles " $lib" ;;
+ esac
+ done
+
+ if test "$build_libtool_libs" = yes; then
+ if test -n "$rpath"; then
+ case $host in
+ *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-beos* | *-cegcc* | *-*-haiku*)
+ # these systems don't actually have a c library (as such)!
+ ;;
+ *-*-rhapsody* | *-*-darwin1.[012])
+ # Rhapsody C library is in the System framework
+ func_append deplibs " System.ltframework"
+ ;;
+ *-*-netbsd*)
+ # Don't link with libc until the a.out ld.so is fixed.
+ ;;
+ *-*-openbsd* | *-*-freebsd* | *-*-dragonfly*)
+ # Do not include libc due to us having libc/libc_r.
+ ;;
+ *-*-sco3.2v5* | *-*-sco5v6*)
+ # Causes problems with __ctype
+ ;;
+ *-*-sysv4.2uw2* | *-*-sysv5* | *-*-unixware* | *-*-OpenUNIX*)
+ # Compiler inserts libc in the correct place for threads to work
+ ;;
+ *)
+ # Add libc to deplibs on all other systems if necessary.
+ if test "$build_libtool_need_lc" = "yes"; then
+ func_append deplibs " -lc"
+ fi
+ ;;
+ esac
+ fi
+
+ # Transform deplibs into only deplibs that can be linked in shared.
+ name_save=$name
+ libname_save=$libname
+ release_save=$release
+ versuffix_save=$versuffix
+ major_save=$major
+ # I'm not sure if I'm treating the release correctly. I think
+ # release should show up in the -l (ie -lgmp5) so we don't want to
+ # add it in twice. Is that correct?
+ release=""
+ versuffix=""
+ major=""
+ newdeplibs=
+ droppeddeps=no
+ case $deplibs_check_method in
+ pass_all)
+ # Don't check for shared/static. Everything works.
+ # This might be a little naive. We might want to check
+ # whether the library exists or not. But this is on
+ # osf3 & osf4 and I'm not really sure... Just
+ # implementing what was already the behavior.
+ newdeplibs=$deplibs
+ ;;
+ test_compile)
+ # This code stresses the "libraries are programs" paradigm to its
+ # limits. Maybe even breaks it. We compile a program, linking it
+ # against the deplibs as a proxy for the library. Then we can check
+ # whether they linked in statically or dynamically with ldd.
+ $opt_dry_run || $RM conftest.c
+ cat > conftest.c <<EOF
+ int main() { return 0; }
+EOF
+ $opt_dry_run || $RM conftest
+ if $LTCC $LTCFLAGS -o conftest conftest.c $deplibs; then
+ ldd_output=`ldd conftest`
+ for i in $deplibs; do
+ case $i in
+ -l*)
+ func_stripname -l '' "$i"
+ name=$func_stripname_result
+ if test "X$allow_libtool_libs_with_static_runtimes" = "Xyes" ; then
+ case " $predeps $postdeps " in
+ *" $i "*)
+ func_append newdeplibs " $i"
+ i=""
+ ;;
+ esac
+ fi
+ if test -n "$i" ; then
+ libname=`eval "\\$ECHO \"$libname_spec\""`
+ deplib_matches=`eval "\\$ECHO \"$library_names_spec\""`
+ set dummy $deplib_matches; shift
+ deplib_match=$1
+ if test `expr "$ldd_output" : ".*$deplib_match"` -ne 0 ; then
+ func_append newdeplibs " $i"
+ else
+ droppeddeps=yes
+ echo
+ $ECHO "*** Warning: dynamic linker does not accept needed library $i."
+ echo "*** I have the capability to make that library automatically link in when"
+ echo "*** you link to this library. But I can only do this if you have a"
+ echo "*** shared version of the library, which I believe you do not have"
+ echo "*** because a test_compile did reveal that the linker did not use it for"
+ echo "*** its dynamic dependency list that programs get resolved with at runtime."
+ fi
+ fi
+ ;;
+ *)
+ func_append newdeplibs " $i"
+ ;;
+ esac
+ done
+ else
+ # Error occurred in the first compile. Let's try to salvage
+ # the situation: Compile a separate program for each library.
+ for i in $deplibs; do
+ case $i in
+ -l*)
+ func_stripname -l '' "$i"
+ name=$func_stripname_result
+ $opt_dry_run || $RM conftest
+ if $LTCC $LTCFLAGS -o conftest conftest.c $i; then
+ ldd_output=`ldd conftest`
+ if test "X$allow_libtool_libs_with_static_runtimes" = "Xyes" ; then
+ case " $predeps $postdeps " in
+ *" $i "*)
+ func_append newdeplibs " $i"
+ i=""
+ ;;
+ esac
+ fi
+ if test -n "$i" ; then
+ libname=`eval "\\$ECHO \"$libname_spec\""`
+ deplib_matches=`eval "\\$ECHO \"$library_names_spec\""`
+ set dummy $deplib_matches; shift
+ deplib_match=$1
+ if test `expr "$ldd_output" : ".*$deplib_match"` -ne 0 ; then
+ func_append newdeplibs " $i"
+ else
+ droppeddeps=yes
+ echo
+ $ECHO "*** Warning: dynamic linker does not accept needed library $i."
+ echo "*** I have the capability to make that library automatically link in when"
+ echo "*** you link to this library. But I can only do this if you have a"
+ echo "*** shared version of the library, which you do not appear to have"
+ echo "*** because a test_compile did reveal that the linker did not use this one"
+ echo "*** as a dynamic dependency that programs can get resolved with at runtime."
+ fi
+ fi
+ else
+ droppeddeps=yes
+ echo
+ $ECHO "*** Warning! Library $i is needed by this library but I was not able to"
+ echo "*** make it link in! You will probably need to install it or some"
+ echo "*** library that it depends on before this library will be fully"
+ echo "*** functional. Installing it before continuing would be even better."
+ fi
+ ;;
+ *)
+ func_append newdeplibs " $i"
+ ;;
+ esac
+ done
+ fi
+ ;;
+ file_magic*)
+ set dummy $deplibs_check_method; shift
+ file_magic_regex=`expr "$deplibs_check_method" : "$1 \(.*\)"`
+ for a_deplib in $deplibs; do
+ case $a_deplib in
+ -l*)
+ func_stripname -l '' "$a_deplib"
+ name=$func_stripname_result
+ if test "X$allow_libtool_libs_with_static_runtimes" = "Xyes" ; then
+ case " $predeps $postdeps " in
+ *" $a_deplib "*)
+ func_append newdeplibs " $a_deplib"
+ a_deplib=""
+ ;;
+ esac
+ fi
+ if test -n "$a_deplib" ; then
+ libname=`eval "\\$ECHO \"$libname_spec\""`
+ if test -n "$file_magic_glob"; then
+ libnameglob=`func_echo_all "$libname" | $SED -e $file_magic_glob`
+ else
+ libnameglob=$libname
+ fi
+ test "$want_nocaseglob" = yes && nocaseglob=`shopt -p nocaseglob`
+ for i in $lib_search_path $sys_lib_search_path $shlib_search_path; do
+ if test "$want_nocaseglob" = yes; then
+ shopt -s nocaseglob
+ potential_libs=`ls $i/$libnameglob[.-]* 2>/dev/null`
+ $nocaseglob
+ else
+ potential_libs=`ls $i/$libnameglob[.-]* 2>/dev/null`
+ fi
+ for potent_lib in $potential_libs; do
+ # Follow soft links.
+ if ls -lLd "$potent_lib" 2>/dev/null |
+ $GREP " -> " >/dev/null; then
+ continue
+ fi
+ # The statement above tries to avoid entering an
+ # endless loop below, in case of cyclic links.
+ # We might still enter an endless loop, since a link
+ # loop can be closed while we follow links,
+ # but so what?
+ potlib="$potent_lib"
+ while test -h "$potlib" 2>/dev/null; do
+ potliblink=`ls -ld $potlib | ${SED} 's/.* -> //'`
+ case $potliblink in
+ [\\/]* | [A-Za-z]:[\\/]*) potlib="$potliblink";;
+ *) potlib=`$ECHO "$potlib" | $SED 's,[^/]*$,,'`"$potliblink";;
+ esac
+ done
+ if eval $file_magic_cmd \"\$potlib\" 2>/dev/null |
+ $SED -e 10q |
+ $EGREP "$file_magic_regex" > /dev/null; then
+ func_append newdeplibs " $a_deplib"
+ a_deplib=""
+ break 2
+ fi
+ done
+ done
+ fi
+ if test -n "$a_deplib" ; then
+ droppeddeps=yes
+ echo
+ $ECHO "*** Warning: linker path does not have real file for library $a_deplib."
+ echo "*** I have the capability to make that library automatically link in when"
+ echo "*** you link to this library. But I can only do this if you have a"
+ echo "*** shared version of the library, which you do not appear to have"
+ echo "*** because I did check the linker path looking for a file starting"
+ if test -z "$potlib" ; then
+ $ECHO "*** with $libname but no candidates were found. (...for file magic test)"
+ else
+ $ECHO "*** with $libname and none of the candidates passed a file format test"
+ $ECHO "*** using a file magic. Last file checked: $potlib"
+ fi
+ fi
+ ;;
+ *)
+ # Add a -L argument.
+ func_append newdeplibs " $a_deplib"
+ ;;
+ esac
+ done # Gone through all deplibs.
+ ;;
+ match_pattern*)
+ set dummy $deplibs_check_method; shift
+ match_pattern_regex=`expr "$deplibs_check_method" : "$1 \(.*\)"`
+ for a_deplib in $deplibs; do
+ case $a_deplib in
+ -l*)
+ func_stripname -l '' "$a_deplib"
+ name=$func_stripname_result
+ if test "X$allow_libtool_libs_with_static_runtimes" = "Xyes" ; then
+ case " $predeps $postdeps " in
+ *" $a_deplib "*)
+ func_append newdeplibs " $a_deplib"
+ a_deplib=""
+ ;;
+ esac
+ fi
+ if test -n "$a_deplib" ; then
+ libname=`eval "\\$ECHO \"$libname_spec\""`
+ for i in $lib_search_path $sys_lib_search_path $shlib_search_path; do
+ potential_libs=`ls $i/$libname[.-]* 2>/dev/null`
+ for potent_lib in $potential_libs; do
+ potlib="$potent_lib" # see symlink-check above in file_magic test
+ if eval "\$ECHO \"$potent_lib\"" 2>/dev/null | $SED 10q | \
+ $EGREP "$match_pattern_regex" > /dev/null; then
+ func_append newdeplibs " $a_deplib"
+ a_deplib=""
+ break 2
+ fi
+ done
+ done
+ fi
+ if test -n "$a_deplib" ; then
+ droppeddeps=yes
+ echo
+ $ECHO "*** Warning: linker path does not have real file for library $a_deplib."
+ echo "*** I have the capability to make that library automatically link in when"
+ echo "*** you link to this library. But I can only do this if you have a"
+ echo "*** shared version of the library, which you do not appear to have"
+ echo "*** because I did check the linker path looking for a file starting"
+ if test -z "$potlib" ; then
+ $ECHO "*** with $libname but no candidates were found. (...for regex pattern test)"
+ else
+ $ECHO "*** with $libname and none of the candidates passed a file format test"
+ $ECHO "*** using a regex pattern. Last file checked: $potlib"
+ fi
+ fi
+ ;;
+ *)
+ # Add a -L argument.
+ func_append newdeplibs " $a_deplib"
+ ;;
+ esac
+ done # Gone through all deplibs.
+ ;;
+ none | unknown | *)
+ newdeplibs=""
+ tmp_deplibs=`$ECHO " $deplibs" | $SED 's/ -lc$//; s/ -[LR][^ ]*//g'`
+ if test "X$allow_libtool_libs_with_static_runtimes" = "Xyes" ; then
+ for i in $predeps $postdeps ; do
+ # can't use Xsed below, because $i might contain '/'
+ tmp_deplibs=`$ECHO " $tmp_deplibs" | $SED "s,$i,,"`
+ done
+ fi
+ case $tmp_deplibs in
+ *[!\ \ ]*)
+ echo
+ if test "X$deplibs_check_method" = "Xnone"; then
+ echo "*** Warning: inter-library dependencies are not supported in this platform."
+ else
+ echo "*** Warning: inter-library dependencies are not known to be supported."
+ fi
+ echo "*** All declared inter-library dependencies are being dropped."
+ droppeddeps=yes
+ ;;
+ esac
+ ;;
+ esac
+ versuffix=$versuffix_save
+ major=$major_save
+ release=$release_save
+ libname=$libname_save
+ name=$name_save
+
+ case $host in
+ *-*-rhapsody* | *-*-darwin1.[012])
+ # On Rhapsody replace the C library with the System framework
+ newdeplibs=`$ECHO " $newdeplibs" | $SED 's/ -lc / System.ltframework /'`
+ ;;
+ esac
+
+ if test "$droppeddeps" = yes; then
+ if test "$module" = yes; then
+ echo
+ echo "*** Warning: libtool could not satisfy all declared inter-library"
+ $ECHO "*** dependencies of module $libname. Therefore, libtool will create"
+ echo "*** a static module, that should work as long as the dlopening"
+ echo "*** application is linked with the -dlopen flag."
+ if test -z "$global_symbol_pipe"; then
+ echo
+ echo "*** However, this would only work if libtool was able to extract symbol"
+ echo "*** lists from a program, using \`nm' or equivalent, but libtool could"
+ echo "*** not find such a program. So, this module is probably useless."
+ echo "*** \`nm' from GNU binutils and a full rebuild may help."
+ fi
+ if test "$build_old_libs" = no; then
+ oldlibs="$output_objdir/$libname.$libext"
+ build_libtool_libs=module
+ build_old_libs=yes
+ else
+ build_libtool_libs=no
+ fi
+ else
+ echo "*** The inter-library dependencies that have been dropped here will be"
+ echo "*** automatically added whenever a program is linked with this library"
+ echo "*** or is declared to -dlopen it."
+
+ if test "$allow_undefined" = no; then
+ echo
+ echo "*** Since this library must not contain undefined symbols,"
+ echo "*** because either the platform does not support them or"
+ echo "*** it was explicitly requested with -no-undefined,"
+ echo "*** libtool will only create a static version of it."
+ if test "$build_old_libs" = no; then
+ oldlibs="$output_objdir/$libname.$libext"
+ build_libtool_libs=module
+ build_old_libs=yes
+ else
+ build_libtool_libs=no
+ fi
+ fi
+ fi
+ fi
+ # Done checking deplibs!
+ deplibs=$newdeplibs
+ fi
+ # Time to change all our "foo.ltframework" stuff back to "-framework foo"
+ case $host in
+ *-*-darwin*)
+ newdeplibs=`$ECHO " $newdeplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'`
+ new_inherited_linker_flags=`$ECHO " $new_inherited_linker_flags" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'`
+ deplibs=`$ECHO " $deplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'`
+ ;;
+ esac
+
+ # move library search paths that coincide with paths to not yet
+ # installed libraries to the beginning of the library search list
+ new_libs=
+ for path in $notinst_path; do
+ case " $new_libs " in
+ *" -L$path/$objdir "*) ;;
+ *)
+ case " $deplibs " in
+ *" -L$path/$objdir "*)
+ func_append new_libs " -L$path/$objdir" ;;
+ esac
+ ;;
+ esac
+ done
+ for deplib in $deplibs; do
+ case $deplib in
+ -L*)
+ case " $new_libs " in
+ *" $deplib "*) ;;
+ *) func_append new_libs " $deplib" ;;
+ esac
+ ;;
+ *) func_append new_libs " $deplib" ;;
+ esac
+ done
+ deplibs="$new_libs"
+
+ # All the library-specific variables (install_libdir is set above).
+ library_names=
+ old_library=
+ dlname=
+
+ # Test again, we may have decided not to build it any more
+ if test "$build_libtool_libs" = yes; then
+ if test "$hardcode_into_libs" = yes; then
+ # Hardcode the library paths
+ hardcode_libdirs=
+ dep_rpath=
+ rpath="$finalize_rpath"
+ test "$opt_mode" != relink && rpath="$compile_rpath$rpath"
+ for libdir in $rpath; do
+ if test -n "$hardcode_libdir_flag_spec"; then
+ if test -n "$hardcode_libdir_separator"; then
+ func_replace_sysroot "$libdir"
+ libdir=$func_replace_sysroot_result
+ if test -z "$hardcode_libdirs"; then
+ hardcode_libdirs="$libdir"
+ else
+ # Just accumulate the unique libdirs.
+ case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in
+ *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*)
+ ;;
+ *)
+ func_append hardcode_libdirs "$hardcode_libdir_separator$libdir"
+ ;;
+ esac
+ fi
+ else
+ eval flag=\"$hardcode_libdir_flag_spec\"
+ func_append dep_rpath " $flag"
+ fi
+ elif test -n "$runpath_var"; then
+ case "$perm_rpath " in
+ *" $libdir "*) ;;
+ *) func_apped perm_rpath " $libdir" ;;
+ esac
+ fi
+ done
+ # Substitute the hardcoded libdirs into the rpath.
+ if test -n "$hardcode_libdir_separator" &&
+ test -n "$hardcode_libdirs"; then
+ libdir="$hardcode_libdirs"
+ if test -n "$hardcode_libdir_flag_spec_ld"; then
+ eval dep_rpath=\"$hardcode_libdir_flag_spec_ld\"
+ else
+ eval dep_rpath=\"$hardcode_libdir_flag_spec\"
+ fi
+ fi
+ if test -n "$runpath_var" && test -n "$perm_rpath"; then
+ # We should set the runpath_var.
+ rpath=
+ for dir in $perm_rpath; do
+ func_append rpath "$dir:"
+ done
+ eval "$runpath_var='$rpath\$$runpath_var'; export $runpath_var"
+ fi
+ test -n "$dep_rpath" && deplibs="$dep_rpath $deplibs"
+ fi
+
+ shlibpath="$finalize_shlibpath"
+ test "$opt_mode" != relink && shlibpath="$compile_shlibpath$shlibpath"
+ if test -n "$shlibpath"; then
+ eval "$shlibpath_var='$shlibpath\$$shlibpath_var'; export $shlibpath_var"
+ fi
+
+ # Get the real and link names of the library.
+ eval shared_ext=\"$shrext_cmds\"
+ eval library_names=\"$library_names_spec\"
+ set dummy $library_names
+ shift
+ realname="$1"
+ shift
+
+ if test -n "$soname_spec"; then
+ eval soname=\"$soname_spec\"
+ else
+ soname="$realname"
+ fi
+ if test -z "$dlname"; then
+ dlname=$soname
+ fi
+
+ lib="$output_objdir/$realname"
+ linknames=
+ for link
+ do
+ func_append linknames " $link"
+ done
+
+ # Use standard objects if they are pic
+ test -z "$pic_flag" && libobjs=`$ECHO "$libobjs" | $SP2NL | $SED "$lo2o" | $NL2SP`
+ test "X$libobjs" = "X " && libobjs=
+
+ delfiles=
+ if test -n "$export_symbols" && test -n "$include_expsyms"; then
+ $opt_dry_run || cp "$export_symbols" "$output_objdir/$libname.uexp"
+ export_symbols="$output_objdir/$libname.uexp"
+ func_append delfiles " $export_symbols"
+ fi
+
+ orig_export_symbols=
+ case $host_os in
+ cygwin* | mingw* | cegcc*)
+ if test -n "$export_symbols" && test -z "$export_symbols_regex"; then
+ # exporting using user supplied symfile
+ if test "x`$SED 1q $export_symbols`" != xEXPORTS; then
+ # and it's NOT already a .def file. Must figure out
+ # which of the given symbols are data symbols and tag
+ # them as such. So, trigger use of export_symbols_cmds.
+ # export_symbols gets reassigned inside the "prepare
+ # the list of exported symbols" if statement, so the
+ # include_expsyms logic still works.
+ orig_export_symbols="$export_symbols"
+ export_symbols=
+ always_export_symbols=yes
+ fi
+ fi
+ ;;
+ esac
+
+ # Prepare the list of exported symbols
+ if test -z "$export_symbols"; then
+ if test "$always_export_symbols" = yes || test -n "$export_symbols_regex"; then
+ func_verbose "generating symbol list for \`$libname.la'"
+ export_symbols="$output_objdir/$libname.exp"
+ $opt_dry_run || $RM $export_symbols
+ cmds=$export_symbols_cmds
+ save_ifs="$IFS"; IFS='~'
+ for cmd1 in $cmds; do
+ IFS="$save_ifs"
+ # Take the normal branch if the nm_file_list_spec branch
+ # doesn't work or if tool conversion is not needed.
+ case $nm_file_list_spec~$to_tool_file_cmd in
+ *~func_convert_file_noop | *~func_convert_file_msys_to_w32 | ~*)
+ try_normal_branch=yes
+ eval cmd=\"$cmd1\"
+ func_len " $cmd"
+ len=$func_len_result
+ ;;
+ *)
+ try_normal_branch=no
+ ;;
+ esac
+ if test "$try_normal_branch" = yes \
+ && { test "$len" -lt "$max_cmd_len" \
+ || test "$max_cmd_len" -le -1; }
+ then
+ func_show_eval "$cmd" 'exit $?'
+ skipped_export=false
+ elif test -n "$nm_file_list_spec"; then
+ func_basename "$output"
+ output_la=$func_basename_result
+ save_libobjs=$libobjs
+ save_output=$output
+ output=${output_objdir}/${output_la}.nm
+ func_to_tool_file "$output"
+ libobjs=$nm_file_list_spec$func_to_tool_file_result
+ func_append delfiles " $output"
+ func_verbose "creating $NM input file list: $output"
+ for obj in $save_libobjs; do
+ func_to_tool_file "$obj"
+ $ECHO "$func_to_tool_file_result"
+ done > "$output"
+ eval cmd=\"$cmd1\"
+ func_show_eval "$cmd" 'exit $?'
+ output=$save_output
+ libobjs=$save_libobjs
+ skipped_export=false
+ else
+ # The command line is too long to execute in one step.
+ func_verbose "using reloadable object file for export list..."
+ skipped_export=:
+ # Break out early, otherwise skipped_export may be
+ # set to false by a later but shorter cmd.
+ break
+ fi
+ done
+ IFS="$save_ifs"
+ if test -n "$export_symbols_regex" && test "X$skipped_export" != "X:"; then
+ func_show_eval '$EGREP -e "$export_symbols_regex" "$export_symbols" > "${export_symbols}T"'
+ func_show_eval '$MV "${export_symbols}T" "$export_symbols"'
+ fi
+ fi
+ fi
+
+ if test -n "$export_symbols" && test -n "$include_expsyms"; then
+ tmp_export_symbols="$export_symbols"
+ test -n "$orig_export_symbols" && tmp_export_symbols="$orig_export_symbols"
+ $opt_dry_run || eval '$ECHO "$include_expsyms" | $SP2NL >> "$tmp_export_symbols"'
+ fi
+
+ if test "X$skipped_export" != "X:" && test -n "$orig_export_symbols"; then
+ # The given exports_symbols file has to be filtered, so filter it.
+ func_verbose "filter symbol list for \`$libname.la' to tag DATA exports"
+ # FIXME: $output_objdir/$libname.filter potentially contains lots of
+ # 's' commands which not all seds can handle. GNU sed should be fine
+ # though. Also, the filter scales superlinearly with the number of
+ # global variables. join(1) would be nice here, but unfortunately
+ # isn't a blessed tool.
+ $opt_dry_run || $SED -e '/[ ,]DATA/!d;s,\(.*\)\([ \,].*\),s|^\1$|\1\2|,' < $export_symbols > $output_objdir/$libname.filter
+ func_append delfiles " $export_symbols $output_objdir/$libname.filter"
+ export_symbols=$output_objdir/$libname.def
+ $opt_dry_run || $SED -f $output_objdir/$libname.filter < $orig_export_symbols > $export_symbols
+ fi
+
+ tmp_deplibs=
+ for test_deplib in $deplibs; do
+ case " $convenience " in
+ *" $test_deplib "*) ;;
+ *)
+ func_append tmp_deplibs " $test_deplib"
+ ;;
+ esac
+ done
+ deplibs="$tmp_deplibs"
+
+ if test -n "$convenience"; then
+ if test -n "$whole_archive_flag_spec" &&
+ test "$compiler_needs_object" = yes &&
+ test -z "$libobjs"; then
+ # extract the archives, so we have objects to list.
+ # TODO: could optimize this to just extract one archive.
+ whole_archive_flag_spec=
+ fi
+ if test -n "$whole_archive_flag_spec"; then
+ save_libobjs=$libobjs
+ eval libobjs=\"\$libobjs $whole_archive_flag_spec\"
+ test "X$libobjs" = "X " && libobjs=
+ else
+ gentop="$output_objdir/${outputname}x"
+ func_append generated " $gentop"
+
+ func_extract_archives $gentop $convenience
+ func_append libobjs " $func_extract_archives_result"
+ test "X$libobjs" = "X " && libobjs=
+ fi
+ fi
+
+ if test "$thread_safe" = yes && test -n "$thread_safe_flag_spec"; then
+ eval flag=\"$thread_safe_flag_spec\"
+ func_append linker_flags " $flag"
+ fi
+
+ # Make a backup of the uninstalled library when relinking
+ if test "$opt_mode" = relink; then
+ $opt_dry_run || eval '(cd $output_objdir && $RM ${realname}U && $MV $realname ${realname}U)' || exit $?
+ fi
+
+ # Do each of the archive commands.
+ if test "$module" = yes && test -n "$module_cmds" ; then
+ if test -n "$export_symbols" && test -n "$module_expsym_cmds"; then
+ eval test_cmds=\"$module_expsym_cmds\"
+ cmds=$module_expsym_cmds
+ else
+ eval test_cmds=\"$module_cmds\"
+ cmds=$module_cmds
+ fi
+ else
+ if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then
+ eval test_cmds=\"$archive_expsym_cmds\"
+ cmds=$archive_expsym_cmds
+ else
+ eval test_cmds=\"$archive_cmds\"
+ cmds=$archive_cmds
+ fi
+ fi
+
+ if test "X$skipped_export" != "X:" &&
+ func_len " $test_cmds" &&
+ len=$func_len_result &&
+ test "$len" -lt "$max_cmd_len" || test "$max_cmd_len" -le -1; then
+ :
+ else
+ # The command line is too long to link in one step, link piecewise
+ # or, if using GNU ld and skipped_export is not :, use a linker
+ # script.
+
+ # Save the value of $output and $libobjs because we want to
+ # use them later. If we have whole_archive_flag_spec, we
+ # want to use save_libobjs as it was before
+ # whole_archive_flag_spec was expanded, because we can't
+ # assume the linker understands whole_archive_flag_spec.
+ # This may have to be revisited, in case too many
+ # convenience libraries get linked in and end up exceeding
+ # the spec.
+ if test -z "$convenience" || test -z "$whole_archive_flag_spec"; then
+ save_libobjs=$libobjs
+ fi
+ save_output=$output
+ func_basename "$output"
+ output_la=$func_basename_result
+
+ # Clear the reloadable object creation command queue and
+ # initialize k to one.
+ test_cmds=
+ concat_cmds=
+ objlist=
+ last_robj=
+ k=1
+
+ if test -n "$save_libobjs" && test "X$skipped_export" != "X:" && test "$with_gnu_ld" = yes; then
+ output=${output_objdir}/${output_la}.lnkscript
+ func_verbose "creating GNU ld script: $output"
+ echo 'INPUT (' > $output
+ for obj in $save_libobjs
+ do
+ func_to_tool_file "$obj"
+ $ECHO "$func_to_tool_file_result" >> $output
+ done
+ echo ')' >> $output
+ func_append delfiles " $output"
+ func_to_tool_file "$output"
+ output=$func_to_tool_file_result
+ elif test -n "$save_libobjs" && test "X$skipped_export" != "X:" && test "X$file_list_spec" != X; then
+ output=${output_objdir}/${output_la}.lnk
+ func_verbose "creating linker input file list: $output"
+ : > $output
+ set x $save_libobjs
+ shift
+ firstobj=
+ if test "$compiler_needs_object" = yes; then
+ firstobj="$1 "
+ shift
+ fi
+ for obj
+ do
+ func_to_tool_file "$obj"
+ $ECHO "$func_to_tool_file_result" >> $output
+ done
+ func_append delfiles " $output"
+ func_to_tool_file "$output"
+ output=$firstobj\"$file_list_spec$func_to_tool_file_result\"
+ else
+ if test -n "$save_libobjs"; then
+ func_verbose "creating reloadable object files..."
+ output=$output_objdir/$output_la-${k}.$objext
+ eval test_cmds=\"$reload_cmds\"
+ func_len " $test_cmds"
+ len0=$func_len_result
+ len=$len0
+
+ # Loop over the list of objects to be linked.
+ for obj in $save_libobjs
+ do
+ func_len " $obj"
+ func_arith $len + $func_len_result
+ len=$func_arith_result
+ if test "X$objlist" = X ||
+ test "$len" -lt "$max_cmd_len"; then
+ func_append objlist " $obj"
+ else
+ # The command $test_cmds is almost too long, add a
+ # command to the queue.
+ if test "$k" -eq 1 ; then
+ # The first file doesn't have a previous command to add.
+ reload_objs=$objlist
+ eval concat_cmds=\"$reload_cmds\"
+ else
+ # All subsequent reloadable object files will link in
+ # the last one created.
+ reload_objs="$objlist $last_robj"
+ eval concat_cmds=\"\$concat_cmds~$reload_cmds~\$RM $last_robj\"
+ fi
+ last_robj=$output_objdir/$output_la-${k}.$objext
+ func_arith $k + 1
+ k=$func_arith_result
+ output=$output_objdir/$output_la-${k}.$objext
+ objlist=" $obj"
+ func_len " $last_robj"
+ func_arith $len0 + $func_len_result
+ len=$func_arith_result
+ fi
+ done
+ # Handle the remaining objects by creating one last
+ # reloadable object file. All subsequent reloadable object
+ # files will link in the last one created.
+ test -z "$concat_cmds" || concat_cmds=$concat_cmds~
+ reload_objs="$objlist $last_robj"
+ eval concat_cmds=\"\${concat_cmds}$reload_cmds\"
+ if test -n "$last_robj"; then
+ eval concat_cmds=\"\${concat_cmds}~\$RM $last_robj\"
+ fi
+ func_append delfiles " $output"
+
+ else
+ output=
+ fi
+
+ if ${skipped_export-false}; then
+ func_verbose "generating symbol list for \`$libname.la'"
+ export_symbols="$output_objdir/$libname.exp"
+ $opt_dry_run || $RM $export_symbols
+ libobjs=$output
+ # Append the command to create the export file.
+ test -z "$concat_cmds" || concat_cmds=$concat_cmds~
+ eval concat_cmds=\"\$concat_cmds$export_symbols_cmds\"
+ if test -n "$last_robj"; then
+ eval concat_cmds=\"\$concat_cmds~\$RM $last_robj\"
+ fi
+ fi
+
+ test -n "$save_libobjs" &&
+ func_verbose "creating a temporary reloadable object file: $output"
+
+ # Loop through the commands generated above and execute them.
+ save_ifs="$IFS"; IFS='~'
+ for cmd in $concat_cmds; do
+ IFS="$save_ifs"
+ $opt_silent || {
+ func_quote_for_expand "$cmd"
+ eval "func_echo $func_quote_for_expand_result"
+ }
+ $opt_dry_run || eval "$cmd" || {
+ lt_exit=$?
+
+ # Restore the uninstalled library and exit
+ if test "$opt_mode" = relink; then
+ ( cd "$output_objdir" && \
+ $RM "${realname}T" && \
+ $MV "${realname}U" "$realname" )
+ fi
+
+ exit $lt_exit
+ }
+ done
+ IFS="$save_ifs"
+
+ if test -n "$export_symbols_regex" && ${skipped_export-false}; then
+ func_show_eval '$EGREP -e "$export_symbols_regex" "$export_symbols" > "${export_symbols}T"'
+ func_show_eval '$MV "${export_symbols}T" "$export_symbols"'
+ fi
+ fi
+
+ if ${skipped_export-false}; then
+ if test -n "$export_symbols" && test -n "$include_expsyms"; then
+ tmp_export_symbols="$export_symbols"
+ test -n "$orig_export_symbols" && tmp_export_symbols="$orig_export_symbols"
+ $opt_dry_run || eval '$ECHO "$include_expsyms" | $SP2NL >> "$tmp_export_symbols"'
+ fi
+
+ if test -n "$orig_export_symbols"; then
+ # The given exports_symbols file has to be filtered, so filter it.
+ func_verbose "filter symbol list for \`$libname.la' to tag DATA exports"
+ # FIXME: $output_objdir/$libname.filter potentially contains lots of
+ # 's' commands which not all seds can handle. GNU sed should be fine
+ # though. Also, the filter scales superlinearly with the number of
+ # global variables. join(1) would be nice here, but unfortunately
+ # isn't a blessed tool.
+ $opt_dry_run || $SED -e '/[ ,]DATA/!d;s,\(.*\)\([ \,].*\),s|^\1$|\1\2|,' < $export_symbols > $output_objdir/$libname.filter
+ func_append delfiles " $export_symbols $output_objdir/$libname.filter"
+ export_symbols=$output_objdir/$libname.def
+ $opt_dry_run || $SED -f $output_objdir/$libname.filter < $orig_export_symbols > $export_symbols
+ fi
+ fi
+
+ libobjs=$output
+ # Restore the value of output.
+ output=$save_output
+
+ if test -n "$convenience" && test -n "$whole_archive_flag_spec"; then
+ eval libobjs=\"\$libobjs $whole_archive_flag_spec\"
+ test "X$libobjs" = "X " && libobjs=
+ fi
+ # Expand the library linking commands again to reset the
+ # value of $libobjs for piecewise linking.
+
+ # Do each of the archive commands.
+ if test "$module" = yes && test -n "$module_cmds" ; then
+ if test -n "$export_symbols" && test -n "$module_expsym_cmds"; then
+ cmds=$module_expsym_cmds
+ else
+ cmds=$module_cmds
+ fi
+ else
+ if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then
+ cmds=$archive_expsym_cmds
+ else
+ cmds=$archive_cmds
+ fi
+ fi
+ fi
+
+ if test -n "$delfiles"; then
+ # Append the command to remove temporary files to $cmds.
+ eval cmds=\"\$cmds~\$RM $delfiles\"
+ fi
+
+ # Add any objects from preloaded convenience libraries
+ if test -n "$dlprefiles"; then
+ gentop="$output_objdir/${outputname}x"
+ func_append generated " $gentop"
+
+ func_extract_archives $gentop $dlprefiles
+ func_append libobjs " $func_extract_archives_result"
+ test "X$libobjs" = "X " && libobjs=
+ fi
+
+ save_ifs="$IFS"; IFS='~'
+ for cmd in $cmds; do
+ IFS="$save_ifs"
+ eval cmd=\"$cmd\"
+ $opt_silent || {
+ func_quote_for_expand "$cmd"
+ eval "func_echo $func_quote_for_expand_result"
+ }
+ $opt_dry_run || eval "$cmd" || {
+ lt_exit=$?
+
+ # Restore the uninstalled library and exit
+ if test "$opt_mode" = relink; then
+ ( cd "$output_objdir" && \
+ $RM "${realname}T" && \
+ $MV "${realname}U" "$realname" )
+ fi
+
+ exit $lt_exit
+ }
+ done
+ IFS="$save_ifs"
+
+ # Restore the uninstalled library and exit
+ if test "$opt_mode" = relink; then
+ $opt_dry_run || eval '(cd $output_objdir && $RM ${realname}T && $MV $realname ${realname}T && $MV ${realname}U $realname)' || exit $?
+
+ if test -n "$convenience"; then
+ if test -z "$whole_archive_flag_spec"; then
+ func_show_eval '${RM}r "$gentop"'
+ fi
+ fi
+
+ exit $EXIT_SUCCESS
+ fi
+
+ # Create links to the real library.
+ for linkname in $linknames; do
+ if test "$realname" != "$linkname"; then
+ func_show_eval '(cd "$output_objdir" && $RM "$linkname" && $LN_S "$realname" "$linkname")' 'exit $?'
+ fi
+ done
+
+ # If -module or -export-dynamic was specified, set the dlname.
+ if test "$module" = yes || test "$export_dynamic" = yes; then
+ # On all known operating systems, these are identical.
+ dlname="$soname"
+ fi
+ fi
+ ;;
+
+ obj)
+ if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then
+ func_warning "\`-dlopen' is ignored for objects"
+ fi
+
+ case " $deplibs" in
+ *\ -l* | *\ -L*)
+ func_warning "\`-l' and \`-L' are ignored for objects" ;;
+ esac
+
+ test -n "$rpath" && \
+ func_warning "\`-rpath' is ignored for objects"
+
+ test -n "$xrpath" && \
+ func_warning "\`-R' is ignored for objects"
+
+ test -n "$vinfo" && \
+ func_warning "\`-version-info' is ignored for objects"
+
+ test -n "$release" && \
+ func_warning "\`-release' is ignored for objects"
+
+ case $output in
+ *.lo)
+ test -n "$objs$old_deplibs" && \
+ func_fatal_error "cannot build library object \`$output' from non-libtool objects"
+
+ libobj=$output
+ func_lo2o "$libobj"
+ obj=$func_lo2o_result
+ ;;
+ *)
+ libobj=
+ obj="$output"
+ ;;
+ esac
+
+ # Delete the old objects.
+ $opt_dry_run || $RM $obj $libobj
+
+ # Objects from convenience libraries. This assumes
+ # single-version convenience libraries. Whenever we create
+ # different ones for PIC/non-PIC, this we'll have to duplicate
+ # the extraction.
+ reload_conv_objs=
+ gentop=
+ # reload_cmds runs $LD directly, so let us get rid of
+ # -Wl from whole_archive_flag_spec and hope we can get by with
+ # turning comma into space..
+ wl=
+
+ if test -n "$convenience"; then
+ if test -n "$whole_archive_flag_spec"; then
+ eval tmp_whole_archive_flags=\"$whole_archive_flag_spec\"
+ reload_conv_objs=$reload_objs\ `$ECHO "$tmp_whole_archive_flags" | $SED 's|,| |g'`
+ else
+ gentop="$output_objdir/${obj}x"
+ func_append generated " $gentop"
+
+ func_extract_archives $gentop $convenience
+ reload_conv_objs="$reload_objs $func_extract_archives_result"
+ fi
+ fi
+
+ # If we're not building shared, we need to use non_pic_objs
+ test "$build_libtool_libs" != yes && libobjs="$non_pic_objects"
+
+ # Create the old-style object.
+ reload_objs="$objs$old_deplibs "`$ECHO "$libobjs" | $SP2NL | $SED "/\.${libext}$/d; /\.lib$/d; $lo2o" | $NL2SP`" $reload_conv_objs" ### testsuite: skip nested quoting test
+
+ output="$obj"
+ func_execute_cmds "$reload_cmds" 'exit $?'
+
+ # Exit if we aren't doing a library object file.
+ if test -z "$libobj"; then
+ if test -n "$gentop"; then
+ func_show_eval '${RM}r "$gentop"'
+ fi
+
+ exit $EXIT_SUCCESS
+ fi
+
+ if test "$build_libtool_libs" != yes; then
+ if test -n "$gentop"; then
+ func_show_eval '${RM}r "$gentop"'
+ fi
+
+ # Create an invalid libtool object if no PIC, so that we don't
+ # accidentally link it into a program.
+ # $show "echo timestamp > $libobj"
+ # $opt_dry_run || eval "echo timestamp > $libobj" || exit $?
+ exit $EXIT_SUCCESS
+ fi
+
+ if test -n "$pic_flag" || test "$pic_mode" != default; then
+ # Only do commands if we really have different PIC objects.
+ reload_objs="$libobjs $reload_conv_objs"
+ output="$libobj"
+ func_execute_cmds "$reload_cmds" 'exit $?'
+ fi
+
+ if test -n "$gentop"; then
+ func_show_eval '${RM}r "$gentop"'
+ fi
+
+ exit $EXIT_SUCCESS
+ ;;
+
+ prog)
+ case $host in
+ *cygwin*) func_stripname '' '.exe' "$output"
+ output=$func_stripname_result.exe;;
+ esac
+ test -n "$vinfo" && \
+ func_warning "\`-version-info' is ignored for programs"
+
+ test -n "$release" && \
+ func_warning "\`-release' is ignored for programs"
+
+ test "$preload" = yes \
+ && test "$dlopen_support" = unknown \
+ && test "$dlopen_self" = unknown \
+ && test "$dlopen_self_static" = unknown && \
+ func_warning "\`LT_INIT([dlopen])' not used. Assuming no dlopen support."
+
+ case $host in
+ *-*-rhapsody* | *-*-darwin1.[012])
+ # On Rhapsody replace the C library is the System framework
+ compile_deplibs=`$ECHO " $compile_deplibs" | $SED 's/ -lc / System.ltframework /'`
+ finalize_deplibs=`$ECHO " $finalize_deplibs" | $SED 's/ -lc / System.ltframework /'`
+ ;;
+ esac
+
+ case $host in
+ *-*-darwin*)
+ # Don't allow lazy linking, it breaks C++ global constructors
+ # But is supposedly fixed on 10.4 or later (yay!).
+ if test "$tagname" = CXX ; then
+ case ${MACOSX_DEPLOYMENT_TARGET-10.0} in
+ 10.[0123])
+ func_append compile_command " ${wl}-bind_at_load"
+ func_append finalize_command " ${wl}-bind_at_load"
+ ;;
+ esac
+ fi
+ # Time to change all our "foo.ltframework" stuff back to "-framework foo"
+ compile_deplibs=`$ECHO " $compile_deplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'`
+ finalize_deplibs=`$ECHO " $finalize_deplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'`
+ ;;
+ esac
+
+
+ # move library search paths that coincide with paths to not yet
+ # installed libraries to the beginning of the library search list
+ new_libs=
+ for path in $notinst_path; do
+ case " $new_libs " in
+ *" -L$path/$objdir "*) ;;
+ *)
+ case " $compile_deplibs " in
+ *" -L$path/$objdir "*)
+ func_append new_libs " -L$path/$objdir" ;;
+ esac
+ ;;
+ esac
+ done
+ for deplib in $compile_deplibs; do
+ case $deplib in
+ -L*)
+ case " $new_libs " in
+ *" $deplib "*) ;;
+ *) func_append new_libs " $deplib" ;;
+ esac
+ ;;
+ *) func_append new_libs " $deplib" ;;
+ esac
+ done
+ compile_deplibs="$new_libs"
+
+
+ func_append compile_command " $compile_deplibs"
+ func_append finalize_command " $finalize_deplibs"
+
+ if test -n "$rpath$xrpath"; then
+ # If the user specified any rpath flags, then add them.
+ for libdir in $rpath $xrpath; do
+ # This is the magic to use -rpath.
+ case "$finalize_rpath " in
+ *" $libdir "*) ;;
+ *) func_append finalize_rpath " $libdir" ;;
+ esac
+ done
+ fi
+
+ # Now hardcode the library paths
+ rpath=
+ hardcode_libdirs=
+ for libdir in $compile_rpath $finalize_rpath; do
+ if test -n "$hardcode_libdir_flag_spec"; then
+ if test -n "$hardcode_libdir_separator"; then
+ if test -z "$hardcode_libdirs"; then
+ hardcode_libdirs="$libdir"
+ else
+ # Just accumulate the unique libdirs.
+ case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in
+ *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*)
+ ;;
+ *)
+ func_append hardcode_libdirs "$hardcode_libdir_separator$libdir"
+ ;;
+ esac
+ fi
+ else
+ eval flag=\"$hardcode_libdir_flag_spec\"
+ func_append rpath " $flag"
+ fi
+ elif test -n "$runpath_var"; then
+ case "$perm_rpath " in
+ *" $libdir "*) ;;
+ *) func_append perm_rpath " $libdir" ;;
+ esac
+ fi
+ case $host in
+ *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*)
+ testbindir=`${ECHO} "$libdir" | ${SED} -e 's*/lib$*/bin*'`
+ case :$dllsearchpath: in
+ *":$libdir:"*) ;;
+ ::) dllsearchpath=$libdir;;
+ *) func_append dllsearchpath ":$libdir";;
+ esac
+ case :$dllsearchpath: in
+ *":$testbindir:"*) ;;
+ ::) dllsearchpath=$testbindir;;
+ *) func_append dllsearchpath ":$testbindir";;
+ esac
+ ;;
+ esac
+ done
+ # Substitute the hardcoded libdirs into the rpath.
+ if test -n "$hardcode_libdir_separator" &&
+ test -n "$hardcode_libdirs"; then
+ libdir="$hardcode_libdirs"
+ eval rpath=\" $hardcode_libdir_flag_spec\"
+ fi
+ compile_rpath="$rpath"
+
+ rpath=
+ hardcode_libdirs=
+ for libdir in $finalize_rpath; do
+ if test -n "$hardcode_libdir_flag_spec"; then
+ if test -n "$hardcode_libdir_separator"; then
+ if test -z "$hardcode_libdirs"; then
+ hardcode_libdirs="$libdir"
+ else
+ # Just accumulate the unique libdirs.
+ case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in
+ *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*)
+ ;;
+ *)
+ func_append hardcode_libdirs "$hardcode_libdir_separator$libdir"
+ ;;
+ esac
+ fi
+ else
+ eval flag=\"$hardcode_libdir_flag_spec\"
+ func_append rpath " $flag"
+ fi
+ elif test -n "$runpath_var"; then
+ case "$finalize_perm_rpath " in
+ *" $libdir "*) ;;
+ *) func_append finalize_perm_rpath " $libdir" ;;
+ esac
+ fi
+ done
+ # Substitute the hardcoded libdirs into the rpath.
+ if test -n "$hardcode_libdir_separator" &&
+ test -n "$hardcode_libdirs"; then
+ libdir="$hardcode_libdirs"
+ eval rpath=\" $hardcode_libdir_flag_spec\"
+ fi
+ finalize_rpath="$rpath"
+
+ if test -n "$libobjs" && test "$build_old_libs" = yes; then
+ # Transform all the library objects into standard objects.
+ compile_command=`$ECHO "$compile_command" | $SP2NL | $SED "$lo2o" | $NL2SP`
+ finalize_command=`$ECHO "$finalize_command" | $SP2NL | $SED "$lo2o" | $NL2SP`
+ fi
+
+ func_generate_dlsyms "$outputname" "@PROGRAM@" "no"
+
+ # template prelinking step
+ if test -n "$prelink_cmds"; then
+ func_execute_cmds "$prelink_cmds" 'exit $?'
+ fi
+
+ wrappers_required=yes
+ case $host in
+ *cegcc* | *mingw32ce*)
+ # Disable wrappers for cegcc and mingw32ce hosts, we are cross compiling anyway.
+ wrappers_required=no
+ ;;
+ *cygwin* | *mingw* )
+ if test "$build_libtool_libs" != yes; then
+ wrappers_required=no
+ fi
+ ;;
+ *)
+ if test "$need_relink" = no || test "$build_libtool_libs" != yes; then
+ wrappers_required=no
+ fi
+ ;;
+ esac
+ if test "$wrappers_required" = no; then
+ # Replace the output file specification.
+ compile_command=`$ECHO "$compile_command" | $SED 's%@OUTPUT@%'"$output"'%g'`
+ link_command="$compile_command$compile_rpath"
+
+ # We have no uninstalled library dependencies, so finalize right now.
+ exit_status=0
+ func_show_eval "$link_command" 'exit_status=$?'
+
+ if test -n "$postlink_cmds"; then
+ func_to_tool_file "$output"
+ postlink_cmds=`func_echo_all "$postlink_cmds" | $SED -e 's%@OUTPUT@%'"$output"'%g' -e 's%@TOOL_OUTPUT@%'"$func_to_tool_file_result"'%g'`
+ func_execute_cmds "$postlink_cmds" 'exit $?'
+ fi
+
+ # Delete the generated files.
+ if test -f "$output_objdir/${outputname}S.${objext}"; then
+ func_show_eval '$RM "$output_objdir/${outputname}S.${objext}"'
+ fi
+
+ exit $exit_status
+ fi
+
+ if test -n "$compile_shlibpath$finalize_shlibpath"; then
+ compile_command="$shlibpath_var=\"$compile_shlibpath$finalize_shlibpath\$$shlibpath_var\" $compile_command"
+ fi
+ if test -n "$finalize_shlibpath"; then
+ finalize_command="$shlibpath_var=\"$finalize_shlibpath\$$shlibpath_var\" $finalize_command"
+ fi
+
+ compile_var=
+ finalize_var=
+ if test -n "$runpath_var"; then
+ if test -n "$perm_rpath"; then
+ # We should set the runpath_var.
+ rpath=
+ for dir in $perm_rpath; do
+ func_append rpath "$dir:"
+ done
+ compile_var="$runpath_var=\"$rpath\$$runpath_var\" "
+ fi
+ if test -n "$finalize_perm_rpath"; then
+ # We should set the runpath_var.
+ rpath=
+ for dir in $finalize_perm_rpath; do
+ func_append rpath "$dir:"
+ done
+ finalize_var="$runpath_var=\"$rpath\$$runpath_var\" "
+ fi
+ fi
+
+ if test "$no_install" = yes; then
+ # We don't need to create a wrapper script.
+ link_command="$compile_var$compile_command$compile_rpath"
+ # Replace the output file specification.
+ link_command=`$ECHO "$link_command" | $SED 's%@OUTPUT@%'"$output"'%g'`
+ # Delete the old output file.
+ $opt_dry_run || $RM $output
+ # Link the executable and exit
+ func_show_eval "$link_command" 'exit $?'
+
+ if test -n "$postlink_cmds"; then
+ func_to_tool_file "$output"
+ postlink_cmds=`func_echo_all "$postlink_cmds" | $SED -e 's%@OUTPUT@%'"$output"'%g' -e 's%@TOOL_OUTPUT@%'"$func_to_tool_file_result"'%g'`
+ func_execute_cmds "$postlink_cmds" 'exit $?'
+ fi
+
+ exit $EXIT_SUCCESS
+ fi
+
+ if test "$hardcode_action" = relink; then
+ # Fast installation is not supported
+ link_command="$compile_var$compile_command$compile_rpath"
+ relink_command="$finalize_var$finalize_command$finalize_rpath"
+
+ func_warning "this platform does not like uninstalled shared libraries"
+ func_warning "\`$output' will be relinked during installation"
+ else
+ if test "$fast_install" != no; then
+ link_command="$finalize_var$compile_command$finalize_rpath"
+ if test "$fast_install" = yes; then
+ relink_command=`$ECHO "$compile_var$compile_command$compile_rpath" | $SED 's%@OUTPUT@%\$progdir/\$file%g'`
+ else
+ # fast_install is set to needless
+ relink_command=
+ fi
+ else
+ link_command="$compile_var$compile_command$compile_rpath"
+ relink_command="$finalize_var$finalize_command$finalize_rpath"
+ fi
+ fi
+
+ # Replace the output file specification.
+ link_command=`$ECHO "$link_command" | $SED 's%@OUTPUT@%'"$output_objdir/$outputname"'%g'`
+
+ # Delete the old output files.
+ $opt_dry_run || $RM $output $output_objdir/$outputname $output_objdir/lt-$outputname
+
+ func_show_eval "$link_command" 'exit $?'
+
+ if test -n "$postlink_cmds"; then
+ func_to_tool_file "$output_objdir/$outputname"
+ postlink_cmds=`func_echo_all "$postlink_cmds" | $SED -e 's%@OUTPUT@%'"$output_objdir/$outputname"'%g' -e 's%@TOOL_OUTPUT@%'"$func_to_tool_file_result"'%g'`
+ func_execute_cmds "$postlink_cmds" 'exit $?'
+ fi
+
+ # Now create the wrapper script.
+ func_verbose "creating $output"
+
+ # Quote the relink command for shipping.
+ if test -n "$relink_command"; then
+ # Preserve any variables that may affect compiler behavior
+ for var in $variables_saved_for_relink; do
+ if eval test -z \"\${$var+set}\"; then
+ relink_command="{ test -z \"\${$var+set}\" || $lt_unset $var || { $var=; export $var; }; }; $relink_command"
+ elif eval var_value=\$$var; test -z "$var_value"; then
+ relink_command="$var=; export $var; $relink_command"
+ else
+ func_quote_for_eval "$var_value"
+ relink_command="$var=$func_quote_for_eval_result; export $var; $relink_command"
+ fi
+ done
+ relink_command="(cd `pwd`; $relink_command)"
+ relink_command=`$ECHO "$relink_command" | $SED "$sed_quote_subst"`
+ fi
+
+ # Only actually do things if not in dry run mode.
+ $opt_dry_run || {
+ # win32 will think the script is a binary if it has
+ # a .exe suffix, so we strip it off here.
+ case $output in
+ *.exe) func_stripname '' '.exe' "$output"
+ output=$func_stripname_result ;;
+ esac
+ # test for cygwin because mv fails w/o .exe extensions
+ case $host in
+ *cygwin*)
+ exeext=.exe
+ func_stripname '' '.exe' "$outputname"
+ outputname=$func_stripname_result ;;
+ *) exeext= ;;
+ esac
+ case $host in
+ *cygwin* | *mingw* )
+ func_dirname_and_basename "$output" "" "."
+ output_name=$func_basename_result
+ output_path=$func_dirname_result
+ cwrappersource="$output_path/$objdir/lt-$output_name.c"
+ cwrapper="$output_path/$output_name.exe"
+ $RM $cwrappersource $cwrapper
+ trap "$RM $cwrappersource $cwrapper; exit $EXIT_FAILURE" 1 2 15
+
+ func_emit_cwrapperexe_src > $cwrappersource
+
+ # The wrapper executable is built using the $host compiler,
+ # because it contains $host paths and files. If cross-
+ # compiling, it, like the target executable, must be
+ # executed on the $host or under an emulation environment.
+ $opt_dry_run || {
+ $LTCC $LTCFLAGS -o $cwrapper $cwrappersource
+ $STRIP $cwrapper
+ }
+
+ # Now, create the wrapper script for func_source use:
+ func_ltwrapper_scriptname $cwrapper
+ $RM $func_ltwrapper_scriptname_result
+ trap "$RM $func_ltwrapper_scriptname_result; exit $EXIT_FAILURE" 1 2 15
+ $opt_dry_run || {
+ # note: this script will not be executed, so do not chmod.
+ if test "x$build" = "x$host" ; then
+ $cwrapper --lt-dump-script > $func_ltwrapper_scriptname_result
+ else
+ func_emit_wrapper no > $func_ltwrapper_scriptname_result
+ fi
+ }
+ ;;
+ * )
+ $RM $output
+ trap "$RM $output; exit $EXIT_FAILURE" 1 2 15
+
+ func_emit_wrapper no > $output
+ chmod +x $output
+ ;;
+ esac
+ }
+ exit $EXIT_SUCCESS
+ ;;
+ esac
+
+ # See if we need to build an old-fashioned archive.
+ for oldlib in $oldlibs; do
+
+ if test "$build_libtool_libs" = convenience; then
+ oldobjs="$libobjs_save $symfileobj"
+ addlibs="$convenience"
+ build_libtool_libs=no
+ else
+ if test "$build_libtool_libs" = module; then
+ oldobjs="$libobjs_save"
+ build_libtool_libs=no
+ else
+ oldobjs="$old_deplibs $non_pic_objects"
+ if test "$preload" = yes && test -f "$symfileobj"; then
+ func_append oldobjs " $symfileobj"
+ fi
+ fi
+ addlibs="$old_convenience"
+ fi
+
+ if test -n "$addlibs"; then
+ gentop="$output_objdir/${outputname}x"
+ func_append generated " $gentop"
+
+ func_extract_archives $gentop $addlibs
+ func_append oldobjs " $func_extract_archives_result"
+ fi
+
+ # Do each command in the archive commands.
+ if test -n "$old_archive_from_new_cmds" && test "$build_libtool_libs" = yes; then
+ cmds=$old_archive_from_new_cmds
+ else
+
+ # Add any objects from preloaded convenience libraries
+ if test -n "$dlprefiles"; then
+ gentop="$output_objdir/${outputname}x"
+ func_append generated " $gentop"
+
+ func_extract_archives $gentop $dlprefiles
+ func_append oldobjs " $func_extract_archives_result"
+ fi
+
+ # POSIX demands no paths to be encoded in archives. We have
+ # to avoid creating archives with duplicate basenames if we
+ # might have to extract them afterwards, e.g., when creating a
+ # static archive out of a convenience library, or when linking
+ # the entirety of a libtool archive into another (currently
+ # not supported by libtool).
+ if (for obj in $oldobjs
+ do
+ func_basename "$obj"
+ $ECHO "$func_basename_result"
+ done | sort | sort -uc >/dev/null 2>&1); then
+ :
+ else
+ echo "copying selected object files to avoid basename conflicts..."
+ gentop="$output_objdir/${outputname}x"
+ func_append generated " $gentop"
+ func_mkdir_p "$gentop"
+ save_oldobjs=$oldobjs
+ oldobjs=
+ counter=1
+ for obj in $save_oldobjs
+ do
+ func_basename "$obj"
+ objbase="$func_basename_result"
+ case " $oldobjs " in
+ " ") oldobjs=$obj ;;
+ *[\ /]"$objbase "*)
+ while :; do
+ # Make sure we don't pick an alternate name that also
+ # overlaps.
+ newobj=lt$counter-$objbase
+ func_arith $counter + 1
+ counter=$func_arith_result
+ case " $oldobjs " in
+ *[\ /]"$newobj "*) ;;
+ *) if test ! -f "$gentop/$newobj"; then break; fi ;;
+ esac
+ done
+ func_show_eval "ln $obj $gentop/$newobj || cp $obj $gentop/$newobj"
+ func_append oldobjs " $gentop/$newobj"
+ ;;
+ *) func_append oldobjs " $obj" ;;
+ esac
+ done
+ fi
+ eval cmds=\"$old_archive_cmds\"
+
+ func_len " $cmds"
+ len=$func_len_result
+ if test "$len" -lt "$max_cmd_len" || test "$max_cmd_len" -le -1; then
+ cmds=$old_archive_cmds
+ elif test -n "$archiver_list_spec"; then
+ func_verbose "using command file archive linking..."
+ for obj in $oldobjs
+ do
+ func_to_tool_file "$obj"
+ $ECHO "$func_to_tool_file_result"
+ done > $output_objdir/$libname.libcmd
+ func_to_tool_file "$output_objdir/$libname.libcmd"
+ oldobjs=" $archiver_list_spec$func_to_tool_file_result"
+ cmds=$old_archive_cmds
+ else
+ # the command line is too long to link in one step, link in parts
+ func_verbose "using piecewise archive linking..."
+ save_RANLIB=$RANLIB
+ RANLIB=:
+ objlist=
+ concat_cmds=
+ save_oldobjs=$oldobjs
+ oldobjs=
+ # Is there a better way of finding the last object in the list?
+ for obj in $save_oldobjs
+ do
+ last_oldobj=$obj
+ done
+ eval test_cmds=\"$old_archive_cmds\"
+ func_len " $test_cmds"
+ len0=$func_len_result
+ len=$len0
+ for obj in $save_oldobjs
+ do
+ func_len " $obj"
+ func_arith $len + $func_len_result
+ len=$func_arith_result
+ func_append objlist " $obj"
+ if test "$len" -lt "$max_cmd_len"; then
+ :
+ else
+ # the above command should be used before it gets too long
+ oldobjs=$objlist
+ if test "$obj" = "$last_oldobj" ; then
+ RANLIB=$save_RANLIB
+ fi
+ test -z "$concat_cmds" || concat_cmds=$concat_cmds~
+ eval concat_cmds=\"\${concat_cmds}$old_archive_cmds\"
+ objlist=
+ len=$len0
+ fi
+ done
+ RANLIB=$save_RANLIB
+ oldobjs=$objlist
+ if test "X$oldobjs" = "X" ; then
+ eval cmds=\"\$concat_cmds\"
+ else
+ eval cmds=\"\$concat_cmds~\$old_archive_cmds\"
+ fi
+ fi
+ fi
+ func_execute_cmds "$cmds" 'exit $?'
+ done
+
+ test -n "$generated" && \
+ func_show_eval "${RM}r$generated"
+
+ # Now create the libtool archive.
+ case $output in
+ *.la)
+ old_library=
+ test "$build_old_libs" = yes && old_library="$libname.$libext"
+ func_verbose "creating $output"
+
+ # Preserve any variables that may affect compiler behavior
+ for var in $variables_saved_for_relink; do
+ if eval test -z \"\${$var+set}\"; then
+ relink_command="{ test -z \"\${$var+set}\" || $lt_unset $var || { $var=; export $var; }; }; $relink_command"
+ elif eval var_value=\$$var; test -z "$var_value"; then
+ relink_command="$var=; export $var; $relink_command"
+ else
+ func_quote_for_eval "$var_value"
+ relink_command="$var=$func_quote_for_eval_result; export $var; $relink_command"
+ fi
+ done
+ # Quote the link command for shipping.
+ relink_command="(cd `pwd`; $SHELL $progpath $preserve_args --mode=relink $libtool_args @inst_prefix_dir@)"
+ relink_command=`$ECHO "$relink_command" | $SED "$sed_quote_subst"`
+ if test "$hardcode_automatic" = yes ; then
+ relink_command=
+ fi
+
+ # Only create the output if not a dry run.
+ $opt_dry_run || {
+ for installed in no yes; do
+ if test "$installed" = yes; then
+ if test -z "$install_libdir"; then
+ break
+ fi
+ output="$output_objdir/$outputname"i
+ # Replace all uninstalled libtool libraries with the installed ones
+ newdependency_libs=
+ for deplib in $dependency_libs; do
+ case $deplib in
+ *.la)
+ func_basename "$deplib"
+ name="$func_basename_result"
+ eval libdir=`${SED} -n -e 's/^libdir=\(.*\)$/\1/p' $deplib`
+ test -z "$libdir" && \
+ func_fatal_error "\`$deplib' is not a valid libtool archive"
+ func_append newdependency_libs " ${lt_sysroot:+=}$libdir/$name"
+ ;;
+ -L*)
+ func_stripname -L '' "$deplib"
+ func_replace_sysroot "$func_stripname_result"
+ func_append newdependency_libs " -L$func_replace_sysroot_result"
+ ;;
+ -R*)
+ func_stripname -R '' "$deplib"
+ func_replace_sysroot "$func_stripname_result"
+ func_append newdependency_libs " -R$func_replace_sysroot_result"
+ ;;
+ *) func_append newdependency_libs " $deplib" ;;
+ esac
+ done
+ dependency_libs="$newdependency_libs"
+ newdlfiles=
+
+ for lib in $dlfiles; do
+ case $lib in
+ *.la)
+ func_basename "$lib"
+ name="$func_basename_result"
+ eval libdir=`${SED} -n -e 's/^libdir=\(.*\)$/\1/p' $lib`
+ test -z "$libdir" && \
+ func_fatal_error "\`$lib' is not a valid libtool archive"
+ func_append newdlfiles " ${lt_sysroot:+=}$libdir/$name"
+ ;;
+ *) func_append newdlfiles " $lib" ;;
+ esac
+ done
+ dlfiles="$newdlfiles"
+ newdlprefiles=
+ for lib in $dlprefiles; do
+ case $lib in
+ *.la)
+ # Only pass preopened files to the pseudo-archive (for
+ # eventual linking with the app. that links it) if we
+ # didn't already link the preopened objects directly into
+ # the library:
+ func_basename "$lib"
+ name="$func_basename_result"
+ eval libdir=`${SED} -n -e 's/^libdir=\(.*\)$/\1/p' $lib`
+ test -z "$libdir" && \
+ func_fatal_error "\`$lib' is not a valid libtool archive"
+ func_append newdlprefiles " ${lt_sysroot:+=}$libdir/$name"
+ ;;
+ esac
+ done
+ dlprefiles="$newdlprefiles"
+ else
+ newdlfiles=
+ for lib in $dlfiles; do
+ case $lib in
+ [\\/]* | [A-Za-z]:[\\/]*) abs="$lib" ;;
+ *) abs=`pwd`"/$lib" ;;
+ esac
+ func_append newdlfiles " $abs"
+ done
+ dlfiles="$newdlfiles"
+ newdlprefiles=
+ for lib in $dlprefiles; do
+ case $lib in
+ [\\/]* | [A-Za-z]:[\\/]*) abs="$lib" ;;
+ *) abs=`pwd`"/$lib" ;;
+ esac
+ func_append newdlprefiles " $abs"
+ done
+ dlprefiles="$newdlprefiles"
+ fi
+ $RM $output
+ # place dlname in correct position for cygwin
+ # In fact, it would be nice if we could use this code for all target
+ # systems that can't hard-code library paths into their executables
+ # and that have no shared library path variable independent of PATH,
+ # but it turns out we can't easily determine that from inspecting
+ # libtool variables, so we have to hard-code the OSs to which it
+ # applies here; at the moment, that means platforms that use the PE
+ # object format with DLL files. See the long comment at the top of
+ # tests/bindir.at for full details.
+ tdlname=$dlname
+ case $host,$output,$installed,$module,$dlname in
+ *cygwin*,*lai,yes,no,*.dll | *mingw*,*lai,yes,no,*.dll | *cegcc*,*lai,yes,no,*.dll)
+ # If a -bindir argument was supplied, place the dll there.
+ if test "x$bindir" != x ;
+ then
+ func_relative_path "$install_libdir" "$bindir"
+ tdlname=$func_relative_path_result$dlname
+ else
+ # Otherwise fall back on heuristic.
+ tdlname=../bin/$dlname
+ fi
+ ;;
+ esac
+ $ECHO > $output "\
+# $outputname - a libtool library file
+# Generated by $PROGRAM (GNU $PACKAGE$TIMESTAMP) $VERSION
+#
+# Please DO NOT delete this file!
+# It is necessary for linking the library.
+
+# The name that we can dlopen(3).
+dlname='$tdlname'
+
+# Names of this library.
+library_names='$library_names'
+
+# The name of the static archive.
+old_library='$old_library'
+
+# Linker flags that can not go in dependency_libs.
+inherited_linker_flags='$new_inherited_linker_flags'
+
+# Libraries that this one depends upon.
+dependency_libs='$dependency_libs'
+
+# Names of additional weak libraries provided by this library
+weak_library_names='$weak_libs'
+
+# Version information for $libname.
+current=$current
+age=$age
+revision=$revision
+
+# Is this an already installed library?
+installed=$installed
+
+# Should we warn about portability when linking against -modules?
+shouldnotlink=$module
+
+# Files to dlopen/dlpreopen
+dlopen='$dlfiles'
+dlpreopen='$dlprefiles'
+
+# Directory that this library needs to be installed in:
+libdir='$install_libdir'"
+ if test "$installed" = no && test "$need_relink" = yes; then
+ $ECHO >> $output "\
+relink_command=\"$relink_command\""
+ fi
+ done
+ }
+
+ # Do a symbolic link so that the libtool archive can be found in
+ # LD_LIBRARY_PATH before the program is installed.
+ func_show_eval '( cd "$output_objdir" && $RM "$outputname" && $LN_S "../$outputname" "$outputname" )' 'exit $?'
+ ;;
+ esac
+ exit $EXIT_SUCCESS
+}
+
+{ test "$opt_mode" = link || test "$opt_mode" = relink; } &&
+ func_mode_link ${1+"$@"}
+
+
+# func_mode_uninstall arg...
+func_mode_uninstall ()
+{
+ $opt_debug
+ RM="$nonopt"
+ files=
+ rmforce=
+ exit_status=0
+
+ # This variable tells wrapper scripts just to set variables rather
+ # than running their programs.
+ libtool_install_magic="$magic"
+
+ for arg
+ do
+ case $arg in
+ -f) func_append RM " $arg"; rmforce=yes ;;
+ -*) func_append RM " $arg" ;;
+ *) func_append files " $arg" ;;
+ esac
+ done
+
+ test -z "$RM" && \
+ func_fatal_help "you must specify an RM program"
+
+ rmdirs=
+
+ for file in $files; do
+ func_dirname "$file" "" "."
+ dir="$func_dirname_result"
+ if test "X$dir" = X.; then
+ odir="$objdir"
+ else
+ odir="$dir/$objdir"
+ fi
+ func_basename "$file"
+ name="$func_basename_result"
+ test "$opt_mode" = uninstall && odir="$dir"
+
+ # Remember odir for removal later, being careful to avoid duplicates
+ if test "$opt_mode" = clean; then
+ case " $rmdirs " in
+ *" $odir "*) ;;
+ *) func_append rmdirs " $odir" ;;
+ esac
+ fi
+
+ # Don't error if the file doesn't exist and rm -f was used.
+ if { test -L "$file"; } >/dev/null 2>&1 ||
+ { test -h "$file"; } >/dev/null 2>&1 ||
+ test -f "$file"; then
+ :
+ elif test -d "$file"; then
+ exit_status=1
+ continue
+ elif test "$rmforce" = yes; then
+ continue
+ fi
+
+ rmfiles="$file"
+
+ case $name in
+ *.la)
+ # Possibly a libtool archive, so verify it.
+ if func_lalib_p "$file"; then
+ func_source $dir/$name
+
+ # Delete the libtool libraries and symlinks.
+ for n in $library_names; do
+ func_append rmfiles " $odir/$n"
+ done
+ test -n "$old_library" && func_append rmfiles " $odir/$old_library"
+
+ case "$opt_mode" in
+ clean)
+ case " $library_names " in
+ *" $dlname "*) ;;
+ *) test -n "$dlname" && func_append rmfiles " $odir/$dlname" ;;
+ esac
+ test -n "$libdir" && func_append rmfiles " $odir/$name $odir/${name}i"
+ ;;
+ uninstall)
+ if test -n "$library_names"; then
+ # Do each command in the postuninstall commands.
+ func_execute_cmds "$postuninstall_cmds" 'test "$rmforce" = yes || exit_status=1'
+ fi
+
+ if test -n "$old_library"; then
+ # Do each command in the old_postuninstall commands.
+ func_execute_cmds "$old_postuninstall_cmds" 'test "$rmforce" = yes || exit_status=1'
+ fi
+ # FIXME: should reinstall the best remaining shared library.
+ ;;
+ esac
+ fi
+ ;;
+
+ *.lo)
+ # Possibly a libtool object, so verify it.
+ if func_lalib_p "$file"; then
+
+ # Read the .lo file
+ func_source $dir/$name
+
+ # Add PIC object to the list of files to remove.
+ if test -n "$pic_object" &&
+ test "$pic_object" != none; then
+ func_append rmfiles " $dir/$pic_object"
+ fi
+
+ # Add non-PIC object to the list of files to remove.
+ if test -n "$non_pic_object" &&
+ test "$non_pic_object" != none; then
+ func_append rmfiles " $dir/$non_pic_object"
+ fi
+ fi
+ ;;
+
+ *)
+ if test "$opt_mode" = clean ; then
+ noexename=$name
+ case $file in
+ *.exe)
+ func_stripname '' '.exe' "$file"
+ file=$func_stripname_result
+ func_stripname '' '.exe' "$name"
+ noexename=$func_stripname_result
+ # $file with .exe has already been added to rmfiles,
+ # add $file without .exe
+ func_append rmfiles " $file"
+ ;;
+ esac
+ # Do a test to see if this is a libtool program.
+ if func_ltwrapper_p "$file"; then
+ if func_ltwrapper_executable_p "$file"; then
+ func_ltwrapper_scriptname "$file"
+ relink_command=
+ func_source $func_ltwrapper_scriptname_result
+ func_append rmfiles " $func_ltwrapper_scriptname_result"
+ else
+ relink_command=
+ func_source $dir/$noexename
+ fi
+
+ # note $name still contains .exe if it was in $file originally
+ # as does the version of $file that was added into $rmfiles
+ func_append rmfiles " $odir/$name $odir/${name}S.${objext}"
+ if test "$fast_install" = yes && test -n "$relink_command"; then
+ func_append rmfiles " $odir/lt-$name"
+ fi
+ if test "X$noexename" != "X$name" ; then
+ func_append rmfiles " $odir/lt-${noexename}.c"
+ fi
+ fi
+ fi
+ ;;
+ esac
+ func_show_eval "$RM $rmfiles" 'exit_status=1'
+ done
+
+ # Try to remove the ${objdir}s in the directories where we deleted files
+ for dir in $rmdirs; do
+ if test -d "$dir"; then
+ func_show_eval "rmdir $dir >/dev/null 2>&1"
+ fi
+ done
+
+ exit $exit_status
+}
+
+{ test "$opt_mode" = uninstall || test "$opt_mode" = clean; } &&
+ func_mode_uninstall ${1+"$@"}
+
+test -z "$opt_mode" && {
+ help="$generic_help"
+ func_fatal_help "you must specify a MODE"
+}
+
+test -z "$exec_cmd" && \
+ func_fatal_help "invalid operation mode \`$opt_mode'"
+
+if test -n "$exec_cmd"; then
+ eval exec "$exec_cmd"
+ exit $EXIT_FAILURE
+fi
+
+exit $exit_status
+
+
+# The TAGs below are defined such that we never get into a situation
+# in which we disable both kinds of libraries. Given conflicting
+# choices, we go for a static library, that is the most portable,
+# since we can't tell whether shared libraries were disabled because
+# the user asked for that or because the platform doesn't support
+# them. This is particularly important on AIX, because we don't
+# support having both static and shared libraries enabled at the same
+# time on that platform, so we default to a shared-only configuration.
+# If a disable-shared tag is given, we'll fallback to a static-only
+# configuration. But we'll never go from static-only to shared-only.
+
+# ### BEGIN LIBTOOL TAG CONFIG: disable-shared
+build_libtool_libs=no
+build_old_libs=yes
+# ### END LIBTOOL TAG CONFIG: disable-shared
+
+# ### BEGIN LIBTOOL TAG CONFIG: disable-static
+build_old_libs=`case $build_libtool_libs in yes) echo no;; *) echo yes;; esac`
+# ### END LIBTOOL TAG CONFIG: disable-static
+
+# Local Variables:
+# mode:shell-script
+# sh-indentation:2
+# End:
+# vi:sw=2
+
diff --git a/config.aux/missing b/config.aux/missing
new file mode 100755
index 0000000..28055d2
--- /dev/null
+++ b/config.aux/missing
@@ -0,0 +1,376 @@
+#! /bin/sh
+# Common stub for a few missing GNU programs while installing.
+
+scriptversion=2009-04-28.21; # UTC
+
+# Copyright (C) 1996, 1997, 1999, 2000, 2002, 2003, 2004, 2005, 2006,
+# 2008, 2009 Free Software Foundation, Inc.
+# Originally by Fran,cois Pinard <pinard@iro.umontreal.ca>, 1996.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+if test $# -eq 0; then
+ echo 1>&2 "Try \`$0 --help' for more information"
+ exit 1
+fi
+
+run=:
+sed_output='s/.* --output[ =]\([^ ]*\).*/\1/p'
+sed_minuso='s/.* -o \([^ ]*\).*/\1/p'
+
+# In the cases where this matters, `missing' is being run in the
+# srcdir already.
+if test -f configure.ac; then
+ configure_ac=configure.ac
+else
+ configure_ac=configure.in
+fi
+
+msg="missing on your system"
+
+case $1 in
+--run)
+ # Try to run requested program, and just exit if it succeeds.
+ run=
+ shift
+ "$@" && exit 0
+ # Exit code 63 means version mismatch. This often happens
+ # when the user try to use an ancient version of a tool on
+ # a file that requires a minimum version. In this case we
+ # we should proceed has if the program had been absent, or
+ # if --run hadn't been passed.
+ if test $? = 63; then
+ run=:
+ msg="probably too old"
+ fi
+ ;;
+
+ -h|--h|--he|--hel|--help)
+ echo "\
+$0 [OPTION]... PROGRAM [ARGUMENT]...
+
+Handle \`PROGRAM [ARGUMENT]...' for when PROGRAM is missing, or return an
+error status if there is no known handling for PROGRAM.
+
+Options:
+ -h, --help display this help and exit
+ -v, --version output version information and exit
+ --run try to run the given command, and emulate it if it fails
+
+Supported PROGRAM values:
+ aclocal touch file \`aclocal.m4'
+ autoconf touch file \`configure'
+ autoheader touch file \`config.h.in'
+ autom4te touch the output file, or create a stub one
+ automake touch all \`Makefile.in' files
+ bison create \`y.tab.[ch]', if possible, from existing .[ch]
+ flex create \`lex.yy.c', if possible, from existing .c
+ help2man touch the output file
+ lex create \`lex.yy.c', if possible, from existing .c
+ makeinfo touch the output file
+ tar try tar, gnutar, gtar, then tar without non-portable flags
+ yacc create \`y.tab.[ch]', if possible, from existing .[ch]
+
+Version suffixes to PROGRAM as well as the prefixes \`gnu-', \`gnu', and
+\`g' are ignored when checking the name.
+
+Send bug reports to <bug-automake@gnu.org>."
+ exit $?
+ ;;
+
+ -v|--v|--ve|--ver|--vers|--versi|--versio|--version)
+ echo "missing $scriptversion (GNU Automake)"
+ exit $?
+ ;;
+
+ -*)
+ echo 1>&2 "$0: Unknown \`$1' option"
+ echo 1>&2 "Try \`$0 --help' for more information"
+ exit 1
+ ;;
+
+esac
+
+# normalize program name to check for.
+program=`echo "$1" | sed '
+ s/^gnu-//; t
+ s/^gnu//; t
+ s/^g//; t'`
+
+# Now exit if we have it, but it failed. Also exit now if we
+# don't have it and --version was passed (most likely to detect
+# the program). This is about non-GNU programs, so use $1 not
+# $program.
+case $1 in
+ lex*|yacc*)
+ # Not GNU programs, they don't have --version.
+ ;;
+
+ tar*)
+ if test -n "$run"; then
+ echo 1>&2 "ERROR: \`tar' requires --run"
+ exit 1
+ elif test "x$2" = "x--version" || test "x$2" = "x--help"; then
+ exit 1
+ fi
+ ;;
+
+ *)
+ if test -z "$run" && ($1 --version) > /dev/null 2>&1; then
+ # We have it, but it failed.
+ exit 1
+ elif test "x$2" = "x--version" || test "x$2" = "x--help"; then
+ # Could not run --version or --help. This is probably someone
+ # running `$TOOL --version' or `$TOOL --help' to check whether
+ # $TOOL exists and not knowing $TOOL uses missing.
+ exit 1
+ fi
+ ;;
+esac
+
+# If it does not exist, or fails to run (possibly an outdated version),
+# try to emulate it.
+case $program in
+ aclocal*)
+ echo 1>&2 "\
+WARNING: \`$1' is $msg. You should only need it if
+ you modified \`acinclude.m4' or \`${configure_ac}'. You might want
+ to install the \`Automake' and \`Perl' packages. Grab them from
+ any GNU archive site."
+ touch aclocal.m4
+ ;;
+
+ autoconf*)
+ echo 1>&2 "\
+WARNING: \`$1' is $msg. You should only need it if
+ you modified \`${configure_ac}'. You might want to install the
+ \`Autoconf' and \`GNU m4' packages. Grab them from any GNU
+ archive site."
+ touch configure
+ ;;
+
+ autoheader*)
+ echo 1>&2 "\
+WARNING: \`$1' is $msg. You should only need it if
+ you modified \`acconfig.h' or \`${configure_ac}'. You might want
+ to install the \`Autoconf' and \`GNU m4' packages. Grab them
+ from any GNU archive site."
+ files=`sed -n 's/^[ ]*A[CM]_CONFIG_HEADER(\([^)]*\)).*/\1/p' ${configure_ac}`
+ test -z "$files" && files="config.h"
+ touch_files=
+ for f in $files; do
+ case $f in
+ *:*) touch_files="$touch_files "`echo "$f" |
+ sed -e 's/^[^:]*://' -e 's/:.*//'`;;
+ *) touch_files="$touch_files $f.in";;
+ esac
+ done
+ touch $touch_files
+ ;;
+
+ automake*)
+ echo 1>&2 "\
+WARNING: \`$1' is $msg. You should only need it if
+ you modified \`Makefile.am', \`acinclude.m4' or \`${configure_ac}'.
+ You might want to install the \`Automake' and \`Perl' packages.
+ Grab them from any GNU archive site."
+ find . -type f -name Makefile.am -print |
+ sed 's/\.am$/.in/' |
+ while read f; do touch "$f"; done
+ ;;
+
+ autom4te*)
+ echo 1>&2 "\
+WARNING: \`$1' is needed, but is $msg.
+ You might have modified some files without having the
+ proper tools for further handling them.
+ You can get \`$1' as part of \`Autoconf' from any GNU
+ archive site."
+
+ file=`echo "$*" | sed -n "$sed_output"`
+ test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"`
+ if test -f "$file"; then
+ touch $file
+ else
+ test -z "$file" || exec >$file
+ echo "#! /bin/sh"
+ echo "# Created by GNU Automake missing as a replacement of"
+ echo "# $ $@"
+ echo "exit 0"
+ chmod +x $file
+ exit 1
+ fi
+ ;;
+
+ bison*|yacc*)
+ echo 1>&2 "\
+WARNING: \`$1' $msg. You should only need it if
+ you modified a \`.y' file. You may need the \`Bison' package
+ in order for those modifications to take effect. You can get
+ \`Bison' from any GNU archive site."
+ rm -f y.tab.c y.tab.h
+ if test $# -ne 1; then
+ eval LASTARG="\${$#}"
+ case $LASTARG in
+ *.y)
+ SRCFILE=`echo "$LASTARG" | sed 's/y$/c/'`
+ if test -f "$SRCFILE"; then
+ cp "$SRCFILE" y.tab.c
+ fi
+ SRCFILE=`echo "$LASTARG" | sed 's/y$/h/'`
+ if test -f "$SRCFILE"; then
+ cp "$SRCFILE" y.tab.h
+ fi
+ ;;
+ esac
+ fi
+ if test ! -f y.tab.h; then
+ echo >y.tab.h
+ fi
+ if test ! -f y.tab.c; then
+ echo 'main() { return 0; }' >y.tab.c
+ fi
+ ;;
+
+ lex*|flex*)
+ echo 1>&2 "\
+WARNING: \`$1' is $msg. You should only need it if
+ you modified a \`.l' file. You may need the \`Flex' package
+ in order for those modifications to take effect. You can get
+ \`Flex' from any GNU archive site."
+ rm -f lex.yy.c
+ if test $# -ne 1; then
+ eval LASTARG="\${$#}"
+ case $LASTARG in
+ *.l)
+ SRCFILE=`echo "$LASTARG" | sed 's/l$/c/'`
+ if test -f "$SRCFILE"; then
+ cp "$SRCFILE" lex.yy.c
+ fi
+ ;;
+ esac
+ fi
+ if test ! -f lex.yy.c; then
+ echo 'main() { return 0; }' >lex.yy.c
+ fi
+ ;;
+
+ help2man*)
+ echo 1>&2 "\
+WARNING: \`$1' is $msg. You should only need it if
+ you modified a dependency of a manual page. You may need the
+ \`Help2man' package in order for those modifications to take
+ effect. You can get \`Help2man' from any GNU archive site."
+
+ file=`echo "$*" | sed -n "$sed_output"`
+ test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"`
+ if test -f "$file"; then
+ touch $file
+ else
+ test -z "$file" || exec >$file
+ echo ".ab help2man is required to generate this page"
+ exit $?
+ fi
+ ;;
+
+ makeinfo*)
+ echo 1>&2 "\
+WARNING: \`$1' is $msg. You should only need it if
+ you modified a \`.texi' or \`.texinfo' file, or any other file
+ indirectly affecting the aspect of the manual. The spurious
+ call might also be the consequence of using a buggy \`make' (AIX,
+ DU, IRIX). You might want to install the \`Texinfo' package or
+ the \`GNU make' package. Grab either from any GNU archive site."
+ # The file to touch is that specified with -o ...
+ file=`echo "$*" | sed -n "$sed_output"`
+ test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"`
+ if test -z "$file"; then
+ # ... or it is the one specified with @setfilename ...
+ infile=`echo "$*" | sed 's/.* \([^ ]*\) *$/\1/'`
+ file=`sed -n '
+ /^@setfilename/{
+ s/.* \([^ ]*\) *$/\1/
+ p
+ q
+ }' $infile`
+ # ... or it is derived from the source name (dir/f.texi becomes f.info)
+ test -z "$file" && file=`echo "$infile" | sed 's,.*/,,;s,.[^.]*$,,'`.info
+ fi
+ # If the file does not exist, the user really needs makeinfo;
+ # let's fail without touching anything.
+ test -f $file || exit 1
+ touch $file
+ ;;
+
+ tar*)
+ shift
+
+ # We have already tried tar in the generic part.
+ # Look for gnutar/gtar before invocation to avoid ugly error
+ # messages.
+ if (gnutar --version > /dev/null 2>&1); then
+ gnutar "$@" && exit 0
+ fi
+ if (gtar --version > /dev/null 2>&1); then
+ gtar "$@" && exit 0
+ fi
+ firstarg="$1"
+ if shift; then
+ case $firstarg in
+ *o*)
+ firstarg=`echo "$firstarg" | sed s/o//`
+ tar "$firstarg" "$@" && exit 0
+ ;;
+ esac
+ case $firstarg in
+ *h*)
+ firstarg=`echo "$firstarg" | sed s/h//`
+ tar "$firstarg" "$@" && exit 0
+ ;;
+ esac
+ fi
+
+ echo 1>&2 "\
+WARNING: I can't seem to be able to run \`tar' with the given arguments.
+ You may want to install GNU tar or Free paxutils, or check the
+ command line arguments."
+ exit 1
+ ;;
+
+ *)
+ echo 1>&2 "\
+WARNING: \`$1' is needed, and is $msg.
+ You might have modified some files without having the
+ proper tools for further handling them. Check the \`README' file,
+ it often tells you about the needed prerequisites for installing
+ this package. You may also peek at any GNU archive site, in case
+ some other package would contain this missing \`$1' program."
+ exit 1
+ ;;
+esac
+
+exit 0
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "scriptversion="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-time-zone: "UTC"
+# time-stamp-end: "; # UTC"
+# End:
diff --git a/configure b/configure
new file mode 100755
index 0000000..7c5b47b
--- /dev/null
+++ b/configure
@@ -0,0 +1,21657 @@
+#! /bin/sh
+# Guess values for system-dependent variables and create Makefiles.
+# Generated by GNU Autoconf 2.68 for GoSam Convenience Package 1.0.
+#
+# Report bugs to <reiterth@mpp.mpg.de>.
+#
+#
+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
+# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software
+# Foundation, Inc.
+#
+#
+# This configure script is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+## -------------------- ##
+## M4sh Initialization. ##
+## -------------------- ##
+
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then :
+ emulate sh
+ NULLCMD=:
+ # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in #(
+ *posix*) :
+ set -o posix ;; #(
+ *) :
+ ;;
+esac
+fi
+
+
+as_nl='
+'
+export as_nl
+# Printing a long string crashes Solaris 7 /usr/bin/printf.
+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo
+# Prefer a ksh shell builtin over an external printf program on Solaris,
+# but without wasting forks for bash or zsh.
+if test -z "$BASH_VERSION$ZSH_VERSION" \
+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='print -r --'
+ as_echo_n='print -rn --'
+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='printf %s\n'
+ as_echo_n='printf %s'
+else
+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then
+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'
+ as_echo_n='/usr/ucb/echo -n'
+ else
+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'
+ as_echo_n_body='eval
+ arg=$1;
+ case $arg in #(
+ *"$as_nl"*)
+ expr "X$arg" : "X\\(.*\\)$as_nl";
+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;
+ esac;
+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"
+ '
+ export as_echo_n_body
+ as_echo_n='sh -c $as_echo_n_body as_echo'
+ fi
+ export as_echo_body
+ as_echo='sh -c $as_echo_body as_echo'
+fi
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; then
+ PATH_SEPARATOR=:
+ (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
+ (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
+ PATH_SEPARATOR=';'
+ }
+fi
+
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+IFS=" "" $as_nl"
+
+# Find who we are. Look in the path if we contain no directory separator.
+as_myself=
+case $0 in #((
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+ done
+IFS=$as_save_IFS
+
+ ;;
+esac
+# We did not find ourselves, most probably we were run as `sh COMMAND'
+# in which case we are not to be found in the path.
+if test "x$as_myself" = x; then
+ as_myself=$0
+fi
+if test ! -f "$as_myself"; then
+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+# Unset variables that we do not need and which cause bugs (e.g. in
+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"
+# suppresses any "Segmentation fault" message there. '((' could
+# trigger a bug in pdksh 5.2.14.
+for as_var in BASH_ENV ENV MAIL MAILPATH
+do eval test x\${$as_var+set} = xset \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
+PS1='$ '
+PS2='> '
+PS4='+ '
+
+# NLS nuisances.
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# CDPATH.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+if test "x$CONFIG_SHELL" = x; then
+ as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then :
+ emulate sh
+ NULLCMD=:
+ # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '\${1+\"\$@\"}'='\"\$@\"'
+ setopt NO_GLOB_SUBST
+else
+ case \`(set -o) 2>/dev/null\` in #(
+ *posix*) :
+ set -o posix ;; #(
+ *) :
+ ;;
+esac
+fi
+"
+ as_required="as_fn_return () { (exit \$1); }
+as_fn_success () { as_fn_return 0; }
+as_fn_failure () { as_fn_return 1; }
+as_fn_ret_success () { return 0; }
+as_fn_ret_failure () { return 1; }
+
+exitcode=0
+as_fn_success || { exitcode=1; echo as_fn_success failed.; }
+as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; }
+as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; }
+as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; }
+if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then :
+
+else
+ exitcode=1; echo positional parameters were not saved.
+fi
+test x\$exitcode = x0 || exit 1"
+ as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO
+ as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO
+ eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&
+ test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1
+
+ test -n \"\${ZSH_VERSION+set}\${BASH_VERSION+set}\" || (
+ ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+ ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO
+ ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO
+ PATH=/empty FPATH=/empty; export PATH FPATH
+ test \"X\`printf %s \$ECHO\`\" = \"X\$ECHO\" \\
+ || test \"X\`print -r -- \$ECHO\`\" = \"X\$ECHO\" ) || exit 1
+test \$(( 1 + 1 )) = 2 || exit 1"
+ if (eval "$as_required") 2>/dev/null; then :
+ as_have_required=yes
+else
+ as_have_required=no
+fi
+ if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then :
+
+else
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+as_found=false
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ as_found=:
+ case $as_dir in #(
+ /*)
+ for as_base in sh bash ksh sh5; do
+ # Try only shells that exist, to save several forks.
+ as_shell=$as_dir/$as_base
+ if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
+ { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then :
+ CONFIG_SHELL=$as_shell as_have_required=yes
+ if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then :
+ break 2
+fi
+fi
+ done;;
+ esac
+ as_found=false
+done
+$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&
+ { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then :
+ CONFIG_SHELL=$SHELL as_have_required=yes
+fi; }
+IFS=$as_save_IFS
+
+
+ if test "x$CONFIG_SHELL" != x; then :
+ # We cannot yet assume a decent shell, so we have to provide a
+ # neutralization value for shells without unset; and this also
+ # works around shells that cannot unset nonexistent variables.
+ # Preserve -v and -x to the replacement shell.
+ BASH_ENV=/dev/null
+ ENV=/dev/null
+ (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
+ export CONFIG_SHELL
+ case $- in # ((((
+ *v*x* | *x*v* ) as_opts=-vx ;;
+ *v* ) as_opts=-v ;;
+ *x* ) as_opts=-x ;;
+ * ) as_opts= ;;
+ esac
+ exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"}
+fi
+
+ if test x$as_have_required = xno; then :
+ $as_echo "$0: This script requires a shell more modern than all"
+ $as_echo "$0: the shells that I found on your system."
+ if test x${ZSH_VERSION+set} = xset ; then
+ $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should"
+ $as_echo "$0: be upgraded to zsh 4.3.4 or later."
+ else
+ $as_echo "$0: Please tell bug-autoconf@gnu.org and
+$0: reiterth@mpp.mpg.de about your system, including any
+$0: error possibly output before this message. Then install
+$0: a modern shell, or manually run the script under such a
+$0: shell if you do have one."
+ fi
+ exit 1
+fi
+fi
+fi
+SHELL=${CONFIG_SHELL-/bin/sh}
+export SHELL
+# Unset more variables known to interfere with behavior of common tools.
+CLICOLOR_FORCE= GREP_OPTIONS=
+unset CLICOLOR_FORCE GREP_OPTIONS
+
+## --------------------- ##
+## M4sh Shell Functions. ##
+## --------------------- ##
+# as_fn_unset VAR
+# ---------------
+# Portably unset VAR.
+as_fn_unset ()
+{
+ { eval $1=; unset $1;}
+}
+as_unset=as_fn_unset
+
+# as_fn_set_status STATUS
+# -----------------------
+# Set $? to STATUS, without forking.
+as_fn_set_status ()
+{
+ return $1
+} # as_fn_set_status
+
+# as_fn_exit STATUS
+# -----------------
+# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
+as_fn_exit ()
+{
+ set +e
+ as_fn_set_status $1
+ exit $1
+} # as_fn_exit
+
+# as_fn_mkdir_p
+# -------------
+# Create "$as_dir" as a directory, including parents if necessary.
+as_fn_mkdir_p ()
+{
+
+ case $as_dir in #(
+ -*) as_dir=./$as_dir;;
+ esac
+ test -d "$as_dir" || eval $as_mkdir_p || {
+ as_dirs=
+ while :; do
+ case $as_dir in #(
+ *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
+ *) as_qdir=$as_dir;;
+ esac
+ as_dirs="'$as_qdir' $as_dirs"
+ as_dir=`$as_dirname -- "$as_dir" ||
+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_dir" : 'X\(//\)[^/]' \| \
+ X"$as_dir" : 'X\(//\)$' \| \
+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X"$as_dir" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ test -d "$as_dir" && break
+ done
+ test -z "$as_dirs" || eval "mkdir $as_dirs"
+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"
+
+
+} # as_fn_mkdir_p
+# as_fn_append VAR VALUE
+# ----------------------
+# Append the text in VALUE to the end of the definition contained in VAR. Take
+# advantage of any shell optimizations that allow amortized linear growth over
+# repeated appends, instead of the typical quadratic growth present in naive
+# implementations.
+if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then :
+ eval 'as_fn_append ()
+ {
+ eval $1+=\$2
+ }'
+else
+ as_fn_append ()
+ {
+ eval $1=\$$1\$2
+ }
+fi # as_fn_append
+
+# as_fn_arith ARG...
+# ------------------
+# Perform arithmetic evaluation on the ARGs, and store the result in the
+# global $as_val. Take advantage of shells that can avoid forks. The arguments
+# must be portable across $(()) and expr.
+if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then :
+ eval 'as_fn_arith ()
+ {
+ as_val=$(( $* ))
+ }'
+else
+ as_fn_arith ()
+ {
+ as_val=`expr "$@" || test $? -eq 1`
+ }
+fi # as_fn_arith
+
+
+# as_fn_error STATUS ERROR [LINENO LOG_FD]
+# ----------------------------------------
+# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
+# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
+# script with STATUS, using 1 if that was 0.
+as_fn_error ()
+{
+ as_status=$1; test $as_status -eq 0 && as_status=1
+ if test "$4"; then
+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
+ fi
+ $as_echo "$as_me: error: $2" >&2
+ as_fn_exit $as_status
+} # as_fn_error
+
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
+ as_basename=basename
+else
+ as_basename=false
+fi
+
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
+
+as_me=`$as_basename -- "$0" ||
+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X/"$0" |
+ sed '/^.*\/\([^/][^/]*\)\/*$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+
+# Avoid depending upon Character Ranges.
+as_cr_letters='abcdefghijklmnopqrstuvwxyz'
+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+as_cr_Letters=$as_cr_letters$as_cr_LETTERS
+as_cr_digits='0123456789'
+as_cr_alnum=$as_cr_Letters$as_cr_digits
+
+
+ as_lineno_1=$LINENO as_lineno_1a=$LINENO
+ as_lineno_2=$LINENO as_lineno_2a=$LINENO
+ eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" &&
+ test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || {
+ # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-)
+ sed -n '
+ p
+ /[$]LINENO/=
+ ' <$as_myself |
+ sed '
+ s/[$]LINENO.*/&-/
+ t lineno
+ b
+ :lineno
+ N
+ :loop
+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
+ t loop
+ s/-\n.*//
+ ' >$as_me.lineno &&
+ chmod +x "$as_me.lineno" ||
+ { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }
+
+ # Don't try to exec as it changes $[0], causing all sort of problems
+ # (the dirname of $[0] is not the place where we might find the
+ # original and so on. Autoconf is especially sensitive to this).
+ . "./$as_me.lineno"
+ # Exit status is that of the last command.
+ exit
+}
+
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in #(((((
+-n*)
+ case `echo 'xy\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ xy) ECHO_C='\c';;
+ *) echo `echo ksh88 bug on AIX 6.1` > /dev/null
+ ECHO_T=' ';;
+ esac;;
+*)
+ ECHO_N='-n';;
+esac
+
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
+fi
+if (echo >conf$$.file) 2>/dev/null; then
+ if ln -s conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -p'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -p'
+ elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+ else
+ as_ln_s='cp -p'
+ fi
+else
+ as_ln_s='cp -p'
+fi
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
+
+if mkdir -p . 2>/dev/null; then
+ as_mkdir_p='mkdir -p "$as_dir"'
+else
+ test -d ./-p && rmdir ./-p
+ as_mkdir_p=false
+fi
+
+if test -x / >/dev/null 2>&1; then
+ as_test_x='test -x'
+else
+ if ls -dL / >/dev/null 2>&1; then
+ as_ls_L_option=L
+ else
+ as_ls_L_option=
+ fi
+ as_test_x='
+ eval sh -c '\''
+ if test -d "$1"; then
+ test -d "$1/.";
+ else
+ case $1 in #(
+ -*)set "./$1";;
+ esac;
+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #((
+ ???[sx]*):;;*)false;;esac;fi
+ '\'' sh
+ '
+fi
+as_executable_p=$as_test_x
+
+# Sed expression to map a string onto a valid CPP name.
+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
+
+# Sed expression to map a string onto a valid variable name.
+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
+
+SHELL=${CONFIG_SHELL-/bin/sh}
+
+
+test -n "$DJDIR" || exec 7<&0 </dev/null
+exec 6>&1
+
+# Name of the host.
+# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status,
+# so uname gets run too.
+ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`
+
+#
+# Initializations.
+#
+ac_default_prefix=/usr/local
+ac_clean_files=
+ac_config_libobj_dir=.
+LIBOBJS=
+cross_compiling=no
+subdirs=
+MFLAGS=
+MAKEFLAGS=
+
+# Identity of this package.
+PACKAGE_NAME='GoSam Convenience Package'
+PACKAGE_TARNAME='gosam-contrib'
+PACKAGE_VERSION='1.0'
+PACKAGE_STRING='GoSam Convenience Package 1.0'
+PACKAGE_BUGREPORT='reiterth@mpp.mpg.de'
+PACKAGE_URL='http://projects.hepforge.org/golem/gosam-contrib/'
+
+# Factoring default headers for most tests.
+ac_includes_default="\
+#include <stdio.h>
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+#endif
+#ifdef HAVE_SYS_STAT_H
+# include <sys/stat.h>
+#endif
+#ifdef STDC_HEADERS
+# include <stdlib.h>
+# include <stddef.h>
+#else
+# ifdef HAVE_STDLIB_H
+# include <stdlib.h>
+# endif
+#endif
+#ifdef HAVE_STRING_H
+# if !defined STDC_HEADERS && defined HAVE_MEMORY_H
+# include <memory.h>
+# endif
+# include <string.h>
+#endif
+#ifdef HAVE_STRINGS_H
+# include <strings.h>
+#endif
+#ifdef HAVE_INTTYPES_H
+# include <inttypes.h>
+#endif
+#ifdef HAVE_STDINT_H
+# include <stdint.h>
+#endif
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif"
+
+ac_subst_vars='am__EXEEXT_FALSE
+am__EXEEXT_TRUE
+LTLIBOBJS
+LIBOBJS
+lt_real_kind
+case_wout_lt
+case_with_lt
+conf_wout_lt
+conf_with_lt
+LIBLOOPTOOLS
+SAMURAIVERSION
+case_wout_samurai
+case_with_samurai
+conf_wout_samurai
+conf_with_samurai
+COMPILE_SAMURAI_FALSE
+COMPILE_SAMURAI_TRUE
+COMPILE_TENSREC_FALSE
+COMPILE_TENSREC_TRUE
+case_wout_golem
+case_with_golem
+conf_wout_golem95
+conf_with_golem95
+COMPILE_GOLEM95C_FALSE
+COMPILE_GOLEM95C_TRUE
+case_wout_avh
+case_with_avh
+case_wout_olo
+case_with_olo
+conf_wout_olo
+conf_with_olo
+avh_olo_real_kind
+COMPILE_OLO_FALSE
+COMPILE_OLO_TRUE
+case_wout_ql
+case_with_ql
+conf_wout_ql
+conf_with_ql
+COMPILE_QL_FALSE
+COMPILE_QL_TRUE
+case_wout_ff
+case_with_ff
+conf_wout_ff
+conf_with_ff
+COMPILE_FF_FALSE
+COMPILE_FF_TRUE
+fortran_real_kind
+DATADIR
+CPP
+OTOOL64
+OTOOL
+LIPO
+NMEDIT
+DSYMUTIL
+MANIFEST_TOOL
+RANLIB
+ac_ct_AR
+AR
+DLLTOOL
+OBJDUMP
+LN_S
+NM
+ac_ct_DUMPBIN
+DUMPBIN
+LD
+FGREP
+EGREP
+GREP
+SED
+host_os
+host_vendor
+host_cpu
+host
+build_os
+build_vendor
+build_cpu
+build
+LIBTOOL
+FCFLAGS_f90
+am__fastdepCC_FALSE
+am__fastdepCC_TRUE
+CCDEPMODE
+AMDEPBACKSLASH
+AMDEP_FALSE
+AMDEP_TRUE
+am__quote
+am__include
+DEPDIR
+ac_ct_CC
+CPPFLAGS
+CFLAGS
+CC
+FCLIBS
+ac_ct_FC
+FCFLAGS
+FC
+OBJEXT
+EXEEXT
+ac_ct_F77
+LDFLAGS
+FFLAGS
+F77
+am__untar
+am__tar
+AMTAR
+am__leading_dot
+SET_MAKE
+AWK
+mkdir_p
+MKDIR_P
+INSTALL_STRIP_PROGRAM
+STRIP
+install_sh
+MAKEINFO
+AUTOHEADER
+AUTOMAKE
+AUTOCONF
+ACLOCAL
+VERSION
+PACKAGE
+CYGPATH_W
+am__isrc
+INSTALL_DATA
+INSTALL_SCRIPT
+INSTALL_PROGRAM
+target_alias
+host_alias
+build_alias
+LIBS
+ECHO_T
+ECHO_N
+ECHO_C
+DEFS
+mandir
+localedir
+libdir
+psdir
+pdfdir
+dvidir
+htmldir
+infodir
+docdir
+oldincludedir
+includedir
+localstatedir
+sharedstatedir
+sysconfdir
+datadir
+datarootdir
+libexecdir
+sbindir
+bindir
+program_transform_name
+prefix
+exec_prefix
+PACKAGE_URL
+PACKAGE_BUGREPORT
+PACKAGE_STRING
+PACKAGE_VERSION
+PACKAGE_TARNAME
+PACKAGE_NAME
+PATH_SEPARATOR
+SHELL'
+ac_subst_files=''
+ac_user_opts='
+enable_option_checking
+enable_dependency_tracking
+enable_shared
+enable_static
+with_pic
+enable_fast_install
+with_gnu_ld
+with_sysroot
+enable_libtool_lock
+with_precision
+enable_ff
+enable_ql
+enable_olo
+enable_golem95
+enable_samurai
+with_looptools
+with_lt_precision
+'
+ ac_precious_vars='build_alias
+host_alias
+target_alias
+F77
+FFLAGS
+LDFLAGS
+LIBS
+FC
+FCFLAGS
+CC
+CFLAGS
+CPPFLAGS
+CPP'
+
+
+# Initialize some variables set by options.
+ac_init_help=
+ac_init_version=false
+ac_unrecognized_opts=
+ac_unrecognized_sep=
+# The variables have the same names as the options, with
+# dashes changed to underlines.
+cache_file=/dev/null
+exec_prefix=NONE
+no_create=
+no_recursion=
+prefix=NONE
+program_prefix=NONE
+program_suffix=NONE
+program_transform_name=s,x,x,
+silent=
+site=
+srcdir=
+verbose=
+x_includes=NONE
+x_libraries=NONE
+
+# Installation directory options.
+# These are left unexpanded so users can "make install exec_prefix=/foo"
+# and all the variables that are supposed to be based on exec_prefix
+# by default will actually change.
+# Use braces instead of parens because sh, perl, etc. also accept them.
+# (The list follows the same order as the GNU Coding Standards.)
+bindir='${exec_prefix}/bin'
+sbindir='${exec_prefix}/sbin'
+libexecdir='${exec_prefix}/libexec'
+datarootdir='${prefix}/share'
+datadir='${datarootdir}'
+sysconfdir='${prefix}/etc'
+sharedstatedir='${prefix}/com'
+localstatedir='${prefix}/var'
+includedir='${prefix}/include'
+oldincludedir='/usr/include'
+docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
+infodir='${datarootdir}/info'
+htmldir='${docdir}'
+dvidir='${docdir}'
+pdfdir='${docdir}'
+psdir='${docdir}'
+libdir='${exec_prefix}/lib'
+localedir='${datarootdir}/locale'
+mandir='${datarootdir}/man'
+
+ac_prev=
+ac_dashdash=
+for ac_option
+do
+ # If the previous option needs an argument, assign it.
+ if test -n "$ac_prev"; then
+ eval $ac_prev=\$ac_option
+ ac_prev=
+ continue
+ fi
+
+ case $ac_option in
+ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
+ *=) ac_optarg= ;;
+ *) ac_optarg=yes ;;
+ esac
+
+ # Accept the important Cygnus configure options, so we can diagnose typos.
+
+ case $ac_dashdash$ac_option in
+ --)
+ ac_dashdash=yes ;;
+
+ -bindir | --bindir | --bindi | --bind | --bin | --bi)
+ ac_prev=bindir ;;
+ -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
+ bindir=$ac_optarg ;;
+
+ -build | --build | --buil | --bui | --bu)
+ ac_prev=build_alias ;;
+ -build=* | --build=* | --buil=* | --bui=* | --bu=*)
+ build_alias=$ac_optarg ;;
+
+ -cache-file | --cache-file | --cache-fil | --cache-fi \
+ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
+ ac_prev=cache_file ;;
+ -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
+ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
+ cache_file=$ac_optarg ;;
+
+ --config-cache | -C)
+ cache_file=config.cache ;;
+
+ -datadir | --datadir | --datadi | --datad)
+ ac_prev=datadir ;;
+ -datadir=* | --datadir=* | --datadi=* | --datad=*)
+ datadir=$ac_optarg ;;
+
+ -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \
+ | --dataroo | --dataro | --datar)
+ ac_prev=datarootdir ;;
+ -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \
+ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
+ datarootdir=$ac_optarg ;;
+
+ -disable-* | --disable-*)
+ ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid feature name: $ac_useropt"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"enable_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
+ esac
+ eval enable_$ac_useropt=no ;;
+
+ -docdir | --docdir | --docdi | --doc | --do)
+ ac_prev=docdir ;;
+ -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)
+ docdir=$ac_optarg ;;
+
+ -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)
+ ac_prev=dvidir ;;
+ -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
+ dvidir=$ac_optarg ;;
+
+ -enable-* | --enable-*)
+ ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid feature name: $ac_useropt"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"enable_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
+ esac
+ eval enable_$ac_useropt=\$ac_optarg ;;
+
+ -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
+ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
+ | --exec | --exe | --ex)
+ ac_prev=exec_prefix ;;
+ -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
+ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
+ | --exec=* | --exe=* | --ex=*)
+ exec_prefix=$ac_optarg ;;
+
+ -gas | --gas | --ga | --g)
+ # Obsolete; use --with-gas.
+ with_gas=yes ;;
+
+ -help | --help | --hel | --he | -h)
+ ac_init_help=long ;;
+ -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)
+ ac_init_help=recursive ;;
+ -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
+ ac_init_help=short ;;
+
+ -host | --host | --hos | --ho)
+ ac_prev=host_alias ;;
+ -host=* | --host=* | --hos=* | --ho=*)
+ host_alias=$ac_optarg ;;
+
+ -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)
+ ac_prev=htmldir ;;
+ -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \
+ | --ht=*)
+ htmldir=$ac_optarg ;;
+
+ -includedir | --includedir | --includedi | --included | --include \
+ | --includ | --inclu | --incl | --inc)
+ ac_prev=includedir ;;
+ -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
+ | --includ=* | --inclu=* | --incl=* | --inc=*)
+ includedir=$ac_optarg ;;
+
+ -infodir | --infodir | --infodi | --infod | --info | --inf)
+ ac_prev=infodir ;;
+ -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
+ infodir=$ac_optarg ;;
+
+ -libdir | --libdir | --libdi | --libd)
+ ac_prev=libdir ;;
+ -libdir=* | --libdir=* | --libdi=* | --libd=*)
+ libdir=$ac_optarg ;;
+
+ -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
+ | --libexe | --libex | --libe)
+ ac_prev=libexecdir ;;
+ -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
+ | --libexe=* | --libex=* | --libe=*)
+ libexecdir=$ac_optarg ;;
+
+ -localedir | --localedir | --localedi | --localed | --locale)
+ ac_prev=localedir ;;
+ -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)
+ localedir=$ac_optarg ;;
+
+ -localstatedir | --localstatedir | --localstatedi | --localstated \
+ | --localstate | --localstat | --localsta | --localst | --locals)
+ ac_prev=localstatedir ;;
+ -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
+ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)
+ localstatedir=$ac_optarg ;;
+
+ -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
+ ac_prev=mandir ;;
+ -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
+ mandir=$ac_optarg ;;
+
+ -nfp | --nfp | --nf)
+ # Obsolete; use --without-fp.
+ with_fp=no ;;
+
+ -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+ | --no-cr | --no-c | -n)
+ no_create=yes ;;
+
+ -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
+ no_recursion=yes ;;
+
+ -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
+ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
+ | --oldin | --oldi | --old | --ol | --o)
+ ac_prev=oldincludedir ;;
+ -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
+ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
+ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
+ oldincludedir=$ac_optarg ;;
+
+ -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+ ac_prev=prefix ;;
+ -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+ prefix=$ac_optarg ;;
+
+ -program-prefix | --program-prefix | --program-prefi | --program-pref \
+ | --program-pre | --program-pr | --program-p)
+ ac_prev=program_prefix ;;
+ -program-prefix=* | --program-prefix=* | --program-prefi=* \
+ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
+ program_prefix=$ac_optarg ;;
+
+ -program-suffix | --program-suffix | --program-suffi | --program-suff \
+ | --program-suf | --program-su | --program-s)
+ ac_prev=program_suffix ;;
+ -program-suffix=* | --program-suffix=* | --program-suffi=* \
+ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
+ program_suffix=$ac_optarg ;;
+
+ -program-transform-name | --program-transform-name \
+ | --program-transform-nam | --program-transform-na \
+ | --program-transform-n | --program-transform- \
+ | --program-transform | --program-transfor \
+ | --program-transfo | --program-transf \
+ | --program-trans | --program-tran \
+ | --progr-tra | --program-tr | --program-t)
+ ac_prev=program_transform_name ;;
+ -program-transform-name=* | --program-transform-name=* \
+ | --program-transform-nam=* | --program-transform-na=* \
+ | --program-transform-n=* | --program-transform-=* \
+ | --program-transform=* | --program-transfor=* \
+ | --program-transfo=* | --program-transf=* \
+ | --program-trans=* | --program-tran=* \
+ | --progr-tra=* | --program-tr=* | --program-t=*)
+ program_transform_name=$ac_optarg ;;
+
+ -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)
+ ac_prev=pdfdir ;;
+ -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)
+ pdfdir=$ac_optarg ;;
+
+ -psdir | --psdir | --psdi | --psd | --ps)
+ ac_prev=psdir ;;
+ -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
+ psdir=$ac_optarg ;;
+
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil)
+ silent=yes ;;
+
+ -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
+ ac_prev=sbindir ;;
+ -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
+ | --sbi=* | --sb=*)
+ sbindir=$ac_optarg ;;
+
+ -sharedstatedir | --sharedstatedir | --sharedstatedi \
+ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
+ | --sharedst | --shareds | --shared | --share | --shar \
+ | --sha | --sh)
+ ac_prev=sharedstatedir ;;
+ -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
+ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
+ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
+ | --sha=* | --sh=*)
+ sharedstatedir=$ac_optarg ;;
+
+ -site | --site | --sit)
+ ac_prev=site ;;
+ -site=* | --site=* | --sit=*)
+ site=$ac_optarg ;;
+
+ -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
+ ac_prev=srcdir ;;
+ -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
+ srcdir=$ac_optarg ;;
+
+ -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
+ | --syscon | --sysco | --sysc | --sys | --sy)
+ ac_prev=sysconfdir ;;
+ -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
+ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
+ sysconfdir=$ac_optarg ;;
+
+ -target | --target | --targe | --targ | --tar | --ta | --t)
+ ac_prev=target_alias ;;
+ -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
+ target_alias=$ac_optarg ;;
+
+ -v | -verbose | --verbose | --verbos | --verbo | --verb)
+ verbose=yes ;;
+
+ -version | --version | --versio | --versi | --vers | -V)
+ ac_init_version=: ;;
+
+ -with-* | --with-*)
+ ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid package name: $ac_useropt"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"with_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
+ esac
+ eval with_$ac_useropt=\$ac_optarg ;;
+
+ -without-* | --without-*)
+ ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid package name: $ac_useropt"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"with_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
+ esac
+ eval with_$ac_useropt=no ;;
+
+ --x)
+ # Obsolete; use --with-x.
+ with_x=yes ;;
+
+ -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
+ | --x-incl | --x-inc | --x-in | --x-i)
+ ac_prev=x_includes ;;
+ -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
+ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
+ x_includes=$ac_optarg ;;
+
+ -x-libraries | --x-libraries | --x-librarie | --x-librari \
+ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
+ ac_prev=x_libraries ;;
+ -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
+ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
+ x_libraries=$ac_optarg ;;
+
+ -*) as_fn_error $? "unrecognized option: \`$ac_option'
+Try \`$0 --help' for more information"
+ ;;
+
+ *=*)
+ ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`
+ # Reject names that are not valid shell variable names.
+ case $ac_envvar in #(
+ '' | [0-9]* | *[!_$as_cr_alnum]* )
+ as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;
+ esac
+ eval $ac_envvar=\$ac_optarg
+ export $ac_envvar ;;
+
+ *)
+ # FIXME: should be removed in autoconf 3.0.
+ $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2
+ expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2
+ : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"
+ ;;
+
+ esac
+done
+
+if test -n "$ac_prev"; then
+ ac_option=--`echo $ac_prev | sed 's/_/-/g'`
+ as_fn_error $? "missing argument to $ac_option"
+fi
+
+if test -n "$ac_unrecognized_opts"; then
+ case $enable_option_checking in
+ no) ;;
+ fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;;
+ *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;;
+ esac
+fi
+
+# Check all directory arguments for consistency.
+for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
+ datadir sysconfdir sharedstatedir localstatedir includedir \
+ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
+ libdir localedir mandir
+do
+ eval ac_val=\$$ac_var
+ # Remove trailing slashes.
+ case $ac_val in
+ */ )
+ ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'`
+ eval $ac_var=\$ac_val;;
+ esac
+ # Be sure to have absolute directory names.
+ case $ac_val in
+ [\\/$]* | ?:[\\/]* ) continue;;
+ NONE | '' ) case $ac_var in *prefix ) continue;; esac;;
+ esac
+ as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val"
+done
+
+# There might be people who depend on the old broken behavior: `$host'
+# used to hold the argument of --host etc.
+# FIXME: To remove some day.
+build=$build_alias
+host=$host_alias
+target=$target_alias
+
+# FIXME: To remove some day.
+if test "x$host_alias" != x; then
+ if test "x$build_alias" = x; then
+ cross_compiling=maybe
+ $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host.
+ If a cross compiler is detected then cross compile mode will be used" >&2
+ elif test "x$build_alias" != "x$host_alias"; then
+ cross_compiling=yes
+ fi
+fi
+
+ac_tool_prefix=
+test -n "$host_alias" && ac_tool_prefix=$host_alias-
+
+test "$silent" = yes && exec 6>/dev/null
+
+
+ac_pwd=`pwd` && test -n "$ac_pwd" &&
+ac_ls_di=`ls -di .` &&
+ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||
+ as_fn_error $? "working directory cannot be determined"
+test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||
+ as_fn_error $? "pwd does not report name of working directory"
+
+
+# Find the source files, if location was not specified.
+if test -z "$srcdir"; then
+ ac_srcdir_defaulted=yes
+ # Try the directory containing this script, then the parent directory.
+ ac_confdir=`$as_dirname -- "$as_myself" ||
+$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_myself" : 'X\(//\)[^/]' \| \
+ X"$as_myself" : 'X\(//\)$' \| \
+ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X"$as_myself" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ srcdir=$ac_confdir
+ if test ! -r "$srcdir/$ac_unique_file"; then
+ srcdir=..
+ fi
+else
+ ac_srcdir_defaulted=no
+fi
+if test ! -r "$srcdir/$ac_unique_file"; then
+ test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."
+ as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir"
+fi
+ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"
+ac_abs_confdir=`(
+ cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg"
+ pwd)`
+# When building in place, set srcdir=.
+if test "$ac_abs_confdir" = "$ac_pwd"; then
+ srcdir=.
+fi
+# Remove unnecessary trailing slashes from srcdir.
+# Double slashes in file names in object file debugging info
+# mess up M-x gdb in Emacs.
+case $srcdir in
+*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;
+esac
+for ac_var in $ac_precious_vars; do
+ eval ac_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_env_${ac_var}_value=\$${ac_var}
+ eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_cv_env_${ac_var}_value=\$${ac_var}
+done
+
+#
+# Report the --help message.
+#
+if test "$ac_init_help" = "long"; then
+ # Omit some internal or obsolete options to make the list less imposing.
+ # This message is too long to be a string in the A/UX 3.1 sh.
+ cat <<_ACEOF
+\`configure' configures GoSam Convenience Package 1.0 to adapt to many kinds of systems.
+
+Usage: $0 [OPTION]... [VAR=VALUE]...
+
+To assign environment variables (e.g., CC, CFLAGS...), specify them as
+VAR=VALUE. See below for descriptions of some of the useful variables.
+
+Defaults for the options are specified in brackets.
+
+Configuration:
+ -h, --help display this help and exit
+ --help=short display options specific to this package
+ --help=recursive display the short help of all the included packages
+ -V, --version display version information and exit
+ -q, --quiet, --silent do not print \`checking ...' messages
+ --cache-file=FILE cache test results in FILE [disabled]
+ -C, --config-cache alias for \`--cache-file=config.cache'
+ -n, --no-create do not create output files
+ --srcdir=DIR find the sources in DIR [configure dir or \`..']
+
+Installation directories:
+ --prefix=PREFIX install architecture-independent files in PREFIX
+ [$ac_default_prefix]
+ --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
+ [PREFIX]
+
+By default, \`make install' will install all the files in
+\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
+an installation prefix other than \`$ac_default_prefix' using \`--prefix',
+for instance \`--prefix=\$HOME'.
+
+For better control, use the options below.
+
+Fine tuning of the installation directories:
+ --bindir=DIR user executables [EPREFIX/bin]
+ --sbindir=DIR system admin executables [EPREFIX/sbin]
+ --libexecdir=DIR program executables [EPREFIX/libexec]
+ --sysconfdir=DIR read-only single-machine data [PREFIX/etc]
+ --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
+ --localstatedir=DIR modifiable single-machine data [PREFIX/var]
+ --libdir=DIR object code libraries [EPREFIX/lib]
+ --includedir=DIR C header files [PREFIX/include]
+ --oldincludedir=DIR C header files for non-gcc [/usr/include]
+ --datarootdir=DIR read-only arch.-independent data root [PREFIX/share]
+ --datadir=DIR read-only architecture-independent data [DATAROOTDIR]
+ --infodir=DIR info documentation [DATAROOTDIR/info]
+ --localedir=DIR locale-dependent data [DATAROOTDIR/locale]
+ --mandir=DIR man documentation [DATAROOTDIR/man]
+ --docdir=DIR documentation root [DATAROOTDIR/doc/gosam-contrib]
+ --htmldir=DIR html documentation [DOCDIR]
+ --dvidir=DIR dvi documentation [DOCDIR]
+ --pdfdir=DIR pdf documentation [DOCDIR]
+ --psdir=DIR ps documentation [DOCDIR]
+_ACEOF
+
+ cat <<\_ACEOF
+
+Program names:
+ --program-prefix=PREFIX prepend PREFIX to installed program names
+ --program-suffix=SUFFIX append SUFFIX to installed program names
+ --program-transform-name=PROGRAM run sed PROGRAM on installed program names
+
+System types:
+ --build=BUILD configure for building on BUILD [guessed]
+ --host=HOST cross-compile to build programs to run on HOST [BUILD]
+_ACEOF
+fi
+
+if test -n "$ac_init_help"; then
+ case $ac_init_help in
+ short | recursive ) echo "Configuration of GoSam Convenience Package 1.0:";;
+ esac
+ cat <<\_ACEOF
+
+Optional Features:
+ --disable-option-checking ignore unrecognized --enable/--with options
+ --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
+ --enable-FEATURE[=ARG] include FEATURE [ARG=yes]
+ --disable-dependency-tracking speeds up one-time build
+ --enable-dependency-tracking do not reject slow dependency extractors
+ --enable-shared[=PKGS] build shared libraries [default=yes]
+ --enable-static[=PKGS] build static libraries [default=yes]
+ --enable-fast-install[=PKGS]
+ optimize for fast installation [default=yes]
+ --disable-libtool-lock avoid locking (might break parallel builds)
+ --disable-ff do not compile and install FF
+ --disable-ql do not compile and install QCDLoop
+ --disable-olo do not compile and install AVH OneLOop
+ --disable-golem95 do not compile and install Golem95C
+ --disable-samurai do not compile and install Samurai
+
+Optional Packages:
+ --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
+ --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
+ --with-pic try to use only PIC/non-PIC objects [default=use
+ both]
+ --with-gnu-ld assume the C compiler uses GNU ld [default=no]
+ --with-sysroot=DIR Search for dependent libraries within DIR
+ (or the compiler's sysroot if not specified).
+ --with-precision set the precision of the library to either 'double'
+ or 'quadruple'. [default=double]
+ --with-looptools enable linking to LoopTools
+ --with-lt-precision set the precision used by LoopTools to either
+ 'double' or 'quadruple'. [default=double]
+
+Some influential environment variables:
+ F77 Fortran 77 compiler command
+ FFLAGS Fortran 77 compiler flags
+ LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a
+ nonstandard directory <lib dir>
+ LIBS libraries to pass to the linker, e.g. -l<library>
+ FC Fortran compiler command
+ FCFLAGS Fortran compiler flags
+ CC C compiler command
+ CFLAGS C compiler flags
+ CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I<include dir> if
+ you have headers in a nonstandard directory <include dir>
+ CPP C preprocessor
+
+Use these variables to override the choices made by `configure' or to help
+it to find libraries and programs with nonstandard names/locations.
+
+Report bugs to <reiterth@mpp.mpg.de>.
+GoSam Convenience Package home page: <http://projects.hepforge.org/golem/gosam-contrib/>.
+_ACEOF
+ac_status=$?
+fi
+
+if test "$ac_init_help" = "recursive"; then
+ # If there are subdirs, report their specific --help.
+ for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue
+ test -d "$ac_dir" ||
+ { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } ||
+ continue
+ ac_builddir=.
+
+case "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
+
+case $srcdir in
+ .) # We are building in place.
+ ac_srcdir=.
+ ac_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
+ ac_srcdir=$srcdir$ac_dir_suffix;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
+esac
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
+
+ cd "$ac_dir" || { ac_status=$?; continue; }
+ # Check for guested configure.
+ if test -f "$ac_srcdir/configure.gnu"; then
+ echo &&
+ $SHELL "$ac_srcdir/configure.gnu" --help=recursive
+ elif test -f "$ac_srcdir/configure"; then
+ echo &&
+ $SHELL "$ac_srcdir/configure" --help=recursive
+ else
+ $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
+ fi || ac_status=$?
+ cd "$ac_pwd" || { ac_status=$?; break; }
+ done
+fi
+
+test -n "$ac_init_help" && exit $ac_status
+if $ac_init_version; then
+ cat <<\_ACEOF
+GoSam Convenience Package configure 1.0
+generated by GNU Autoconf 2.68
+
+Copyright (C) 2010 Free Software Foundation, Inc.
+This configure script is free software; the Free Software Foundation
+gives unlimited permission to copy, distribute and modify it.
+_ACEOF
+ exit
+fi
+
+## ------------------------ ##
+## Autoconf initialization. ##
+## ------------------------ ##
+
+# ac_fn_f77_try_compile LINENO
+# ----------------------------
+# Try to compile conftest.$ac_ext, and return whether this succeeded.
+ac_fn_f77_try_compile ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext
+ if { { ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_compile") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_f77_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_f77_try_compile
+
+# ac_fn_fc_try_compile LINENO
+# ---------------------------
+# Try to compile conftest.$ac_ext, and return whether this succeeded.
+ac_fn_fc_try_compile ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext
+ if { { ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_compile") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_fc_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_fc_try_compile
+
+# ac_fn_c_try_compile LINENO
+# --------------------------
+# Try to compile conftest.$ac_ext, and return whether this succeeded.
+ac_fn_c_try_compile ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext
+ if { { ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_compile") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_compile
+
+# ac_fn_c_try_link LINENO
+# -----------------------
+# Try to link conftest.$ac_ext, and return whether this succeeded.
+ac_fn_c_try_link ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext conftest$ac_exeext
+ if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext && {
+ test "$cross_compiling" = yes ||
+ $as_test_x conftest$ac_exeext
+ }; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information
+ # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would
+ # interfere with the next link command; also delete a directory that is
+ # left behind by Apple's compiler. We do this before executing the actions.
+ rm -rf conftest.dSYM conftest_ipa8_conftest.oo
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_link
+
+# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES
+# -------------------------------------------------------
+# Tests whether HEADER exists and can be compiled using the include files in
+# INCLUDES, setting the cache variable VAR accordingly.
+ac_fn_c_check_header_compile ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+#include <$2>
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+ eval "$3=yes"
+else
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_header_compile
+
+# ac_fn_c_try_cpp LINENO
+# ----------------------
+# Try to preprocess conftest.$ac_ext, and return whether this succeeded.
+ac_fn_c_try_cpp ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ if { { ac_try="$ac_cpp conftest.$ac_ext"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } > conftest.i && {
+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ }; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_cpp
+
+# ac_fn_c_try_run LINENO
+# ----------------------
+# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes
+# that executables *can* be run.
+ac_fn_c_try_run ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && { ac_try='./conftest$ac_exeext'
+ { { case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; }; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: program exited with status $ac_status" >&5
+ $as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=$ac_status
+fi
+ rm -rf conftest.dSYM conftest_ipa8_conftest.oo
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_run
+
+# ac_fn_c_check_func LINENO FUNC VAR
+# ----------------------------------
+# Tests whether FUNC exists, setting the cache variable VAR accordingly
+ac_fn_c_check_func ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+/* Define $2 to an innocuous variant, in case <limits.h> declares $2.
+ For example, HP-UX 11i <limits.h> declares gettimeofday. */
+#define $2 innocuous_$2
+
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $2 (); below.
+ Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
+ <limits.h> exists even on freestanding compilers. */
+
+#ifdef __STDC__
+# include <limits.h>
+#else
+# include <assert.h>
+#endif
+
+#undef $2
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char $2 ();
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined __stub_$2 || defined __stub___$2
+choke me
+#endif
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return $2 ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ eval "$3=yes"
+else
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_func
+
+# ac_fn_f77_try_link LINENO
+# -------------------------
+# Try to link conftest.$ac_ext, and return whether this succeeded.
+ac_fn_f77_try_link ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext conftest$ac_exeext
+ if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_f77_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext && {
+ test "$cross_compiling" = yes ||
+ $as_test_x conftest$ac_exeext
+ }; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information
+ # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would
+ # interfere with the next link command; also delete a directory that is
+ # left behind by Apple's compiler. We do this before executing the actions.
+ rm -rf conftest.dSYM conftest_ipa8_conftest.oo
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_f77_try_link
+
+# ac_fn_fc_try_link LINENO
+# ------------------------
+# Try to link conftest.$ac_ext, and return whether this succeeded.
+ac_fn_fc_try_link ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext conftest$ac_exeext
+ if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_fc_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext && {
+ test "$cross_compiling" = yes ||
+ $as_test_x conftest$ac_exeext
+ }; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information
+ # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would
+ # interfere with the next link command; also delete a directory that is
+ # left behind by Apple's compiler. We do this before executing the actions.
+ rm -rf conftest.dSYM conftest_ipa8_conftest.oo
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_fc_try_link
+cat >config.log <<_ACEOF
+This file contains any messages produced by compilers while
+running configure, to aid debugging if configure makes a mistake.
+
+It was created by GoSam Convenience Package $as_me 1.0, which was
+generated by GNU Autoconf 2.68. Invocation command line was
+
+ $ $0 $@
+
+_ACEOF
+exec 5>>config.log
+{
+cat <<_ASUNAME
+## --------- ##
+## Platform. ##
+## --------- ##
+
+hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`
+uname -m = `(uname -m) 2>/dev/null || echo unknown`
+uname -r = `(uname -r) 2>/dev/null || echo unknown`
+uname -s = `(uname -s) 2>/dev/null || echo unknown`
+uname -v = `(uname -v) 2>/dev/null || echo unknown`
+
+/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`
+/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`
+
+/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`
+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`
+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`
+/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown`
+/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`
+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`
+/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`
+
+_ASUNAME
+
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ $as_echo "PATH: $as_dir"
+ done
+IFS=$as_save_IFS
+
+} >&5
+
+cat >&5 <<_ACEOF
+
+
+## ----------- ##
+## Core tests. ##
+## ----------- ##
+
+_ACEOF
+
+
+# Keep a trace of the command line.
+# Strip out --no-create and --no-recursion so they do not pile up.
+# Strip out --silent because we don't want to record it for future runs.
+# Also quote any args containing shell meta-characters.
+# Make two passes to allow for proper duplicate-argument suppression.
+ac_configure_args=
+ac_configure_args0=
+ac_configure_args1=
+ac_must_keep_next=false
+for ac_pass in 1 2
+do
+ for ac_arg
+ do
+ case $ac_arg in
+ -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil)
+ continue ;;
+ *\'*)
+ ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ esac
+ case $ac_pass in
+ 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;;
+ 2)
+ as_fn_append ac_configure_args1 " '$ac_arg'"
+ if test $ac_must_keep_next = true; then
+ ac_must_keep_next=false # Got value, back to normal.
+ else
+ case $ac_arg in
+ *=* | --config-cache | -C | -disable-* | --disable-* \
+ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
+ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
+ | -with-* | --with-* | -without-* | --without-* | --x)
+ case "$ac_configure_args0 " in
+ "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
+ esac
+ ;;
+ -* ) ac_must_keep_next=true ;;
+ esac
+ fi
+ as_fn_append ac_configure_args " '$ac_arg'"
+ ;;
+ esac
+ done
+done
+{ ac_configure_args0=; unset ac_configure_args0;}
+{ ac_configure_args1=; unset ac_configure_args1;}
+
+# When interrupted or exit'd, cleanup temporary files, and complete
+# config.log. We remove comments because anyway the quotes in there
+# would cause problems or look ugly.
+# WARNING: Use '\'' to represent an apostrophe within the trap.
+# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
+trap 'exit_status=$?
+ # Save into config.log some information that might help in debugging.
+ {
+ echo
+
+ $as_echo "## ---------------- ##
+## Cache variables. ##
+## ---------------- ##"
+ echo
+ # The following way of writing the cache mishandles newlines in values,
+(
+ for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
+ *) { eval $ac_var=; unset $ac_var;} ;;
+ esac ;;
+ esac
+ done
+ (set) 2>&1 |
+ case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(
+ *${as_nl}ac_space=\ *)
+ sed -n \
+ "s/'\''/'\''\\\\'\'''\''/g;
+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p"
+ ;; #(
+ *)
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
+ ;;
+ esac |
+ sort
+)
+ echo
+
+ $as_echo "## ----------------- ##
+## Output variables. ##
+## ----------------- ##"
+ echo
+ for ac_var in $ac_subst_vars
+ do
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ $as_echo "$ac_var='\''$ac_val'\''"
+ done | sort
+ echo
+
+ if test -n "$ac_subst_files"; then
+ $as_echo "## ------------------- ##
+## File substitutions. ##
+## ------------------- ##"
+ echo
+ for ac_var in $ac_subst_files
+ do
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ $as_echo "$ac_var='\''$ac_val'\''"
+ done | sort
+ echo
+ fi
+
+ if test -s confdefs.h; then
+ $as_echo "## ----------- ##
+## confdefs.h. ##
+## ----------- ##"
+ echo
+ cat confdefs.h
+ echo
+ fi
+ test "$ac_signal" != 0 &&
+ $as_echo "$as_me: caught signal $ac_signal"
+ $as_echo "$as_me: exit $exit_status"
+ } >&5
+ rm -f core *.core core.conftest.* &&
+ rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
+ exit $exit_status
+' 0
+for ac_signal in 1 2 13 15; do
+ trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal
+done
+ac_signal=0
+
+# confdefs.h avoids OS command line length limits that DEFS can exceed.
+rm -f -r conftest* confdefs.h
+
+$as_echo "/* confdefs.h */" > confdefs.h
+
+# Predefined preprocessor variables.
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_NAME "$PACKAGE_NAME"
+_ACEOF
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_TARNAME "$PACKAGE_TARNAME"
+_ACEOF
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_VERSION "$PACKAGE_VERSION"
+_ACEOF
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_STRING "$PACKAGE_STRING"
+_ACEOF
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
+_ACEOF
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_URL "$PACKAGE_URL"
+_ACEOF
+
+
+# Let the site file select an alternate cache file if it wants to.
+# Prefer an explicitly selected file to automatically selected ones.
+ac_site_file1=NONE
+ac_site_file2=NONE
+if test -n "$CONFIG_SITE"; then
+ # We do not want a PATH search for config.site.
+ case $CONFIG_SITE in #((
+ -*) ac_site_file1=./$CONFIG_SITE;;
+ */*) ac_site_file1=$CONFIG_SITE;;
+ *) ac_site_file1=./$CONFIG_SITE;;
+ esac
+elif test "x$prefix" != xNONE; then
+ ac_site_file1=$prefix/share/config.site
+ ac_site_file2=$prefix/etc/config.site
+else
+ ac_site_file1=$ac_default_prefix/share/config.site
+ ac_site_file2=$ac_default_prefix/etc/config.site
+fi
+for ac_site_file in "$ac_site_file1" "$ac_site_file2"
+do
+ test "x$ac_site_file" = xNONE && continue
+ if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5
+$as_echo "$as_me: loading site script $ac_site_file" >&6;}
+ sed 's/^/| /' "$ac_site_file" >&5
+ . "$ac_site_file" \
+ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "failed to load site script $ac_site_file
+See \`config.log' for more details" "$LINENO" 5; }
+ fi
+done
+
+if test -r "$cache_file"; then
+ # Some versions of bash will fail to source /dev/null (special files
+ # actually), so we avoid doing that. DJGPP emulates it as a regular file.
+ if test /dev/null != "$cache_file" && test -f "$cache_file"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5
+$as_echo "$as_me: loading cache $cache_file" >&6;}
+ case $cache_file in
+ [\\/]* | ?:[\\/]* ) . "$cache_file";;
+ *) . "./$cache_file";;
+ esac
+ fi
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5
+$as_echo "$as_me: creating cache $cache_file" >&6;}
+ >$cache_file
+fi
+
+# Check that the precious variables saved in the cache have kept the same
+# value.
+ac_cache_corrupted=false
+for ac_var in $ac_precious_vars; do
+ eval ac_old_set=\$ac_cv_env_${ac_var}_set
+ eval ac_new_set=\$ac_env_${ac_var}_set
+ eval ac_old_val=\$ac_cv_env_${ac_var}_value
+ eval ac_new_val=\$ac_env_${ac_var}_value
+ case $ac_old_set,$ac_new_set in
+ set,)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
+$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
+ ac_cache_corrupted=: ;;
+ ,set)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5
+$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
+ ac_cache_corrupted=: ;;
+ ,);;
+ *)
+ if test "x$ac_old_val" != "x$ac_new_val"; then
+ # differences in whitespace do not lead to failure.
+ ac_old_val_w=`echo x $ac_old_val`
+ ac_new_val_w=`echo x $ac_new_val`
+ if test "$ac_old_val_w" != "$ac_new_val_w"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5
+$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
+ ac_cache_corrupted=:
+ else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5
+$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}
+ eval $ac_var=\$ac_old_val
+ fi
+ { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5
+$as_echo "$as_me: former value: \`$ac_old_val'" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5
+$as_echo "$as_me: current value: \`$ac_new_val'" >&2;}
+ fi;;
+ esac
+ # Pass precious variables to config.status.
+ if test "$ac_new_set" = set; then
+ case $ac_new_val in
+ *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
+ *) ac_arg=$ac_var=$ac_new_val ;;
+ esac
+ case " $ac_configure_args " in
+ *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
+ *) as_fn_append ac_configure_args " '$ac_arg'" ;;
+ esac
+ fi
+done
+if $ac_cache_corrupted; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5
+$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;}
+ as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5
+fi
+## -------------------- ##
+## Main body of script. ##
+## -------------------- ##
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+
+
+
+ac_aux_dir=
+for ac_dir in config.aux "$srcdir"/config.aux; do
+ if test -f "$ac_dir/install-sh"; then
+ ac_aux_dir=$ac_dir
+ ac_install_sh="$ac_aux_dir/install-sh -c"
+ break
+ elif test -f "$ac_dir/install.sh"; then
+ ac_aux_dir=$ac_dir
+ ac_install_sh="$ac_aux_dir/install.sh -c"
+ break
+ elif test -f "$ac_dir/shtool"; then
+ ac_aux_dir=$ac_dir
+ ac_install_sh="$ac_aux_dir/shtool install -c"
+ break
+ fi
+done
+if test -z "$ac_aux_dir"; then
+ as_fn_error $? "cannot find install-sh, install.sh, or shtool in config.aux \"$srcdir\"/config.aux" "$LINENO" 5
+fi
+
+# These three variables are undocumented and unsupported,
+# and are intended to be withdrawn in a future Autoconf release.
+# They can cause serious problems if a builder's source tree is in a directory
+# whose full name contains unusual characters.
+ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var.
+ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var.
+ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var.
+
+
+
+VERSION=1.0
+PACKAGE=gosam-contrib
+
+
+am__api_version='1.11'
+
+# Find a good install program. We prefer a C program (faster),
+# so one script is as good as another. But avoid the broken or
+# incompatible versions:
+# SysV /etc/install, /usr/sbin/install
+# SunOS /usr/etc/install
+# IRIX /sbin/install
+# AIX /bin/install
+# AmigaOS /C/install, which installs bootblocks on floppy discs
+# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag
+# AFS /usr/afsws/bin/install, which mishandles nonexistent args
+# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
+# OS/2's system install, which has a completely different semantic
+# ./install, which can be erroneously created by make from ./install.sh.
+# Reject install programs that cannot install multiple files.
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5
+$as_echo_n "checking for a BSD-compatible install... " >&6; }
+if test -z "$INSTALL"; then
+if ${ac_cv_path_install+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ # Account for people who put trailing slashes in PATH elements.
+case $as_dir/ in #((
+ ./ | .// | /[cC]/* | \
+ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \
+ ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \
+ /usr/ucb/* ) ;;
+ *)
+ # OSF1 and SCO ODT 3.0 have their own names for install.
+ # Don't use installbsd from OSF since it installs stuff as root
+ # by default.
+ for ac_prog in ginstall scoinst install; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then
+ if test $ac_prog = install &&
+ grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
+ # AIX install. It has an incompatible calling convention.
+ :
+ elif test $ac_prog = install &&
+ grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
+ # program-specific install script used by HP pwplus--don't use.
+ :
+ else
+ rm -rf conftest.one conftest.two conftest.dir
+ echo one > conftest.one
+ echo two > conftest.two
+ mkdir conftest.dir
+ if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" &&
+ test -s conftest.one && test -s conftest.two &&
+ test -s conftest.dir/conftest.one &&
+ test -s conftest.dir/conftest.two
+ then
+ ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c"
+ break 3
+ fi
+ fi
+ fi
+ done
+ done
+ ;;
+esac
+
+ done
+IFS=$as_save_IFS
+
+rm -rf conftest.one conftest.two conftest.dir
+
+fi
+ if test "${ac_cv_path_install+set}" = set; then
+ INSTALL=$ac_cv_path_install
+ else
+ # As a last resort, use the slow shell script. Don't cache a
+ # value for INSTALL within a source directory, because that will
+ # break other packages using the cache if that directory is
+ # removed, or if the value is a relative name.
+ INSTALL=$ac_install_sh
+ fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5
+$as_echo "$INSTALL" >&6; }
+
+# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
+# It thinks the first close brace ends the variable substitution.
+test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
+
+test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}'
+
+test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether build environment is sane" >&5
+$as_echo_n "checking whether build environment is sane... " >&6; }
+# Just in case
+sleep 1
+echo timestamp > conftest.file
+# Reject unsafe characters in $srcdir or the absolute working directory
+# name. Accept space and tab only in the latter.
+am_lf='
+'
+case `pwd` in
+ *[\\\"\#\$\&\'\`$am_lf]*)
+ as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;;
+esac
+case $srcdir in
+ *[\\\"\#\$\&\'\`$am_lf\ \ ]*)
+ as_fn_error $? "unsafe srcdir value: \`$srcdir'" "$LINENO" 5;;
+esac
+
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments. Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+ set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null`
+ if test "$*" = "X"; then
+ # -L didn't work.
+ set X `ls -t "$srcdir/configure" conftest.file`
+ fi
+ rm -f conftest.file
+ if test "$*" != "X $srcdir/configure conftest.file" \
+ && test "$*" != "X conftest.file $srcdir/configure"; then
+
+ # If neither matched, then we have a broken ls. This can happen
+ # if, for instance, CONFIG_SHELL is bash and it inherits a
+ # broken ls alias from the environment. This has actually
+ # happened. Such a system could not be considered "sane".
+ as_fn_error $? "ls -t appears to fail. Make sure there is not a broken
+alias in your environment" "$LINENO" 5
+ fi
+
+ test "$2" = conftest.file
+ )
+then
+ # Ok.
+ :
+else
+ as_fn_error $? "newly created file is older than distributed files!
+Check your system clock" "$LINENO" 5
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+test "$program_prefix" != NONE &&
+ program_transform_name="s&^&$program_prefix&;$program_transform_name"
+# Use a double $ so make ignores it.
+test "$program_suffix" != NONE &&
+ program_transform_name="s&\$&$program_suffix&;$program_transform_name"
+# Double any \ or $.
+# By default was `s,x,x', remove it if useless.
+ac_script='s/[\\$]/&&/g;s/;s,x,x,$//'
+program_transform_name=`$as_echo "$program_transform_name" | sed "$ac_script"`
+
+# expand $ac_aux_dir to an absolute path
+am_aux_dir=`cd $ac_aux_dir && pwd`
+
+if test x"${MISSING+set}" != xset; then
+ case $am_aux_dir in
+ *\ * | *\ *)
+ MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;;
+ *)
+ MISSING="\${SHELL} $am_aux_dir/missing" ;;
+ esac
+fi
+# Use eval to expand $SHELL
+if eval "$MISSING --run true"; then
+ am_missing_run="$MISSING --run "
+else
+ am_missing_run=
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \`missing' script is too old or missing" >&5
+$as_echo "$as_me: WARNING: \`missing' script is too old or missing" >&2;}
+fi
+
+if test x"${install_sh}" != xset; then
+ case $am_aux_dir in
+ *\ * | *\ *)
+ install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;;
+ *)
+ install_sh="\${SHELL} $am_aux_dir/install-sh"
+ esac
+fi
+
+# Installed binaries are usually stripped using `strip' when the user
+# run `make install-strip'. However `strip' might not be the right
+# tool to use in cross-compilation environments, therefore Automake
+# will honor the `STRIP' environment variable to overrule this program.
+if test "$cross_compiling" != no; then
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args.
+set dummy ${ac_tool_prefix}strip; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_STRIP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$STRIP"; then
+ ac_cv_prog_STRIP="$STRIP" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_STRIP="${ac_tool_prefix}strip"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+STRIP=$ac_cv_prog_STRIP
+if test -n "$STRIP"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5
+$as_echo "$STRIP" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_STRIP"; then
+ ac_ct_STRIP=$STRIP
+ # Extract the first word of "strip", so it can be a program name with args.
+set dummy strip; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_STRIP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_STRIP"; then
+ ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_STRIP="strip"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP
+if test -n "$ac_ct_STRIP"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5
+$as_echo "$ac_ct_STRIP" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_STRIP" = x; then
+ STRIP=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ STRIP=$ac_ct_STRIP
+ fi
+else
+ STRIP="$ac_cv_prog_STRIP"
+fi
+
+fi
+INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s"
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a thread-safe mkdir -p" >&5
+$as_echo_n "checking for a thread-safe mkdir -p... " >&6; }
+if test -z "$MKDIR_P"; then
+ if ${ac_cv_path_mkdir+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_prog in mkdir gmkdir; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; } || continue
+ case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #(
+ 'mkdir (GNU coreutils) '* | \
+ 'mkdir (coreutils) '* | \
+ 'mkdir (fileutils) '4.1*)
+ ac_cv_path_mkdir=$as_dir/$ac_prog$ac_exec_ext
+ break 3;;
+ esac
+ done
+ done
+ done
+IFS=$as_save_IFS
+
+fi
+
+ test -d ./--version && rmdir ./--version
+ if test "${ac_cv_path_mkdir+set}" = set; then
+ MKDIR_P="$ac_cv_path_mkdir -p"
+ else
+ # As a last resort, use the slow shell script. Don't cache a
+ # value for MKDIR_P within a source directory, because that will
+ # break other packages using the cache if that directory is
+ # removed, or if the value is a relative name.
+ MKDIR_P="$ac_install_sh -d"
+ fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5
+$as_echo "$MKDIR_P" >&6; }
+
+mkdir_p="$MKDIR_P"
+case $mkdir_p in
+ [\\/$]* | ?:[\\/]*) ;;
+ */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;;
+esac
+
+for ac_prog in gawk mawk nawk awk
+do
+ # Extract the first word of "$ac_prog", so it can be a program name with args.
+set dummy $ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_AWK+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$AWK"; then
+ ac_cv_prog_AWK="$AWK" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_AWK="$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+AWK=$ac_cv_prog_AWK
+if test -n "$AWK"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5
+$as_echo "$AWK" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$AWK" && break
+done
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5
+$as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; }
+set x ${MAKE-make}
+ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'`
+if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat >conftest.make <<\_ACEOF
+SHELL = /bin/sh
+all:
+ @echo '@@@%%%=$(MAKE)=@@@%%%'
+_ACEOF
+# GNU make sometimes prints "make[1]: Entering ...", which would confuse us.
+case `${MAKE-make} -f conftest.make 2>/dev/null` in
+ *@@@%%%=?*=@@@%%%*)
+ eval ac_cv_prog_make_${ac_make}_set=yes;;
+ *)
+ eval ac_cv_prog_make_${ac_make}_set=no;;
+esac
+rm -f conftest.make
+fi
+if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+ SET_MAKE=
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+ SET_MAKE="MAKE=${MAKE-make}"
+fi
+
+rm -rf .tst 2>/dev/null
+mkdir .tst 2>/dev/null
+if test -d .tst; then
+ am__leading_dot=.
+else
+ am__leading_dot=_
+fi
+rmdir .tst 2>/dev/null
+
+if test "`cd $srcdir && pwd`" != "`pwd`"; then
+ # Use -I$(srcdir) only when $(srcdir) != ., so that make's output
+ # is not polluted with repeated "-I."
+ am__isrc=' -I$(srcdir)'
+ # test to see if srcdir already configured
+ if test -f $srcdir/config.status; then
+ as_fn_error $? "source directory already configured; run \"make distclean\" there first" "$LINENO" 5
+ fi
+fi
+
+# test whether we have cygpath
+if test -z "$CYGPATH_W"; then
+ if (cygpath --version) >/dev/null 2>/dev/null; then
+ CYGPATH_W='cygpath -w'
+ else
+ CYGPATH_W=echo
+ fi
+fi
+
+
+# Define the identity of the package.
+ PACKAGE=$PACKAGE
+ VERSION=$VERSION
+
+
+# Some tools Automake needs.
+
+ACLOCAL=${ACLOCAL-"${am_missing_run}aclocal-${am__api_version}"}
+
+
+AUTOCONF=${AUTOCONF-"${am_missing_run}autoconf"}
+
+
+AUTOMAKE=${AUTOMAKE-"${am_missing_run}automake-${am__api_version}"}
+
+
+AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"}
+
+
+MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"}
+
+# We need awk for the "check" target. The system "awk" is bad on
+# some platforms.
+# Always define AMTAR for backward compatibility.
+
+AMTAR=${AMTAR-"${am_missing_run}tar"}
+
+am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -'
+
+
+
+
+
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+
+ac_ext=f
+ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5'
+ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_f77_compiler_gnu
+if test -n "$ac_tool_prefix"; then
+ for ac_prog in gfortran ifort g77 f77 xlf frt pgf77 fort77 fl32 af77
+ do
+ # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
+set dummy $ac_tool_prefix$ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$F77"; then
+ ac_cv_prog_F77="$F77" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_F77="$ac_tool_prefix$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+F77=$ac_cv_prog_F77
+if test -n "$F77"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $F77" >&5
+$as_echo "$F77" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$F77" && break
+ done
+fi
+if test -z "$F77"; then
+ ac_ct_F77=$F77
+ for ac_prog in gfortran ifort g77 f77 xlf frt pgf77 fort77 fl32 af77
+do
+ # Extract the first word of "$ac_prog", so it can be a program name with args.
+set dummy $ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_F77"; then
+ ac_cv_prog_ac_ct_F77="$ac_ct_F77" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_F77="$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_F77=$ac_cv_prog_ac_ct_F77
+if test -n "$ac_ct_F77"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_F77" >&5
+$as_echo "$ac_ct_F77" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$ac_ct_F77" && break
+done
+
+ if test "x$ac_ct_F77" = x; then
+ F77=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ F77=$ac_ct_F77
+ fi
+fi
+
+
+# Provide some information about the compiler.
+$as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 compiler version" >&5
+set X $ac_compile
+ac_compiler=$2
+for ac_option in --version -v -V -qversion; do
+ { { ac_try="$ac_compiler $ac_option >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_compiler $ac_option >&5") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ sed '10a\
+... rest of stderr output deleted ...
+ 10q' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ fi
+ rm -f conftest.er1 conftest.err
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+done
+rm -f a.out
+
+cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+ac_clean_files_save=$ac_clean_files
+ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out"
+# Try to create an executable without -o first, disregard a.out.
+# It will help us diagnose broken compilers, and finding out an intuition
+# of exeext.
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the Fortran 77 compiler works" >&5
+$as_echo_n "checking whether the Fortran 77 compiler works... " >&6; }
+ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
+
+# The possible output files:
+ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*"
+
+ac_rmfiles=
+for ac_file in $ac_files
+do
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
+ * ) ac_rmfiles="$ac_rmfiles $ac_file";;
+ esac
+done
+rm -f $ac_rmfiles
+
+if { { ac_try="$ac_link_default"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link_default") 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; then :
+ # Autoconf-2.13 could set the ac_cv_exeext variable to `no'.
+# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'
+# in a Makefile. We should not override ac_cv_exeext if it was cached,
+# so that the user can short-circuit this test for compilers unknown to
+# Autoconf.
+for ac_file in $ac_files ''
+do
+ test -f "$ac_file" || continue
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj )
+ ;;
+ [ab].out )
+ # We found the default executable, but exeext='' is most
+ # certainly right.
+ break;;
+ *.* )
+ if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no;
+ then :; else
+ ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
+ fi
+ # We set ac_cv_exeext here because the later test for it is not
+ # safe: cross compilers may not add the suffix if given an `-o'
+ # argument, so we may need to know it at that point already.
+ # Even if this section looks crufty: it has the advantage of
+ # actually working.
+ break;;
+ * )
+ break;;
+ esac
+done
+test "$ac_cv_exeext" = no && ac_cv_exeext=
+
+else
+ ac_file=''
+fi
+if test -z "$ac_file"; then :
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+$as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error 77 "Fortran 77 compiler cannot create executables
+See \`config.log' for more details" "$LINENO" 5; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 compiler default output file name" >&5
+$as_echo_n "checking for Fortran 77 compiler default output file name... " >&6; }
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5
+$as_echo "$ac_file" >&6; }
+ac_exeext=$ac_cv_exeext
+
+rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out
+ac_clean_files=$ac_clean_files_save
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5
+$as_echo_n "checking for suffix of executables... " >&6; }
+if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; then :
+ # If both `conftest.exe' and `conftest' are `present' (well, observable)
+# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will
+# work properly (i.e., refer to `conftest.exe'), while it won't with
+# `rm'.
+for ac_file in conftest.exe conftest conftest.*; do
+ test -f "$ac_file" || continue
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
+ *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
+ break;;
+ * ) break;;
+ esac
+done
+else
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot compute suffix of executables: cannot compile and link
+See \`config.log' for more details" "$LINENO" 5; }
+fi
+rm -f conftest conftest$ac_cv_exeext
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5
+$as_echo "$ac_cv_exeext" >&6; }
+
+rm -f conftest.$ac_ext
+EXEEXT=$ac_cv_exeext
+ac_exeext=$EXEEXT
+cat > conftest.$ac_ext <<_ACEOF
+ program main
+ open(unit=9,file='conftest.out')
+ close(unit=9)
+
+ end
+_ACEOF
+ac_clean_files="$ac_clean_files conftest.out"
+# Check that the compiler produces executables we can run. If not, either
+# the compiler is broken, or we cross compile.
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5
+$as_echo_n "checking whether we are cross compiling... " >&6; }
+if test "$cross_compiling" != yes; then
+ { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+ if { ac_try='./conftest$ac_cv_exeext'
+ { { case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; }; then
+ cross_compiling=no
+ else
+ if test "$cross_compiling" = maybe; then
+ cross_compiling=yes
+ else
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot run Fortran 77 compiled programs.
+If you meant to cross compile, use \`--host'.
+See \`config.log' for more details" "$LINENO" 5; }
+ fi
+ fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5
+$as_echo "$cross_compiling" >&6; }
+
+rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out
+ac_clean_files=$ac_clean_files_save
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5
+$as_echo_n "checking for suffix of object files... " >&6; }
+if ${ac_cv_objext+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+rm -f conftest.o conftest.obj
+if { { ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_compile") 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; then :
+ for ac_file in conftest.o conftest.obj conftest.*; do
+ test -f "$ac_file" || continue;
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;;
+ *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`
+ break;;
+ esac
+done
+else
+ $as_echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot compute suffix of object files: cannot compile
+See \`config.log' for more details" "$LINENO" 5; }
+fi
+rm -f conftest.$ac_cv_objext conftest.$ac_ext
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5
+$as_echo "$ac_cv_objext" >&6; }
+OBJEXT=$ac_cv_objext
+ac_objext=$OBJEXT
+# If we don't use `.F' as extension, the preprocessor is not run on the
+# input file. (Note that this only needs to work for GNU compilers.)
+ac_save_ext=$ac_ext
+ac_ext=F
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU Fortran 77 compiler" >&5
+$as_echo_n "checking whether we are using the GNU Fortran 77 compiler... " >&6; }
+if ${ac_cv_f77_compiler_gnu+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+#ifndef __GNUC__
+ choke me
+#endif
+
+ end
+_ACEOF
+if ac_fn_f77_try_compile "$LINENO"; then :
+ ac_compiler_gnu=yes
+else
+ ac_compiler_gnu=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ac_cv_f77_compiler_gnu=$ac_compiler_gnu
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_f77_compiler_gnu" >&5
+$as_echo "$ac_cv_f77_compiler_gnu" >&6; }
+ac_ext=$ac_save_ext
+ac_test_FFLAGS=${FFLAGS+set}
+ac_save_FFLAGS=$FFLAGS
+FFLAGS=
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $F77 accepts -g" >&5
+$as_echo_n "checking whether $F77 accepts -g... " >&6; }
+if ${ac_cv_prog_f77_g+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ FFLAGS=-g
+cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_f77_try_compile "$LINENO"; then :
+ ac_cv_prog_f77_g=yes
+else
+ ac_cv_prog_f77_g=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_f77_g" >&5
+$as_echo "$ac_cv_prog_f77_g" >&6; }
+if test "$ac_test_FFLAGS" = set; then
+ FFLAGS=$ac_save_FFLAGS
+elif test $ac_cv_prog_f77_g = yes; then
+ if test "x$ac_cv_f77_compiler_gnu" = xyes; then
+ FFLAGS="-g -O2"
+ else
+ FFLAGS="-g"
+ fi
+else
+ if test "x$ac_cv_f77_compiler_gnu" = xyes; then
+ FFLAGS="-O2"
+ else
+ FFLAGS=
+ fi
+fi
+
+if test $ac_compiler_gnu = yes; then
+ G77=yes
+else
+ G77=
+fi
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+if test -n "$ac_tool_prefix"; then
+ for ac_prog in gfortran ifort g77 f77 xlf frt pgf77 fort77 fl32 af77
+ do
+ # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
+set dummy $ac_tool_prefix$ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$FC"; then
+ ac_cv_prog_FC="$FC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_FC="$ac_tool_prefix$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+FC=$ac_cv_prog_FC
+if test -n "$FC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $FC" >&5
+$as_echo "$FC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$FC" && break
+ done
+fi
+if test -z "$FC"; then
+ ac_ct_FC=$FC
+ for ac_prog in gfortran ifort g77 f77 xlf frt pgf77 fort77 fl32 af77
+do
+ # Extract the first word of "$ac_prog", so it can be a program name with args.
+set dummy $ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_FC"; then
+ ac_cv_prog_ac_ct_FC="$ac_ct_FC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_FC="$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_FC=$ac_cv_prog_ac_ct_FC
+if test -n "$ac_ct_FC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_FC" >&5
+$as_echo "$ac_ct_FC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$ac_ct_FC" && break
+done
+
+ if test "x$ac_ct_FC" = x; then
+ FC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ FC=$ac_ct_FC
+ fi
+fi
+
+
+# Provide some information about the compiler.
+$as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler version" >&5
+set X $ac_compile
+ac_compiler=$2
+for ac_option in --version -v -V -qversion; do
+ { { ac_try="$ac_compiler $ac_option >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_compiler $ac_option >&5") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ sed '10a\
+... rest of stderr output deleted ...
+ 10q' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ fi
+ rm -f conftest.er1 conftest.err
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+done
+rm -f a.out
+
+# If we don't use `.F' as extension, the preprocessor is not run on the
+# input file. (Note that this only needs to work for GNU compilers.)
+ac_save_ext=$ac_ext
+ac_ext=F
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU Fortran compiler" >&5
+$as_echo_n "checking whether we are using the GNU Fortran compiler... " >&6; }
+if ${ac_cv_fc_compiler_gnu+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+#ifndef __GNUC__
+ choke me
+#endif
+
+ end
+_ACEOF
+if ac_fn_fc_try_compile "$LINENO"; then :
+ ac_compiler_gnu=yes
+else
+ ac_compiler_gnu=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ac_cv_fc_compiler_gnu=$ac_compiler_gnu
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_compiler_gnu" >&5
+$as_echo "$ac_cv_fc_compiler_gnu" >&6; }
+ac_ext=$ac_save_ext
+ac_test_FCFLAGS=${FCFLAGS+set}
+ac_save_FCFLAGS=$FCFLAGS
+FCFLAGS=
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $FC accepts -g" >&5
+$as_echo_n "checking whether $FC accepts -g... " >&6; }
+if ${ac_cv_prog_fc_g+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ FCFLAGS=-g
+cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_fc_try_compile "$LINENO"; then :
+ ac_cv_prog_fc_g=yes
+else
+ ac_cv_prog_fc_g=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_g" >&5
+$as_echo "$ac_cv_prog_fc_g" >&6; }
+if test "$ac_test_FCFLAGS" = set; then
+ FCFLAGS=$ac_save_FCFLAGS
+elif test $ac_cv_prog_fc_g = yes; then
+ if test "x$ac_cv_fc_compiler_gnu" = xyes; then
+ FCFLAGS="-g -O2"
+ else
+ FCFLAGS="-g"
+ fi
+else
+ if test "x$ac_cv_fc_compiler_gnu" = xyes; then
+ FCFLAGS="-O2"
+ else
+ FCFLAGS=
+ fi
+fi
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to get verbose linking output from $FC" >&5
+$as_echo_n "checking how to get verbose linking output from $FC... " >&6; }
+if ${ac_cv_prog_fc_v+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_fc_try_compile "$LINENO"; then :
+ ac_cv_prog_fc_v=
+# Try some options frequently used verbose output
+for ac_verb in -v -verbose --verbose -V -\#\#\#; do
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+
+# Compile and link our simple test program by passing a flag (argument
+# 1 to this macro) to the Fortran compiler in order to get
+# "verbose" output that we can then parse for the Fortran linker
+# flags.
+ac_save_FCFLAGS=$FCFLAGS
+FCFLAGS="$FCFLAGS $ac_verb"
+eval "set x $ac_link"
+shift
+$as_echo "$as_me:${as_lineno-$LINENO}: $*" >&5
+# gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH,
+# LIBRARY_PATH; skip all such settings.
+ac_fc_v_output=`eval $ac_link 5>&1 2>&1 |
+ sed '/^Driving:/d; /^Configured with:/d;
+ '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"`
+$as_echo "$ac_fc_v_output" >&5
+FCFLAGS=$ac_save_FCFLAGS
+
+rm -rf conftest*
+
+# On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where
+# /foo, /bar, and /baz are search directories for the Fortran linker.
+# Here, we change these into -L/foo -L/bar -L/baz (and put it first):
+ac_fc_v_output="`echo $ac_fc_v_output |
+ grep 'LPATH is:' |
+ sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_fc_v_output"
+
+# FIXME: we keep getting bitten by quoted arguments; a more general fix
+# that detects unbalanced quotes in FLIBS should be implemented
+# and (ugh) tested at some point.
+case $ac_fc_v_output in
+ # If we are using xlf then replace all the commas with spaces.
+ *xlfentry*)
+ ac_fc_v_output=`echo $ac_fc_v_output | sed 's/,/ /g'` ;;
+
+ # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted
+ # $LIBS confuse us, and the libraries appear later in the output anyway).
+ *mGLOB_options_string*)
+ ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;;
+
+ # Portland Group compiler has singly- or doubly-quoted -cmdline argument
+ # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4.
+ # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2".
+ *-cmdline\ * | *-ignore\ * | *-def\ *)
+ ac_fc_v_output=`echo $ac_fc_v_output | sed "\
+ s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g
+ s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g
+ s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;;
+
+ # If we are using Cray Fortran then delete quotes.
+ *cft90*)
+ ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"//g'` ;;
+esac
+
+
+ # look for -l* and *.a constructs in the output
+ for ac_arg in $ac_fc_v_output; do
+ case $ac_arg in
+ [\\/]*.a | ?:[\\/]*.a | -[lLRu]*)
+ ac_cv_prog_fc_v=$ac_verb
+ break 2 ;;
+ esac
+ done
+done
+if test -z "$ac_cv_prog_fc_v"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine how to obtain linking information from $FC" >&5
+$as_echo "$as_me: WARNING: cannot determine how to obtain linking information from $FC" >&2;}
+fi
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: compilation failed" >&5
+$as_echo "$as_me: WARNING: compilation failed" >&2;}
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_v" >&5
+$as_echo "$ac_cv_prog_fc_v" >&6; }
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran libraries of $FC" >&5
+$as_echo_n "checking for Fortran libraries of $FC... " >&6; }
+if ${ac_cv_fc_libs+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test "x$FCLIBS" != "x"; then
+ ac_cv_fc_libs="$FCLIBS" # Let the user override the test.
+else
+
+cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+
+# Compile and link our simple test program by passing a flag (argument
+# 1 to this macro) to the Fortran compiler in order to get
+# "verbose" output that we can then parse for the Fortran linker
+# flags.
+ac_save_FCFLAGS=$FCFLAGS
+FCFLAGS="$FCFLAGS $ac_cv_prog_fc_v"
+eval "set x $ac_link"
+shift
+$as_echo "$as_me:${as_lineno-$LINENO}: $*" >&5
+# gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH,
+# LIBRARY_PATH; skip all such settings.
+ac_fc_v_output=`eval $ac_link 5>&1 2>&1 |
+ sed '/^Driving:/d; /^Configured with:/d;
+ '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"`
+$as_echo "$ac_fc_v_output" >&5
+FCFLAGS=$ac_save_FCFLAGS
+
+rm -rf conftest*
+
+# On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where
+# /foo, /bar, and /baz are search directories for the Fortran linker.
+# Here, we change these into -L/foo -L/bar -L/baz (and put it first):
+ac_fc_v_output="`echo $ac_fc_v_output |
+ grep 'LPATH is:' |
+ sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_fc_v_output"
+
+# FIXME: we keep getting bitten by quoted arguments; a more general fix
+# that detects unbalanced quotes in FLIBS should be implemented
+# and (ugh) tested at some point.
+case $ac_fc_v_output in
+ # If we are using xlf then replace all the commas with spaces.
+ *xlfentry*)
+ ac_fc_v_output=`echo $ac_fc_v_output | sed 's/,/ /g'` ;;
+
+ # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted
+ # $LIBS confuse us, and the libraries appear later in the output anyway).
+ *mGLOB_options_string*)
+ ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;;
+
+ # Portland Group compiler has singly- or doubly-quoted -cmdline argument
+ # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4.
+ # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2".
+ *-cmdline\ * | *-ignore\ * | *-def\ *)
+ ac_fc_v_output=`echo $ac_fc_v_output | sed "\
+ s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g
+ s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g
+ s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;;
+
+ # If we are using Cray Fortran then delete quotes.
+ *cft90*)
+ ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"//g'` ;;
+esac
+
+
+
+ac_cv_fc_libs=
+
+# Save positional arguments (if any)
+ac_save_positional="$@"
+
+set X $ac_fc_v_output
+while test $# != 1; do
+ shift
+ ac_arg=$1
+ case $ac_arg in
+ [\\/]*.a | ?:[\\/]*.a)
+ ac_exists=false
+ for ac_i in $ac_cv_fc_libs; do
+ if test x"$ac_arg" = x"$ac_i"; then
+ ac_exists=true
+ break
+ fi
+ done
+
+ if test x"$ac_exists" = xtrue; then :
+
+else
+ ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg"
+fi
+ ;;
+ -bI:*)
+ ac_exists=false
+ for ac_i in $ac_cv_fc_libs; do
+ if test x"$ac_arg" = x"$ac_i"; then
+ ac_exists=true
+ break
+ fi
+ done
+
+ if test x"$ac_exists" = xtrue; then :
+
+else
+ if test "$ac_compiler_gnu" = yes; then
+ for ac_link_opt in $ac_arg; do
+ ac_cv_fc_libs="$ac_cv_fc_libs -Xlinker $ac_link_opt"
+ done
+else
+ ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg"
+fi
+fi
+ ;;
+ # Ignore these flags.
+ -lang* | -lcrt*.o | -lc | -lgcc* | -lSystem | -libmil | -little \
+ |-LANG:=* | -LIST:* | -LNO:* | -link)
+ ;;
+ -lkernel32)
+ test x"$CYGWIN" != xyes && ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg"
+ ;;
+ -[LRuYz])
+ # These flags, when seen by themselves, take an argument.
+ # We remove the space between option and argument and re-iterate
+ # unless we find an empty arg or a new option (starting with -)
+ case $2 in
+ "" | -*);;
+ *)
+ ac_arg="$ac_arg$2"
+ shift; shift
+ set X $ac_arg "$@"
+ ;;
+ esac
+ ;;
+ -YP,*)
+ for ac_j in `$as_echo "$ac_arg" | sed -e 's/-YP,/-L/;s/:/ -L/g'`; do
+ ac_exists=false
+ for ac_i in $ac_cv_fc_libs; do
+ if test x"$ac_j" = x"$ac_i"; then
+ ac_exists=true
+ break
+ fi
+ done
+
+ if test x"$ac_exists" = xtrue; then :
+
+else
+ ac_arg="$ac_arg $ac_j"
+ ac_cv_fc_libs="$ac_cv_fc_libs $ac_j"
+fi
+ done
+ ;;
+ -[lLR]*)
+ ac_exists=false
+ for ac_i in $ac_cv_fc_libs; do
+ if test x"$ac_arg" = x"$ac_i"; then
+ ac_exists=true
+ break
+ fi
+ done
+
+ if test x"$ac_exists" = xtrue; then :
+
+else
+ ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg"
+fi
+ ;;
+ -zallextract*| -zdefaultextract)
+ ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg"
+ ;;
+ # Ignore everything else.
+ esac
+done
+# restore positional arguments
+set X $ac_save_positional; shift
+
+# We only consider "LD_RUN_PATH" on Solaris systems. If this is seen,
+# then we insist that the "run path" must be an absolute path (i.e. it
+# must begin with a "/").
+case `(uname -sr) 2>/dev/null` in
+ "SunOS 5"*)
+ ac_ld_run_path=`$as_echo "$ac_fc_v_output" |
+ sed -n 's,^.*LD_RUN_PATH *= *\(/[^ ]*\).*$,-R\1,p'`
+ test "x$ac_ld_run_path" != x &&
+ if test "$ac_compiler_gnu" = yes; then
+ for ac_link_opt in $ac_ld_run_path; do
+ ac_cv_fc_libs="$ac_cv_fc_libs -Xlinker $ac_link_opt"
+ done
+else
+ ac_cv_fc_libs="$ac_cv_fc_libs $ac_ld_run_path"
+fi
+ ;;
+esac
+fi # test "x$[]_AC_LANG_PREFIX[]LIBS" = "x"
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_libs" >&5
+$as_echo "$ac_cv_fc_libs" >&6; }
+FCLIBS="$ac_cv_fc_libs"
+
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+DEPDIR="${am__leading_dot}deps"
+
+ac_config_commands="$ac_config_commands depfiles"
+
+
+am_make=${MAKE-make}
+cat > confinc << 'END'
+am__doit:
+ @echo this is the am__doit target
+.PHONY: am__doit
+END
+# If we don't find an include directive, just comment out the code.
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for style of include used by $am_make" >&5
+$as_echo_n "checking for style of include used by $am_make... " >&6; }
+am__include="#"
+am__quote=
+_am_result=none
+# First try GNU make style include.
+echo "include confinc" > confmf
+# Ignore all kinds of additional output from `make'.
+case `$am_make -s -f confmf 2> /dev/null` in #(
+*the\ am__doit\ target*)
+ am__include=include
+ am__quote=
+ _am_result=GNU
+ ;;
+esac
+# Now try BSD make style include.
+if test "$am__include" = "#"; then
+ echo '.include "confinc"' > confmf
+ case `$am_make -s -f confmf 2> /dev/null` in #(
+ *the\ am__doit\ target*)
+ am__include=.include
+ am__quote="\""
+ _am_result=BSD
+ ;;
+ esac
+fi
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $_am_result" >&5
+$as_echo "$_am_result" >&6; }
+rm -f confinc confmf
+
+# Check whether --enable-dependency-tracking was given.
+if test "${enable_dependency_tracking+set}" = set; then :
+ enableval=$enable_dependency_tracking;
+fi
+
+if test "x$enable_dependency_tracking" != xno; then
+ am_depcomp="$ac_aux_dir/depcomp"
+ AMDEPBACKSLASH='\'
+fi
+ if test "x$enable_dependency_tracking" != xno; then
+ AMDEP_TRUE=
+ AMDEP_FALSE='#'
+else
+ AMDEP_TRUE='#'
+ AMDEP_FALSE=
+fi
+
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.
+set dummy ${ac_tool_prefix}gcc; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$CC"; then
+ ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_CC="${ac_tool_prefix}gcc"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_CC"; then
+ ac_ct_CC=$CC
+ # Extract the first word of "gcc", so it can be a program name with args.
+set dummy gcc; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_CC"; then
+ ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_CC="gcc"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_CC=$ac_cv_prog_ac_ct_CC
+if test -n "$ac_ct_CC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+$as_echo "$ac_ct_CC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
+else
+ CC="$ac_cv_prog_CC"
+fi
+
+if test -z "$CC"; then
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
+set dummy ${ac_tool_prefix}cc; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$CC"; then
+ ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_CC="${ac_tool_prefix}cc"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ fi
+fi
+if test -z "$CC"; then
+ # Extract the first word of "cc", so it can be a program name with args.
+set dummy cc; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$CC"; then
+ ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+ ac_prog_rejected=no
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then
+ ac_prog_rejected=yes
+ continue
+ fi
+ ac_cv_prog_CC="cc"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+if test $ac_prog_rejected = yes; then
+ # We found a bogon in the path, so make sure we never use it.
+ set dummy $ac_cv_prog_CC
+ shift
+ if test $# != 0; then
+ # We chose a different compiler from the bogus one.
+ # However, it has the same basename, so the bogon will be chosen
+ # first if we set CC to just the basename; use the full file name.
+ shift
+ ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@"
+ fi
+fi
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$CC"; then
+ if test -n "$ac_tool_prefix"; then
+ for ac_prog in cl.exe
+ do
+ # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
+set dummy $ac_tool_prefix$ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$CC"; then
+ ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_CC="$ac_tool_prefix$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$CC" && break
+ done
+fi
+if test -z "$CC"; then
+ ac_ct_CC=$CC
+ for ac_prog in cl.exe
+do
+ # Extract the first word of "$ac_prog", so it can be a program name with args.
+set dummy $ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_CC"; then
+ ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_CC="$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_CC=$ac_cv_prog_ac_ct_CC
+if test -n "$ac_ct_CC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+$as_echo "$ac_ct_CC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$ac_ct_CC" && break
+done
+
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
+fi
+
+fi
+
+
+test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "no acceptable C compiler found in \$PATH
+See \`config.log' for more details" "$LINENO" 5; }
+
+# Provide some information about the compiler.
+$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5
+set X $ac_compile
+ac_compiler=$2
+for ac_option in --version -v -V -qversion; do
+ { { ac_try="$ac_compiler $ac_option >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_compiler $ac_option >&5") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ sed '10a\
+... rest of stderr output deleted ...
+ 10q' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ fi
+ rm -f conftest.er1 conftest.err
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+done
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5
+$as_echo_n "checking whether we are using the GNU C compiler... " >&6; }
+if ${ac_cv_c_compiler_gnu+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+#ifndef __GNUC__
+ choke me
+#endif
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+ ac_compiler_gnu=yes
+else
+ ac_compiler_gnu=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ac_cv_c_compiler_gnu=$ac_compiler_gnu
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5
+$as_echo "$ac_cv_c_compiler_gnu" >&6; }
+if test $ac_compiler_gnu = yes; then
+ GCC=yes
+else
+ GCC=
+fi
+ac_test_CFLAGS=${CFLAGS+set}
+ac_save_CFLAGS=$CFLAGS
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5
+$as_echo_n "checking whether $CC accepts -g... " >&6; }
+if ${ac_cv_prog_cc_g+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_save_c_werror_flag=$ac_c_werror_flag
+ ac_c_werror_flag=yes
+ ac_cv_prog_cc_g=no
+ CFLAGS="-g"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+ ac_cv_prog_cc_g=yes
+else
+ CFLAGS=""
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+
+else
+ ac_c_werror_flag=$ac_save_c_werror_flag
+ CFLAGS="-g"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+ ac_cv_prog_cc_g=yes
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ ac_c_werror_flag=$ac_save_c_werror_flag
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5
+$as_echo "$ac_cv_prog_cc_g" >&6; }
+if test "$ac_test_CFLAGS" = set; then
+ CFLAGS=$ac_save_CFLAGS
+elif test $ac_cv_prog_cc_g = yes; then
+ if test "$GCC" = yes; then
+ CFLAGS="-g -O2"
+ else
+ CFLAGS="-g"
+ fi
+else
+ if test "$GCC" = yes; then
+ CFLAGS="-O2"
+ else
+ CFLAGS=
+ fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5
+$as_echo_n "checking for $CC option to accept ISO C89... " >&6; }
+if ${ac_cv_prog_cc_c89+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_cv_prog_cc_c89=no
+ac_save_CC=$CC
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <stdarg.h>
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */
+struct buf { int x; };
+FILE * (*rcsopen) (struct buf *, struct stat *, int);
+static char *e (p, i)
+ char **p;
+ int i;
+{
+ return p[i];
+}
+static char *f (char * (*g) (char **, int), char **p, ...)
+{
+ char *s;
+ va_list v;
+ va_start (v,p);
+ s = g (p, va_arg (v,int));
+ va_end (v);
+ return s;
+}
+
+/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
+ function prototypes and stuff, but not '\xHH' hex character constants.
+ These don't provoke an error unfortunately, instead are silently treated
+ as 'x'. The following induces an error, until -std is added to get
+ proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an
+ array size at least. It's necessary to write '\x00'==0 to get something
+ that's true only with -std. */
+int osf4_cc_array ['\x00' == 0 ? 1 : -1];
+
+/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters
+ inside strings and character constants. */
+#define FOO(x) 'x'
+int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1];
+
+int test (int i, double x);
+struct s1 {int (*f) (int a);};
+struct s2 {int (*f) (double a);};
+int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);
+int argc;
+char **argv;
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1];
+ ;
+ return 0;
+}
+_ACEOF
+for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \
+ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
+do
+ CC="$ac_save_CC $ac_arg"
+ if ac_fn_c_try_compile "$LINENO"; then :
+ ac_cv_prog_cc_c89=$ac_arg
+fi
+rm -f core conftest.err conftest.$ac_objext
+ test "x$ac_cv_prog_cc_c89" != "xno" && break
+done
+rm -f conftest.$ac_ext
+CC=$ac_save_CC
+
+fi
+# AC_CACHE_VAL
+case "x$ac_cv_prog_cc_c89" in
+ x)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
+$as_echo "none needed" >&6; } ;;
+ xno)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
+$as_echo "unsupported" >&6; } ;;
+ *)
+ CC="$CC $ac_cv_prog_cc_c89"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5
+$as_echo "$ac_cv_prog_cc_c89" >&6; } ;;
+esac
+if test "x$ac_cv_prog_cc_c89" != xno; then :
+
+fi
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+depcc="$CC" am_compiler_list=
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5
+$as_echo_n "checking dependency style of $depcc... " >&6; }
+if ${am_cv_CC_dependencies_compiler_type+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then
+ # We make a subdir and do the tests there. Otherwise we can end up
+ # making bogus files that we don't know about and never remove. For
+ # instance it was reported that on HP-UX the gcc test will end up
+ # making a dummy file named `D' -- because `-MD' means `put the output
+ # in D'.
+ mkdir conftest.dir
+ # Copy depcomp to subdir because otherwise we won't find it if we're
+ # using a relative directory.
+ cp "$am_depcomp" conftest.dir
+ cd conftest.dir
+ # We will build objects and dependencies in a subdirectory because
+ # it helps to detect inapplicable dependency modes. For instance
+ # both Tru64's cc and ICC support -MD to output dependencies as a
+ # side effect of compilation, but ICC will put the dependencies in
+ # the current directory while Tru64 will put them in the object
+ # directory.
+ mkdir sub
+
+ am_cv_CC_dependencies_compiler_type=none
+ if test "$am_compiler_list" = ""; then
+ am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp`
+ fi
+ am__universal=false
+ case " $depcc " in #(
+ *\ -arch\ *\ -arch\ *) am__universal=true ;;
+ esac
+
+ for depmode in $am_compiler_list; do
+ # Setup a source with many dependencies, because some compilers
+ # like to wrap large dependency lists on column 80 (with \), and
+ # we should not choose a depcomp mode which is confused by this.
+ #
+ # We need to recreate these files for each test, as the compiler may
+ # overwrite some of them when testing with obscure command lines.
+ # This happens at least with the AIX C compiler.
+ : > sub/conftest.c
+ for i in 1 2 3 4 5 6; do
+ echo '#include "conftst'$i'.h"' >> sub/conftest.c
+ # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with
+ # Solaris 8's {/usr,}/bin/sh.
+ touch sub/conftst$i.h
+ done
+ echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf
+
+ # We check with `-c' and `-o' for the sake of the "dashmstdout"
+ # mode. It turns out that the SunPro C++ compiler does not properly
+ # handle `-M -o', and we need to detect this. Also, some Intel
+ # versions had trouble with output in subdirs
+ am__obj=sub/conftest.${OBJEXT-o}
+ am__minus_obj="-o $am__obj"
+ case $depmode in
+ gcc)
+ # This depmode causes a compiler race in universal mode.
+ test "$am__universal" = false || continue
+ ;;
+ nosideeffect)
+ # after this tag, mechanisms are not by side-effect, so they'll
+ # only be used when explicitly requested
+ if test "x$enable_dependency_tracking" = xyes; then
+ continue
+ else
+ break
+ fi
+ ;;
+ msvisualcpp | msvcmsys)
+ # This compiler won't grok `-c -o', but also, the minuso test has
+ # not run yet. These depmodes are late enough in the game, and
+ # so weak that their functioning should not be impacted.
+ am__obj=conftest.${OBJEXT-o}
+ am__minus_obj=
+ ;;
+ none) break ;;
+ esac
+ if depmode=$depmode \
+ source=sub/conftest.c object=$am__obj \
+ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \
+ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \
+ >/dev/null 2>conftest.err &&
+ grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 &&
+ grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 &&
+ grep $am__obj sub/conftest.Po > /dev/null 2>&1 &&
+ ${MAKE-make} -s -f confmf > /dev/null 2>&1; then
+ # icc doesn't choke on unknown options, it will just issue warnings
+ # or remarks (even with -Werror). So we grep stderr for any message
+ # that says an option was ignored or not supported.
+ # When given -MP, icc 7.0 and 7.1 complain thusly:
+ # icc: Command line warning: ignoring option '-M'; no argument required
+ # The diagnosis changed in icc 8.0:
+ # icc: Command line remark: option '-MP' not supported
+ if (grep 'ignoring option' conftest.err ||
+ grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else
+ am_cv_CC_dependencies_compiler_type=$depmode
+ break
+ fi
+ fi
+ done
+
+ cd ..
+ rm -rf conftest.dir
+else
+ am_cv_CC_dependencies_compiler_type=none
+fi
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5
+$as_echo "$am_cv_CC_dependencies_compiler_type" >&6; }
+CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type
+
+ if
+ test "x$enable_dependency_tracking" != xno \
+ && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then
+ am__fastdepCC_TRUE=
+ am__fastdepCC_FALSE='#'
+else
+ am__fastdepCC_TRUE='#'
+ am__fastdepCC_FALSE=
+fi
+
+
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for dummy main to link with Fortran libraries" >&5
+$as_echo_n "checking for dummy main to link with Fortran libraries... " >&6; }
+if ${ac_cv_fc_dummy_main+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_fc_dm_save_LIBS=$LIBS
+ LIBS="$LIBS $FCLIBS"
+ ac_fortran_dm_var=FC_DUMMY_MAIN
+ ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+ # First, try linking without a dummy main:
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_fortran_dummy_main=none
+else
+ ac_cv_fortran_dummy_main=unknown
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+
+ if test $ac_cv_fortran_dummy_main = unknown; then
+ for ac_func in MAIN__ MAIN_ __main MAIN _MAIN __MAIN main_ main__ _main; do
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#define $ac_fortran_dm_var $ac_func
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_fortran_dummy_main=$ac_func; break
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ done
+ fi
+ ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+ ac_cv_fc_dummy_main=$ac_cv_fortran_dummy_main
+ rm -rf conftest*
+ LIBS=$ac_fc_dm_save_LIBS
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_dummy_main" >&5
+$as_echo "$ac_cv_fc_dummy_main" >&6; }
+FC_DUMMY_MAIN=$ac_cv_fc_dummy_main
+if test "$FC_DUMMY_MAIN" != unknown; then :
+ if test $FC_DUMMY_MAIN != none; then
+
+cat >>confdefs.h <<_ACEOF
+#define FC_DUMMY_MAIN $FC_DUMMY_MAIN
+_ACEOF
+
+ if test "x$ac_cv_fc_dummy_main" = "x$ac_cv_f77_dummy_main"; then
+
+$as_echo "#define FC_DUMMY_MAIN_EQ_F77 1" >>confdefs.h
+
+ fi
+fi
+else
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "linking to Fortran libraries from C fails
+See \`config.log' for more details" "$LINENO" 5; }
+fi
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran name-mangling scheme" >&5
+$as_echo_n "checking for Fortran name-mangling scheme... " >&6; }
+if ${ac_cv_fc_mangling+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat > conftest.$ac_ext <<_ACEOF
+ subroutine foobar()
+ return
+ end
+ subroutine foo_bar()
+ return
+ end
+_ACEOF
+if ac_fn_fc_try_compile "$LINENO"; then :
+ mv conftest.$ac_objext cfortran_test.$ac_objext
+
+ ac_save_LIBS=$LIBS
+ LIBS="cfortran_test.$ac_objext $LIBS $FCLIBS"
+
+ ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+ ac_success=no
+ for ac_foobar in foobar FOOBAR; do
+ for ac_underscore in "" "_"; do
+ ac_func="$ac_foobar$ac_underscore"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char $ac_func ();
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return $ac_func ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_success=yes; break 2
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ done
+ done
+ ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+ if test "$ac_success" = "yes"; then
+ case $ac_foobar in
+ foobar)
+ ac_case=lower
+ ac_foo_bar=foo_bar
+ ;;
+ FOOBAR)
+ ac_case=upper
+ ac_foo_bar=FOO_BAR
+ ;;
+ esac
+
+ ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+ ac_success_extra=no
+ for ac_extra in "" "_"; do
+ ac_func="$ac_foo_bar$ac_underscore$ac_extra"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char $ac_func ();
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return $ac_func ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_success_extra=yes; break
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ done
+ ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+ if test "$ac_success_extra" = "yes"; then
+ ac_cv_fc_mangling="$ac_case case"
+ if test -z "$ac_underscore"; then
+ ac_cv_fc_mangling="$ac_cv_fc_mangling, no underscore"
+ else
+ ac_cv_fc_mangling="$ac_cv_fc_mangling, underscore"
+ fi
+ if test -z "$ac_extra"; then
+ ac_cv_fc_mangling="$ac_cv_fc_mangling, no extra underscore"
+ else
+ ac_cv_fc_mangling="$ac_cv_fc_mangling, extra underscore"
+ fi
+ else
+ ac_cv_fc_mangling="unknown"
+ fi
+ else
+ ac_cv_fc_mangling="unknown"
+ fi
+
+ LIBS=$ac_save_LIBS
+ rm -rf conftest*
+ rm -f cfortran_test*
+else
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot compile a simple Fortran program
+See \`config.log' for more details" "$LINENO" 5; }
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_mangling" >&5
+$as_echo "$ac_cv_fc_mangling" >&6; }
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+case $ac_cv_fc_mangling in
+ "lower case, no underscore, no extra underscore")
+ $as_echo "#define FC_FUNC(name,NAME) name" >>confdefs.h
+
+ $as_echo "#define FC_FUNC_(name,NAME) name" >>confdefs.h
+ ;;
+ "lower case, no underscore, extra underscore")
+ $as_echo "#define FC_FUNC(name,NAME) name" >>confdefs.h
+
+ $as_echo "#define FC_FUNC_(name,NAME) name ## _" >>confdefs.h
+ ;;
+ "lower case, underscore, no extra underscore")
+ $as_echo "#define FC_FUNC(name,NAME) name ## _" >>confdefs.h
+
+ $as_echo "#define FC_FUNC_(name,NAME) name ## _" >>confdefs.h
+ ;;
+ "lower case, underscore, extra underscore")
+ $as_echo "#define FC_FUNC(name,NAME) name ## _" >>confdefs.h
+
+ $as_echo "#define FC_FUNC_(name,NAME) name ## __" >>confdefs.h
+ ;;
+ "upper case, no underscore, no extra underscore")
+ $as_echo "#define FC_FUNC(name,NAME) NAME" >>confdefs.h
+
+ $as_echo "#define FC_FUNC_(name,NAME) NAME" >>confdefs.h
+ ;;
+ "upper case, no underscore, extra underscore")
+ $as_echo "#define FC_FUNC(name,NAME) NAME" >>confdefs.h
+
+ $as_echo "#define FC_FUNC_(name,NAME) NAME ## _" >>confdefs.h
+ ;;
+ "upper case, underscore, no extra underscore")
+ $as_echo "#define FC_FUNC(name,NAME) NAME ## _" >>confdefs.h
+
+ $as_echo "#define FC_FUNC_(name,NAME) NAME ## _" >>confdefs.h
+ ;;
+ "upper case, underscore, extra underscore")
+ $as_echo "#define FC_FUNC(name,NAME) NAME ## _" >>confdefs.h
+
+ $as_echo "#define FC_FUNC_(name,NAME) NAME ## __" >>confdefs.h
+ ;;
+ *)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unknown Fortran name-mangling scheme" >&5
+$as_echo "$as_me: WARNING: unknown Fortran name-mangling scheme" >&2;}
+ ;;
+esac
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran flag to compile .f90 files" >&5
+$as_echo_n "checking for Fortran flag to compile .f90 files... " >&6; }
+if ${ac_cv_fc_srcext_f90+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_ext=f90
+ac_fcflags_srcext_save=$ac_fcflags_srcext
+ac_fcflags_srcext=
+ac_cv_fc_srcext_f90=unknown
+for ac_flag in none -qsuffix=f=f90 -Tf; do
+ test "x$ac_flag" != xnone && ac_fcflags_srcext="$ac_flag"
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_fc_try_compile "$LINENO"; then :
+ ac_cv_fc_srcext_f90=$ac_flag; break
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+done
+rm -f conftest.$ac_objext conftest.f90
+ac_fcflags_srcext=$ac_fcflags_srcext_save
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_srcext_f90" >&5
+$as_echo "$ac_cv_fc_srcext_f90" >&6; }
+if test "x$ac_cv_fc_srcext_f90" = xunknown; then
+ as_fn_error $? "Fortran could not compile .f90 files" "$LINENO" 5
+else
+ ac_fc_srcext=f90
+ if test "x$ac_cv_fc_srcext_f90" = xnone; then
+ ac_fcflags_srcext=""
+ FCFLAGS_f90=""
+ else
+ ac_fcflags_srcext=$ac_cv_fc_srcext_f90
+ FCFLAGS_f90=$ac_cv_fc_srcext_f90
+ fi
+
+
+fi
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran flag needed to accept free-form source" >&5
+$as_echo_n "checking for Fortran flag needed to accept free-form source... " >&6; }
+if ${ac_cv_fc_freeform+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_cv_fc_freeform=unknown
+ac_fc_freeform_FCFLAGS_save=$FCFLAGS
+for ac_flag in none -ffree-form -FR -free -qfree -Mfree -Mfreeform \
+ -freeform "-f free" +source=free -nfix
+do
+ test "x$ac_flag" != xnone && FCFLAGS="$ac_fc_freeform_FCFLAGS_save $ac_flag"
+ cat > conftest.$ac_ext <<_ACEOF
+
+ program freeform
+ ! FIXME: how to best confuse non-freeform compilers?
+ print *, 'Hello ', &
+ 'world.'
+ end
+_ACEOF
+if ac_fn_fc_try_compile "$LINENO"; then :
+ ac_cv_fc_freeform=$ac_flag; break
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+done
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+FCFLAGS=$ac_fc_freeform_FCFLAGS_save
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_freeform" >&5
+$as_echo "$ac_cv_fc_freeform" >&6; }
+if test "x$ac_cv_fc_freeform" = xunknown; then
+ as_fn_error 77 "Fortran does not accept free-form source" "$LINENO" 5
+else
+ if test "x$ac_cv_fc_freeform" != xnone; then
+ FCFLAGS="$FCFLAGS $ac_cv_fc_freeform"
+ fi
+
+fi
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+ac_fc_line_len_string=unlimited
+ ac_fc_line_len=0
+ ac_fc_line_length_test='
+ subroutine longer_than_132(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,'\
+'arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,arg17,arg18,arg19)'
+: ${ac_fc_line_len_string=$ac_fc_line_len}
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran flag needed to accept $ac_fc_line_len_string column source lines" >&5
+$as_echo_n "checking for Fortran flag needed to accept $ac_fc_line_len_string column source lines... " >&6; }
+if ${ac_cv_fc_line_length+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_cv_fc_line_length=unknown
+ac_fc_line_length_FCFLAGS_save=$FCFLAGS
+for ac_flag in none \
+ -ffree-line-length-none -ffixed-line-length-none \
+ -ffree-line-length-$ac_fc_line_len \
+ -ffixed-line-length-$ac_fc_line_len \
+ -qfixed=$ac_fc_line_len -Mextend \
+ -$ac_fc_line_len -extend_source \
+ "-W $ac_fc_line_len" +extend_source -wide -e
+do
+ test "x$ac_flag" != xnone && FCFLAGS="$ac_fc_line_length_FCFLAGS_save $ac_flag"
+ cat > conftest.$ac_ext <<_ACEOF
+$ac_fc_line_length_test
+ end subroutine
+_ACEOF
+if ac_fn_fc_try_compile "$LINENO"; then :
+ ac_cv_fc_line_length=$ac_flag; break
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+done
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+FCFLAGS=$ac_fc_line_length_FCFLAGS_save
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_line_length" >&5
+$as_echo "$ac_cv_fc_line_length" >&6; }
+if test "x$ac_cv_fc_line_length" = xunknown; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Fortran compiler does not accept long source lines" >&5
+$as_echo "$as_me: WARNING: Fortran compiler does not accept long source lines" >&2;}
+else
+ if test "x$ac_cv_fc_line_length" != xnone; then
+ FCFLAGS="$FCFLAGS $ac_cv_fc_line_length"
+ fi
+
+fi
+ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+ac_ext=f
+ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5'
+ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_f77_compiler_gnu
+
+
+ac_ext=f
+ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5'
+ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_f77_compiler_gnu
+my_f77_line_len=132
+ my_f77_line_length_test='
+ subroutine longer_than_80(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,'\
+'arg10)'
+: ${my_f77_line_len_string=$my_f77_line_len}
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 flag needed to accept $my_f77_line_len_string column source lines" >&5
+$as_echo_n "checking for Fortran 77 flag needed to accept $my_f77_line_len_string column source lines... " >&6; }
+if ${my_cv_f77_line_length+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ my_cv_f77_line_length=unknown
+my_f77_line_length_FFLAGS_save=$FFLAGS
+for ac_flag in none \
+ -ffixed-line-length-none \
+ -ffixed-line-length-$my_f77_line_len \
+ -qfixed=$my_f77_line_len -Mextend \
+ -$my_f77_line_len -extend_source \
+ "-W $my_f77_line_len" +extend_source -wide -e
+do
+ test "x$ac_flag" != xnone && FFLAGS="$my_f77_line_length_FFLAGS_save $ac_flag"
+ cat > conftest.$ac_ext <<_ACEOF
+$my_f77_line_length_test
+ end subroutine
+_ACEOF
+if ac_fn_f77_try_compile "$LINENO"; then :
+ my_cv_f77_line_length=$ac_flag; break
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+done
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+FFLAGS=$my_f77_line_length_FFLAGS_save
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $my_cv_f77_line_length" >&5
+$as_echo "$my_cv_f77_line_length" >&6; }
+if test "x$my_cv_f77_line_length" = xunknown; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Fortran 77 compiler does not accept long source lines" >&5
+$as_echo "$as_me: WARNING: Fortran 77 compiler does not accept long source lines" >&2;}
+else
+ if test "x$my_cv_f77_line_length" != xnone; then
+ FFLAGS="$FFLAGS $my_cv_f77_line_length"
+ fi
+
+fi
+ac_ext=f
+ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5'
+ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_f77_compiler_gnu
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+case `pwd` in
+ *\ * | *\ *)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Libtool does not cope well with whitespace in \`pwd\`" >&5
+$as_echo "$as_me: WARNING: Libtool does not cope well with whitespace in \`pwd\`" >&2;} ;;
+esac
+
+
+
+macro_version='2.4'
+macro_revision='1.3293'
+
+
+
+
+
+
+
+
+
+
+
+
+
+ltmain="$ac_aux_dir/ltmain.sh"
+
+# Make sure we can run config.sub.
+$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 ||
+ as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5
+$as_echo_n "checking build system type... " >&6; }
+if ${ac_cv_build+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_build_alias=$build_alias
+test "x$ac_build_alias" = x &&
+ ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"`
+test "x$ac_build_alias" = x &&
+ as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5
+ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` ||
+ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5
+$as_echo "$ac_cv_build" >&6; }
+case $ac_cv_build in
+*-*-*) ;;
+*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;;
+esac
+build=$ac_cv_build
+ac_save_IFS=$IFS; IFS='-'
+set x $ac_cv_build
+shift
+build_cpu=$1
+build_vendor=$2
+shift; shift
+# Remember, the first character of IFS is used to create $*,
+# except with old shells:
+build_os=$*
+IFS=$ac_save_IFS
+case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5
+$as_echo_n "checking host system type... " >&6; }
+if ${ac_cv_host+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test "x$host_alias" = x; then
+ ac_cv_host=$ac_cv_build
+else
+ ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` ||
+ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5
+fi
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5
+$as_echo "$ac_cv_host" >&6; }
+case $ac_cv_host in
+*-*-*) ;;
+*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;;
+esac
+host=$ac_cv_host
+ac_save_IFS=$IFS; IFS='-'
+set x $ac_cv_host
+shift
+host_cpu=$1
+host_vendor=$2
+shift; shift
+# Remember, the first character of IFS is used to create $*,
+# except with old shells:
+host_os=$*
+IFS=$ac_save_IFS
+case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac
+
+
+# Backslashify metacharacters that are still active within
+# double-quoted strings.
+sed_quote_subst='s/\(["`$\\]\)/\\\1/g'
+
+# Same as above, but do not quote variable references.
+double_quote_subst='s/\(["`\\]\)/\\\1/g'
+
+# Sed substitution to delay expansion of an escaped shell variable in a
+# double_quote_subst'ed string.
+delay_variable_subst='s/\\\\\\\\\\\$/\\\\\\$/g'
+
+# Sed substitution to delay expansion of an escaped single quote.
+delay_single_quote_subst='s/'\''/'\'\\\\\\\'\''/g'
+
+# Sed substitution to avoid accidental globbing in evaled expressions
+no_glob_subst='s/\*/\\\*/g'
+
+ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO
+ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to print strings" >&5
+$as_echo_n "checking how to print strings... " >&6; }
+# Test print first, because it will be a builtin if present.
+if test "X`( print -r -- -n ) 2>/dev/null`" = X-n && \
+ test "X`print -r -- $ECHO 2>/dev/null`" = "X$ECHO"; then
+ ECHO='print -r --'
+elif test "X`printf %s $ECHO 2>/dev/null`" = "X$ECHO"; then
+ ECHO='printf %s\n'
+else
+ # Use this function as a fallback that always works.
+ func_fallback_echo ()
+ {
+ eval 'cat <<_LTECHO_EOF
+$1
+_LTECHO_EOF'
+ }
+ ECHO='func_fallback_echo'
+fi
+
+# func_echo_all arg...
+# Invoke $ECHO with all args, space-separated.
+func_echo_all ()
+{
+ $ECHO ""
+}
+
+case "$ECHO" in
+ printf*) { $as_echo "$as_me:${as_lineno-$LINENO}: result: printf" >&5
+$as_echo "printf" >&6; } ;;
+ print*) { $as_echo "$as_me:${as_lineno-$LINENO}: result: print -r" >&5
+$as_echo "print -r" >&6; } ;;
+ *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: cat" >&5
+$as_echo "cat" >&6; } ;;
+esac
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a sed that does not truncate output" >&5
+$as_echo_n "checking for a sed that does not truncate output... " >&6; }
+if ${ac_cv_path_SED+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/
+ for ac_i in 1 2 3 4 5 6 7; do
+ ac_script="$ac_script$as_nl$ac_script"
+ done
+ echo "$ac_script" 2>/dev/null | sed 99q >conftest.sed
+ { ac_script=; unset ac_script;}
+ if test -z "$SED"; then
+ ac_path_SED_found=false
+ # Loop through the user's path and test for each of PROGNAME-LIST
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_prog in sed gsed; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_SED="$as_dir/$ac_prog$ac_exec_ext"
+ { test -f "$ac_path_SED" && $as_test_x "$ac_path_SED"; } || continue
+# Check for GNU ac_path_SED and select it if it is found.
+ # Check for GNU $ac_path_SED
+case `"$ac_path_SED" --version 2>&1` in
+*GNU*)
+ ac_cv_path_SED="$ac_path_SED" ac_path_SED_found=:;;
+*)
+ ac_count=0
+ $as_echo_n 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ $as_echo '' >> "conftest.nl"
+ "$ac_path_SED" -f conftest.sed < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ as_fn_arith $ac_count + 1 && ac_count=$as_val
+ if test $ac_count -gt ${ac_path_SED_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_SED="$ac_path_SED"
+ ac_path_SED_max=$ac_count
+ fi
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
+
+ $ac_path_SED_found && break 3
+ done
+ done
+ done
+IFS=$as_save_IFS
+ if test -z "$ac_cv_path_SED"; then
+ as_fn_error $? "no acceptable sed could be found in \$PATH" "$LINENO" 5
+ fi
+else
+ ac_cv_path_SED=$SED
+fi
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_SED" >&5
+$as_echo "$ac_cv_path_SED" >&6; }
+ SED="$ac_cv_path_SED"
+ rm -f conftest.sed
+
+test -z "$SED" && SED=sed
+Xsed="$SED -e 1s/^X//"
+
+
+
+
+
+
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5
+$as_echo_n "checking for grep that handles long lines and -e... " >&6; }
+if ${ac_cv_path_GREP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -z "$GREP"; then
+ ac_path_GREP_found=false
+ # Loop through the user's path and test for each of PROGNAME-LIST
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_prog in grep ggrep; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext"
+ { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue
+# Check for GNU ac_path_GREP and select it if it is found.
+ # Check for GNU $ac_path_GREP
+case `"$ac_path_GREP" --version 2>&1` in
+*GNU*)
+ ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;;
+*)
+ ac_count=0
+ $as_echo_n 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ $as_echo 'GREP' >> "conftest.nl"
+ "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ as_fn_arith $ac_count + 1 && ac_count=$as_val
+ if test $ac_count -gt ${ac_path_GREP_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_GREP="$ac_path_GREP"
+ ac_path_GREP_max=$ac_count
+ fi
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
+
+ $ac_path_GREP_found && break 3
+ done
+ done
+ done
+IFS=$as_save_IFS
+ if test -z "$ac_cv_path_GREP"; then
+ as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
+ fi
+else
+ ac_cv_path_GREP=$GREP
+fi
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5
+$as_echo "$ac_cv_path_GREP" >&6; }
+ GREP="$ac_cv_path_GREP"
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5
+$as_echo_n "checking for egrep... " >&6; }
+if ${ac_cv_path_EGREP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if echo a | $GREP -E '(a|b)' >/dev/null 2>&1
+ then ac_cv_path_EGREP="$GREP -E"
+ else
+ if test -z "$EGREP"; then
+ ac_path_EGREP_found=false
+ # Loop through the user's path and test for each of PROGNAME-LIST
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_prog in egrep; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext"
+ { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue
+# Check for GNU ac_path_EGREP and select it if it is found.
+ # Check for GNU $ac_path_EGREP
+case `"$ac_path_EGREP" --version 2>&1` in
+*GNU*)
+ ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;;
+*)
+ ac_count=0
+ $as_echo_n 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ $as_echo 'EGREP' >> "conftest.nl"
+ "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ as_fn_arith $ac_count + 1 && ac_count=$as_val
+ if test $ac_count -gt ${ac_path_EGREP_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_EGREP="$ac_path_EGREP"
+ ac_path_EGREP_max=$ac_count
+ fi
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
+
+ $ac_path_EGREP_found && break 3
+ done
+ done
+ done
+IFS=$as_save_IFS
+ if test -z "$ac_cv_path_EGREP"; then
+ as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
+ fi
+else
+ ac_cv_path_EGREP=$EGREP
+fi
+
+ fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5
+$as_echo "$ac_cv_path_EGREP" >&6; }
+ EGREP="$ac_cv_path_EGREP"
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for fgrep" >&5
+$as_echo_n "checking for fgrep... " >&6; }
+if ${ac_cv_path_FGREP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if echo 'ab*c' | $GREP -F 'ab*c' >/dev/null 2>&1
+ then ac_cv_path_FGREP="$GREP -F"
+ else
+ if test -z "$FGREP"; then
+ ac_path_FGREP_found=false
+ # Loop through the user's path and test for each of PROGNAME-LIST
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_prog in fgrep; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_FGREP="$as_dir/$ac_prog$ac_exec_ext"
+ { test -f "$ac_path_FGREP" && $as_test_x "$ac_path_FGREP"; } || continue
+# Check for GNU ac_path_FGREP and select it if it is found.
+ # Check for GNU $ac_path_FGREP
+case `"$ac_path_FGREP" --version 2>&1` in
+*GNU*)
+ ac_cv_path_FGREP="$ac_path_FGREP" ac_path_FGREP_found=:;;
+*)
+ ac_count=0
+ $as_echo_n 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ $as_echo 'FGREP' >> "conftest.nl"
+ "$ac_path_FGREP" FGREP < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ as_fn_arith $ac_count + 1 && ac_count=$as_val
+ if test $ac_count -gt ${ac_path_FGREP_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_FGREP="$ac_path_FGREP"
+ ac_path_FGREP_max=$ac_count
+ fi
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
+
+ $ac_path_FGREP_found && break 3
+ done
+ done
+ done
+IFS=$as_save_IFS
+ if test -z "$ac_cv_path_FGREP"; then
+ as_fn_error $? "no acceptable fgrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
+ fi
+else
+ ac_cv_path_FGREP=$FGREP
+fi
+
+ fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_FGREP" >&5
+$as_echo "$ac_cv_path_FGREP" >&6; }
+ FGREP="$ac_cv_path_FGREP"
+
+
+test -z "$GREP" && GREP=grep
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# Check whether --with-gnu-ld was given.
+if test "${with_gnu_ld+set}" = set; then :
+ withval=$with_gnu_ld; test "$withval" = no || with_gnu_ld=yes
+else
+ with_gnu_ld=no
+fi
+
+ac_prog=ld
+if test "$GCC" = yes; then
+ # Check if gcc -print-prog-name=ld gives a path.
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ld used by $CC" >&5
+$as_echo_n "checking for ld used by $CC... " >&6; }
+ case $host in
+ *-*-mingw*)
+ # gcc leaves a trailing carriage return which upsets mingw
+ ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;;
+ *)
+ ac_prog=`($CC -print-prog-name=ld) 2>&5` ;;
+ esac
+ case $ac_prog in
+ # Accept absolute paths.
+ [\\/]* | ?:[\\/]*)
+ re_direlt='/[^/][^/]*/\.\./'
+ # Canonicalize the pathname of ld
+ ac_prog=`$ECHO "$ac_prog"| $SED 's%\\\\%/%g'`
+ while $ECHO "$ac_prog" | $GREP "$re_direlt" > /dev/null 2>&1; do
+ ac_prog=`$ECHO $ac_prog| $SED "s%$re_direlt%/%"`
+ done
+ test -z "$LD" && LD="$ac_prog"
+ ;;
+ "")
+ # If it fails, then pretend we aren't using GCC.
+ ac_prog=ld
+ ;;
+ *)
+ # If it is relative, then search for the first ld in PATH.
+ with_gnu_ld=unknown
+ ;;
+ esac
+elif test "$with_gnu_ld" = yes; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GNU ld" >&5
+$as_echo_n "checking for GNU ld... " >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for non-GNU ld" >&5
+$as_echo_n "checking for non-GNU ld... " >&6; }
+fi
+if ${lt_cv_path_LD+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -z "$LD"; then
+ lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR
+ for ac_dir in $PATH; do
+ IFS="$lt_save_ifs"
+ test -z "$ac_dir" && ac_dir=.
+ if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then
+ lt_cv_path_LD="$ac_dir/$ac_prog"
+ # Check to see if the program is GNU ld. I'd rather use --version,
+ # but apparently some variants of GNU ld only accept -v.
+ # Break only if it was the GNU/non-GNU ld that we prefer.
+ case `"$lt_cv_path_LD" -v 2>&1 </dev/null` in
+ *GNU* | *'with BFD'*)
+ test "$with_gnu_ld" != no && break
+ ;;
+ *)
+ test "$with_gnu_ld" != yes && break
+ ;;
+ esac
+ fi
+ done
+ IFS="$lt_save_ifs"
+else
+ lt_cv_path_LD="$LD" # Let the user override the test with a path.
+fi
+fi
+
+LD="$lt_cv_path_LD"
+if test -n "$LD"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LD" >&5
+$as_echo "$LD" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+test -z "$LD" && as_fn_error $? "no acceptable ld found in \$PATH" "$LINENO" 5
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if the linker ($LD) is GNU ld" >&5
+$as_echo_n "checking if the linker ($LD) is GNU ld... " >&6; }
+if ${lt_cv_prog_gnu_ld+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ # I'd rather use --version here, but apparently some GNU lds only accept -v.
+case `$LD -v 2>&1 </dev/null` in
+*GNU* | *'with BFD'*)
+ lt_cv_prog_gnu_ld=yes
+ ;;
+*)
+ lt_cv_prog_gnu_ld=no
+ ;;
+esac
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_gnu_ld" >&5
+$as_echo "$lt_cv_prog_gnu_ld" >&6; }
+with_gnu_ld=$lt_cv_prog_gnu_ld
+
+
+
+
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for BSD- or MS-compatible name lister (nm)" >&5
+$as_echo_n "checking for BSD- or MS-compatible name lister (nm)... " >&6; }
+if ${lt_cv_path_NM+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$NM"; then
+ # Let the user override the test.
+ lt_cv_path_NM="$NM"
+else
+ lt_nm_to_check="${ac_tool_prefix}nm"
+ if test -n "$ac_tool_prefix" && test "$build" = "$host"; then
+ lt_nm_to_check="$lt_nm_to_check nm"
+ fi
+ for lt_tmp_nm in $lt_nm_to_check; do
+ lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR
+ for ac_dir in $PATH /usr/ccs/bin/elf /usr/ccs/bin /usr/ucb /bin; do
+ IFS="$lt_save_ifs"
+ test -z "$ac_dir" && ac_dir=.
+ tmp_nm="$ac_dir/$lt_tmp_nm"
+ if test -f "$tmp_nm" || test -f "$tmp_nm$ac_exeext" ; then
+ # Check to see if the nm accepts a BSD-compat flag.
+ # Adding the `sed 1q' prevents false positives on HP-UX, which says:
+ # nm: unknown option "B" ignored
+ # Tru64's nm complains that /dev/null is an invalid object file
+ case `"$tmp_nm" -B /dev/null 2>&1 | sed '1q'` in
+ */dev/null* | *'Invalid file or object type'*)
+ lt_cv_path_NM="$tmp_nm -B"
+ break
+ ;;
+ *)
+ case `"$tmp_nm" -p /dev/null 2>&1 | sed '1q'` in
+ */dev/null*)
+ lt_cv_path_NM="$tmp_nm -p"
+ break
+ ;;
+ *)
+ lt_cv_path_NM=${lt_cv_path_NM="$tmp_nm"} # keep the first match, but
+ continue # so that we can try to find one that supports BSD flags
+ ;;
+ esac
+ ;;
+ esac
+ fi
+ done
+ IFS="$lt_save_ifs"
+ done
+ : ${lt_cv_path_NM=no}
+fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_NM" >&5
+$as_echo "$lt_cv_path_NM" >&6; }
+if test "$lt_cv_path_NM" != "no"; then
+ NM="$lt_cv_path_NM"
+else
+ # Didn't find any BSD compatible name lister, look for dumpbin.
+ if test -n "$DUMPBIN"; then :
+ # Let the user override the test.
+ else
+ if test -n "$ac_tool_prefix"; then
+ for ac_prog in dumpbin "link -dump"
+ do
+ # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
+set dummy $ac_tool_prefix$ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_DUMPBIN+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$DUMPBIN"; then
+ ac_cv_prog_DUMPBIN="$DUMPBIN" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_DUMPBIN="$ac_tool_prefix$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+DUMPBIN=$ac_cv_prog_DUMPBIN
+if test -n "$DUMPBIN"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DUMPBIN" >&5
+$as_echo "$DUMPBIN" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$DUMPBIN" && break
+ done
+fi
+if test -z "$DUMPBIN"; then
+ ac_ct_DUMPBIN=$DUMPBIN
+ for ac_prog in dumpbin "link -dump"
+do
+ # Extract the first word of "$ac_prog", so it can be a program name with args.
+set dummy $ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_DUMPBIN+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_DUMPBIN"; then
+ ac_cv_prog_ac_ct_DUMPBIN="$ac_ct_DUMPBIN" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_DUMPBIN="$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_DUMPBIN=$ac_cv_prog_ac_ct_DUMPBIN
+if test -n "$ac_ct_DUMPBIN"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DUMPBIN" >&5
+$as_echo "$ac_ct_DUMPBIN" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$ac_ct_DUMPBIN" && break
+done
+
+ if test "x$ac_ct_DUMPBIN" = x; then
+ DUMPBIN=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ DUMPBIN=$ac_ct_DUMPBIN
+ fi
+fi
+
+ case `$DUMPBIN -symbols /dev/null 2>&1 | sed '1q'` in
+ *COFF*)
+ DUMPBIN="$DUMPBIN -symbols"
+ ;;
+ *)
+ DUMPBIN=:
+ ;;
+ esac
+ fi
+
+ if test "$DUMPBIN" != ":"; then
+ NM="$DUMPBIN"
+ fi
+fi
+test -z "$NM" && NM=nm
+
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking the name lister ($NM) interface" >&5
+$as_echo_n "checking the name lister ($NM) interface... " >&6; }
+if ${lt_cv_nm_interface+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_nm_interface="BSD nm"
+ echo "int some_variable = 0;" > conftest.$ac_ext
+ (eval echo "\"\$as_me:$LINENO: $ac_compile\"" >&5)
+ (eval "$ac_compile" 2>conftest.err)
+ cat conftest.err >&5
+ (eval echo "\"\$as_me:$LINENO: $NM \\\"conftest.$ac_objext\\\"\"" >&5)
+ (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out)
+ cat conftest.err >&5
+ (eval echo "\"\$as_me:$LINENO: output\"" >&5)
+ cat conftest.out >&5
+ if $GREP 'External.*some_variable' conftest.out > /dev/null; then
+ lt_cv_nm_interface="MS dumpbin"
+ fi
+ rm -f conftest*
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_nm_interface" >&5
+$as_echo "$lt_cv_nm_interface" >&6; }
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ln -s works" >&5
+$as_echo_n "checking whether ln -s works... " >&6; }
+LN_S=$as_ln_s
+if test "$LN_S" = "ln -s"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no, using $LN_S" >&5
+$as_echo "no, using $LN_S" >&6; }
+fi
+
+# find the maximum length of command line arguments
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking the maximum length of command line arguments" >&5
+$as_echo_n "checking the maximum length of command line arguments... " >&6; }
+if ${lt_cv_sys_max_cmd_len+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ i=0
+ teststring="ABCD"
+
+ case $build_os in
+ msdosdjgpp*)
+ # On DJGPP, this test can blow up pretty badly due to problems in libc
+ # (any single argument exceeding 2000 bytes causes a buffer overrun
+ # during glob expansion). Even if it were fixed, the result of this
+ # check would be larger than it should be.
+ lt_cv_sys_max_cmd_len=12288; # 12K is about right
+ ;;
+
+ gnu*)
+ # Under GNU Hurd, this test is not required because there is
+ # no limit to the length of command line arguments.
+ # Libtool will interpret -1 as no limit whatsoever
+ lt_cv_sys_max_cmd_len=-1;
+ ;;
+
+ cygwin* | mingw* | cegcc*)
+ # On Win9x/ME, this test blows up -- it succeeds, but takes
+ # about 5 minutes as the teststring grows exponentially.
+ # Worse, since 9x/ME are not pre-emptively multitasking,
+ # you end up with a "frozen" computer, even though with patience
+ # the test eventually succeeds (with a max line length of 256k).
+ # Instead, let's just punt: use the minimum linelength reported by
+ # all of the supported platforms: 8192 (on NT/2K/XP).
+ lt_cv_sys_max_cmd_len=8192;
+ ;;
+
+ mint*)
+ # On MiNT this can take a long time and run out of memory.
+ lt_cv_sys_max_cmd_len=8192;
+ ;;
+
+ amigaos*)
+ # On AmigaOS with pdksh, this test takes hours, literally.
+ # So we just punt and use a minimum line length of 8192.
+ lt_cv_sys_max_cmd_len=8192;
+ ;;
+
+ netbsd* | freebsd* | openbsd* | darwin* | dragonfly*)
+ # This has been around since 386BSD, at least. Likely further.
+ if test -x /sbin/sysctl; then
+ lt_cv_sys_max_cmd_len=`/sbin/sysctl -n kern.argmax`
+ elif test -x /usr/sbin/sysctl; then
+ lt_cv_sys_max_cmd_len=`/usr/sbin/sysctl -n kern.argmax`
+ else
+ lt_cv_sys_max_cmd_len=65536 # usable default for all BSDs
+ fi
+ # And add a safety zone
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4`
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3`
+ ;;
+
+ interix*)
+ # We know the value 262144 and hardcode it with a safety zone (like BSD)
+ lt_cv_sys_max_cmd_len=196608
+ ;;
+
+ osf*)
+ # Dr. Hans Ekkehard Plesser reports seeing a kernel panic running configure
+ # due to this test when exec_disable_arg_limit is 1 on Tru64. It is not
+ # nice to cause kernel panics so lets avoid the loop below.
+ # First set a reasonable default.
+ lt_cv_sys_max_cmd_len=16384
+ #
+ if test -x /sbin/sysconfig; then
+ case `/sbin/sysconfig -q proc exec_disable_arg_limit` in
+ *1*) lt_cv_sys_max_cmd_len=-1 ;;
+ esac
+ fi
+ ;;
+ sco3.2v5*)
+ lt_cv_sys_max_cmd_len=102400
+ ;;
+ sysv5* | sco5v6* | sysv4.2uw2*)
+ kargmax=`grep ARG_MAX /etc/conf/cf.d/stune 2>/dev/null`
+ if test -n "$kargmax"; then
+ lt_cv_sys_max_cmd_len=`echo $kargmax | sed 's/.*[ ]//'`
+ else
+ lt_cv_sys_max_cmd_len=32768
+ fi
+ ;;
+ *)
+ lt_cv_sys_max_cmd_len=`(getconf ARG_MAX) 2> /dev/null`
+ if test -n "$lt_cv_sys_max_cmd_len"; then
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4`
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3`
+ else
+ # Make teststring a little bigger before we do anything with it.
+ # a 1K string should be a reasonable start.
+ for i in 1 2 3 4 5 6 7 8 ; do
+ teststring=$teststring$teststring
+ done
+ SHELL=${SHELL-${CONFIG_SHELL-/bin/sh}}
+ # If test is not a shell built-in, we'll probably end up computing a
+ # maximum length that is only half of the actual maximum length, but
+ # we can't tell.
+ while { test "X"`func_fallback_echo "$teststring$teststring" 2>/dev/null` \
+ = "X$teststring$teststring"; } >/dev/null 2>&1 &&
+ test $i != 17 # 1/2 MB should be enough
+ do
+ i=`expr $i + 1`
+ teststring=$teststring$teststring
+ done
+ # Only check the string length outside the loop.
+ lt_cv_sys_max_cmd_len=`expr "X$teststring" : ".*" 2>&1`
+ teststring=
+ # Add a significant safety factor because C++ compilers can tack on
+ # massive amounts of additional arguments before passing them to the
+ # linker. It appears as though 1/2 is a usable value.
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 2`
+ fi
+ ;;
+ esac
+
+fi
+
+if test -n $lt_cv_sys_max_cmd_len ; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sys_max_cmd_len" >&5
+$as_echo "$lt_cv_sys_max_cmd_len" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5
+$as_echo "none" >&6; }
+fi
+max_cmd_len=$lt_cv_sys_max_cmd_len
+
+
+
+
+
+
+: ${CP="cp -f"}
+: ${MV="mv -f"}
+: ${RM="rm -f"}
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the shell understands some XSI constructs" >&5
+$as_echo_n "checking whether the shell understands some XSI constructs... " >&6; }
+# Try some XSI features
+xsi_shell=no
+( _lt_dummy="a/b/c"
+ test "${_lt_dummy##*/},${_lt_dummy%/*},${_lt_dummy#??}"${_lt_dummy%"$_lt_dummy"}, \
+ = c,a/b,b/c, \
+ && eval 'test $(( 1 + 1 )) -eq 2 \
+ && test "${#_lt_dummy}" -eq 5' ) >/dev/null 2>&1 \
+ && xsi_shell=yes
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $xsi_shell" >&5
+$as_echo "$xsi_shell" >&6; }
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the shell understands \"+=\"" >&5
+$as_echo_n "checking whether the shell understands \"+=\"... " >&6; }
+lt_shell_append=no
+( foo=bar; set foo baz; eval "$1+=\$2" && test "$foo" = barbaz ) \
+ >/dev/null 2>&1 \
+ && lt_shell_append=yes
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_shell_append" >&5
+$as_echo "$lt_shell_append" >&6; }
+
+
+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
+ lt_unset=unset
+else
+ lt_unset=false
+fi
+
+
+
+
+
+# test EBCDIC or ASCII
+case `echo X|tr X '\101'` in
+ A) # ASCII based system
+ # \n is not interpreted correctly by Solaris 8 /usr/ucb/tr
+ lt_SP2NL='tr \040 \012'
+ lt_NL2SP='tr \015\012 \040\040'
+ ;;
+ *) # EBCDIC based system
+ lt_SP2NL='tr \100 \n'
+ lt_NL2SP='tr \r\n \100\100'
+ ;;
+esac
+
+
+
+
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to convert $build file names to $host format" >&5
+$as_echo_n "checking how to convert $build file names to $host format... " >&6; }
+if ${lt_cv_to_host_file_cmd+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ case $host in
+ *-*-mingw* )
+ case $build in
+ *-*-mingw* ) # actually msys
+ lt_cv_to_host_file_cmd=func_convert_file_msys_to_w32
+ ;;
+ *-*-cygwin* )
+ lt_cv_to_host_file_cmd=func_convert_file_cygwin_to_w32
+ ;;
+ * ) # otherwise, assume *nix
+ lt_cv_to_host_file_cmd=func_convert_file_nix_to_w32
+ ;;
+ esac
+ ;;
+ *-*-cygwin* )
+ case $build in
+ *-*-mingw* ) # actually msys
+ lt_cv_to_host_file_cmd=func_convert_file_msys_to_cygwin
+ ;;
+ *-*-cygwin* )
+ lt_cv_to_host_file_cmd=func_convert_file_noop
+ ;;
+ * ) # otherwise, assume *nix
+ lt_cv_to_host_file_cmd=func_convert_file_nix_to_cygwin
+ ;;
+ esac
+ ;;
+ * ) # unhandled hosts (and "normal" native builds)
+ lt_cv_to_host_file_cmd=func_convert_file_noop
+ ;;
+esac
+
+fi
+
+to_host_file_cmd=$lt_cv_to_host_file_cmd
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_host_file_cmd" >&5
+$as_echo "$lt_cv_to_host_file_cmd" >&6; }
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to convert $build file names to toolchain format" >&5
+$as_echo_n "checking how to convert $build file names to toolchain format... " >&6; }
+if ${lt_cv_to_tool_file_cmd+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ #assume ordinary cross tools, or native build.
+lt_cv_to_tool_file_cmd=func_convert_file_noop
+case $host in
+ *-*-mingw* )
+ case $build in
+ *-*-mingw* ) # actually msys
+ lt_cv_to_tool_file_cmd=func_convert_file_msys_to_w32
+ ;;
+ esac
+ ;;
+esac
+
+fi
+
+to_tool_file_cmd=$lt_cv_to_tool_file_cmd
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_tool_file_cmd" >&5
+$as_echo "$lt_cv_to_tool_file_cmd" >&6; }
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $LD option to reload object files" >&5
+$as_echo_n "checking for $LD option to reload object files... " >&6; }
+if ${lt_cv_ld_reload_flag+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_ld_reload_flag='-r'
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_reload_flag" >&5
+$as_echo "$lt_cv_ld_reload_flag" >&6; }
+reload_flag=$lt_cv_ld_reload_flag
+case $reload_flag in
+"" | " "*) ;;
+*) reload_flag=" $reload_flag" ;;
+esac
+reload_cmds='$LD$reload_flag -o $output$reload_objs'
+case $host_os in
+ cygwin* | mingw* | pw32* | cegcc*)
+ if test "$GCC" != yes; then
+ reload_cmds=false
+ fi
+ ;;
+ darwin*)
+ if test "$GCC" = yes; then
+ reload_cmds='$LTCC $LTCFLAGS -nostdlib ${wl}-r -o $output$reload_objs'
+ else
+ reload_cmds='$LD$reload_flag -o $output$reload_objs'
+ fi
+ ;;
+esac
+
+
+
+
+
+
+
+
+
+if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}objdump", so it can be a program name with args.
+set dummy ${ac_tool_prefix}objdump; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_OBJDUMP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$OBJDUMP"; then
+ ac_cv_prog_OBJDUMP="$OBJDUMP" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_OBJDUMP="${ac_tool_prefix}objdump"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+OBJDUMP=$ac_cv_prog_OBJDUMP
+if test -n "$OBJDUMP"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OBJDUMP" >&5
+$as_echo "$OBJDUMP" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_OBJDUMP"; then
+ ac_ct_OBJDUMP=$OBJDUMP
+ # Extract the first word of "objdump", so it can be a program name with args.
+set dummy objdump; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_OBJDUMP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_OBJDUMP"; then
+ ac_cv_prog_ac_ct_OBJDUMP="$ac_ct_OBJDUMP" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_OBJDUMP="objdump"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_OBJDUMP=$ac_cv_prog_ac_ct_OBJDUMP
+if test -n "$ac_ct_OBJDUMP"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OBJDUMP" >&5
+$as_echo "$ac_ct_OBJDUMP" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_OBJDUMP" = x; then
+ OBJDUMP="false"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ OBJDUMP=$ac_ct_OBJDUMP
+ fi
+else
+ OBJDUMP="$ac_cv_prog_OBJDUMP"
+fi
+
+test -z "$OBJDUMP" && OBJDUMP=objdump
+
+
+
+
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to recognize dependent libraries" >&5
+$as_echo_n "checking how to recognize dependent libraries... " >&6; }
+if ${lt_cv_deplibs_check_method+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_file_magic_cmd='$MAGIC_CMD'
+lt_cv_file_magic_test_file=
+lt_cv_deplibs_check_method='unknown'
+# Need to set the preceding variable on all platforms that support
+# interlibrary dependencies.
+# 'none' -- dependencies not supported.
+# `unknown' -- same as none, but documents that we really don't know.
+# 'pass_all' -- all dependencies passed with no checks.
+# 'test_compile' -- check by making test program.
+# 'file_magic [[regex]]' -- check by looking for files in library path
+# which responds to the $file_magic_cmd with a given extended regex.
+# If you have `file' or equivalent on your system and you're not sure
+# whether `pass_all' will *always* work, you probably want this one.
+
+case $host_os in
+aix[4-9]*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+beos*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+bsdi[45]*)
+ lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (shared object|dynamic lib)'
+ lt_cv_file_magic_cmd='/usr/bin/file -L'
+ lt_cv_file_magic_test_file=/shlib/libc.so
+ ;;
+
+cygwin*)
+ # func_win32_libid is a shell function defined in ltmain.sh
+ lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL'
+ lt_cv_file_magic_cmd='func_win32_libid'
+ ;;
+
+mingw* | pw32*)
+ # Base MSYS/MinGW do not provide the 'file' command needed by
+ # func_win32_libid shell function, so use a weaker test based on 'objdump',
+ # unless we find 'file', for example because we are cross-compiling.
+ # func_win32_libid assumes BSD nm, so disallow it if using MS dumpbin.
+ if ( test "$lt_cv_nm_interface" = "BSD nm" && file / ) >/dev/null 2>&1; then
+ lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL'
+ lt_cv_file_magic_cmd='func_win32_libid'
+ else
+ # Keep this pattern in sync with the one in func_win32_libid.
+ lt_cv_deplibs_check_method='file_magic file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)'
+ lt_cv_file_magic_cmd='$OBJDUMP -f'
+ fi
+ ;;
+
+cegcc*)
+ # use the weaker test based on 'objdump'. See mingw*.
+ lt_cv_deplibs_check_method='file_magic file format pe-arm-.*little(.*architecture: arm)?'
+ lt_cv_file_magic_cmd='$OBJDUMP -f'
+ ;;
+
+darwin* | rhapsody*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+freebsd* | dragonfly*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then
+ case $host_cpu in
+ i*86 )
+ # Not sure whether the presence of OpenBSD here was a mistake.
+ # Let's accept both of them until this is cleared up.
+ lt_cv_deplibs_check_method='file_magic (FreeBSD|OpenBSD|DragonFly)/i[3-9]86 (compact )?demand paged shared library'
+ lt_cv_file_magic_cmd=/usr/bin/file
+ lt_cv_file_magic_test_file=`echo /usr/lib/libc.so.*`
+ ;;
+ esac
+ else
+ lt_cv_deplibs_check_method=pass_all
+ fi
+ ;;
+
+gnu*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+haiku*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+hpux10.20* | hpux11*)
+ lt_cv_file_magic_cmd=/usr/bin/file
+ case $host_cpu in
+ ia64*)
+ lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF-[0-9][0-9]) shared object file - IA64'
+ lt_cv_file_magic_test_file=/usr/lib/hpux32/libc.so
+ ;;
+ hppa*64*)
+ lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF[ -][0-9][0-9])(-bit)?( [LM]SB)? shared object( file)?[, -]* PA-RISC [0-9]\.[0-9]'
+ lt_cv_file_magic_test_file=/usr/lib/pa20_64/libc.sl
+ ;;
+ *)
+ lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|PA-RISC[0-9]\.[0-9]) shared library'
+ lt_cv_file_magic_test_file=/usr/lib/libc.sl
+ ;;
+ esac
+ ;;
+
+interix[3-9]*)
+ # PIC code is broken on Interix 3.x, that's why |\.a not |_pic\.a here
+ lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so|\.a)$'
+ ;;
+
+irix5* | irix6* | nonstopux*)
+ case $LD in
+ *-32|*"-32 ") libmagic=32-bit;;
+ *-n32|*"-n32 ") libmagic=N32;;
+ *-64|*"-64 ") libmagic=64-bit;;
+ *) libmagic=never-match;;
+ esac
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+# This must be Linux ELF.
+linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then
+ lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|_pic\.a)$'
+ else
+ lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so|_pic\.a)$'
+ fi
+ ;;
+
+newos6*)
+ lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (executable|dynamic lib)'
+ lt_cv_file_magic_cmd=/usr/bin/file
+ lt_cv_file_magic_test_file=/usr/lib/libnls.so
+ ;;
+
+*nto* | *qnx*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+openbsd*)
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|\.so|_pic\.a)$'
+ else
+ lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|_pic\.a)$'
+ fi
+ ;;
+
+osf3* | osf4* | osf5*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+rdos*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+solaris*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+sysv4 | sysv4.3*)
+ case $host_vendor in
+ motorola)
+ lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (shared object|dynamic lib) M[0-9][0-9]* Version [0-9]'
+ lt_cv_file_magic_test_file=`echo /usr/lib/libc.so*`
+ ;;
+ ncr)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+ sequent)
+ lt_cv_file_magic_cmd='/bin/file'
+ lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [LM]SB (shared object|dynamic lib )'
+ ;;
+ sni)
+ lt_cv_file_magic_cmd='/bin/file'
+ lt_cv_deplibs_check_method="file_magic ELF [0-9][0-9]*-bit [LM]SB dynamic lib"
+ lt_cv_file_magic_test_file=/lib/libc.so
+ ;;
+ siemens)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+ pc)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+ esac
+ ;;
+
+tpf*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+esac
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_deplibs_check_method" >&5
+$as_echo "$lt_cv_deplibs_check_method" >&6; }
+
+file_magic_glob=
+want_nocaseglob=no
+if test "$build" = "$host"; then
+ case $host_os in
+ mingw* | pw32*)
+ if ( shopt | grep nocaseglob ) >/dev/null 2>&1; then
+ want_nocaseglob=yes
+ else
+ file_magic_glob=`echo aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ | $SED -e "s/\(..\)/s\/[\1]\/[\1]\/g;/g"`
+ fi
+ ;;
+ esac
+fi
+
+file_magic_cmd=$lt_cv_file_magic_cmd
+deplibs_check_method=$lt_cv_deplibs_check_method
+test -z "$deplibs_check_method" && deplibs_check_method=unknown
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}dlltool", so it can be a program name with args.
+set dummy ${ac_tool_prefix}dlltool; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_DLLTOOL+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$DLLTOOL"; then
+ ac_cv_prog_DLLTOOL="$DLLTOOL" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_DLLTOOL="${ac_tool_prefix}dlltool"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+DLLTOOL=$ac_cv_prog_DLLTOOL
+if test -n "$DLLTOOL"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DLLTOOL" >&5
+$as_echo "$DLLTOOL" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_DLLTOOL"; then
+ ac_ct_DLLTOOL=$DLLTOOL
+ # Extract the first word of "dlltool", so it can be a program name with args.
+set dummy dlltool; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_DLLTOOL+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_DLLTOOL"; then
+ ac_cv_prog_ac_ct_DLLTOOL="$ac_ct_DLLTOOL" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_DLLTOOL="dlltool"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_DLLTOOL=$ac_cv_prog_ac_ct_DLLTOOL
+if test -n "$ac_ct_DLLTOOL"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DLLTOOL" >&5
+$as_echo "$ac_ct_DLLTOOL" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_DLLTOOL" = x; then
+ DLLTOOL="false"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ DLLTOOL=$ac_ct_DLLTOOL
+ fi
+else
+ DLLTOOL="$ac_cv_prog_DLLTOOL"
+fi
+
+test -z "$DLLTOOL" && DLLTOOL=dlltool
+
+
+
+
+
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to associate runtime and link libraries" >&5
+$as_echo_n "checking how to associate runtime and link libraries... " >&6; }
+if ${lt_cv_sharedlib_from_linklib_cmd+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_sharedlib_from_linklib_cmd='unknown'
+
+case $host_os in
+cygwin* | mingw* | pw32* | cegcc*)
+ # two different shell functions defined in ltmain.sh
+ # decide which to use based on capabilities of $DLLTOOL
+ case `$DLLTOOL --help 2>&1` in
+ *--identify-strict*)
+ lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib
+ ;;
+ *)
+ lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib_fallback
+ ;;
+ esac
+ ;;
+*)
+ # fallback: assume linklib IS sharedlib
+ lt_cv_sharedlib_from_linklib_cmd="$ECHO"
+ ;;
+esac
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sharedlib_from_linklib_cmd" >&5
+$as_echo "$lt_cv_sharedlib_from_linklib_cmd" >&6; }
+sharedlib_from_linklib_cmd=$lt_cv_sharedlib_from_linklib_cmd
+test -z "$sharedlib_from_linklib_cmd" && sharedlib_from_linklib_cmd=$ECHO
+
+
+
+
+
+
+
+if test -n "$ac_tool_prefix"; then
+ for ac_prog in ar
+ do
+ # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
+set dummy $ac_tool_prefix$ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_AR+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$AR"; then
+ ac_cv_prog_AR="$AR" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_AR="$ac_tool_prefix$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+AR=$ac_cv_prog_AR
+if test -n "$AR"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5
+$as_echo "$AR" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$AR" && break
+ done
+fi
+if test -z "$AR"; then
+ ac_ct_AR=$AR
+ for ac_prog in ar
+do
+ # Extract the first word of "$ac_prog", so it can be a program name with args.
+set dummy $ac_prog; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_AR+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_AR"; then
+ ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_AR="$ac_prog"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_AR=$ac_cv_prog_ac_ct_AR
+if test -n "$ac_ct_AR"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5
+$as_echo "$ac_ct_AR" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ test -n "$ac_ct_AR" && break
+done
+
+ if test "x$ac_ct_AR" = x; then
+ AR="false"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ AR=$ac_ct_AR
+ fi
+fi
+
+: ${AR=ar}
+: ${AR_FLAGS=cru}
+
+
+
+
+
+
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for archiver @FILE support" >&5
+$as_echo_n "checking for archiver @FILE support... " >&6; }
+if ${lt_cv_ar_at_file+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_ar_at_file=no
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+ echo conftest.$ac_objext > conftest.lst
+ lt_ar_try='$AR $AR_FLAGS libconftest.a @conftest.lst >&5'
+ { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5
+ (eval $lt_ar_try) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+ if test "$ac_status" -eq 0; then
+ # Ensure the archiver fails upon bogus file names.
+ rm -f conftest.$ac_objext libconftest.a
+ { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5
+ (eval $lt_ar_try) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+ if test "$ac_status" -ne 0; then
+ lt_cv_ar_at_file=@
+ fi
+ fi
+ rm -f conftest.* libconftest.a
+
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ar_at_file" >&5
+$as_echo "$lt_cv_ar_at_file" >&6; }
+
+if test "x$lt_cv_ar_at_file" = xno; then
+ archiver_list_spec=
+else
+ archiver_list_spec=$lt_cv_ar_at_file
+fi
+
+
+
+
+
+
+
+if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args.
+set dummy ${ac_tool_prefix}strip; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_STRIP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$STRIP"; then
+ ac_cv_prog_STRIP="$STRIP" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_STRIP="${ac_tool_prefix}strip"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+STRIP=$ac_cv_prog_STRIP
+if test -n "$STRIP"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5
+$as_echo "$STRIP" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_STRIP"; then
+ ac_ct_STRIP=$STRIP
+ # Extract the first word of "strip", so it can be a program name with args.
+set dummy strip; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_STRIP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_STRIP"; then
+ ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_STRIP="strip"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP
+if test -n "$ac_ct_STRIP"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5
+$as_echo "$ac_ct_STRIP" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_STRIP" = x; then
+ STRIP=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ STRIP=$ac_ct_STRIP
+ fi
+else
+ STRIP="$ac_cv_prog_STRIP"
+fi
+
+test -z "$STRIP" && STRIP=:
+
+
+
+
+
+
+if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args.
+set dummy ${ac_tool_prefix}ranlib; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_RANLIB+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$RANLIB"; then
+ ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+RANLIB=$ac_cv_prog_RANLIB
+if test -n "$RANLIB"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5
+$as_echo "$RANLIB" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_RANLIB"; then
+ ac_ct_RANLIB=$RANLIB
+ # Extract the first word of "ranlib", so it can be a program name with args.
+set dummy ranlib; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_RANLIB+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_RANLIB"; then
+ ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_RANLIB="ranlib"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB
+if test -n "$ac_ct_RANLIB"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5
+$as_echo "$ac_ct_RANLIB" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_RANLIB" = x; then
+ RANLIB=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ RANLIB=$ac_ct_RANLIB
+ fi
+else
+ RANLIB="$ac_cv_prog_RANLIB"
+fi
+
+test -z "$RANLIB" && RANLIB=:
+
+
+
+
+
+
+# Determine commands to create old-style static archives.
+old_archive_cmds='$AR $AR_FLAGS $oldlib$oldobjs'
+old_postinstall_cmds='chmod 644 $oldlib'
+old_postuninstall_cmds=
+
+if test -n "$RANLIB"; then
+ case $host_os in
+ openbsd*)
+ old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$oldlib"
+ ;;
+ *)
+ old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$oldlib"
+ ;;
+ esac
+ old_archive_cmds="$old_archive_cmds~\$RANLIB \$oldlib"
+fi
+
+case $host_os in
+ darwin*)
+ lock_old_archive_extraction=yes ;;
+ *)
+ lock_old_archive_extraction=no ;;
+esac
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# If no C compiler was specified, use CC.
+LTCC=${LTCC-"$CC"}
+
+# If no C compiler flags were specified, use CFLAGS.
+LTCFLAGS=${LTCFLAGS-"$CFLAGS"}
+
+# Allow CC to be a program name with arguments.
+compiler=$CC
+
+
+# Check for command to grab the raw symbol name followed by C symbol from nm.
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking command to parse $NM output from $compiler object" >&5
+$as_echo_n "checking command to parse $NM output from $compiler object... " >&6; }
+if ${lt_cv_sys_global_symbol_pipe+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+
+# These are sane defaults that work on at least a few old systems.
+# [They come from Ultrix. What could be older than Ultrix?!! ;)]
+
+# Character class describing NM global symbol codes.
+symcode='[BCDEGRST]'
+
+# Regexp to match symbols that can be accessed directly from C.
+sympat='\([_A-Za-z][_A-Za-z0-9]*\)'
+
+# Define system-specific variables.
+case $host_os in
+aix*)
+ symcode='[BCDT]'
+ ;;
+cygwin* | mingw* | pw32* | cegcc*)
+ symcode='[ABCDGISTW]'
+ ;;
+hpux*)
+ if test "$host_cpu" = ia64; then
+ symcode='[ABCDEGRST]'
+ fi
+ ;;
+irix* | nonstopux*)
+ symcode='[BCDEGRST]'
+ ;;
+osf*)
+ symcode='[BCDEGQRST]'
+ ;;
+solaris*)
+ symcode='[BDRT]'
+ ;;
+sco3.2v5*)
+ symcode='[DT]'
+ ;;
+sysv4.2uw2*)
+ symcode='[DT]'
+ ;;
+sysv5* | sco5v6* | unixware* | OpenUNIX*)
+ symcode='[ABDT]'
+ ;;
+sysv4)
+ symcode='[DFNSTU]'
+ ;;
+esac
+
+# If we're using GNU nm, then use its standard symbol codes.
+case `$NM -V 2>&1` in
+*GNU* | *'with BFD'*)
+ symcode='[ABCDGIRSTW]' ;;
+esac
+
+# Transform an extracted symbol line into a proper C declaration.
+# Some systems (esp. on ia64) link data and code symbols differently,
+# so use this general approach.
+lt_cv_sys_global_symbol_to_cdecl="sed -n -e 's/^T .* \(.*\)$/extern int \1();/p' -e 's/^$symcode* .* \(.*\)$/extern char \1;/p'"
+
+# Transform an extracted symbol line into symbol name and symbol address
+lt_cv_sys_global_symbol_to_c_name_address="sed -n -e 's/^: \([^ ]*\)[ ]*$/ {\\\"\1\\\", (void *) 0},/p' -e 's/^$symcode* \([^ ]*\) \([^ ]*\)$/ {\"\2\", (void *) \&\2},/p'"
+lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="sed -n -e 's/^: \([^ ]*\)[ ]*$/ {\\\"\1\\\", (void *) 0},/p' -e 's/^$symcode* \([^ ]*\) \(lib[^ ]*\)$/ {\"\2\", (void *) \&\2},/p' -e 's/^$symcode* \([^ ]*\) \([^ ]*\)$/ {\"lib\2\", (void *) \&\2},/p'"
+
+# Handle CRLF in mingw tool chain
+opt_cr=
+case $build_os in
+mingw*)
+ opt_cr=`$ECHO 'x\{0,1\}' | tr x '\015'` # option cr in regexp
+ ;;
+esac
+
+# Try without a prefix underscore, then with it.
+for ac_symprfx in "" "_"; do
+
+ # Transform symcode, sympat, and symprfx into a raw symbol and a C symbol.
+ symxfrm="\\1 $ac_symprfx\\2 \\2"
+
+ # Write the raw and C identifiers.
+ if test "$lt_cv_nm_interface" = "MS dumpbin"; then
+ # Fake it for dumpbin and say T for any non-static function
+ # and D for any global variable.
+ # Also find C++ and __fastcall symbols from MSVC++,
+ # which start with @ or ?.
+ lt_cv_sys_global_symbol_pipe="$AWK '"\
+" {last_section=section; section=\$ 3};"\
+" /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\
+" \$ 0!~/External *\|/{next};"\
+" / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\
+" {if(hide[section]) next};"\
+" {f=0}; \$ 0~/\(\).*\|/{f=1}; {printf f ? \"T \" : \"D \"};"\
+" {split(\$ 0, a, /\||\r/); split(a[2], s)};"\
+" s[1]~/^[@?]/{print s[1], s[1]; next};"\
+" s[1]~prfx {split(s[1],t,\"@\"); print t[1], substr(t[1],length(prfx))}"\
+" ' prfx=^$ac_symprfx"
+ else
+ lt_cv_sys_global_symbol_pipe="sed -n -e 's/^.*[ ]\($symcode$symcode*\)[ ][ ]*$ac_symprfx$sympat$opt_cr$/$symxfrm/p'"
+ fi
+ lt_cv_sys_global_symbol_pipe="$lt_cv_sys_global_symbol_pipe | sed '/ __gnu_lto/d'"
+
+ # Check to see that the pipe works correctly.
+ pipe_works=no
+
+ rm -f conftest*
+ cat > conftest.$ac_ext <<_LT_EOF
+#ifdef __cplusplus
+extern "C" {
+#endif
+char nm_test_var;
+void nm_test_func(void);
+void nm_test_func(void){}
+#ifdef __cplusplus
+}
+#endif
+int main(){nm_test_var='a';nm_test_func();return(0);}
+_LT_EOF
+
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; then
+ # Now try to grab the symbols.
+ nlist=conftest.nm
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$NM conftest.$ac_objext \| "$lt_cv_sys_global_symbol_pipe" \> $nlist\""; } >&5
+ (eval $NM conftest.$ac_objext \| "$lt_cv_sys_global_symbol_pipe" \> $nlist) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && test -s "$nlist"; then
+ # Try sorting and uniquifying the output.
+ if sort "$nlist" | uniq > "$nlist"T; then
+ mv -f "$nlist"T "$nlist"
+ else
+ rm -f "$nlist"T
+ fi
+
+ # Make sure that we snagged all the symbols we need.
+ if $GREP ' nm_test_var$' "$nlist" >/dev/null; then
+ if $GREP ' nm_test_func$' "$nlist" >/dev/null; then
+ cat <<_LT_EOF > conftest.$ac_ext
+/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */
+#if defined(_WIN32) || defined(__CYGWIN__) || defined(_WIN32_WCE)
+/* DATA imports from DLLs on WIN32 con't be const, because runtime
+ relocations are performed -- see ld's documentation on pseudo-relocs. */
+# define LT_DLSYM_CONST
+#elif defined(__osf__)
+/* This system does not cope well with relocations in const data. */
+# define LT_DLSYM_CONST
+#else
+# define LT_DLSYM_CONST const
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+_LT_EOF
+ # Now generate the symbol file.
+ eval "$lt_cv_sys_global_symbol_to_cdecl"' < "$nlist" | $GREP -v main >> conftest.$ac_ext'
+
+ cat <<_LT_EOF >> conftest.$ac_ext
+
+/* The mapping between symbol names and symbols. */
+LT_DLSYM_CONST struct {
+ const char *name;
+ void *address;
+}
+lt__PROGRAM__LTX_preloaded_symbols[] =
+{
+ { "@PROGRAM@", (void *) 0 },
+_LT_EOF
+ $SED "s/^$symcode$symcode* \(.*\) \(.*\)$/ {\"\2\", (void *) \&\2},/" < "$nlist" | $GREP -v main >> conftest.$ac_ext
+ cat <<\_LT_EOF >> conftest.$ac_ext
+ {0, (void *) 0}
+};
+
+/* This works around a problem in FreeBSD linker */
+#ifdef FREEBSD_WORKAROUND
+static const void *lt_preloaded_setup() {
+ return lt__PROGRAM__LTX_preloaded_symbols;
+}
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+_LT_EOF
+ # Now try linking the two files.
+ mv conftest.$ac_objext conftstm.$ac_objext
+ lt_globsym_save_LIBS=$LIBS
+ lt_globsym_save_CFLAGS=$CFLAGS
+ LIBS="conftstm.$ac_objext"
+ CFLAGS="$CFLAGS$lt_prog_compiler_no_builtin_flag"
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5
+ (eval $ac_link) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && test -s conftest${ac_exeext}; then
+ pipe_works=yes
+ fi
+ LIBS=$lt_globsym_save_LIBS
+ CFLAGS=$lt_globsym_save_CFLAGS
+ else
+ echo "cannot find nm_test_func in $nlist" >&5
+ fi
+ else
+ echo "cannot find nm_test_var in $nlist" >&5
+ fi
+ else
+ echo "cannot run $lt_cv_sys_global_symbol_pipe" >&5
+ fi
+ else
+ echo "$progname: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ fi
+ rm -rf conftest* conftst*
+
+ # Do not use the global_symbol_pipe unless it works.
+ if test "$pipe_works" = yes; then
+ break
+ else
+ lt_cv_sys_global_symbol_pipe=
+ fi
+done
+
+fi
+
+if test -z "$lt_cv_sys_global_symbol_pipe"; then
+ lt_cv_sys_global_symbol_to_cdecl=
+fi
+if test -z "$lt_cv_sys_global_symbol_pipe$lt_cv_sys_global_symbol_to_cdecl"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: failed" >&5
+$as_echo "failed" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5
+$as_echo "ok" >&6; }
+fi
+
+# Response file support.
+if test "$lt_cv_nm_interface" = "MS dumpbin"; then
+ nm_file_list_spec='@'
+elif $NM --help 2>/dev/null | grep '[@]FILE' >/dev/null; then
+ nm_file_list_spec='@'
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for sysroot" >&5
+$as_echo_n "checking for sysroot... " >&6; }
+
+# Check whether --with-sysroot was given.
+if test "${with_sysroot+set}" = set; then :
+ withval=$with_sysroot;
+else
+ with_sysroot=no
+fi
+
+
+lt_sysroot=
+case ${with_sysroot} in #(
+ yes)
+ if test "$GCC" = yes; then
+ lt_sysroot=`$CC --print-sysroot 2>/dev/null`
+ fi
+ ;; #(
+ /*)
+ lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"`
+ ;; #(
+ no|'')
+ ;; #(
+ *)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${with_sysroot}" >&5
+$as_echo "${with_sysroot}" >&6; }
+ as_fn_error $? "The sysroot must be an absolute path." "$LINENO" 5
+ ;;
+esac
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${lt_sysroot:-no}" >&5
+$as_echo "${lt_sysroot:-no}" >&6; }
+
+
+
+
+
+# Check whether --enable-libtool-lock was given.
+if test "${enable_libtool_lock+set}" = set; then :
+ enableval=$enable_libtool_lock;
+fi
+
+test "x$enable_libtool_lock" != xno && enable_libtool_lock=yes
+
+# Some flags need to be propagated to the compiler or linker for good
+# libtool support.
+case $host in
+ia64-*-hpux*)
+ # Find out which ABI we are using.
+ echo 'int i;' > conftest.$ac_ext
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; then
+ case `/usr/bin/file conftest.$ac_objext` in
+ *ELF-32*)
+ HPUX_IA64_MODE="32"
+ ;;
+ *ELF-64*)
+ HPUX_IA64_MODE="64"
+ ;;
+ esac
+ fi
+ rm -rf conftest*
+ ;;
+*-*-irix6*)
+ # Find out which ABI we are using.
+ echo '#line '$LINENO' "configure"' > conftest.$ac_ext
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; then
+ if test "$lt_cv_prog_gnu_ld" = yes; then
+ case `/usr/bin/file conftest.$ac_objext` in
+ *32-bit*)
+ LD="${LD-ld} -melf32bsmip"
+ ;;
+ *N32*)
+ LD="${LD-ld} -melf32bmipn32"
+ ;;
+ *64-bit*)
+ LD="${LD-ld} -melf64bmip"
+ ;;
+ esac
+ else
+ case `/usr/bin/file conftest.$ac_objext` in
+ *32-bit*)
+ LD="${LD-ld} -32"
+ ;;
+ *N32*)
+ LD="${LD-ld} -n32"
+ ;;
+ *64-bit*)
+ LD="${LD-ld} -64"
+ ;;
+ esac
+ fi
+ fi
+ rm -rf conftest*
+ ;;
+
+x86_64-*kfreebsd*-gnu|x86_64-*linux*|ppc*-*linux*|powerpc*-*linux*| \
+s390*-*linux*|s390*-*tpf*|sparc*-*linux*)
+ # Find out which ABI we are using.
+ echo 'int i;' > conftest.$ac_ext
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; then
+ case `/usr/bin/file conftest.o` in
+ *32-bit*)
+ case $host in
+ x86_64-*kfreebsd*-gnu)
+ LD="${LD-ld} -m elf_i386_fbsd"
+ ;;
+ x86_64-*linux*)
+ LD="${LD-ld} -m elf_i386"
+ ;;
+ ppc64-*linux*|powerpc64-*linux*)
+ LD="${LD-ld} -m elf32ppclinux"
+ ;;
+ s390x-*linux*)
+ LD="${LD-ld} -m elf_s390"
+ ;;
+ sparc64-*linux*)
+ LD="${LD-ld} -m elf32_sparc"
+ ;;
+ esac
+ ;;
+ *64-bit*)
+ case $host in
+ x86_64-*kfreebsd*-gnu)
+ LD="${LD-ld} -m elf_x86_64_fbsd"
+ ;;
+ x86_64-*linux*)
+ LD="${LD-ld} -m elf_x86_64"
+ ;;
+ ppc*-*linux*|powerpc*-*linux*)
+ LD="${LD-ld} -m elf64ppc"
+ ;;
+ s390*-*linux*|s390*-*tpf*)
+ LD="${LD-ld} -m elf64_s390"
+ ;;
+ sparc*-*linux*)
+ LD="${LD-ld} -m elf64_sparc"
+ ;;
+ esac
+ ;;
+ esac
+ fi
+ rm -rf conftest*
+ ;;
+
+*-*-sco3.2v5*)
+ # On SCO OpenServer 5, we need -belf to get full-featured binaries.
+ SAVE_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -belf"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler needs -belf" >&5
+$as_echo_n "checking whether the C compiler needs -belf... " >&6; }
+if ${lt_cv_cc_needs_belf+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ lt_cv_cc_needs_belf=yes
+else
+ lt_cv_cc_needs_belf=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_cc_needs_belf" >&5
+$as_echo "$lt_cv_cc_needs_belf" >&6; }
+ if test x"$lt_cv_cc_needs_belf" != x"yes"; then
+ # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf
+ CFLAGS="$SAVE_CFLAGS"
+ fi
+ ;;
+sparc*-*solaris*)
+ # Find out which ABI we are using.
+ echo 'int i;' > conftest.$ac_ext
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; then
+ case `/usr/bin/file conftest.o` in
+ *64-bit*)
+ case $lt_cv_prog_gnu_ld in
+ yes*) LD="${LD-ld} -m elf64_sparc" ;;
+ *)
+ if ${LD-ld} -64 -r -o conftest2.o conftest.o >/dev/null 2>&1; then
+ LD="${LD-ld} -64"
+ fi
+ ;;
+ esac
+ ;;
+ esac
+ fi
+ rm -rf conftest*
+ ;;
+esac
+
+need_locks="$enable_libtool_lock"
+
+if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}mt", so it can be a program name with args.
+set dummy ${ac_tool_prefix}mt; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_MANIFEST_TOOL+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$MANIFEST_TOOL"; then
+ ac_cv_prog_MANIFEST_TOOL="$MANIFEST_TOOL" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_MANIFEST_TOOL="${ac_tool_prefix}mt"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+MANIFEST_TOOL=$ac_cv_prog_MANIFEST_TOOL
+if test -n "$MANIFEST_TOOL"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MANIFEST_TOOL" >&5
+$as_echo "$MANIFEST_TOOL" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_MANIFEST_TOOL"; then
+ ac_ct_MANIFEST_TOOL=$MANIFEST_TOOL
+ # Extract the first word of "mt", so it can be a program name with args.
+set dummy mt; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_MANIFEST_TOOL+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_MANIFEST_TOOL"; then
+ ac_cv_prog_ac_ct_MANIFEST_TOOL="$ac_ct_MANIFEST_TOOL" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_MANIFEST_TOOL="mt"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_MANIFEST_TOOL=$ac_cv_prog_ac_ct_MANIFEST_TOOL
+if test -n "$ac_ct_MANIFEST_TOOL"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_MANIFEST_TOOL" >&5
+$as_echo "$ac_ct_MANIFEST_TOOL" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_MANIFEST_TOOL" = x; then
+ MANIFEST_TOOL=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ MANIFEST_TOOL=$ac_ct_MANIFEST_TOOL
+ fi
+else
+ MANIFEST_TOOL="$ac_cv_prog_MANIFEST_TOOL"
+fi
+
+test -z "$MANIFEST_TOOL" && MANIFEST_TOOL=mt
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if $MANIFEST_TOOL is a manifest tool" >&5
+$as_echo_n "checking if $MANIFEST_TOOL is a manifest tool... " >&6; }
+if ${lt_cv_path_mainfest_tool+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_path_mainfest_tool=no
+ echo "$as_me:$LINENO: $MANIFEST_TOOL '-?'" >&5
+ $MANIFEST_TOOL '-?' 2>conftest.err > conftest.out
+ cat conftest.err >&5
+ if $GREP 'Manifest Tool' conftest.out > /dev/null; then
+ lt_cv_path_mainfest_tool=yes
+ fi
+ rm -f conftest*
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_mainfest_tool" >&5
+$as_echo "$lt_cv_path_mainfest_tool" >&6; }
+if test "x$lt_cv_path_mainfest_tool" != xyes; then
+ MANIFEST_TOOL=:
+fi
+
+
+
+
+
+
+ case $host_os in
+ rhapsody* | darwin*)
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}dsymutil", so it can be a program name with args.
+set dummy ${ac_tool_prefix}dsymutil; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_DSYMUTIL+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$DSYMUTIL"; then
+ ac_cv_prog_DSYMUTIL="$DSYMUTIL" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_DSYMUTIL="${ac_tool_prefix}dsymutil"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+DSYMUTIL=$ac_cv_prog_DSYMUTIL
+if test -n "$DSYMUTIL"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DSYMUTIL" >&5
+$as_echo "$DSYMUTIL" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_DSYMUTIL"; then
+ ac_ct_DSYMUTIL=$DSYMUTIL
+ # Extract the first word of "dsymutil", so it can be a program name with args.
+set dummy dsymutil; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_DSYMUTIL+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_DSYMUTIL"; then
+ ac_cv_prog_ac_ct_DSYMUTIL="$ac_ct_DSYMUTIL" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_DSYMUTIL="dsymutil"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_DSYMUTIL=$ac_cv_prog_ac_ct_DSYMUTIL
+if test -n "$ac_ct_DSYMUTIL"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DSYMUTIL" >&5
+$as_echo "$ac_ct_DSYMUTIL" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_DSYMUTIL" = x; then
+ DSYMUTIL=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ DSYMUTIL=$ac_ct_DSYMUTIL
+ fi
+else
+ DSYMUTIL="$ac_cv_prog_DSYMUTIL"
+fi
+
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}nmedit", so it can be a program name with args.
+set dummy ${ac_tool_prefix}nmedit; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_NMEDIT+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$NMEDIT"; then
+ ac_cv_prog_NMEDIT="$NMEDIT" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_NMEDIT="${ac_tool_prefix}nmedit"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+NMEDIT=$ac_cv_prog_NMEDIT
+if test -n "$NMEDIT"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $NMEDIT" >&5
+$as_echo "$NMEDIT" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_NMEDIT"; then
+ ac_ct_NMEDIT=$NMEDIT
+ # Extract the first word of "nmedit", so it can be a program name with args.
+set dummy nmedit; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_NMEDIT+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_NMEDIT"; then
+ ac_cv_prog_ac_ct_NMEDIT="$ac_ct_NMEDIT" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_NMEDIT="nmedit"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_NMEDIT=$ac_cv_prog_ac_ct_NMEDIT
+if test -n "$ac_ct_NMEDIT"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_NMEDIT" >&5
+$as_echo "$ac_ct_NMEDIT" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_NMEDIT" = x; then
+ NMEDIT=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ NMEDIT=$ac_ct_NMEDIT
+ fi
+else
+ NMEDIT="$ac_cv_prog_NMEDIT"
+fi
+
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}lipo", so it can be a program name with args.
+set dummy ${ac_tool_prefix}lipo; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_LIPO+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$LIPO"; then
+ ac_cv_prog_LIPO="$LIPO" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_LIPO="${ac_tool_prefix}lipo"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+LIPO=$ac_cv_prog_LIPO
+if test -n "$LIPO"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LIPO" >&5
+$as_echo "$LIPO" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_LIPO"; then
+ ac_ct_LIPO=$LIPO
+ # Extract the first word of "lipo", so it can be a program name with args.
+set dummy lipo; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_LIPO+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_LIPO"; then
+ ac_cv_prog_ac_ct_LIPO="$ac_ct_LIPO" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_LIPO="lipo"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_LIPO=$ac_cv_prog_ac_ct_LIPO
+if test -n "$ac_ct_LIPO"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_LIPO" >&5
+$as_echo "$ac_ct_LIPO" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_LIPO" = x; then
+ LIPO=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ LIPO=$ac_ct_LIPO
+ fi
+else
+ LIPO="$ac_cv_prog_LIPO"
+fi
+
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}otool", so it can be a program name with args.
+set dummy ${ac_tool_prefix}otool; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_OTOOL+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$OTOOL"; then
+ ac_cv_prog_OTOOL="$OTOOL" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_OTOOL="${ac_tool_prefix}otool"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+OTOOL=$ac_cv_prog_OTOOL
+if test -n "$OTOOL"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OTOOL" >&5
+$as_echo "$OTOOL" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_OTOOL"; then
+ ac_ct_OTOOL=$OTOOL
+ # Extract the first word of "otool", so it can be a program name with args.
+set dummy otool; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_OTOOL+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_OTOOL"; then
+ ac_cv_prog_ac_ct_OTOOL="$ac_ct_OTOOL" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_OTOOL="otool"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_OTOOL=$ac_cv_prog_ac_ct_OTOOL
+if test -n "$ac_ct_OTOOL"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OTOOL" >&5
+$as_echo "$ac_ct_OTOOL" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_OTOOL" = x; then
+ OTOOL=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ OTOOL=$ac_ct_OTOOL
+ fi
+else
+ OTOOL="$ac_cv_prog_OTOOL"
+fi
+
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}otool64", so it can be a program name with args.
+set dummy ${ac_tool_prefix}otool64; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_OTOOL64+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$OTOOL64"; then
+ ac_cv_prog_OTOOL64="$OTOOL64" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_OTOOL64="${ac_tool_prefix}otool64"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+OTOOL64=$ac_cv_prog_OTOOL64
+if test -n "$OTOOL64"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OTOOL64" >&5
+$as_echo "$OTOOL64" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_OTOOL64"; then
+ ac_ct_OTOOL64=$OTOOL64
+ # Extract the first word of "otool64", so it can be a program name with args.
+set dummy otool64; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_OTOOL64+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_OTOOL64"; then
+ ac_cv_prog_ac_ct_OTOOL64="$ac_ct_OTOOL64" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_OTOOL64="otool64"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_OTOOL64=$ac_cv_prog_ac_ct_OTOOL64
+if test -n "$ac_ct_OTOOL64"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OTOOL64" >&5
+$as_echo "$ac_ct_OTOOL64" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_OTOOL64" = x; then
+ OTOOL64=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ OTOOL64=$ac_ct_OTOOL64
+ fi
+else
+ OTOOL64="$ac_cv_prog_OTOOL64"
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -single_module linker flag" >&5
+$as_echo_n "checking for -single_module linker flag... " >&6; }
+if ${lt_cv_apple_cc_single_mod+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_apple_cc_single_mod=no
+ if test -z "${LT_MULTI_MODULE}"; then
+ # By default we will add the -single_module flag. You can override
+ # by either setting the environment variable LT_MULTI_MODULE
+ # non-empty at configure time, or by adding -multi_module to the
+ # link flags.
+ rm -rf libconftest.dylib*
+ echo "int foo(void){return 1;}" > conftest.c
+ echo "$LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \
+-dynamiclib -Wl,-single_module conftest.c" >&5
+ $LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \
+ -dynamiclib -Wl,-single_module conftest.c 2>conftest.err
+ _lt_result=$?
+ if test -f libconftest.dylib && test ! -s conftest.err && test $_lt_result = 0; then
+ lt_cv_apple_cc_single_mod=yes
+ else
+ cat conftest.err >&5
+ fi
+ rm -rf libconftest.dylib*
+ rm -f conftest.*
+ fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_apple_cc_single_mod" >&5
+$as_echo "$lt_cv_apple_cc_single_mod" >&6; }
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -exported_symbols_list linker flag" >&5
+$as_echo_n "checking for -exported_symbols_list linker flag... " >&6; }
+if ${lt_cv_ld_exported_symbols_list+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_ld_exported_symbols_list=no
+ save_LDFLAGS=$LDFLAGS
+ echo "_main" > conftest.sym
+ LDFLAGS="$LDFLAGS -Wl,-exported_symbols_list,conftest.sym"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ lt_cv_ld_exported_symbols_list=yes
+else
+ lt_cv_ld_exported_symbols_list=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ LDFLAGS="$save_LDFLAGS"
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_exported_symbols_list" >&5
+$as_echo "$lt_cv_ld_exported_symbols_list" >&6; }
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -force_load linker flag" >&5
+$as_echo_n "checking for -force_load linker flag... " >&6; }
+if ${lt_cv_ld_force_load+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_ld_force_load=no
+ cat > conftest.c << _LT_EOF
+int forced_loaded() { return 2;}
+_LT_EOF
+ echo "$LTCC $LTCFLAGS -c -o conftest.o conftest.c" >&5
+ $LTCC $LTCFLAGS -c -o conftest.o conftest.c 2>&5
+ echo "$AR cru libconftest.a conftest.o" >&5
+ $AR cru libconftest.a conftest.o 2>&5
+ echo "$RANLIB libconftest.a" >&5
+ $RANLIB libconftest.a 2>&5
+ cat > conftest.c << _LT_EOF
+int main() { return 0;}
+_LT_EOF
+ echo "$LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a" >&5
+ $LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a 2>conftest.err
+ _lt_result=$?
+ if test -f conftest && test ! -s conftest.err && test $_lt_result = 0 && $GREP forced_load conftest 2>&1 >/dev/null; then
+ lt_cv_ld_force_load=yes
+ else
+ cat conftest.err >&5
+ fi
+ rm -f conftest.err libconftest.a conftest conftest.c
+ rm -rf conftest.dSYM
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_force_load" >&5
+$as_echo "$lt_cv_ld_force_load" >&6; }
+ case $host_os in
+ rhapsody* | darwin1.[012])
+ _lt_dar_allow_undefined='${wl}-undefined ${wl}suppress' ;;
+ darwin1.*)
+ _lt_dar_allow_undefined='${wl}-flat_namespace ${wl}-undefined ${wl}suppress' ;;
+ darwin*) # darwin 5.x on
+ # if running on 10.5 or later, the deployment target defaults
+ # to the OS version, if on x86, and 10.4, the deployment
+ # target defaults to 10.4. Don't you love it?
+ case ${MACOSX_DEPLOYMENT_TARGET-10.0},$host in
+ 10.0,*86*-darwin8*|10.0,*-darwin[91]*)
+ _lt_dar_allow_undefined='${wl}-undefined ${wl}dynamic_lookup' ;;
+ 10.[012]*)
+ _lt_dar_allow_undefined='${wl}-flat_namespace ${wl}-undefined ${wl}suppress' ;;
+ 10.*)
+ _lt_dar_allow_undefined='${wl}-undefined ${wl}dynamic_lookup' ;;
+ esac
+ ;;
+ esac
+ if test "$lt_cv_apple_cc_single_mod" = "yes"; then
+ _lt_dar_single_mod='$single_module'
+ fi
+ if test "$lt_cv_ld_exported_symbols_list" = "yes"; then
+ _lt_dar_export_syms=' ${wl}-exported_symbols_list,$output_objdir/${libname}-symbols.expsym'
+ else
+ _lt_dar_export_syms='~$NMEDIT -s $output_objdir/${libname}-symbols.expsym ${lib}'
+ fi
+ if test "$DSYMUTIL" != ":" && test "$lt_cv_ld_force_load" = "no"; then
+ _lt_dsymutil='~$DSYMUTIL $lib || :'
+ else
+ _lt_dsymutil=
+ fi
+ ;;
+ esac
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5
+$as_echo_n "checking how to run the C preprocessor... " >&6; }
+# On Suns, sometimes $CPP names a directory.
+if test -n "$CPP" && test -d "$CPP"; then
+ CPP=
+fi
+if test -z "$CPP"; then
+ if ${ac_cv_prog_CPP+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ # Double quotes because CPP needs to be expanded
+ for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp"
+ do
+ ac_preproc_ok=false
+for ac_c_preproc_warn_flag in '' yes
+do
+ # Use a header file that comes with gcc, so configuring glibc
+ # with a fresh cross-compiler works.
+ # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
+ # <limits.h> exists even on freestanding compilers.
+ # On the NeXT, cc -E runs the code through the compiler's parser,
+ # not just through cpp. "Syntax error" is here to catch this case.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#ifdef __STDC__
+# include <limits.h>
+#else
+# include <assert.h>
+#endif
+ Syntax error
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"; then :
+
+else
+ # Broken: fails on valid input.
+continue
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+
+ # OK, works on sane cases. Now check whether nonexistent headers
+ # can be detected and how.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <ac_nonexistent.h>
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"; then :
+ # Broken: success on invalid input.
+continue
+else
+ # Passes both tests.
+ac_preproc_ok=:
+break
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+
+done
+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
+rm -f conftest.i conftest.err conftest.$ac_ext
+if $ac_preproc_ok; then :
+ break
+fi
+
+ done
+ ac_cv_prog_CPP=$CPP
+
+fi
+ CPP=$ac_cv_prog_CPP
+else
+ ac_cv_prog_CPP=$CPP
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5
+$as_echo "$CPP" >&6; }
+ac_preproc_ok=false
+for ac_c_preproc_warn_flag in '' yes
+do
+ # Use a header file that comes with gcc, so configuring glibc
+ # with a fresh cross-compiler works.
+ # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
+ # <limits.h> exists even on freestanding compilers.
+ # On the NeXT, cc -E runs the code through the compiler's parser,
+ # not just through cpp. "Syntax error" is here to catch this case.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#ifdef __STDC__
+# include <limits.h>
+#else
+# include <assert.h>
+#endif
+ Syntax error
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"; then :
+
+else
+ # Broken: fails on valid input.
+continue
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+
+ # OK, works on sane cases. Now check whether nonexistent headers
+ # can be detected and how.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <ac_nonexistent.h>
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"; then :
+ # Broken: success on invalid input.
+continue
+else
+ # Passes both tests.
+ac_preproc_ok=:
+break
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+
+done
+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
+rm -f conftest.i conftest.err conftest.$ac_ext
+if $ac_preproc_ok; then :
+
+else
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "C preprocessor \"$CPP\" fails sanity check
+See \`config.log' for more details" "$LINENO" 5; }
+fi
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5
+$as_echo_n "checking for ANSI C header files... " >&6; }
+if ${ac_cv_header_stdc+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <stdlib.h>
+#include <stdarg.h>
+#include <string.h>
+#include <float.h>
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+ ac_cv_header_stdc=yes
+else
+ ac_cv_header_stdc=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+
+if test $ac_cv_header_stdc = yes; then
+ # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <string.h>
+
+_ACEOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ $EGREP "memchr" >/dev/null 2>&1; then :
+
+else
+ ac_cv_header_stdc=no
+fi
+rm -f conftest*
+
+fi
+
+if test $ac_cv_header_stdc = yes; then
+ # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <stdlib.h>
+
+_ACEOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ $EGREP "free" >/dev/null 2>&1; then :
+
+else
+ ac_cv_header_stdc=no
+fi
+rm -f conftest*
+
+fi
+
+if test $ac_cv_header_stdc = yes; then
+ # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
+ if test "$cross_compiling" = yes; then :
+ :
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <ctype.h>
+#include <stdlib.h>
+#if ((' ' & 0x0FF) == 0x020)
+# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
+# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
+#else
+# define ISLOWER(c) \
+ (('a' <= (c) && (c) <= 'i') \
+ || ('j' <= (c) && (c) <= 'r') \
+ || ('s' <= (c) && (c) <= 'z'))
+# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))
+#endif
+
+#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
+int
+main ()
+{
+ int i;
+ for (i = 0; i < 256; i++)
+ if (XOR (islower (i), ISLOWER (i))
+ || toupper (i) != TOUPPER (i))
+ return 2;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_run "$LINENO"; then :
+
+else
+ ac_cv_header_stdc=no
+fi
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
+ conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+
+fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5
+$as_echo "$ac_cv_header_stdc" >&6; }
+if test $ac_cv_header_stdc = yes; then
+
+$as_echo "#define STDC_HEADERS 1" >>confdefs.h
+
+fi
+
+# On IRIX 5.3, sys/types and inttypes.h are conflicting.
+for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \
+ inttypes.h stdint.h unistd.h
+do :
+ as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh`
+ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default
+"
+if eval test \"x\$"$as_ac_Header"\" = x"yes"; then :
+ cat >>confdefs.h <<_ACEOF
+#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1
+_ACEOF
+
+fi
+
+done
+
+
+for ac_header in dlfcn.h
+do :
+ ac_fn_c_check_header_compile "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default
+"
+if test "x$ac_cv_header_dlfcn_h" = xyes; then :
+ cat >>confdefs.h <<_ACEOF
+#define HAVE_DLFCN_H 1
+_ACEOF
+
+fi
+
+done
+
+
+
+func_stripname_cnf ()
+{
+ case ${2} in
+ .*) func_stripname_result=`$ECHO "${3}" | $SED "s%^${1}%%; s%\\\\${2}\$%%"`;;
+ *) func_stripname_result=`$ECHO "${3}" | $SED "s%^${1}%%; s%${2}\$%%"`;;
+ esac
+} # func_stripname_cnf
+
+
+
+
+
+# Set options
+
+
+
+ enable_dlopen=no
+
+
+ enable_win32_dll=no
+
+
+ # Check whether --enable-shared was given.
+if test "${enable_shared+set}" = set; then :
+ enableval=$enable_shared; p=${PACKAGE-default}
+ case $enableval in
+ yes) enable_shared=yes ;;
+ no) enable_shared=no ;;
+ *)
+ enable_shared=no
+ # Look at the argument we got. We use all the common list separators.
+ lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR,"
+ for pkg in $enableval; do
+ IFS="$lt_save_ifs"
+ if test "X$pkg" = "X$p"; then
+ enable_shared=yes
+ fi
+ done
+ IFS="$lt_save_ifs"
+ ;;
+ esac
+else
+ enable_shared=yes
+fi
+
+
+
+
+
+
+
+
+
+ # Check whether --enable-static was given.
+if test "${enable_static+set}" = set; then :
+ enableval=$enable_static; p=${PACKAGE-default}
+ case $enableval in
+ yes) enable_static=yes ;;
+ no) enable_static=no ;;
+ *)
+ enable_static=no
+ # Look at the argument we got. We use all the common list separators.
+ lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR,"
+ for pkg in $enableval; do
+ IFS="$lt_save_ifs"
+ if test "X$pkg" = "X$p"; then
+ enable_static=yes
+ fi
+ done
+ IFS="$lt_save_ifs"
+ ;;
+ esac
+else
+ enable_static=yes
+fi
+
+
+
+
+
+
+
+
+
+
+# Check whether --with-pic was given.
+if test "${with_pic+set}" = set; then :
+ withval=$with_pic; pic_mode="$withval"
+else
+ pic_mode=default
+fi
+
+
+test -z "$pic_mode" && pic_mode=default
+
+
+
+
+
+
+
+ # Check whether --enable-fast-install was given.
+if test "${enable_fast_install+set}" = set; then :
+ enableval=$enable_fast_install; p=${PACKAGE-default}
+ case $enableval in
+ yes) enable_fast_install=yes ;;
+ no) enable_fast_install=no ;;
+ *)
+ enable_fast_install=no
+ # Look at the argument we got. We use all the common list separators.
+ lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR,"
+ for pkg in $enableval; do
+ IFS="$lt_save_ifs"
+ if test "X$pkg" = "X$p"; then
+ enable_fast_install=yes
+ fi
+ done
+ IFS="$lt_save_ifs"
+ ;;
+ esac
+else
+ enable_fast_install=yes
+fi
+
+
+
+
+
+
+
+
+
+
+
+# This can be used to rebuild libtool when needed
+LIBTOOL_DEPS="$ltmain"
+
+# Always use our own libtool.
+LIBTOOL='$(SHELL) $(top_builddir)/libtool'
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+test -z "$LN_S" && LN_S="ln -s"
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+if test -n "${ZSH_VERSION+set}" ; then
+ setopt NO_GLOB_SUBST
+fi
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for objdir" >&5
+$as_echo_n "checking for objdir... " >&6; }
+if ${lt_cv_objdir+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ rm -f .libs 2>/dev/null
+mkdir .libs 2>/dev/null
+if test -d .libs; then
+ lt_cv_objdir=.libs
+else
+ # MS-DOS does not allow filenames that begin with a dot.
+ lt_cv_objdir=_libs
+fi
+rmdir .libs 2>/dev/null
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_objdir" >&5
+$as_echo "$lt_cv_objdir" >&6; }
+objdir=$lt_cv_objdir
+
+
+
+
+
+cat >>confdefs.h <<_ACEOF
+#define LT_OBJDIR "$lt_cv_objdir/"
+_ACEOF
+
+
+
+
+case $host_os in
+aix3*)
+ # AIX sometimes has problems with the GCC collect2 program. For some
+ # reason, if we set the COLLECT_NAMES environment variable, the problems
+ # vanish in a puff of smoke.
+ if test "X${COLLECT_NAMES+set}" != Xset; then
+ COLLECT_NAMES=
+ export COLLECT_NAMES
+ fi
+ ;;
+esac
+
+# Global variables:
+ofile=libtool
+can_build_shared=yes
+
+# All known linkers require a `.a' archive for static linking (except MSVC,
+# which needs '.lib').
+libext=a
+
+with_gnu_ld="$lt_cv_prog_gnu_ld"
+
+old_CC="$CC"
+old_CFLAGS="$CFLAGS"
+
+# Set sane defaults for various variables
+test -z "$CC" && CC=cc
+test -z "$LTCC" && LTCC=$CC
+test -z "$LTCFLAGS" && LTCFLAGS=$CFLAGS
+test -z "$LD" && LD=ld
+test -z "$ac_objext" && ac_objext=o
+
+for cc_temp in $compiler""; do
+ case $cc_temp in
+ compile | *[\\/]compile | ccache | *[\\/]ccache ) ;;
+ distcc | *[\\/]distcc | purify | *[\\/]purify ) ;;
+ \-*) ;;
+ *) break;;
+ esac
+done
+cc_basename=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"`
+
+
+# Only perform the check for file, if the check method requires it
+test -z "$MAGIC_CMD" && MAGIC_CMD=file
+case $deplibs_check_method in
+file_magic*)
+ if test "$file_magic_cmd" = '$MAGIC_CMD'; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ${ac_tool_prefix}file" >&5
+$as_echo_n "checking for ${ac_tool_prefix}file... " >&6; }
+if ${lt_cv_path_MAGIC_CMD+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ case $MAGIC_CMD in
+[\\/*] | ?:[\\/]*)
+ lt_cv_path_MAGIC_CMD="$MAGIC_CMD" # Let the user override the test with a path.
+ ;;
+*)
+ lt_save_MAGIC_CMD="$MAGIC_CMD"
+ lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR
+ ac_dummy="/usr/bin$PATH_SEPARATOR$PATH"
+ for ac_dir in $ac_dummy; do
+ IFS="$lt_save_ifs"
+ test -z "$ac_dir" && ac_dir=.
+ if test -f $ac_dir/${ac_tool_prefix}file; then
+ lt_cv_path_MAGIC_CMD="$ac_dir/${ac_tool_prefix}file"
+ if test -n "$file_magic_test_file"; then
+ case $deplibs_check_method in
+ "file_magic "*)
+ file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"`
+ MAGIC_CMD="$lt_cv_path_MAGIC_CMD"
+ if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null |
+ $EGREP "$file_magic_regex" > /dev/null; then
+ :
+ else
+ cat <<_LT_EOF 1>&2
+
+*** Warning: the command libtool uses to detect shared libraries,
+*** $file_magic_cmd, produces output that libtool cannot recognize.
+*** The result is that libtool may fail to recognize shared libraries
+*** as such. This will affect the creation of libtool libraries that
+*** depend on shared libraries, but programs linked with such libtool
+*** libraries will work regardless of this problem. Nevertheless, you
+*** may want to report the problem to your system manager and/or to
+*** bug-libtool@gnu.org
+
+_LT_EOF
+ fi ;;
+ esac
+ fi
+ break
+ fi
+ done
+ IFS="$lt_save_ifs"
+ MAGIC_CMD="$lt_save_MAGIC_CMD"
+ ;;
+esac
+fi
+
+MAGIC_CMD="$lt_cv_path_MAGIC_CMD"
+if test -n "$MAGIC_CMD"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAGIC_CMD" >&5
+$as_echo "$MAGIC_CMD" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+
+
+
+if test -z "$lt_cv_path_MAGIC_CMD"; then
+ if test -n "$ac_tool_prefix"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for file" >&5
+$as_echo_n "checking for file... " >&6; }
+if ${lt_cv_path_MAGIC_CMD+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ case $MAGIC_CMD in
+[\\/*] | ?:[\\/]*)
+ lt_cv_path_MAGIC_CMD="$MAGIC_CMD" # Let the user override the test with a path.
+ ;;
+*)
+ lt_save_MAGIC_CMD="$MAGIC_CMD"
+ lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR
+ ac_dummy="/usr/bin$PATH_SEPARATOR$PATH"
+ for ac_dir in $ac_dummy; do
+ IFS="$lt_save_ifs"
+ test -z "$ac_dir" && ac_dir=.
+ if test -f $ac_dir/file; then
+ lt_cv_path_MAGIC_CMD="$ac_dir/file"
+ if test -n "$file_magic_test_file"; then
+ case $deplibs_check_method in
+ "file_magic "*)
+ file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"`
+ MAGIC_CMD="$lt_cv_path_MAGIC_CMD"
+ if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null |
+ $EGREP "$file_magic_regex" > /dev/null; then
+ :
+ else
+ cat <<_LT_EOF 1>&2
+
+*** Warning: the command libtool uses to detect shared libraries,
+*** $file_magic_cmd, produces output that libtool cannot recognize.
+*** The result is that libtool may fail to recognize shared libraries
+*** as such. This will affect the creation of libtool libraries that
+*** depend on shared libraries, but programs linked with such libtool
+*** libraries will work regardless of this problem. Nevertheless, you
+*** may want to report the problem to your system manager and/or to
+*** bug-libtool@gnu.org
+
+_LT_EOF
+ fi ;;
+ esac
+ fi
+ break
+ fi
+ done
+ IFS="$lt_save_ifs"
+ MAGIC_CMD="$lt_save_MAGIC_CMD"
+ ;;
+esac
+fi
+
+MAGIC_CMD="$lt_cv_path_MAGIC_CMD"
+if test -n "$MAGIC_CMD"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAGIC_CMD" >&5
+$as_echo "$MAGIC_CMD" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ else
+ MAGIC_CMD=:
+ fi
+fi
+
+ fi
+ ;;
+esac
+
+# Use C for the default configuration in the libtool script
+
+lt_save_CC="$CC"
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+# Source file extension for C test sources.
+ac_ext=c
+
+# Object file extension for compiled C test sources.
+objext=o
+objext=$objext
+
+# Code to be used in simple compile tests
+lt_simple_compile_test_code="int some_variable = 0;"
+
+# Code to be used in simple link tests
+lt_simple_link_test_code='int main(){return(0);}'
+
+
+
+
+
+
+
+# If no C compiler was specified, use CC.
+LTCC=${LTCC-"$CC"}
+
+# If no C compiler flags were specified, use CFLAGS.
+LTCFLAGS=${LTCFLAGS-"$CFLAGS"}
+
+# Allow CC to be a program name with arguments.
+compiler=$CC
+
+# Save the default compiler, since it gets overwritten when the other
+# tags are being tested, and _LT_TAGVAR(compiler, []) is a NOP.
+compiler_DEFAULT=$CC
+
+# save warnings/boilerplate of simple test code
+ac_outfile=conftest.$ac_objext
+echo "$lt_simple_compile_test_code" >conftest.$ac_ext
+eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err
+_lt_compiler_boilerplate=`cat conftest.err`
+$RM conftest*
+
+ac_outfile=conftest.$ac_objext
+echo "$lt_simple_link_test_code" >conftest.$ac_ext
+eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err
+_lt_linker_boilerplate=`cat conftest.err`
+$RM -r conftest*
+
+
+## CAVEAT EMPTOR:
+## There is no encapsulation within the following macros, do not change
+## the running order or otherwise move them around unless you know exactly
+## what you are doing...
+if test -n "$compiler"; then
+
+lt_prog_compiler_no_builtin_flag=
+
+if test "$GCC" = yes; then
+ case $cc_basename in
+ nvcc*)
+ lt_prog_compiler_no_builtin_flag=' -Xcompiler -fno-builtin' ;;
+ *)
+ lt_prog_compiler_no_builtin_flag=' -fno-builtin' ;;
+ esac
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -fno-rtti -fno-exceptions" >&5
+$as_echo_n "checking if $compiler supports -fno-rtti -fno-exceptions... " >&6; }
+if ${lt_cv_prog_compiler_rtti_exceptions+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_rtti_exceptions=no
+ ac_outfile=conftest.$ac_objext
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+ lt_compiler_flag="-fno-rtti -fno-exceptions"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ # The option is referenced via a variable to avoid confusing sed.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_rtti_exceptions=yes
+ fi
+ fi
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_rtti_exceptions" >&5
+$as_echo "$lt_cv_prog_compiler_rtti_exceptions" >&6; }
+
+if test x"$lt_cv_prog_compiler_rtti_exceptions" = xyes; then
+ lt_prog_compiler_no_builtin_flag="$lt_prog_compiler_no_builtin_flag -fno-rtti -fno-exceptions"
+else
+ :
+fi
+
+fi
+
+
+
+
+
+
+ lt_prog_compiler_wl=
+lt_prog_compiler_pic=
+lt_prog_compiler_static=
+
+
+ if test "$GCC" = yes; then
+ lt_prog_compiler_wl='-Wl,'
+ lt_prog_compiler_static='-static'
+
+ case $host_os in
+ aix*)
+ # All AIX code is PIC.
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ lt_prog_compiler_static='-Bstatic'
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ lt_prog_compiler_pic='-fPIC'
+ ;;
+ m68k)
+ # FIXME: we need at least 68020 code to build shared libraries, but
+ # adding the `-m68020' flag to GCC prevents building anything better,
+ # like `-m68040'.
+ lt_prog_compiler_pic='-m68020 -resident32 -malways-restore-a4'
+ ;;
+ esac
+ ;;
+
+ beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*)
+ # PIC is the default for these OSes.
+ ;;
+
+ mingw* | cygwin* | pw32* | os2* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ # Although the cygwin gcc ignores -fPIC, still need this for old-style
+ # (--disable-auto-import) libraries
+ lt_prog_compiler_pic='-DDLL_EXPORT'
+ ;;
+
+ darwin* | rhapsody*)
+ # PIC is the default on this platform
+ # Common symbols not allowed in MH_DYLIB files
+ lt_prog_compiler_pic='-fno-common'
+ ;;
+
+ haiku*)
+ # PIC is the default for Haiku.
+ # The "-static" flag exists, but is broken.
+ lt_prog_compiler_static=
+ ;;
+
+ hpux*)
+ # PIC is the default for 64-bit PA HP-UX, but not for 32-bit
+ # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag
+ # sets the default TLS model and affects inlining.
+ case $host_cpu in
+ hppa*64*)
+ # +Z the default
+ ;;
+ *)
+ lt_prog_compiler_pic='-fPIC'
+ ;;
+ esac
+ ;;
+
+ interix[3-9]*)
+ # Interix 3.x gcc -fpic/-fPIC options generate broken code.
+ # Instead, we relocate shared libraries at runtime.
+ ;;
+
+ msdosdjgpp*)
+ # Just because we use GCC doesn't mean we suddenly get shared libraries
+ # on systems that don't support them.
+ lt_prog_compiler_can_build_shared=no
+ enable_shared=no
+ ;;
+
+ *nto* | *qnx*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ lt_prog_compiler_pic='-fPIC -shared'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ lt_prog_compiler_pic=-Kconform_pic
+ fi
+ ;;
+
+ *)
+ lt_prog_compiler_pic='-fPIC'
+ ;;
+ esac
+
+ case $cc_basename in
+ nvcc*) # Cuda Compiler Driver 2.2
+ lt_prog_compiler_wl='-Xlinker '
+ lt_prog_compiler_pic='-Xcompiler -fPIC'
+ ;;
+ esac
+ else
+ # PORTME Check for flag to pass linker flags through the system compiler.
+ case $host_os in
+ aix*)
+ lt_prog_compiler_wl='-Wl,'
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ lt_prog_compiler_static='-Bstatic'
+ else
+ lt_prog_compiler_static='-bnso -bI:/lib/syscalls.exp'
+ fi
+ ;;
+
+ mingw* | cygwin* | pw32* | os2* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ lt_prog_compiler_pic='-DDLL_EXPORT'
+ ;;
+
+ hpux9* | hpux10* | hpux11*)
+ lt_prog_compiler_wl='-Wl,'
+ # PIC is the default for IA64 HP-UX and 64-bit HP-UX, but
+ # not for PA HP-UX.
+ case $host_cpu in
+ hppa*64*|ia64*)
+ # +Z the default
+ ;;
+ *)
+ lt_prog_compiler_pic='+Z'
+ ;;
+ esac
+ # Is there a better lt_prog_compiler_static that works with the bundled CC?
+ lt_prog_compiler_static='${wl}-a ${wl}archive'
+ ;;
+
+ irix5* | irix6* | nonstopux*)
+ lt_prog_compiler_wl='-Wl,'
+ # PIC (with -KPIC) is the default.
+ lt_prog_compiler_static='-non_shared'
+ ;;
+
+ linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ case $cc_basename in
+ # old Intel for x86_64 which still supported -KPIC.
+ ecc*)
+ lt_prog_compiler_wl='-Wl,'
+ lt_prog_compiler_pic='-KPIC'
+ lt_prog_compiler_static='-static'
+ ;;
+ # icc used to be incompatible with GCC.
+ # ICC 10 doesn't accept -KPIC any more.
+ icc* | ifort*)
+ lt_prog_compiler_wl='-Wl,'
+ lt_prog_compiler_pic='-fPIC'
+ lt_prog_compiler_static='-static'
+ ;;
+ # Lahey Fortran 8.1.
+ lf95*)
+ lt_prog_compiler_wl='-Wl,'
+ lt_prog_compiler_pic='--shared'
+ lt_prog_compiler_static='--static'
+ ;;
+ nagfor*)
+ # NAG Fortran compiler
+ lt_prog_compiler_wl='-Wl,-Wl,,'
+ lt_prog_compiler_pic='-PIC'
+ lt_prog_compiler_static='-Bstatic'
+ ;;
+ pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*)
+ # Portland Group compilers (*not* the Pentium gcc compiler,
+ # which looks to be a dead project)
+ lt_prog_compiler_wl='-Wl,'
+ lt_prog_compiler_pic='-fpic'
+ lt_prog_compiler_static='-Bstatic'
+ ;;
+ ccc*)
+ lt_prog_compiler_wl='-Wl,'
+ # All Alpha code is PIC.
+ lt_prog_compiler_static='-non_shared'
+ ;;
+ xl* | bgxl* | bgf* | mpixl*)
+ # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene
+ lt_prog_compiler_wl='-Wl,'
+ lt_prog_compiler_pic='-qpic'
+ lt_prog_compiler_static='-qstaticlink'
+ ;;
+ *)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ F* | *Sun*Fortran*)
+ # Sun Fortran 8.3 passes all unrecognized flags to the linker
+ lt_prog_compiler_pic='-KPIC'
+ lt_prog_compiler_static='-Bstatic'
+ lt_prog_compiler_wl=''
+ ;;
+ *Sun\ C*)
+ # Sun C 5.9
+ lt_prog_compiler_pic='-KPIC'
+ lt_prog_compiler_static='-Bstatic'
+ lt_prog_compiler_wl='-Wl,'
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+
+ newsos6)
+ lt_prog_compiler_pic='-KPIC'
+ lt_prog_compiler_static='-Bstatic'
+ ;;
+
+ *nto* | *qnx*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ lt_prog_compiler_pic='-fPIC -shared'
+ ;;
+
+ osf3* | osf4* | osf5*)
+ lt_prog_compiler_wl='-Wl,'
+ # All OSF/1 code is PIC.
+ lt_prog_compiler_static='-non_shared'
+ ;;
+
+ rdos*)
+ lt_prog_compiler_static='-non_shared'
+ ;;
+
+ solaris*)
+ lt_prog_compiler_pic='-KPIC'
+ lt_prog_compiler_static='-Bstatic'
+ case $cc_basename in
+ f77* | f90* | f95* | sunf77* | sunf90* | sunf95*)
+ lt_prog_compiler_wl='-Qoption ld ';;
+ *)
+ lt_prog_compiler_wl='-Wl,';;
+ esac
+ ;;
+
+ sunos4*)
+ lt_prog_compiler_wl='-Qoption ld '
+ lt_prog_compiler_pic='-PIC'
+ lt_prog_compiler_static='-Bstatic'
+ ;;
+
+ sysv4 | sysv4.2uw2* | sysv4.3*)
+ lt_prog_compiler_wl='-Wl,'
+ lt_prog_compiler_pic='-KPIC'
+ lt_prog_compiler_static='-Bstatic'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec ;then
+ lt_prog_compiler_pic='-Kconform_pic'
+ lt_prog_compiler_static='-Bstatic'
+ fi
+ ;;
+
+ sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*)
+ lt_prog_compiler_wl='-Wl,'
+ lt_prog_compiler_pic='-KPIC'
+ lt_prog_compiler_static='-Bstatic'
+ ;;
+
+ unicos*)
+ lt_prog_compiler_wl='-Wl,'
+ lt_prog_compiler_can_build_shared=no
+ ;;
+
+ uts4*)
+ lt_prog_compiler_pic='-pic'
+ lt_prog_compiler_static='-Bstatic'
+ ;;
+
+ *)
+ lt_prog_compiler_can_build_shared=no
+ ;;
+ esac
+ fi
+
+case $host_os in
+ # For platforms which do not support PIC, -DPIC is meaningless:
+ *djgpp*)
+ lt_prog_compiler_pic=
+ ;;
+ *)
+ lt_prog_compiler_pic="$lt_prog_compiler_pic -DPIC"
+ ;;
+esac
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $compiler option to produce PIC" >&5
+$as_echo_n "checking for $compiler option to produce PIC... " >&6; }
+if ${lt_cv_prog_compiler_pic+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_pic=$lt_prog_compiler_pic
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic" >&5
+$as_echo "$lt_cv_prog_compiler_pic" >&6; }
+lt_prog_compiler_pic=$lt_cv_prog_compiler_pic
+
+#
+# Check to make sure the PIC flag actually works.
+#
+if test -n "$lt_prog_compiler_pic"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler PIC flag $lt_prog_compiler_pic works" >&5
+$as_echo_n "checking if $compiler PIC flag $lt_prog_compiler_pic works... " >&6; }
+if ${lt_cv_prog_compiler_pic_works+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_pic_works=no
+ ac_outfile=conftest.$ac_objext
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+ lt_compiler_flag="$lt_prog_compiler_pic -DPIC"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ # The option is referenced via a variable to avoid confusing sed.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_pic_works=yes
+ fi
+ fi
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_works" >&5
+$as_echo "$lt_cv_prog_compiler_pic_works" >&6; }
+
+if test x"$lt_cv_prog_compiler_pic_works" = xyes; then
+ case $lt_prog_compiler_pic in
+ "" | " "*) ;;
+ *) lt_prog_compiler_pic=" $lt_prog_compiler_pic" ;;
+ esac
+else
+ lt_prog_compiler_pic=
+ lt_prog_compiler_can_build_shared=no
+fi
+
+fi
+
+
+
+
+
+
+
+
+
+
+
+#
+# Check to make sure the static flag actually works.
+#
+wl=$lt_prog_compiler_wl eval lt_tmp_static_flag=\"$lt_prog_compiler_static\"
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler static flag $lt_tmp_static_flag works" >&5
+$as_echo_n "checking if $compiler static flag $lt_tmp_static_flag works... " >&6; }
+if ${lt_cv_prog_compiler_static_works+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_static_works=no
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS $lt_tmp_static_flag"
+ echo "$lt_simple_link_test_code" > conftest.$ac_ext
+ if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then
+ # The linker can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ if test -s conftest.err; then
+ # Append any errors to the config.log.
+ cat conftest.err 1>&5
+ $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if diff conftest.exp conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_static_works=yes
+ fi
+ else
+ lt_cv_prog_compiler_static_works=yes
+ fi
+ fi
+ $RM -r conftest*
+ LDFLAGS="$save_LDFLAGS"
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_static_works" >&5
+$as_echo "$lt_cv_prog_compiler_static_works" >&6; }
+
+if test x"$lt_cv_prog_compiler_static_works" = xyes; then
+ :
+else
+ lt_prog_compiler_static=
+fi
+
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5
+$as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; }
+if ${lt_cv_prog_compiler_c_o+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_c_o=no
+ $RM -r conftest 2>/dev/null
+ mkdir conftest
+ cd conftest
+ mkdir out
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ lt_compiler_flag="-o out/conftest2.$ac_objext"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp
+ $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2
+ if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_c_o=yes
+ fi
+ fi
+ chmod u+w . 2>&5
+ $RM conftest*
+ # SGI C++ compiler will create directory out/ii_files/ for
+ # template instantiation
+ test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files
+ $RM out/* && rmdir out
+ cd ..
+ $RM -r conftest
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5
+$as_echo "$lt_cv_prog_compiler_c_o" >&6; }
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5
+$as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; }
+if ${lt_cv_prog_compiler_c_o+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_c_o=no
+ $RM -r conftest 2>/dev/null
+ mkdir conftest
+ cd conftest
+ mkdir out
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ lt_compiler_flag="-o out/conftest2.$ac_objext"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp
+ $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2
+ if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_c_o=yes
+ fi
+ fi
+ chmod u+w . 2>&5
+ $RM conftest*
+ # SGI C++ compiler will create directory out/ii_files/ for
+ # template instantiation
+ test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files
+ $RM out/* && rmdir out
+ cd ..
+ $RM -r conftest
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5
+$as_echo "$lt_cv_prog_compiler_c_o" >&6; }
+
+
+
+
+hard_links="nottested"
+if test "$lt_cv_prog_compiler_c_o" = no && test "$need_locks" != no; then
+ # do not overwrite the value of need_locks provided by the user
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if we can lock with hard links" >&5
+$as_echo_n "checking if we can lock with hard links... " >&6; }
+ hard_links=yes
+ $RM conftest*
+ ln conftest.a conftest.b 2>/dev/null && hard_links=no
+ touch conftest.a
+ ln conftest.a conftest.b 2>&5 || hard_links=no
+ ln conftest.a conftest.b 2>/dev/null && hard_links=no
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hard_links" >&5
+$as_echo "$hard_links" >&6; }
+ if test "$hard_links" = no; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \`$CC' does not support \`-c -o', so \`make -j' may be unsafe" >&5
+$as_echo "$as_me: WARNING: \`$CC' does not support \`-c -o', so \`make -j' may be unsafe" >&2;}
+ need_locks=warn
+ fi
+else
+ need_locks=no
+fi
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $compiler linker ($LD) supports shared libraries" >&5
+$as_echo_n "checking whether the $compiler linker ($LD) supports shared libraries... " >&6; }
+
+ runpath_var=
+ allow_undefined_flag=
+ always_export_symbols=no
+ archive_cmds=
+ archive_expsym_cmds=
+ compiler_needs_object=no
+ enable_shared_with_static_runtimes=no
+ export_dynamic_flag_spec=
+ export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols'
+ hardcode_automatic=no
+ hardcode_direct=no
+ hardcode_direct_absolute=no
+ hardcode_libdir_flag_spec=
+ hardcode_libdir_flag_spec_ld=
+ hardcode_libdir_separator=
+ hardcode_minus_L=no
+ hardcode_shlibpath_var=unsupported
+ inherit_rpath=no
+ link_all_deplibs=unknown
+ module_cmds=
+ module_expsym_cmds=
+ old_archive_from_new_cmds=
+ old_archive_from_expsyms_cmds=
+ thread_safe_flag_spec=
+ whole_archive_flag_spec=
+ # include_expsyms should be a list of space-separated symbols to be *always*
+ # included in the symbol list
+ include_expsyms=
+ # exclude_expsyms can be an extended regexp of symbols to exclude
+ # it will be wrapped by ` (' and `)$', so one must not match beginning or
+ # end of line. Example: `a|bc|.*d.*' will exclude the symbols `a' and `bc',
+ # as well as any symbol that contains `d'.
+ exclude_expsyms='_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*'
+ # Although _GLOBAL_OFFSET_TABLE_ is a valid symbol C name, most a.out
+ # platforms (ab)use it in PIC code, but their linkers get confused if
+ # the symbol is explicitly referenced. Since portable code cannot
+ # rely on this symbol name, it's probably fine to never include it in
+ # preloaded symbol tables.
+ # Exclude shared library initialization/finalization symbols.
+ extract_expsyms_cmds=
+
+ case $host_os in
+ cygwin* | mingw* | pw32* | cegcc*)
+ # FIXME: the MSVC++ port hasn't been tested in a loooong time
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ if test "$GCC" != yes; then
+ with_gnu_ld=no
+ fi
+ ;;
+ interix*)
+ # we just hope/assume this is gcc and not c89 (= MSVC++)
+ with_gnu_ld=yes
+ ;;
+ openbsd*)
+ with_gnu_ld=no
+ ;;
+ esac
+
+ ld_shlibs=yes
+
+ # On some targets, GNU ld is compatible enough with the native linker
+ # that we're better off using the native interface for both.
+ lt_use_gnu_ld_interface=no
+ if test "$with_gnu_ld" = yes; then
+ case $host_os in
+ aix*)
+ # The AIX port of GNU ld has always aspired to compatibility
+ # with the native linker. However, as the warning in the GNU ld
+ # block says, versions before 2.19.5* couldn't really create working
+ # shared libraries, regardless of the interface used.
+ case `$LD -v 2>&1` in
+ *\ \(GNU\ Binutils\)\ 2.19.5*) ;;
+ *\ \(GNU\ Binutils\)\ 2.[2-9]*) ;;
+ *\ \(GNU\ Binutils\)\ [3-9]*) ;;
+ *)
+ lt_use_gnu_ld_interface=yes
+ ;;
+ esac
+ ;;
+ *)
+ lt_use_gnu_ld_interface=yes
+ ;;
+ esac
+ fi
+
+ if test "$lt_use_gnu_ld_interface" = yes; then
+ # If archive_cmds runs LD, not CC, wlarc should be empty
+ wlarc='${wl}'
+
+ # Set some defaults for GNU ld with shared library support. These
+ # are reset later if shared libraries are not supported. Putting them
+ # here allows them to be overridden if necessary.
+ runpath_var=LD_RUN_PATH
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ export_dynamic_flag_spec='${wl}--export-dynamic'
+ # ancient GNU ld didn't support --whole-archive et. al.
+ if $LD --help 2>&1 | $GREP 'no-whole-archive' > /dev/null; then
+ whole_archive_flag_spec="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive'
+ else
+ whole_archive_flag_spec=
+ fi
+ supports_anon_versioning=no
+ case `$LD -v 2>&1` in
+ *GNU\ gold*) supports_anon_versioning=yes ;;
+ *\ [01].* | *\ 2.[0-9].* | *\ 2.10.*) ;; # catch versions < 2.11
+ *\ 2.11.93.0.2\ *) supports_anon_versioning=yes ;; # RH7.3 ...
+ *\ 2.11.92.0.12\ *) supports_anon_versioning=yes ;; # Mandrake 8.2 ...
+ *\ 2.11.*) ;; # other 2.11 versions
+ *) supports_anon_versioning=yes ;;
+ esac
+
+ # See if GNU ld supports shared libraries.
+ case $host_os in
+ aix[3-9]*)
+ # On AIX/PPC, the GNU linker is very broken
+ if test "$host_cpu" != ia64; then
+ ld_shlibs=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: the GNU linker, at least up to release 2.19, is reported
+*** to be unable to reliably create shared libraries on AIX.
+*** Therefore, libtool is disabling shared libraries support. If you
+*** really care for shared libraries, you may want to install binutils
+*** 2.20 or above, or modify your PATH so that a non-GNU linker is found.
+*** You will then need to restart the configuration process.
+
+_LT_EOF
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds=''
+ ;;
+ m68k)
+ archive_cmds='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)'
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ ;;
+ esac
+ ;;
+
+ beos*)
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ allow_undefined_flag=unsupported
+ # Joseph Beckenbach <jrb3@best.com> says some releases of gcc
+ # support --undefined. This deserves some investigation. FIXME
+ archive_cmds='$CC -nostart $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ else
+ ld_shlibs=no
+ fi
+ ;;
+
+ cygwin* | mingw* | pw32* | cegcc*)
+ # _LT_TAGVAR(hardcode_libdir_flag_spec, ) is actually meaningless,
+ # as there is no search path for DLLs.
+ hardcode_libdir_flag_spec='-L$libdir'
+ export_dynamic_flag_spec='${wl}--export-all-symbols'
+ allow_undefined_flag=unsupported
+ always_export_symbols=no
+ enable_shared_with_static_runtimes=yes
+ export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1 DATA/;s/^.*[ ]__nm__\([^ ]*\)[ ][^ ]*/\1 DATA/;/^I[ ]/d;/^[AITW][ ]/s/.* //'\'' | sort | uniq > $export_symbols'
+ exclude_expsyms='[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname'
+
+ if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then
+ archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ # If the export-symbols file already is a .def file (1st line
+ # is EXPORTS), use it as is; otherwise, prepend...
+ archive_expsym_cmds='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ cp $export_symbols $output_objdir/$soname.def;
+ else
+ echo EXPORTS > $output_objdir/$soname.def;
+ cat $export_symbols >> $output_objdir/$soname.def;
+ fi~
+ $CC -shared $output_objdir/$soname.def $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ else
+ ld_shlibs=no
+ fi
+ ;;
+
+ haiku*)
+ archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ link_all_deplibs=yes
+ ;;
+
+ interix[3-9]*)
+ hardcode_direct=no
+ hardcode_shlibpath_var=no
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ export_dynamic_flag_spec='${wl}-E'
+ # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc.
+ # Instead, shared libraries are loaded at an image base (0x10000000 by
+ # default) and relocated if they conflict, which is a slow very memory
+ # consuming and fragmenting process. To avoid this, we pick a random,
+ # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link
+ # time. Moving up from 0x10000000 also allows more sbrk(2) space.
+ archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ archive_expsym_cmds='sed "s,^,_," $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--retain-symbols-file,$output_objdir/$soname.expsym ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ ;;
+
+ gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu)
+ tmp_diet=no
+ if test "$host_os" = linux-dietlibc; then
+ case $cc_basename in
+ diet\ *) tmp_diet=yes;; # linux-dietlibc with static linking (!diet-dyn)
+ esac
+ fi
+ if $LD --help 2>&1 | $EGREP ': supported targets:.* elf' > /dev/null \
+ && test "$tmp_diet" = no
+ then
+ tmp_addflag=' $pic_flag'
+ tmp_sharedflag='-shared'
+ case $cc_basename,$host_cpu in
+ pgcc*) # Portland Group C compiler
+ whole_archive_flag_spec='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ tmp_addflag=' $pic_flag'
+ ;;
+ pgf77* | pgf90* | pgf95* | pgfortran*)
+ # Portland Group f77 and f90 compilers
+ whole_archive_flag_spec='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ tmp_addflag=' $pic_flag -Mnomain' ;;
+ ecc*,ia64* | icc*,ia64*) # Intel C compiler on ia64
+ tmp_addflag=' -i_dynamic' ;;
+ efc*,ia64* | ifort*,ia64*) # Intel Fortran compiler on ia64
+ tmp_addflag=' -i_dynamic -nofor_main' ;;
+ ifc* | ifort*) # Intel Fortran compiler
+ tmp_addflag=' -nofor_main' ;;
+ lf95*) # Lahey Fortran 8.1
+ whole_archive_flag_spec=
+ tmp_sharedflag='--shared' ;;
+ xl[cC]* | bgxl[cC]* | mpixl[cC]*) # IBM XL C 8.0 on PPC (deal with xlf below)
+ tmp_sharedflag='-qmkshrobj'
+ tmp_addflag= ;;
+ nvcc*) # Cuda Compiler Driver 2.2
+ whole_archive_flag_spec='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ compiler_needs_object=yes
+ ;;
+ esac
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*) # Sun C 5.9
+ whole_archive_flag_spec='${wl}--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ compiler_needs_object=yes
+ tmp_sharedflag='-G' ;;
+ *Sun\ F*) # Sun Fortran 8.3
+ tmp_sharedflag='-G' ;;
+ esac
+ archive_cmds='$CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+
+ if test "x$supports_anon_versioning" = xyes; then
+ archive_expsym_cmds='echo "{ global:" > $output_objdir/$libname.ver~
+ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~
+ echo "local: *; };" >> $output_objdir/$libname.ver~
+ $CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-version-script ${wl}$output_objdir/$libname.ver -o $lib'
+ fi
+
+ case $cc_basename in
+ xlf* | bgf* | bgxlf* | mpixlf*)
+ # IBM XL Fortran 10.1 on PPC cannot create shared libs itself
+ whole_archive_flag_spec='--whole-archive$convenience --no-whole-archive'
+ hardcode_libdir_flag_spec=
+ hardcode_libdir_flag_spec_ld='-rpath $libdir'
+ archive_cmds='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib'
+ if test "x$supports_anon_versioning" = xyes; then
+ archive_expsym_cmds='echo "{ global:" > $output_objdir/$libname.ver~
+ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~
+ echo "local: *; };" >> $output_objdir/$libname.ver~
+ $LD -shared $libobjs $deplibs $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib'
+ fi
+ ;;
+ esac
+ else
+ ld_shlibs=no
+ fi
+ ;;
+
+ netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ archive_cmds='$LD -Bshareable $libobjs $deplibs $linker_flags -o $lib'
+ wlarc=
+ else
+ archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ fi
+ ;;
+
+ solaris*)
+ if $LD -v 2>&1 | $GREP 'BFD 2\.8' > /dev/null; then
+ ld_shlibs=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: The releases 2.8.* of the GNU linker cannot reliably
+*** create shared libraries on Solaris systems. Therefore, libtool
+*** is disabling shared libraries support. We urge you to upgrade GNU
+*** binutils to release 2.9.1 or newer. Another option is to modify
+*** your PATH or compiler configuration so that the native linker is
+*** used, and then restart.
+
+_LT_EOF
+ elif $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ ld_shlibs=no
+ fi
+ ;;
+
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*)
+ case `$LD -v 2>&1` in
+ *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*)
+ ld_shlibs=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: Releases of the GNU linker prior to 2.16.91.0.3 can not
+*** reliably create shared libraries on SCO systems. Therefore, libtool
+*** is disabling shared libraries support. We urge you to upgrade GNU
+*** binutils to release 2.16.91.0.3 or newer. Another option is to modify
+*** your PATH or compiler configuration so that the native linker is
+*** used, and then restart.
+
+_LT_EOF
+ ;;
+ *)
+ # For security reasons, it is highly recommended that you always
+ # use absolute paths for naming shared libraries, and exclude the
+ # DT_RUNPATH tag from executables and libraries. But doing so
+ # requires that you compile everything twice, which is a pain.
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ esac
+ ;;
+
+ sunos4*)
+ archive_cmds='$LD -assert pure-text -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ wlarc=
+ hardcode_direct=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ *)
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ esac
+
+ if test "$ld_shlibs" = no; then
+ runpath_var=
+ hardcode_libdir_flag_spec=
+ export_dynamic_flag_spec=
+ whole_archive_flag_spec=
+ fi
+ else
+ # PORTME fill in a description of your system's linker (not GNU ld)
+ case $host_os in
+ aix3*)
+ allow_undefined_flag=unsupported
+ always_export_symbols=yes
+ archive_expsym_cmds='$LD -o $output_objdir/$soname $libobjs $deplibs $linker_flags -bE:$export_symbols -T512 -H512 -bM:SRE~$AR $AR_FLAGS $lib $output_objdir/$soname'
+ # Note: this linker hardcodes the directories in LIBPATH if there
+ # are no directories specified by -L.
+ hardcode_minus_L=yes
+ if test "$GCC" = yes && test -z "$lt_prog_compiler_static"; then
+ # Neither direct hardcoding nor static linking is supported with a
+ # broken collect2.
+ hardcode_direct=unsupported
+ fi
+ ;;
+
+ aix[4-9]*)
+ if test "$host_cpu" = ia64; then
+ # On IA64, the linker does run time linking by default, so we don't
+ # have to do anything special.
+ aix_use_runtimelinking=no
+ exp_sym_flag='-Bexport'
+ no_entry_flag=""
+ else
+ # If we're using GNU nm, then we don't want the "-C" option.
+ # -C means demangle to AIX nm, but means don't demangle with GNU nm
+ # Also, AIX nm treats weak defined symbols like other global
+ # defined symbols, whereas GNU nm marks them as "W".
+ if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then
+ export_symbols_cmds='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && (substr(\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ else
+ export_symbols_cmds='$NM -BCpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && (substr(\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ fi
+ aix_use_runtimelinking=no
+
+ # Test if we are trying to use run time linking or normal
+ # AIX style linking. If -brtl is somewhere in LDFLAGS, we
+ # need to do runtime linking.
+ case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*)
+ for ld_flag in $LDFLAGS; do
+ if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then
+ aix_use_runtimelinking=yes
+ break
+ fi
+ done
+ ;;
+ esac
+
+ exp_sym_flag='-bexport'
+ no_entry_flag='-bnoentry'
+ fi
+
+ # When large executables or shared objects are built, AIX ld can
+ # have problems creating the table of contents. If linking a library
+ # or program results in "error TOC overflow" add -mminimal-toc to
+ # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not
+ # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS.
+
+ archive_cmds=''
+ hardcode_direct=yes
+ hardcode_direct_absolute=yes
+ hardcode_libdir_separator=':'
+ link_all_deplibs=yes
+ file_list_spec='${wl}-f,'
+
+ if test "$GCC" = yes; then
+ case $host_os in aix4.[012]|aix4.[012].*)
+ # We only want to do this on AIX 4.2 and lower, the check
+ # below for broken collect2 doesn't work under 4.3+
+ collect2name=`${CC} -print-prog-name=collect2`
+ if test -f "$collect2name" &&
+ strings "$collect2name" | $GREP resolve_lib_name >/dev/null
+ then
+ # We have reworked collect2
+ :
+ else
+ # We have old collect2
+ hardcode_direct=unsupported
+ # It fails to find uninstalled libraries when the uninstalled
+ # path is not listed in the libpath. Setting hardcode_minus_L
+ # to unsupported forces relinking
+ hardcode_minus_L=yes
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_libdir_separator=
+ fi
+ ;;
+ esac
+ shared_flag='-shared'
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag="$shared_flag "'${wl}-G'
+ fi
+ else
+ # not using gcc
+ if test "$host_cpu" = ia64; then
+ # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release
+ # chokes on -Wl,-G. The following line is correct:
+ shared_flag='-G'
+ else
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag='${wl}-G'
+ else
+ shared_flag='${wl}-bM:SRE'
+ fi
+ fi
+ fi
+
+ export_dynamic_flag_spec='${wl}-bexpall'
+ # It seems that -bexpall does not export symbols beginning with
+ # underscore (_), so it is better to generate a list of symbols to export.
+ always_export_symbols=yes
+ if test "$aix_use_runtimelinking" = yes; then
+ # Warning - without using the other runtime loading flags (-brtl),
+ # -berok will link without error, but may produce a broken library.
+ allow_undefined_flag='-berok'
+ # Determine the default libpath from the value encoded in an
+ # empty executable.
+ if test "${lt_cv_aix_libpath+set}" = set; then
+ aix_libpath=$lt_cv_aix_libpath
+else
+ if ${lt_cv_aix_libpath_+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+
+ lt_aix_libpath_sed='
+ /Import File Strings/,/^$/ {
+ /^0/ {
+ s/^0 *\([^ ]*\) *$/\1/
+ p
+ }
+ }'
+ lt_cv_aix_libpath_=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ # Check for a 64-bit object if we didn't find anything.
+ if test -z "$lt_cv_aix_libpath_"; then
+ lt_cv_aix_libpath_=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ fi
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ if test -z "$lt_cv_aix_libpath_"; then
+ lt_cv_aix_libpath_="/usr/lib:/lib"
+ fi
+
+fi
+
+ aix_libpath=$lt_cv_aix_libpath_
+fi
+
+ hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
+ archive_expsym_cmds='$CC -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags `if test "x${allow_undefined_flag}" != "x"; then func_echo_all "${wl}${allow_undefined_flag}"; else :; fi` '"\${wl}$exp_sym_flag:\$export_symbols $shared_flag"
+ else
+ if test "$host_cpu" = ia64; then
+ hardcode_libdir_flag_spec='${wl}-R $libdir:/usr/lib:/lib'
+ allow_undefined_flag="-z nodefs"
+ archive_expsym_cmds="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags ${wl}${allow_undefined_flag} '"\${wl}$exp_sym_flag:\$export_symbols"
+ else
+ # Determine the default libpath from the value encoded in an
+ # empty executable.
+ if test "${lt_cv_aix_libpath+set}" = set; then
+ aix_libpath=$lt_cv_aix_libpath
+else
+ if ${lt_cv_aix_libpath_+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+
+ lt_aix_libpath_sed='
+ /Import File Strings/,/^$/ {
+ /^0/ {
+ s/^0 *\([^ ]*\) *$/\1/
+ p
+ }
+ }'
+ lt_cv_aix_libpath_=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ # Check for a 64-bit object if we didn't find anything.
+ if test -z "$lt_cv_aix_libpath_"; then
+ lt_cv_aix_libpath_=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ fi
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ if test -z "$lt_cv_aix_libpath_"; then
+ lt_cv_aix_libpath_="/usr/lib:/lib"
+ fi
+
+fi
+
+ aix_libpath=$lt_cv_aix_libpath_
+fi
+
+ hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
+ # Warning - without using the other run time loading flags,
+ # -berok will link without error, but may produce a broken library.
+ no_undefined_flag=' ${wl}-bernotok'
+ allow_undefined_flag=' ${wl}-berok'
+ if test "$with_gnu_ld" = yes; then
+ # We only use this code for GNU lds that support --whole-archive.
+ whole_archive_flag_spec='${wl}--whole-archive$convenience ${wl}--no-whole-archive'
+ else
+ # Exported symbols can be pulled into shared objects from archives
+ whole_archive_flag_spec='$convenience'
+ fi
+ archive_cmds_need_lc=yes
+ # This is similar to how AIX traditionally builds its shared libraries.
+ archive_expsym_cmds="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs ${wl}-bnoentry $compiler_flags ${wl}-bE:$export_symbols${allow_undefined_flag}~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$soname'
+ fi
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds=''
+ ;;
+ m68k)
+ archive_cmds='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)'
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ ;;
+ esac
+ ;;
+
+ bsdi[45]*)
+ export_dynamic_flag_spec=-rdynamic
+ ;;
+
+ cygwin* | mingw* | pw32* | cegcc*)
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ case $cc_basename in
+ cl*)
+ # Native MSVC
+ hardcode_libdir_flag_spec=' '
+ allow_undefined_flag=unsupported
+ always_export_symbols=yes
+ file_list_spec='@'
+ # Tell ltmain to make .lib files, not .a files.
+ libext=lib
+ # Tell ltmain to make .dll files, not .so files.
+ shrext_cmds=".dll"
+ # FIXME: Setting linknames here is a bad hack.
+ archive_cmds='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-dll~linknames='
+ archive_expsym_cmds='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ sed -n -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' -e '1\\\!p' < $export_symbols > $output_objdir/$soname.exp;
+ else
+ sed -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' < $export_symbols > $output_objdir/$soname.exp;
+ fi~
+ $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~
+ linknames='
+ # The linker will not automatically build a static lib if we build a DLL.
+ # _LT_TAGVAR(old_archive_from_new_cmds, )='true'
+ enable_shared_with_static_runtimes=yes
+ export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1,DATA/'\'' | $SED -e '\''/^[AITW][ ]/s/.*[ ]//'\'' | sort | uniq > $export_symbols'
+ # Don't use ranlib
+ old_postinstall_cmds='chmod 644 $oldlib'
+ postlink_cmds='lt_outputfile="@OUTPUT@"~
+ lt_tool_outputfile="@TOOL_OUTPUT@"~
+ case $lt_outputfile in
+ *.exe|*.EXE) ;;
+ *)
+ lt_outputfile="$lt_outputfile.exe"
+ lt_tool_outputfile="$lt_tool_outputfile.exe"
+ ;;
+ esac~
+ if test "$MANIFEST_TOOL" != ":" && test -f "$lt_outputfile.manifest"; then
+ $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1;
+ $RM "$lt_outputfile.manifest";
+ fi'
+ ;;
+ *)
+ # Assume MSVC wrapper
+ hardcode_libdir_flag_spec=' '
+ allow_undefined_flag=unsupported
+ # Tell ltmain to make .lib files, not .a files.
+ libext=lib
+ # Tell ltmain to make .dll files, not .so files.
+ shrext_cmds=".dll"
+ # FIXME: Setting linknames here is a bad hack.
+ archive_cmds='$CC -o $lib $libobjs $compiler_flags `func_echo_all "$deplibs" | $SED '\''s/ -lc$//'\''` -link -dll~linknames='
+ # The linker will automatically build a .lib file if we build a DLL.
+ old_archive_from_new_cmds='true'
+ # FIXME: Should let the user specify the lib program.
+ old_archive_cmds='lib -OUT:$oldlib$oldobjs$old_deplibs'
+ enable_shared_with_static_runtimes=yes
+ ;;
+ esac
+ ;;
+
+ darwin* | rhapsody*)
+
+
+ archive_cmds_need_lc=no
+ hardcode_direct=no
+ hardcode_automatic=yes
+ hardcode_shlibpath_var=unsupported
+ if test "$lt_cv_ld_force_load" = "yes"; then
+ whole_archive_flag_spec='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience ${wl}-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`'
+ else
+ whole_archive_flag_spec=''
+ fi
+ link_all_deplibs=yes
+ allow_undefined_flag="$_lt_dar_allow_undefined"
+ case $cc_basename in
+ ifort*) _lt_dar_can_shared=yes ;;
+ *) _lt_dar_can_shared=$GCC ;;
+ esac
+ if test "$_lt_dar_can_shared" = "yes"; then
+ output_verbose_link_cmd=func_echo_all
+ archive_cmds="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod${_lt_dsymutil}"
+ module_cmds="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dsymutil}"
+ archive_expsym_cmds="sed 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring ${_lt_dar_single_mod}${_lt_dar_export_syms}${_lt_dsymutil}"
+ module_expsym_cmds="sed -e 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dar_export_syms}${_lt_dsymutil}"
+
+ else
+ ld_shlibs=no
+ fi
+
+ ;;
+
+ dgux*)
+ archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_shlibpath_var=no
+ ;;
+
+ freebsd1*)
+ ld_shlibs=no
+ ;;
+
+ # FreeBSD 2.2.[012] allows us to include c++rt0.o to get C++ constructor
+ # support. Future versions do this automatically, but an explicit c++rt0.o
+ # does not break anything, and helps significantly (at the cost of a little
+ # extra space).
+ freebsd2.2*)
+ archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags /usr/lib/c++rt0.o'
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ # Unfortunately, older versions of FreeBSD 2 do not have this feature.
+ freebsd2*)
+ archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ # FreeBSD 3 and greater uses gcc -shared to do shared libraries.
+ freebsd* | dragonfly*)
+ archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ hpux9*)
+ if test "$GCC" = yes; then
+ archive_cmds='$RM $output_objdir/$soname~$CC -shared $pic_flag ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ else
+ archive_cmds='$RM $output_objdir/$soname~$LD -b +b $install_libdir -o $output_objdir/$soname $libobjs $deplibs $linker_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ fi
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ hardcode_direct=yes
+
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ export_dynamic_flag_spec='${wl}-E'
+ ;;
+
+ hpux10*)
+ if test "$GCC" = yes && test "$with_gnu_ld" = no; then
+ archive_cmds='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags'
+ fi
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_flag_spec_ld='+b $libdir'
+ hardcode_libdir_separator=:
+ hardcode_direct=yes
+ hardcode_direct_absolute=yes
+ export_dynamic_flag_spec='${wl}-E'
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ fi
+ ;;
+
+ hpux11*)
+ if test "$GCC" = yes && test "$with_gnu_ld" = no; then
+ case $host_cpu in
+ hppa*64*)
+ archive_cmds='$CC -shared ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ ia64*)
+ archive_cmds='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ *)
+ archive_cmds='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ esac
+ else
+ case $host_cpu in
+ hppa*64*)
+ archive_cmds='$CC -b ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ ia64*)
+ archive_cmds='$CC -b ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ *)
+
+ # Older versions of the 11.00 compiler do not understand -b yet
+ # (HP92453-01 A.11.01.20 doesn't, HP92453-01 B.11.X.35175-35176.GP does)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $CC understands -b" >&5
+$as_echo_n "checking if $CC understands -b... " >&6; }
+if ${lt_cv_prog_compiler__b+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler__b=no
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS -b"
+ echo "$lt_simple_link_test_code" > conftest.$ac_ext
+ if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then
+ # The linker can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ if test -s conftest.err; then
+ # Append any errors to the config.log.
+ cat conftest.err 1>&5
+ $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if diff conftest.exp conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler__b=yes
+ fi
+ else
+ lt_cv_prog_compiler__b=yes
+ fi
+ fi
+ $RM -r conftest*
+ LDFLAGS="$save_LDFLAGS"
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler__b" >&5
+$as_echo "$lt_cv_prog_compiler__b" >&6; }
+
+if test x"$lt_cv_prog_compiler__b" = xyes; then
+ archive_cmds='$CC -b ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+else
+ archive_cmds='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags'
+fi
+
+ ;;
+ esac
+ fi
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+
+ case $host_cpu in
+ hppa*64*|ia64*)
+ hardcode_direct=no
+ hardcode_shlibpath_var=no
+ ;;
+ *)
+ hardcode_direct=yes
+ hardcode_direct_absolute=yes
+ export_dynamic_flag_spec='${wl}-E'
+
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ ;;
+ esac
+ fi
+ ;;
+
+ irix5* | irix6* | nonstopux*)
+ if test "$GCC" = yes; then
+ archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ # Try to use the -exported_symbol ld option, if it does not
+ # work, assume that -exports_file does not work either and
+ # implicitly export all symbols.
+ # This should be the same for all languages, so no per-tag cache variable.
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $host_os linker accepts -exported_symbol" >&5
+$as_echo_n "checking whether the $host_os linker accepts -exported_symbol... " >&6; }
+if ${lt_cv_irix_exported_symbol+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS -shared ${wl}-exported_symbol ${wl}foo ${wl}-update_registry ${wl}/dev/null"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+int foo (void) { return 0; }
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ lt_cv_irix_exported_symbol=yes
+else
+ lt_cv_irix_exported_symbol=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ LDFLAGS="$save_LDFLAGS"
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_irix_exported_symbol" >&5
+$as_echo "$lt_cv_irix_exported_symbol" >&6; }
+ if test "$lt_cv_irix_exported_symbol" = yes; then
+ archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations ${wl}-exports_file ${wl}$export_symbols -o $lib'
+ fi
+ else
+ archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -exports_file $export_symbols -o $lib'
+ fi
+ archive_cmds_need_lc='no'
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ inherit_rpath=yes
+ link_all_deplibs=yes
+ ;;
+
+ netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' # a.out
+ else
+ archive_cmds='$LD -shared -o $lib $libobjs $deplibs $linker_flags' # ELF
+ fi
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ newsos6)
+ archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct=yes
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ hardcode_shlibpath_var=no
+ ;;
+
+ *nto* | *qnx*)
+ ;;
+
+ openbsd*)
+ if test -f /usr/libexec/ld.so; then
+ hardcode_direct=yes
+ hardcode_shlibpath_var=no
+ hardcode_direct_absolute=yes
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags ${wl}-retain-symbols-file,$export_symbols'
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ export_dynamic_flag_spec='${wl}-E'
+ else
+ case $host_os in
+ openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*)
+ archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_libdir_flag_spec='-R$libdir'
+ ;;
+ *)
+ archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ ;;
+ esac
+ fi
+ else
+ ld_shlibs=no
+ fi
+ ;;
+
+ os2*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ allow_undefined_flag=unsupported
+ archive_cmds='$ECHO "LIBRARY $libname INITINSTANCE" > $output_objdir/$libname.def~$ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~echo DATA >> $output_objdir/$libname.def~echo " SINGLE NONSHARED" >> $output_objdir/$libname.def~echo EXPORTS >> $output_objdir/$libname.def~emxexp $libobjs >> $output_objdir/$libname.def~$CC -Zdll -Zcrtdll -o $lib $libobjs $deplibs $compiler_flags $output_objdir/$libname.def'
+ old_archive_from_new_cmds='emximp -o $output_objdir/$libname.a $output_objdir/$libname.def'
+ ;;
+
+ osf3*)
+ if test "$GCC" = yes; then
+ allow_undefined_flag=' ${wl}-expect_unresolved ${wl}\*'
+ archive_cmds='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ else
+ allow_undefined_flag=' -expect_unresolved \*'
+ archive_cmds='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ fi
+ archive_cmds_need_lc='no'
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+
+ osf4* | osf5*) # as osf3* with the addition of -msym flag
+ if test "$GCC" = yes; then
+ allow_undefined_flag=' ${wl}-expect_unresolved ${wl}\*'
+ archive_cmds='$CC -shared${allow_undefined_flag} $pic_flag $libobjs $deplibs $compiler_flags ${wl}-msym ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ else
+ allow_undefined_flag=' -expect_unresolved \*'
+ archive_cmds='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ archive_expsym_cmds='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done; printf "%s\\n" "-hidden">> $lib.exp~
+ $CC -shared${allow_undefined_flag} ${wl}-input ${wl}$lib.exp $compiler_flags $libobjs $deplibs -soname $soname `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib~$RM $lib.exp'
+
+ # Both c and cxx compiler support -rpath directly
+ hardcode_libdir_flag_spec='-rpath $libdir'
+ fi
+ archive_cmds_need_lc='no'
+ hardcode_libdir_separator=:
+ ;;
+
+ solaris*)
+ no_undefined_flag=' -z defs'
+ if test "$GCC" = yes; then
+ wlarc='${wl}'
+ archive_cmds='$CC -shared $pic_flag ${wl}-z ${wl}text ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -shared $pic_flag ${wl}-z ${wl}text ${wl}-M ${wl}$lib.exp ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp'
+ else
+ case `$CC -V 2>&1` in
+ *"Compilers 5.0"*)
+ wlarc=''
+ archive_cmds='$LD -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $LD -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $linker_flags~$RM $lib.exp'
+ ;;
+ *)
+ wlarc='${wl}'
+ archive_cmds='$CC -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp'
+ ;;
+ esac
+ fi
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_shlibpath_var=no
+ case $host_os in
+ solaris2.[0-5] | solaris2.[0-5].*) ;;
+ *)
+ # The compiler driver will combine and reorder linker options,
+ # but understands `-z linker_flag'. GCC discards it without `$wl',
+ # but is careful enough not to reorder.
+ # Supported since Solaris 2.6 (maybe 2.5.1?)
+ if test "$GCC" = yes; then
+ whole_archive_flag_spec='${wl}-z ${wl}allextract$convenience ${wl}-z ${wl}defaultextract'
+ else
+ whole_archive_flag_spec='-z allextract$convenience -z defaultextract'
+ fi
+ ;;
+ esac
+ link_all_deplibs=yes
+ ;;
+
+ sunos4*)
+ if test "x$host_vendor" = xsequent; then
+ # Use $CC to link under sequent, because it throws in some extra .o
+ # files that make .init and .fini sections work.
+ archive_cmds='$CC -G ${wl}-h $soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds='$LD -assert pure-text -Bstatic -o $lib $libobjs $deplibs $linker_flags'
+ fi
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ sysv4)
+ case $host_vendor in
+ sni)
+ archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct=yes # is this really true???
+ ;;
+ siemens)
+ ## LD is ld it makes a PLAMLIB
+ ## CC just makes a GrossModule.
+ archive_cmds='$LD -G -o $lib $libobjs $deplibs $linker_flags'
+ reload_cmds='$CC -r -o $output$reload_objs'
+ hardcode_direct=no
+ ;;
+ motorola)
+ archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct=no #Motorola manual says yes, but my tests say they lie
+ ;;
+ esac
+ runpath_var='LD_RUN_PATH'
+ hardcode_shlibpath_var=no
+ ;;
+
+ sysv4.3*)
+ archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_shlibpath_var=no
+ export_dynamic_flag_spec='-Bexport'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_shlibpath_var=no
+ runpath_var=LD_RUN_PATH
+ hardcode_runpath_var=yes
+ ld_shlibs=yes
+ fi
+ ;;
+
+ sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*)
+ no_undefined_flag='${wl}-z,text'
+ archive_cmds_need_lc=no
+ hardcode_shlibpath_var=no
+ runpath_var='LD_RUN_PATH'
+
+ if test "$GCC" = yes; then
+ archive_cmds='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ fi
+ ;;
+
+ sysv5* | sco3.2v5* | sco5v6*)
+ # Note: We can NOT use -z defs as we might desire, because we do not
+ # link with -lc, and that would cause any symbols used from libc to
+ # always be unresolved, which means just about no library would
+ # ever link correctly. If we're not using GNU ld we use -z text
+ # though, which does catch some bad symbols but isn't as heavy-handed
+ # as -z defs.
+ no_undefined_flag='${wl}-z,text'
+ allow_undefined_flag='${wl}-z,nodefs'
+ archive_cmds_need_lc=no
+ hardcode_shlibpath_var=no
+ hardcode_libdir_flag_spec='${wl}-R,$libdir'
+ hardcode_libdir_separator=':'
+ link_all_deplibs=yes
+ export_dynamic_flag_spec='${wl}-Bexport'
+ runpath_var='LD_RUN_PATH'
+
+ if test "$GCC" = yes; then
+ archive_cmds='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ fi
+ ;;
+
+ uts4*)
+ archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_shlibpath_var=no
+ ;;
+
+ *)
+ ld_shlibs=no
+ ;;
+ esac
+
+ if test x$host_vendor = xsni; then
+ case $host in
+ sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*)
+ export_dynamic_flag_spec='${wl}-Blargedynsym'
+ ;;
+ esac
+ fi
+ fi
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs" >&5
+$as_echo "$ld_shlibs" >&6; }
+test "$ld_shlibs" = no && can_build_shared=no
+
+with_gnu_ld=$with_gnu_ld
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+#
+# Do we need to explicitly link libc?
+#
+case "x$archive_cmds_need_lc" in
+x|xyes)
+ # Assume -lc should be added
+ archive_cmds_need_lc=yes
+
+ if test "$enable_shared" = yes && test "$GCC" = yes; then
+ case $archive_cmds in
+ *'~'*)
+ # FIXME: we may have to deal with multi-command sequences.
+ ;;
+ '$CC '*)
+ # Test whether the compiler implicitly links with -lc since on some
+ # systems, -lgcc has to come before -lc. If gcc already passes -lc
+ # to ld, don't add -lc before -lgcc.
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether -lc should be explicitly linked in" >&5
+$as_echo_n "checking whether -lc should be explicitly linked in... " >&6; }
+if ${lt_cv_archive_cmds_need_lc+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ $RM conftest*
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } 2>conftest.err; then
+ soname=conftest
+ lib=conftest
+ libobjs=conftest.$ac_objext
+ deplibs=
+ wl=$lt_prog_compiler_wl
+ pic_flag=$lt_prog_compiler_pic
+ compiler_flags=-v
+ linker_flags=-v
+ verstring=
+ output_objdir=.
+ libname=conftest
+ lt_save_allow_undefined_flag=$allow_undefined_flag
+ allow_undefined_flag=
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$archive_cmds 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1\""; } >&5
+ (eval $archive_cmds 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+ then
+ lt_cv_archive_cmds_need_lc=no
+ else
+ lt_cv_archive_cmds_need_lc=yes
+ fi
+ allow_undefined_flag=$lt_save_allow_undefined_flag
+ else
+ cat conftest.err 1>&5
+ fi
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc" >&5
+$as_echo "$lt_cv_archive_cmds_need_lc" >&6; }
+ archive_cmds_need_lc=$lt_cv_archive_cmds_need_lc
+ ;;
+ esac
+ fi
+ ;;
+esac
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking dynamic linker characteristics" >&5
+$as_echo_n "checking dynamic linker characteristics... " >&6; }
+
+if test "$GCC" = yes; then
+ case $host_os in
+ darwin*) lt_awk_arg="/^libraries:/,/LR/" ;;
+ *) lt_awk_arg="/^libraries:/" ;;
+ esac
+ case $host_os in
+ mingw* | cegcc*) lt_sed_strip_eq="s,=\([A-Za-z]:\),\1,g" ;;
+ *) lt_sed_strip_eq="s,=/,/,g" ;;
+ esac
+ lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e $lt_sed_strip_eq`
+ case $lt_search_path_spec in
+ *\;*)
+ # if the path contains ";" then we assume it to be the separator
+ # otherwise default to the standard path separator (i.e. ":") - it is
+ # assumed that no part of a normal pathname contains ";" but that should
+ # okay in the real world where ";" in dirpaths is itself problematic.
+ lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED 's/;/ /g'`
+ ;;
+ *)
+ lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED "s/$PATH_SEPARATOR/ /g"`
+ ;;
+ esac
+ # Ok, now we have the path, separated by spaces, we can step through it
+ # and add multilib dir if necessary.
+ lt_tmp_lt_search_path_spec=
+ lt_multi_os_dir=`$CC $CPPFLAGS $CFLAGS $LDFLAGS -print-multi-os-directory 2>/dev/null`
+ for lt_sys_path in $lt_search_path_spec; do
+ if test -d "$lt_sys_path/$lt_multi_os_dir"; then
+ lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path/$lt_multi_os_dir"
+ else
+ test -d "$lt_sys_path" && \
+ lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path"
+ fi
+ done
+ lt_search_path_spec=`$ECHO "$lt_tmp_lt_search_path_spec" | awk '
+BEGIN {RS=" "; FS="/|\n";} {
+ lt_foo="";
+ lt_count=0;
+ for (lt_i = NF; lt_i > 0; lt_i--) {
+ if ($lt_i != "" && $lt_i != ".") {
+ if ($lt_i == "..") {
+ lt_count++;
+ } else {
+ if (lt_count == 0) {
+ lt_foo="/" $lt_i lt_foo;
+ } else {
+ lt_count--;
+ }
+ }
+ }
+ }
+ if (lt_foo != "") { lt_freq[lt_foo]++; }
+ if (lt_freq[lt_foo] == 1) { print lt_foo; }
+}'`
+ # AWK program above erroneously prepends '/' to C:/dos/paths
+ # for these hosts.
+ case $host_os in
+ mingw* | cegcc*) lt_search_path_spec=`$ECHO "$lt_search_path_spec" |\
+ $SED 's,/\([A-Za-z]:\),\1,g'` ;;
+ esac
+ sys_lib_search_path_spec=`$ECHO "$lt_search_path_spec" | $lt_NL2SP`
+else
+ sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib"
+fi
+library_names_spec=
+libname_spec='lib$name'
+soname_spec=
+shrext_cmds=".so"
+postinstall_cmds=
+postuninstall_cmds=
+finish_cmds=
+finish_eval=
+shlibpath_var=
+shlibpath_overrides_runpath=unknown
+version_type=none
+dynamic_linker="$host_os ld.so"
+sys_lib_dlsearch_path_spec="/lib /usr/lib"
+need_lib_prefix=unknown
+hardcode_into_libs=no
+
+# when you set need_version to no, make sure it does not cause -set_version
+# flags to be left without arguments
+need_version=unknown
+
+case $host_os in
+aix3*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix $libname.a'
+ shlibpath_var=LIBPATH
+
+ # AIX 3 has no versioning support, so we append a major version to the name.
+ soname_spec='${libname}${release}${shared_ext}$major'
+ ;;
+
+aix[4-9]*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ hardcode_into_libs=yes
+ if test "$host_cpu" = ia64; then
+ # AIX 5 supports IA64
+ library_names_spec='${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext}$versuffix $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ else
+ # With GCC up to 2.95.x, collect2 would create an import file
+ # for dependence libraries. The import file would start with
+ # the line `#! .'. This would cause the generated library to
+ # depend on `.', always an invalid library. This was fixed in
+ # development snapshots of GCC prior to 3.0.
+ case $host_os in
+ aix4 | aix4.[01] | aix4.[01].*)
+ if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)'
+ echo ' yes '
+ echo '#endif'; } | ${CC} -E - | $GREP yes > /dev/null; then
+ :
+ else
+ can_build_shared=no
+ fi
+ ;;
+ esac
+ # AIX (on Power*) has no versioning support, so currently we can not hardcode correct
+ # soname into executable. Probably we can add versioning support to
+ # collect2, so additional links can be useful in future.
+ if test "$aix_use_runtimelinking" = yes; then
+ # If using run time linking (on AIX 4.2 or later) use lib<name>.so
+ # instead of lib<name>.a to let people know that these are not
+ # typical AIX shared libraries.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ else
+ # We preserve .a as extension for shared libraries through AIX4.2
+ # and later when we are not doing run time linking.
+ library_names_spec='${libname}${release}.a $libname.a'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ fi
+ shlibpath_var=LIBPATH
+ fi
+ ;;
+
+amigaos*)
+ case $host_cpu in
+ powerpc)
+ # Since July 2007 AmigaOS4 officially supports .so libraries.
+ # When compiling the executable, add -use-dynld -Lsobjs: to the compileline.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ ;;
+ m68k)
+ library_names_spec='$libname.ixlibrary $libname.a'
+ # Create ${libname}_ixlibrary.a entries in /sys/libs.
+ finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`func_echo_all "$lib" | $SED '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; test $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done'
+ ;;
+ esac
+ ;;
+
+beos*)
+ library_names_spec='${libname}${shared_ext}'
+ dynamic_linker="$host_os ld.so"
+ shlibpath_var=LIBRARY_PATH
+ ;;
+
+bsdi[45]*)
+ version_type=linux
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib"
+ sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib"
+ # the default ld.so.conf also contains /usr/contrib/lib and
+ # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow
+ # libtool to hard-code these into programs
+ ;;
+
+cygwin* | mingw* | pw32* | cegcc*)
+ version_type=windows
+ shrext_cmds=".dll"
+ need_version=no
+ need_lib_prefix=no
+
+ case $GCC,$cc_basename in
+ yes,*)
+ # gcc
+ library_names_spec='$libname.dll.a'
+ # DLL is installed to $(libdir)/../bin by postinstall_cmds
+ postinstall_cmds='base_file=`basename \${file}`~
+ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~
+ dldir=$destdir/`dirname \$dlpath`~
+ test -d \$dldir || mkdir -p \$dldir~
+ $install_prog $dir/$dlname \$dldir/$dlname~
+ chmod a+x \$dldir/$dlname~
+ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then
+ eval '\''$striplib \$dldir/$dlname'\'' || exit \$?;
+ fi'
+ postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~
+ dlpath=$dir/\$dldll~
+ $RM \$dlpath'
+ shlibpath_overrides_runpath=yes
+
+ case $host_os in
+ cygwin*)
+ # Cygwin DLLs use 'cyg' prefix rather than 'lib'
+ soname_spec='`echo ${libname} | sed -e 's/^lib/cyg/'``echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+
+ sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/lib/w32api"
+ ;;
+ mingw* | cegcc*)
+ # MinGW DLLs use traditional 'lib' prefix
+ soname_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+ ;;
+ pw32*)
+ # pw32 DLLs use 'pw' prefix rather than 'lib'
+ library_names_spec='`echo ${libname} | sed -e 's/^lib/pw/'``echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+ ;;
+ esac
+ dynamic_linker='Win32 ld.exe'
+ ;;
+
+ *,cl*)
+ # Native MSVC
+ libname_spec='$name'
+ soname_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+ library_names_spec='${libname}.dll.lib'
+
+ case $build_os in
+ mingw*)
+ sys_lib_search_path_spec=
+ lt_save_ifs=$IFS
+ IFS=';'
+ for lt_path in $LIB
+ do
+ IFS=$lt_save_ifs
+ # Let DOS variable expansion print the short 8.3 style file name.
+ lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"`
+ sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path"
+ done
+ IFS=$lt_save_ifs
+ # Convert to MSYS style.
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([a-zA-Z]\\):| /\\1|g' -e 's|^ ||'`
+ ;;
+ cygwin*)
+ # Convert to unix form, then to dos form, then back to unix form
+ # but this time dos style (no spaces!) so that the unix form looks
+ # like /cygdrive/c/PROGRA~1:/cygdr...
+ sys_lib_search_path_spec=`cygpath --path --unix "$LIB"`
+ sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null`
+ sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"`
+ ;;
+ *)
+ sys_lib_search_path_spec="$LIB"
+ if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then
+ # It is most probably a Windows format PATH.
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'`
+ else
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"`
+ fi
+ # FIXME: find the short name or the path components, as spaces are
+ # common. (e.g. "Program Files" -> "PROGRA~1")
+ ;;
+ esac
+
+ # DLL is installed to $(libdir)/../bin by postinstall_cmds
+ postinstall_cmds='base_file=`basename \${file}`~
+ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~
+ dldir=$destdir/`dirname \$dlpath`~
+ test -d \$dldir || mkdir -p \$dldir~
+ $install_prog $dir/$dlname \$dldir/$dlname'
+ postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~
+ dlpath=$dir/\$dldll~
+ $RM \$dlpath'
+ shlibpath_overrides_runpath=yes
+ dynamic_linker='Win32 link.exe'
+ ;;
+
+ *)
+ # Assume MSVC wrapper
+ library_names_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext} $libname.lib'
+ dynamic_linker='Win32 ld.exe'
+ ;;
+ esac
+ # FIXME: first we should search . and the directory the executable is in
+ shlibpath_var=PATH
+ ;;
+
+darwin* | rhapsody*)
+ dynamic_linker="$host_os dyld"
+ version_type=darwin
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${major}$shared_ext ${libname}$shared_ext'
+ soname_spec='${libname}${release}${major}$shared_ext'
+ shlibpath_overrides_runpath=yes
+ shlibpath_var=DYLD_LIBRARY_PATH
+ shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`'
+
+ sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/local/lib"
+ sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib'
+ ;;
+
+dgux*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname$shared_ext'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+freebsd1*)
+ dynamic_linker=no
+ ;;
+
+freebsd* | dragonfly*)
+ # DragonFly does not have aout. When/if they implement a new
+ # versioning mechanism, adjust this.
+ if test -x /usr/bin/objformat; then
+ objformat=`/usr/bin/objformat`
+ else
+ case $host_os in
+ freebsd[123]*) objformat=aout ;;
+ *) objformat=elf ;;
+ esac
+ fi
+ version_type=freebsd-$objformat
+ case $version_type in
+ freebsd-elf*)
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}'
+ need_version=no
+ need_lib_prefix=no
+ ;;
+ freebsd-*)
+ library_names_spec='${libname}${release}${shared_ext}$versuffix $libname${shared_ext}$versuffix'
+ need_version=yes
+ ;;
+ esac
+ shlibpath_var=LD_LIBRARY_PATH
+ case $host_os in
+ freebsd2*)
+ shlibpath_overrides_runpath=yes
+ ;;
+ freebsd3.[01]* | freebsdelf3.[01]*)
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+ freebsd3.[2-9]* | freebsdelf3.[2-9]* | \
+ freebsd4.[0-5] | freebsdelf4.[0-5] | freebsd4.1.1 | freebsdelf4.1.1)
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+ *) # from 4.6 on, and DragonFly
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+ esac
+ ;;
+
+gnu*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ hardcode_into_libs=yes
+ ;;
+
+haiku*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ dynamic_linker="$host_os runtime_loader"
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib'
+ hardcode_into_libs=yes
+ ;;
+
+hpux9* | hpux10* | hpux11*)
+ # Give a soname corresponding to the major version so that dld.sl refuses to
+ # link against other versions.
+ version_type=sunos
+ need_lib_prefix=no
+ need_version=no
+ case $host_cpu in
+ ia64*)
+ shrext_cmds='.so'
+ hardcode_into_libs=yes
+ dynamic_linker="$host_os dld.so"
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes # Unless +noenvvar is specified.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ if test "X$HPUX_IA64_MODE" = X32; then
+ sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib"
+ else
+ sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64"
+ fi
+ sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec
+ ;;
+ hppa*64*)
+ shrext_cmds='.sl'
+ hardcode_into_libs=yes
+ dynamic_linker="$host_os dld.sl"
+ shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH
+ shlibpath_overrides_runpath=yes # Unless +noenvvar is specified.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64"
+ sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec
+ ;;
+ *)
+ shrext_cmds='.sl'
+ dynamic_linker="$host_os dld.sl"
+ shlibpath_var=SHLIB_PATH
+ shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ ;;
+ esac
+ # HP-UX runs *really* slowly unless shared libraries are mode 555, ...
+ postinstall_cmds='chmod 555 $lib'
+ # or fails outright, so override atomically:
+ install_override_mode=555
+ ;;
+
+interix[3-9]*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+
+irix5* | irix6* | nonstopux*)
+ case $host_os in
+ nonstopux*) version_type=nonstopux ;;
+ *)
+ if test "$lt_cv_prog_gnu_ld" = yes; then
+ version_type=linux
+ else
+ version_type=irix
+ fi ;;
+ esac
+ need_lib_prefix=no
+ need_version=no
+ soname_spec='${libname}${release}${shared_ext}$major'
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext} $libname${shared_ext}'
+ case $host_os in
+ irix5* | nonstopux*)
+ libsuff= shlibsuff=
+ ;;
+ *)
+ case $LD in # libtool.m4 will add one of these switches to LD
+ *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ")
+ libsuff= shlibsuff= libmagic=32-bit;;
+ *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ")
+ libsuff=32 shlibsuff=N32 libmagic=N32;;
+ *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ")
+ libsuff=64 shlibsuff=64 libmagic=64-bit;;
+ *) libsuff= shlibsuff= libmagic=never-match;;
+ esac
+ ;;
+ esac
+ shlibpath_var=LD_LIBRARY${shlibsuff}_PATH
+ shlibpath_overrides_runpath=no
+ sys_lib_search_path_spec="/usr/lib${libsuff} /lib${libsuff} /usr/local/lib${libsuff}"
+ sys_lib_dlsearch_path_spec="/usr/lib${libsuff} /lib${libsuff}"
+ hardcode_into_libs=yes
+ ;;
+
+# No shared lib support for Linux oldld, aout, or coff.
+linux*oldld* | linux*aout* | linux*coff*)
+ dynamic_linker=no
+ ;;
+
+# This must be Linux ELF.
+linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+
+ # Some binutils ld are patched to set DT_RUNPATH
+ if ${lt_cv_shlibpath_overrides_runpath+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_shlibpath_overrides_runpath=no
+ save_LDFLAGS=$LDFLAGS
+ save_libdir=$libdir
+ eval "libdir=/foo; wl=\"$lt_prog_compiler_wl\"; \
+ LDFLAGS=\"\$LDFLAGS $hardcode_libdir_flag_spec\""
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ if ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null; then :
+ lt_cv_shlibpath_overrides_runpath=yes
+fi
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ LDFLAGS=$save_LDFLAGS
+ libdir=$save_libdir
+
+fi
+
+ shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath
+
+ # This implies no fast_install, which is unacceptable.
+ # Some rework will be needed to allow for fast_install
+ # before this can be enabled.
+ hardcode_into_libs=yes
+
+ # Append ld.so.conf contents to the search path
+ if test -f /etc/ld.so.conf; then
+ lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \$2)); skip = 1; } { if (!skip) print \$0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;s/"//g;/^$/d' | tr '\n' ' '`
+ sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra"
+ fi
+
+ # We used to test for /lib/ld.so.1 and disable shared libraries on
+ # powerpc, because MkLinux only supported shared libraries with the
+ # GNU dynamic linker. Since this was broken with cross compilers,
+ # most powerpc-linux boxes support dynamic linking these days and
+ # people can always --disable-shared, the test was removed, and we
+ # assume the GNU/Linux dynamic linker is in use.
+ dynamic_linker='GNU/Linux ld.so'
+ ;;
+
+netbsd*)
+ version_type=sunos
+ need_lib_prefix=no
+ need_version=no
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir'
+ dynamic_linker='NetBSD (a.out) ld.so'
+ else
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ dynamic_linker='NetBSD ld.elf_so'
+ fi
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+
+newsos6)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ ;;
+
+*nto* | *qnx*)
+ version_type=qnx
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ dynamic_linker='ldqnx.so'
+ ;;
+
+openbsd*)
+ version_type=sunos
+ sys_lib_dlsearch_path_spec="/usr/lib"
+ need_lib_prefix=no
+ # Some older versions of OpenBSD (3.3 at least) *do* need versioned libs.
+ case $host_os in
+ openbsd3.3 | openbsd3.3.*) need_version=yes ;;
+ *) need_version=no ;;
+ esac
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ case $host_os in
+ openbsd2.[89] | openbsd2.[89].*)
+ shlibpath_overrides_runpath=no
+ ;;
+ *)
+ shlibpath_overrides_runpath=yes
+ ;;
+ esac
+ else
+ shlibpath_overrides_runpath=yes
+ fi
+ ;;
+
+os2*)
+ libname_spec='$name'
+ shrext_cmds=".dll"
+ need_lib_prefix=no
+ library_names_spec='$libname${shared_ext} $libname.a'
+ dynamic_linker='OS/2 ld.exe'
+ shlibpath_var=LIBPATH
+ ;;
+
+osf3* | osf4* | osf5*)
+ version_type=osf
+ need_lib_prefix=no
+ need_version=no
+ soname_spec='${libname}${release}${shared_ext}$major'
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib"
+ sys_lib_dlsearch_path_spec="$sys_lib_search_path_spec"
+ ;;
+
+rdos*)
+ dynamic_linker=no
+ ;;
+
+solaris*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ # ldd complains unless libraries are executable
+ postinstall_cmds='chmod +x $lib'
+ ;;
+
+sunos4*)
+ version_type=sunos
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ if test "$with_gnu_ld" = yes; then
+ need_lib_prefix=no
+ fi
+ need_version=yes
+ ;;
+
+sysv4 | sysv4.3*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ case $host_vendor in
+ sni)
+ shlibpath_overrides_runpath=no
+ need_lib_prefix=no
+ runpath_var=LD_RUN_PATH
+ ;;
+ siemens)
+ need_lib_prefix=no
+ ;;
+ motorola)
+ need_lib_prefix=no
+ need_version=no
+ shlibpath_overrides_runpath=no
+ sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib'
+ ;;
+ esac
+ ;;
+
+sysv4*MP*)
+ if test -d /usr/nec ;then
+ version_type=linux
+ library_names_spec='$libname${shared_ext}.$versuffix $libname${shared_ext}.$major $libname${shared_ext}'
+ soname_spec='$libname${shared_ext}.$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ fi
+ ;;
+
+sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
+ version_type=freebsd-elf
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ if test "$with_gnu_ld" = yes; then
+ sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib'
+ else
+ sys_lib_search_path_spec='/usr/ccs/lib /usr/lib'
+ case $host_os in
+ sco3.2v5*)
+ sys_lib_search_path_spec="$sys_lib_search_path_spec /lib"
+ ;;
+ esac
+ fi
+ sys_lib_dlsearch_path_spec='/usr/lib'
+ ;;
+
+tpf*)
+ # TPF is a cross-target only. Preferred cross-host = GNU/Linux.
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+
+uts4*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*)
+ dynamic_linker=no
+ ;;
+esac
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $dynamic_linker" >&5
+$as_echo "$dynamic_linker" >&6; }
+test "$dynamic_linker" = no && can_build_shared=no
+
+variables_saved_for_relink="PATH $shlibpath_var $runpath_var"
+if test "$GCC" = yes; then
+ variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH"
+fi
+
+if test "${lt_cv_sys_lib_search_path_spec+set}" = set; then
+ sys_lib_search_path_spec="$lt_cv_sys_lib_search_path_spec"
+fi
+if test "${lt_cv_sys_lib_dlsearch_path_spec+set}" = set; then
+ sys_lib_dlsearch_path_spec="$lt_cv_sys_lib_dlsearch_path_spec"
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to hardcode library paths into programs" >&5
+$as_echo_n "checking how to hardcode library paths into programs... " >&6; }
+hardcode_action=
+if test -n "$hardcode_libdir_flag_spec" ||
+ test -n "$runpath_var" ||
+ test "X$hardcode_automatic" = "Xyes" ; then
+
+ # We can hardcode non-existent directories.
+ if test "$hardcode_direct" != no &&
+ # If the only mechanism to avoid hardcoding is shlibpath_var, we
+ # have to relink, otherwise we might link with an installed library
+ # when we should be linking with a yet-to-be-installed one
+ ## test "$_LT_TAGVAR(hardcode_shlibpath_var, )" != no &&
+ test "$hardcode_minus_L" != no; then
+ # Linking always hardcodes the temporary library directory.
+ hardcode_action=relink
+ else
+ # We can link without hardcoding, and we can hardcode nonexisting dirs.
+ hardcode_action=immediate
+ fi
+else
+ # We cannot hardcode anything, or else we can only hardcode existing
+ # directories.
+ hardcode_action=unsupported
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $hardcode_action" >&5
+$as_echo "$hardcode_action" >&6; }
+
+if test "$hardcode_action" = relink ||
+ test "$inherit_rpath" = yes; then
+ # Fast installation is not supported
+ enable_fast_install=no
+elif test "$shlibpath_overrides_runpath" = yes ||
+ test "$enable_shared" = no; then
+ # Fast installation is not necessary
+ enable_fast_install=needless
+fi
+
+
+
+
+
+
+ if test "x$enable_dlopen" != xyes; then
+ enable_dlopen=unknown
+ enable_dlopen_self=unknown
+ enable_dlopen_self_static=unknown
+else
+ lt_cv_dlopen=no
+ lt_cv_dlopen_libs=
+
+ case $host_os in
+ beos*)
+ lt_cv_dlopen="load_add_on"
+ lt_cv_dlopen_libs=
+ lt_cv_dlopen_self=yes
+ ;;
+
+ mingw* | pw32* | cegcc*)
+ lt_cv_dlopen="LoadLibrary"
+ lt_cv_dlopen_libs=
+ ;;
+
+ cygwin*)
+ lt_cv_dlopen="dlopen"
+ lt_cv_dlopen_libs=
+ ;;
+
+ darwin*)
+ # if libdl is installed we need to link against it
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5
+$as_echo_n "checking for dlopen in -ldl... " >&6; }
+if ${ac_cv_lib_dl_dlopen+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-ldl $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char dlopen ();
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return dlopen ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_lib_dl_dlopen=yes
+else
+ ac_cv_lib_dl_dlopen=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5
+$as_echo "$ac_cv_lib_dl_dlopen" >&6; }
+if test "x$ac_cv_lib_dl_dlopen" = xyes; then :
+ lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-ldl"
+else
+
+ lt_cv_dlopen="dyld"
+ lt_cv_dlopen_libs=
+ lt_cv_dlopen_self=yes
+
+fi
+
+ ;;
+
+ *)
+ ac_fn_c_check_func "$LINENO" "shl_load" "ac_cv_func_shl_load"
+if test "x$ac_cv_func_shl_load" = xyes; then :
+ lt_cv_dlopen="shl_load"
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5
+$as_echo_n "checking for shl_load in -ldld... " >&6; }
+if ${ac_cv_lib_dld_shl_load+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-ldld $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char shl_load ();
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return shl_load ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_lib_dld_shl_load=yes
+else
+ ac_cv_lib_dld_shl_load=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5
+$as_echo "$ac_cv_lib_dld_shl_load" >&6; }
+if test "x$ac_cv_lib_dld_shl_load" = xyes; then :
+ lt_cv_dlopen="shl_load" lt_cv_dlopen_libs="-ldld"
+else
+ ac_fn_c_check_func "$LINENO" "dlopen" "ac_cv_func_dlopen"
+if test "x$ac_cv_func_dlopen" = xyes; then :
+ lt_cv_dlopen="dlopen"
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5
+$as_echo_n "checking for dlopen in -ldl... " >&6; }
+if ${ac_cv_lib_dl_dlopen+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-ldl $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char dlopen ();
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return dlopen ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_lib_dl_dlopen=yes
+else
+ ac_cv_lib_dl_dlopen=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5
+$as_echo "$ac_cv_lib_dl_dlopen" >&6; }
+if test "x$ac_cv_lib_dl_dlopen" = xyes; then :
+ lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-ldl"
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -lsvld" >&5
+$as_echo_n "checking for dlopen in -lsvld... " >&6; }
+if ${ac_cv_lib_svld_dlopen+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lsvld $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char dlopen ();
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return dlopen ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_lib_svld_dlopen=yes
+else
+ ac_cv_lib_svld_dlopen=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_svld_dlopen" >&5
+$as_echo "$ac_cv_lib_svld_dlopen" >&6; }
+if test "x$ac_cv_lib_svld_dlopen" = xyes; then :
+ lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-lsvld"
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dld_link in -ldld" >&5
+$as_echo_n "checking for dld_link in -ldld... " >&6; }
+if ${ac_cv_lib_dld_dld_link+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-ldld $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char dld_link ();
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return dld_link ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_lib_dld_dld_link=yes
+else
+ ac_cv_lib_dld_dld_link=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_dld_link" >&5
+$as_echo "$ac_cv_lib_dld_dld_link" >&6; }
+if test "x$ac_cv_lib_dld_dld_link" = xyes; then :
+ lt_cv_dlopen="dld_link" lt_cv_dlopen_libs="-ldld"
+fi
+
+
+fi
+
+
+fi
+
+
+fi
+
+
+fi
+
+
+fi
+
+ ;;
+ esac
+
+ if test "x$lt_cv_dlopen" != xno; then
+ enable_dlopen=yes
+ else
+ enable_dlopen=no
+ fi
+
+ case $lt_cv_dlopen in
+ dlopen)
+ save_CPPFLAGS="$CPPFLAGS"
+ test "x$ac_cv_header_dlfcn_h" = xyes && CPPFLAGS="$CPPFLAGS -DHAVE_DLFCN_H"
+
+ save_LDFLAGS="$LDFLAGS"
+ wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $export_dynamic_flag_spec\"
+
+ save_LIBS="$LIBS"
+ LIBS="$lt_cv_dlopen_libs $LIBS"
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether a program can dlopen itself" >&5
+$as_echo_n "checking whether a program can dlopen itself... " >&6; }
+if ${lt_cv_dlopen_self+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test "$cross_compiling" = yes; then :
+ lt_cv_dlopen_self=cross
+else
+ lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
+ lt_status=$lt_dlunknown
+ cat > conftest.$ac_ext <<_LT_EOF
+#line $LINENO "configure"
+#include "confdefs.h"
+
+#if HAVE_DLFCN_H
+#include <dlfcn.h>
+#endif
+
+#include <stdio.h>
+
+#ifdef RTLD_GLOBAL
+# define LT_DLGLOBAL RTLD_GLOBAL
+#else
+# ifdef DL_GLOBAL
+# define LT_DLGLOBAL DL_GLOBAL
+# else
+# define LT_DLGLOBAL 0
+# endif
+#endif
+
+/* We may have to define LT_DLLAZY_OR_NOW in the command line if we
+ find out it does not work in some platform. */
+#ifndef LT_DLLAZY_OR_NOW
+# ifdef RTLD_LAZY
+# define LT_DLLAZY_OR_NOW RTLD_LAZY
+# else
+# ifdef DL_LAZY
+# define LT_DLLAZY_OR_NOW DL_LAZY
+# else
+# ifdef RTLD_NOW
+# define LT_DLLAZY_OR_NOW RTLD_NOW
+# else
+# ifdef DL_NOW
+# define LT_DLLAZY_OR_NOW DL_NOW
+# else
+# define LT_DLLAZY_OR_NOW 0
+# endif
+# endif
+# endif
+# endif
+#endif
+
+/* When -fvisbility=hidden is used, assume the code has been annotated
+ correspondingly for the symbols needed. */
+#if defined(__GNUC__) && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3))
+int fnord () __attribute__((visibility("default")));
+#endif
+
+int fnord () { return 42; }
+int main ()
+{
+ void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW);
+ int status = $lt_dlunknown;
+
+ if (self)
+ {
+ if (dlsym (self,"fnord")) status = $lt_dlno_uscore;
+ else
+ {
+ if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore;
+ else puts (dlerror ());
+ }
+ /* dlclose (self); */
+ }
+ else
+ puts (dlerror ());
+
+ return status;
+}
+_LT_EOF
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5
+ (eval $ac_link) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && test -s conftest${ac_exeext} 2>/dev/null; then
+ (./conftest; exit; ) >&5 2>/dev/null
+ lt_status=$?
+ case x$lt_status in
+ x$lt_dlno_uscore) lt_cv_dlopen_self=yes ;;
+ x$lt_dlneed_uscore) lt_cv_dlopen_self=yes ;;
+ x$lt_dlunknown|x*) lt_cv_dlopen_self=no ;;
+ esac
+ else :
+ # compilation failed
+ lt_cv_dlopen_self=no
+ fi
+fi
+rm -fr conftest*
+
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self" >&5
+$as_echo "$lt_cv_dlopen_self" >&6; }
+
+ if test "x$lt_cv_dlopen_self" = xyes; then
+ wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $lt_prog_compiler_static\"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether a statically linked program can dlopen itself" >&5
+$as_echo_n "checking whether a statically linked program can dlopen itself... " >&6; }
+if ${lt_cv_dlopen_self_static+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test "$cross_compiling" = yes; then :
+ lt_cv_dlopen_self_static=cross
+else
+ lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
+ lt_status=$lt_dlunknown
+ cat > conftest.$ac_ext <<_LT_EOF
+#line $LINENO "configure"
+#include "confdefs.h"
+
+#if HAVE_DLFCN_H
+#include <dlfcn.h>
+#endif
+
+#include <stdio.h>
+
+#ifdef RTLD_GLOBAL
+# define LT_DLGLOBAL RTLD_GLOBAL
+#else
+# ifdef DL_GLOBAL
+# define LT_DLGLOBAL DL_GLOBAL
+# else
+# define LT_DLGLOBAL 0
+# endif
+#endif
+
+/* We may have to define LT_DLLAZY_OR_NOW in the command line if we
+ find out it does not work in some platform. */
+#ifndef LT_DLLAZY_OR_NOW
+# ifdef RTLD_LAZY
+# define LT_DLLAZY_OR_NOW RTLD_LAZY
+# else
+# ifdef DL_LAZY
+# define LT_DLLAZY_OR_NOW DL_LAZY
+# else
+# ifdef RTLD_NOW
+# define LT_DLLAZY_OR_NOW RTLD_NOW
+# else
+# ifdef DL_NOW
+# define LT_DLLAZY_OR_NOW DL_NOW
+# else
+# define LT_DLLAZY_OR_NOW 0
+# endif
+# endif
+# endif
+# endif
+#endif
+
+/* When -fvisbility=hidden is used, assume the code has been annotated
+ correspondingly for the symbols needed. */
+#if defined(__GNUC__) && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3))
+int fnord () __attribute__((visibility("default")));
+#endif
+
+int fnord () { return 42; }
+int main ()
+{
+ void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW);
+ int status = $lt_dlunknown;
+
+ if (self)
+ {
+ if (dlsym (self,"fnord")) status = $lt_dlno_uscore;
+ else
+ {
+ if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore;
+ else puts (dlerror ());
+ }
+ /* dlclose (self); */
+ }
+ else
+ puts (dlerror ());
+
+ return status;
+}
+_LT_EOF
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5
+ (eval $ac_link) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && test -s conftest${ac_exeext} 2>/dev/null; then
+ (./conftest; exit; ) >&5 2>/dev/null
+ lt_status=$?
+ case x$lt_status in
+ x$lt_dlno_uscore) lt_cv_dlopen_self_static=yes ;;
+ x$lt_dlneed_uscore) lt_cv_dlopen_self_static=yes ;;
+ x$lt_dlunknown|x*) lt_cv_dlopen_self_static=no ;;
+ esac
+ else :
+ # compilation failed
+ lt_cv_dlopen_self_static=no
+ fi
+fi
+rm -fr conftest*
+
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self_static" >&5
+$as_echo "$lt_cv_dlopen_self_static" >&6; }
+ fi
+
+ CPPFLAGS="$save_CPPFLAGS"
+ LDFLAGS="$save_LDFLAGS"
+ LIBS="$save_LIBS"
+ ;;
+ esac
+
+ case $lt_cv_dlopen_self in
+ yes|no) enable_dlopen_self=$lt_cv_dlopen_self ;;
+ *) enable_dlopen_self=unknown ;;
+ esac
+
+ case $lt_cv_dlopen_self_static in
+ yes|no) enable_dlopen_self_static=$lt_cv_dlopen_self_static ;;
+ *) enable_dlopen_self_static=unknown ;;
+ esac
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+striplib=
+old_striplib=
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether stripping libraries is possible" >&5
+$as_echo_n "checking whether stripping libraries is possible... " >&6; }
+if test -n "$STRIP" && $STRIP -V 2>&1 | $GREP "GNU strip" >/dev/null; then
+ test -z "$old_striplib" && old_striplib="$STRIP --strip-debug"
+ test -z "$striplib" && striplib="$STRIP --strip-unneeded"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+else
+# FIXME - insert some real tests, host_os isn't really good enough
+ case $host_os in
+ darwin*)
+ if test -n "$STRIP" ; then
+ striplib="$STRIP -x"
+ old_striplib="$STRIP -S"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+ else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+ fi
+ ;;
+ *)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+ ;;
+ esac
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+ # Report which library types will actually be built
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if libtool supports shared libraries" >&5
+$as_echo_n "checking if libtool supports shared libraries... " >&6; }
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $can_build_shared" >&5
+$as_echo "$can_build_shared" >&6; }
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries" >&5
+$as_echo_n "checking whether to build shared libraries... " >&6; }
+ test "$can_build_shared" = "no" && enable_shared=no
+
+ # On AIX, shared libraries and static libraries use the same namespace, and
+ # are all built from PIC.
+ case $host_os in
+ aix3*)
+ test "$enable_shared" = yes && enable_static=no
+ if test -n "$RANLIB"; then
+ archive_cmds="$archive_cmds~\$RANLIB \$lib"
+ postinstall_cmds='$RANLIB $lib'
+ fi
+ ;;
+
+ aix[4-9]*)
+ if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then
+ test "$enable_shared" = yes && enable_static=no
+ fi
+ ;;
+ esac
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_shared" >&5
+$as_echo "$enable_shared" >&6; }
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build static libraries" >&5
+$as_echo_n "checking whether to build static libraries... " >&6; }
+ # Make sure either enable_shared or enable_static is yes.
+ test "$enable_shared" = yes || enable_static=yes
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_static" >&5
+$as_echo "$enable_static" >&6; }
+
+
+
+
+fi
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+CC="$lt_save_CC"
+
+
+
+ ac_ext=f
+ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5'
+ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_f77_compiler_gnu
+
+if test -z "$F77" || test "X$F77" = "Xno"; then
+ _lt_disable_F77=yes
+fi
+
+archive_cmds_need_lc_F77=no
+allow_undefined_flag_F77=
+always_export_symbols_F77=no
+archive_expsym_cmds_F77=
+export_dynamic_flag_spec_F77=
+hardcode_direct_F77=no
+hardcode_direct_absolute_F77=no
+hardcode_libdir_flag_spec_F77=
+hardcode_libdir_flag_spec_ld_F77=
+hardcode_libdir_separator_F77=
+hardcode_minus_L_F77=no
+hardcode_automatic_F77=no
+inherit_rpath_F77=no
+module_cmds_F77=
+module_expsym_cmds_F77=
+link_all_deplibs_F77=unknown
+old_archive_cmds_F77=$old_archive_cmds
+reload_flag_F77=$reload_flag
+reload_cmds_F77=$reload_cmds
+no_undefined_flag_F77=
+whole_archive_flag_spec_F77=
+enable_shared_with_static_runtimes_F77=no
+
+# Source file extension for f77 test sources.
+ac_ext=f
+
+# Object file extension for compiled f77 test sources.
+objext=o
+objext_F77=$objext
+
+# No sense in running all these tests if we already determined that
+# the F77 compiler isn't working. Some variables (like enable_shared)
+# are currently assumed to apply to all compilers on this platform,
+# and will be corrupted by setting them based on a non-working compiler.
+if test "$_lt_disable_F77" != yes; then
+ # Code to be used in simple compile tests
+ lt_simple_compile_test_code="\
+ subroutine t
+ return
+ end
+"
+
+ # Code to be used in simple link tests
+ lt_simple_link_test_code="\
+ program t
+ end
+"
+
+ # ltmain only uses $CC for tagged configurations so make sure $CC is set.
+
+
+
+
+
+
+# If no C compiler was specified, use CC.
+LTCC=${LTCC-"$CC"}
+
+# If no C compiler flags were specified, use CFLAGS.
+LTCFLAGS=${LTCFLAGS-"$CFLAGS"}
+
+# Allow CC to be a program name with arguments.
+compiler=$CC
+
+
+ # save warnings/boilerplate of simple test code
+ ac_outfile=conftest.$ac_objext
+echo "$lt_simple_compile_test_code" >conftest.$ac_ext
+eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err
+_lt_compiler_boilerplate=`cat conftest.err`
+$RM conftest*
+
+ ac_outfile=conftest.$ac_objext
+echo "$lt_simple_link_test_code" >conftest.$ac_ext
+eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err
+_lt_linker_boilerplate=`cat conftest.err`
+$RM -r conftest*
+
+
+ # Allow CC to be a program name with arguments.
+ lt_save_CC="$CC"
+ lt_save_GCC=$GCC
+ lt_save_CFLAGS=$CFLAGS
+ CC=${F77-"f77"}
+ CFLAGS=$FFLAGS
+ compiler=$CC
+ compiler_F77=$CC
+ for cc_temp in $compiler""; do
+ case $cc_temp in
+ compile | *[\\/]compile | ccache | *[\\/]ccache ) ;;
+ distcc | *[\\/]distcc | purify | *[\\/]purify ) ;;
+ \-*) ;;
+ *) break;;
+ esac
+done
+cc_basename=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"`
+
+ GCC=$G77
+ if test -n "$compiler"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if libtool supports shared libraries" >&5
+$as_echo_n "checking if libtool supports shared libraries... " >&6; }
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $can_build_shared" >&5
+$as_echo "$can_build_shared" >&6; }
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries" >&5
+$as_echo_n "checking whether to build shared libraries... " >&6; }
+ test "$can_build_shared" = "no" && enable_shared=no
+
+ # On AIX, shared libraries and static libraries use the same namespace, and
+ # are all built from PIC.
+ case $host_os in
+ aix3*)
+ test "$enable_shared" = yes && enable_static=no
+ if test -n "$RANLIB"; then
+ archive_cmds="$archive_cmds~\$RANLIB \$lib"
+ postinstall_cmds='$RANLIB $lib'
+ fi
+ ;;
+ aix[4-9]*)
+ if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then
+ test "$enable_shared" = yes && enable_static=no
+ fi
+ ;;
+ esac
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_shared" >&5
+$as_echo "$enable_shared" >&6; }
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build static libraries" >&5
+$as_echo_n "checking whether to build static libraries... " >&6; }
+ # Make sure either enable_shared or enable_static is yes.
+ test "$enable_shared" = yes || enable_static=yes
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_static" >&5
+$as_echo "$enable_static" >&6; }
+
+ GCC_F77="$G77"
+ LD_F77="$LD"
+
+ ## CAVEAT EMPTOR:
+ ## There is no encapsulation within the following macros, do not change
+ ## the running order or otherwise move them around unless you know exactly
+ ## what you are doing...
+ lt_prog_compiler_wl_F77=
+lt_prog_compiler_pic_F77=
+lt_prog_compiler_static_F77=
+
+
+ if test "$GCC" = yes; then
+ lt_prog_compiler_wl_F77='-Wl,'
+ lt_prog_compiler_static_F77='-static'
+
+ case $host_os in
+ aix*)
+ # All AIX code is PIC.
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ lt_prog_compiler_static_F77='-Bstatic'
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ lt_prog_compiler_pic_F77='-fPIC'
+ ;;
+ m68k)
+ # FIXME: we need at least 68020 code to build shared libraries, but
+ # adding the `-m68020' flag to GCC prevents building anything better,
+ # like `-m68040'.
+ lt_prog_compiler_pic_F77='-m68020 -resident32 -malways-restore-a4'
+ ;;
+ esac
+ ;;
+
+ beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*)
+ # PIC is the default for these OSes.
+ ;;
+
+ mingw* | cygwin* | pw32* | os2* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ # Although the cygwin gcc ignores -fPIC, still need this for old-style
+ # (--disable-auto-import) libraries
+ lt_prog_compiler_pic_F77='-DDLL_EXPORT'
+ ;;
+
+ darwin* | rhapsody*)
+ # PIC is the default on this platform
+ # Common symbols not allowed in MH_DYLIB files
+ lt_prog_compiler_pic_F77='-fno-common'
+ ;;
+
+ haiku*)
+ # PIC is the default for Haiku.
+ # The "-static" flag exists, but is broken.
+ lt_prog_compiler_static_F77=
+ ;;
+
+ hpux*)
+ # PIC is the default for 64-bit PA HP-UX, but not for 32-bit
+ # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag
+ # sets the default TLS model and affects inlining.
+ case $host_cpu in
+ hppa*64*)
+ # +Z the default
+ ;;
+ *)
+ lt_prog_compiler_pic_F77='-fPIC'
+ ;;
+ esac
+ ;;
+
+ interix[3-9]*)
+ # Interix 3.x gcc -fpic/-fPIC options generate broken code.
+ # Instead, we relocate shared libraries at runtime.
+ ;;
+
+ msdosdjgpp*)
+ # Just because we use GCC doesn't mean we suddenly get shared libraries
+ # on systems that don't support them.
+ lt_prog_compiler_can_build_shared_F77=no
+ enable_shared=no
+ ;;
+
+ *nto* | *qnx*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ lt_prog_compiler_pic_F77='-fPIC -shared'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ lt_prog_compiler_pic_F77=-Kconform_pic
+ fi
+ ;;
+
+ *)
+ lt_prog_compiler_pic_F77='-fPIC'
+ ;;
+ esac
+
+ case $cc_basename in
+ nvcc*) # Cuda Compiler Driver 2.2
+ lt_prog_compiler_wl_F77='-Xlinker '
+ lt_prog_compiler_pic_F77='-Xcompiler -fPIC'
+ ;;
+ esac
+ else
+ # PORTME Check for flag to pass linker flags through the system compiler.
+ case $host_os in
+ aix*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ lt_prog_compiler_static_F77='-Bstatic'
+ else
+ lt_prog_compiler_static_F77='-bnso -bI:/lib/syscalls.exp'
+ fi
+ ;;
+
+ mingw* | cygwin* | pw32* | os2* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ lt_prog_compiler_pic_F77='-DDLL_EXPORT'
+ ;;
+
+ hpux9* | hpux10* | hpux11*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ # PIC is the default for IA64 HP-UX and 64-bit HP-UX, but
+ # not for PA HP-UX.
+ case $host_cpu in
+ hppa*64*|ia64*)
+ # +Z the default
+ ;;
+ *)
+ lt_prog_compiler_pic_F77='+Z'
+ ;;
+ esac
+ # Is there a better lt_prog_compiler_static that works with the bundled CC?
+ lt_prog_compiler_static_F77='${wl}-a ${wl}archive'
+ ;;
+
+ irix5* | irix6* | nonstopux*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ # PIC (with -KPIC) is the default.
+ lt_prog_compiler_static_F77='-non_shared'
+ ;;
+
+ linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ case $cc_basename in
+ # old Intel for x86_64 which still supported -KPIC.
+ ecc*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ lt_prog_compiler_pic_F77='-KPIC'
+ lt_prog_compiler_static_F77='-static'
+ ;;
+ # icc used to be incompatible with GCC.
+ # ICC 10 doesn't accept -KPIC any more.
+ icc* | ifort*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ lt_prog_compiler_pic_F77='-fPIC'
+ lt_prog_compiler_static_F77='-static'
+ ;;
+ # Lahey Fortran 8.1.
+ lf95*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ lt_prog_compiler_pic_F77='--shared'
+ lt_prog_compiler_static_F77='--static'
+ ;;
+ nagfor*)
+ # NAG Fortran compiler
+ lt_prog_compiler_wl_F77='-Wl,-Wl,,'
+ lt_prog_compiler_pic_F77='-PIC'
+ lt_prog_compiler_static_F77='-Bstatic'
+ ;;
+ pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*)
+ # Portland Group compilers (*not* the Pentium gcc compiler,
+ # which looks to be a dead project)
+ lt_prog_compiler_wl_F77='-Wl,'
+ lt_prog_compiler_pic_F77='-fpic'
+ lt_prog_compiler_static_F77='-Bstatic'
+ ;;
+ ccc*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ # All Alpha code is PIC.
+ lt_prog_compiler_static_F77='-non_shared'
+ ;;
+ xl* | bgxl* | bgf* | mpixl*)
+ # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene
+ lt_prog_compiler_wl_F77='-Wl,'
+ lt_prog_compiler_pic_F77='-qpic'
+ lt_prog_compiler_static_F77='-qstaticlink'
+ ;;
+ *)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ F* | *Sun*Fortran*)
+ # Sun Fortran 8.3 passes all unrecognized flags to the linker
+ lt_prog_compiler_pic_F77='-KPIC'
+ lt_prog_compiler_static_F77='-Bstatic'
+ lt_prog_compiler_wl_F77=''
+ ;;
+ *Sun\ C*)
+ # Sun C 5.9
+ lt_prog_compiler_pic_F77='-KPIC'
+ lt_prog_compiler_static_F77='-Bstatic'
+ lt_prog_compiler_wl_F77='-Wl,'
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+
+ newsos6)
+ lt_prog_compiler_pic_F77='-KPIC'
+ lt_prog_compiler_static_F77='-Bstatic'
+ ;;
+
+ *nto* | *qnx*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ lt_prog_compiler_pic_F77='-fPIC -shared'
+ ;;
+
+ osf3* | osf4* | osf5*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ # All OSF/1 code is PIC.
+ lt_prog_compiler_static_F77='-non_shared'
+ ;;
+
+ rdos*)
+ lt_prog_compiler_static_F77='-non_shared'
+ ;;
+
+ solaris*)
+ lt_prog_compiler_pic_F77='-KPIC'
+ lt_prog_compiler_static_F77='-Bstatic'
+ case $cc_basename in
+ f77* | f90* | f95* | sunf77* | sunf90* | sunf95*)
+ lt_prog_compiler_wl_F77='-Qoption ld ';;
+ *)
+ lt_prog_compiler_wl_F77='-Wl,';;
+ esac
+ ;;
+
+ sunos4*)
+ lt_prog_compiler_wl_F77='-Qoption ld '
+ lt_prog_compiler_pic_F77='-PIC'
+ lt_prog_compiler_static_F77='-Bstatic'
+ ;;
+
+ sysv4 | sysv4.2uw2* | sysv4.3*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ lt_prog_compiler_pic_F77='-KPIC'
+ lt_prog_compiler_static_F77='-Bstatic'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec ;then
+ lt_prog_compiler_pic_F77='-Kconform_pic'
+ lt_prog_compiler_static_F77='-Bstatic'
+ fi
+ ;;
+
+ sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ lt_prog_compiler_pic_F77='-KPIC'
+ lt_prog_compiler_static_F77='-Bstatic'
+ ;;
+
+ unicos*)
+ lt_prog_compiler_wl_F77='-Wl,'
+ lt_prog_compiler_can_build_shared_F77=no
+ ;;
+
+ uts4*)
+ lt_prog_compiler_pic_F77='-pic'
+ lt_prog_compiler_static_F77='-Bstatic'
+ ;;
+
+ *)
+ lt_prog_compiler_can_build_shared_F77=no
+ ;;
+ esac
+ fi
+
+case $host_os in
+ # For platforms which do not support PIC, -DPIC is meaningless:
+ *djgpp*)
+ lt_prog_compiler_pic_F77=
+ ;;
+ *)
+ lt_prog_compiler_pic_F77="$lt_prog_compiler_pic_F77"
+ ;;
+esac
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $compiler option to produce PIC" >&5
+$as_echo_n "checking for $compiler option to produce PIC... " >&6; }
+if ${lt_cv_prog_compiler_pic_F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_pic_F77=$lt_prog_compiler_pic_F77
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_F77" >&5
+$as_echo "$lt_cv_prog_compiler_pic_F77" >&6; }
+lt_prog_compiler_pic_F77=$lt_cv_prog_compiler_pic_F77
+
+#
+# Check to make sure the PIC flag actually works.
+#
+if test -n "$lt_prog_compiler_pic_F77"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler PIC flag $lt_prog_compiler_pic_F77 works" >&5
+$as_echo_n "checking if $compiler PIC flag $lt_prog_compiler_pic_F77 works... " >&6; }
+if ${lt_cv_prog_compiler_pic_works_F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_pic_works_F77=no
+ ac_outfile=conftest.$ac_objext
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+ lt_compiler_flag="$lt_prog_compiler_pic_F77"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ # The option is referenced via a variable to avoid confusing sed.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_pic_works_F77=yes
+ fi
+ fi
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_works_F77" >&5
+$as_echo "$lt_cv_prog_compiler_pic_works_F77" >&6; }
+
+if test x"$lt_cv_prog_compiler_pic_works_F77" = xyes; then
+ case $lt_prog_compiler_pic_F77 in
+ "" | " "*) ;;
+ *) lt_prog_compiler_pic_F77=" $lt_prog_compiler_pic_F77" ;;
+ esac
+else
+ lt_prog_compiler_pic_F77=
+ lt_prog_compiler_can_build_shared_F77=no
+fi
+
+fi
+
+
+
+
+
+#
+# Check to make sure the static flag actually works.
+#
+wl=$lt_prog_compiler_wl_F77 eval lt_tmp_static_flag=\"$lt_prog_compiler_static_F77\"
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler static flag $lt_tmp_static_flag works" >&5
+$as_echo_n "checking if $compiler static flag $lt_tmp_static_flag works... " >&6; }
+if ${lt_cv_prog_compiler_static_works_F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_static_works_F77=no
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS $lt_tmp_static_flag"
+ echo "$lt_simple_link_test_code" > conftest.$ac_ext
+ if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then
+ # The linker can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ if test -s conftest.err; then
+ # Append any errors to the config.log.
+ cat conftest.err 1>&5
+ $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if diff conftest.exp conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_static_works_F77=yes
+ fi
+ else
+ lt_cv_prog_compiler_static_works_F77=yes
+ fi
+ fi
+ $RM -r conftest*
+ LDFLAGS="$save_LDFLAGS"
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_static_works_F77" >&5
+$as_echo "$lt_cv_prog_compiler_static_works_F77" >&6; }
+
+if test x"$lt_cv_prog_compiler_static_works_F77" = xyes; then
+ :
+else
+ lt_prog_compiler_static_F77=
+fi
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5
+$as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; }
+if ${lt_cv_prog_compiler_c_o_F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_c_o_F77=no
+ $RM -r conftest 2>/dev/null
+ mkdir conftest
+ cd conftest
+ mkdir out
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ lt_compiler_flag="-o out/conftest2.$ac_objext"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp
+ $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2
+ if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_c_o_F77=yes
+ fi
+ fi
+ chmod u+w . 2>&5
+ $RM conftest*
+ # SGI C++ compiler will create directory out/ii_files/ for
+ # template instantiation
+ test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files
+ $RM out/* && rmdir out
+ cd ..
+ $RM -r conftest
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o_F77" >&5
+$as_echo "$lt_cv_prog_compiler_c_o_F77" >&6; }
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5
+$as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; }
+if ${lt_cv_prog_compiler_c_o_F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_c_o_F77=no
+ $RM -r conftest 2>/dev/null
+ mkdir conftest
+ cd conftest
+ mkdir out
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ lt_compiler_flag="-o out/conftest2.$ac_objext"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp
+ $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2
+ if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_c_o_F77=yes
+ fi
+ fi
+ chmod u+w . 2>&5
+ $RM conftest*
+ # SGI C++ compiler will create directory out/ii_files/ for
+ # template instantiation
+ test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files
+ $RM out/* && rmdir out
+ cd ..
+ $RM -r conftest
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o_F77" >&5
+$as_echo "$lt_cv_prog_compiler_c_o_F77" >&6; }
+
+
+
+
+hard_links="nottested"
+if test "$lt_cv_prog_compiler_c_o_F77" = no && test "$need_locks" != no; then
+ # do not overwrite the value of need_locks provided by the user
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if we can lock with hard links" >&5
+$as_echo_n "checking if we can lock with hard links... " >&6; }
+ hard_links=yes
+ $RM conftest*
+ ln conftest.a conftest.b 2>/dev/null && hard_links=no
+ touch conftest.a
+ ln conftest.a conftest.b 2>&5 || hard_links=no
+ ln conftest.a conftest.b 2>/dev/null && hard_links=no
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hard_links" >&5
+$as_echo "$hard_links" >&6; }
+ if test "$hard_links" = no; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \`$CC' does not support \`-c -o', so \`make -j' may be unsafe" >&5
+$as_echo "$as_me: WARNING: \`$CC' does not support \`-c -o', so \`make -j' may be unsafe" >&2;}
+ need_locks=warn
+ fi
+else
+ need_locks=no
+fi
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $compiler linker ($LD) supports shared libraries" >&5
+$as_echo_n "checking whether the $compiler linker ($LD) supports shared libraries... " >&6; }
+
+ runpath_var=
+ allow_undefined_flag_F77=
+ always_export_symbols_F77=no
+ archive_cmds_F77=
+ archive_expsym_cmds_F77=
+ compiler_needs_object_F77=no
+ enable_shared_with_static_runtimes_F77=no
+ export_dynamic_flag_spec_F77=
+ export_symbols_cmds_F77='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols'
+ hardcode_automatic_F77=no
+ hardcode_direct_F77=no
+ hardcode_direct_absolute_F77=no
+ hardcode_libdir_flag_spec_F77=
+ hardcode_libdir_flag_spec_ld_F77=
+ hardcode_libdir_separator_F77=
+ hardcode_minus_L_F77=no
+ hardcode_shlibpath_var_F77=unsupported
+ inherit_rpath_F77=no
+ link_all_deplibs_F77=unknown
+ module_cmds_F77=
+ module_expsym_cmds_F77=
+ old_archive_from_new_cmds_F77=
+ old_archive_from_expsyms_cmds_F77=
+ thread_safe_flag_spec_F77=
+ whole_archive_flag_spec_F77=
+ # include_expsyms should be a list of space-separated symbols to be *always*
+ # included in the symbol list
+ include_expsyms_F77=
+ # exclude_expsyms can be an extended regexp of symbols to exclude
+ # it will be wrapped by ` (' and `)$', so one must not match beginning or
+ # end of line. Example: `a|bc|.*d.*' will exclude the symbols `a' and `bc',
+ # as well as any symbol that contains `d'.
+ exclude_expsyms_F77='_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*'
+ # Although _GLOBAL_OFFSET_TABLE_ is a valid symbol C name, most a.out
+ # platforms (ab)use it in PIC code, but their linkers get confused if
+ # the symbol is explicitly referenced. Since portable code cannot
+ # rely on this symbol name, it's probably fine to never include it in
+ # preloaded symbol tables.
+ # Exclude shared library initialization/finalization symbols.
+ extract_expsyms_cmds=
+
+ case $host_os in
+ cygwin* | mingw* | pw32* | cegcc*)
+ # FIXME: the MSVC++ port hasn't been tested in a loooong time
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ if test "$GCC" != yes; then
+ with_gnu_ld=no
+ fi
+ ;;
+ interix*)
+ # we just hope/assume this is gcc and not c89 (= MSVC++)
+ with_gnu_ld=yes
+ ;;
+ openbsd*)
+ with_gnu_ld=no
+ ;;
+ esac
+
+ ld_shlibs_F77=yes
+
+ # On some targets, GNU ld is compatible enough with the native linker
+ # that we're better off using the native interface for both.
+ lt_use_gnu_ld_interface=no
+ if test "$with_gnu_ld" = yes; then
+ case $host_os in
+ aix*)
+ # The AIX port of GNU ld has always aspired to compatibility
+ # with the native linker. However, as the warning in the GNU ld
+ # block says, versions before 2.19.5* couldn't really create working
+ # shared libraries, regardless of the interface used.
+ case `$LD -v 2>&1` in
+ *\ \(GNU\ Binutils\)\ 2.19.5*) ;;
+ *\ \(GNU\ Binutils\)\ 2.[2-9]*) ;;
+ *\ \(GNU\ Binutils\)\ [3-9]*) ;;
+ *)
+ lt_use_gnu_ld_interface=yes
+ ;;
+ esac
+ ;;
+ *)
+ lt_use_gnu_ld_interface=yes
+ ;;
+ esac
+ fi
+
+ if test "$lt_use_gnu_ld_interface" = yes; then
+ # If archive_cmds runs LD, not CC, wlarc should be empty
+ wlarc='${wl}'
+
+ # Set some defaults for GNU ld with shared library support. These
+ # are reset later if shared libraries are not supported. Putting them
+ # here allows them to be overridden if necessary.
+ runpath_var=LD_RUN_PATH
+ hardcode_libdir_flag_spec_F77='${wl}-rpath ${wl}$libdir'
+ export_dynamic_flag_spec_F77='${wl}--export-dynamic'
+ # ancient GNU ld didn't support --whole-archive et. al.
+ if $LD --help 2>&1 | $GREP 'no-whole-archive' > /dev/null; then
+ whole_archive_flag_spec_F77="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive'
+ else
+ whole_archive_flag_spec_F77=
+ fi
+ supports_anon_versioning=no
+ case `$LD -v 2>&1` in
+ *GNU\ gold*) supports_anon_versioning=yes ;;
+ *\ [01].* | *\ 2.[0-9].* | *\ 2.10.*) ;; # catch versions < 2.11
+ *\ 2.11.93.0.2\ *) supports_anon_versioning=yes ;; # RH7.3 ...
+ *\ 2.11.92.0.12\ *) supports_anon_versioning=yes ;; # Mandrake 8.2 ...
+ *\ 2.11.*) ;; # other 2.11 versions
+ *) supports_anon_versioning=yes ;;
+ esac
+
+ # See if GNU ld supports shared libraries.
+ case $host_os in
+ aix[3-9]*)
+ # On AIX/PPC, the GNU linker is very broken
+ if test "$host_cpu" != ia64; then
+ ld_shlibs_F77=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: the GNU linker, at least up to release 2.19, is reported
+*** to be unable to reliably create shared libraries on AIX.
+*** Therefore, libtool is disabling shared libraries support. If you
+*** really care for shared libraries, you may want to install binutils
+*** 2.20 or above, or modify your PATH so that a non-GNU linker is found.
+*** You will then need to restart the configuration process.
+
+_LT_EOF
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ archive_cmds_F77='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_F77=''
+ ;;
+ m68k)
+ archive_cmds_F77='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)'
+ hardcode_libdir_flag_spec_F77='-L$libdir'
+ hardcode_minus_L_F77=yes
+ ;;
+ esac
+ ;;
+
+ beos*)
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ allow_undefined_flag_F77=unsupported
+ # Joseph Beckenbach <jrb3@best.com> says some releases of gcc
+ # support --undefined. This deserves some investigation. FIXME
+ archive_cmds_F77='$CC -nostart $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ else
+ ld_shlibs_F77=no
+ fi
+ ;;
+
+ cygwin* | mingw* | pw32* | cegcc*)
+ # _LT_TAGVAR(hardcode_libdir_flag_spec, F77) is actually meaningless,
+ # as there is no search path for DLLs.
+ hardcode_libdir_flag_spec_F77='-L$libdir'
+ export_dynamic_flag_spec_F77='${wl}--export-all-symbols'
+ allow_undefined_flag_F77=unsupported
+ always_export_symbols_F77=no
+ enable_shared_with_static_runtimes_F77=yes
+ export_symbols_cmds_F77='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1 DATA/;s/^.*[ ]__nm__\([^ ]*\)[ ][^ ]*/\1 DATA/;/^I[ ]/d;/^[AITW][ ]/s/.* //'\'' | sort | uniq > $export_symbols'
+ exclude_expsyms_F77='[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname'
+
+ if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then
+ archive_cmds_F77='$CC -shared $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ # If the export-symbols file already is a .def file (1st line
+ # is EXPORTS), use it as is; otherwise, prepend...
+ archive_expsym_cmds_F77='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ cp $export_symbols $output_objdir/$soname.def;
+ else
+ echo EXPORTS > $output_objdir/$soname.def;
+ cat $export_symbols >> $output_objdir/$soname.def;
+ fi~
+ $CC -shared $output_objdir/$soname.def $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ else
+ ld_shlibs_F77=no
+ fi
+ ;;
+
+ haiku*)
+ archive_cmds_F77='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ link_all_deplibs_F77=yes
+ ;;
+
+ interix[3-9]*)
+ hardcode_direct_F77=no
+ hardcode_shlibpath_var_F77=no
+ hardcode_libdir_flag_spec_F77='${wl}-rpath,$libdir'
+ export_dynamic_flag_spec_F77='${wl}-E'
+ # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc.
+ # Instead, shared libraries are loaded at an image base (0x10000000 by
+ # default) and relocated if they conflict, which is a slow very memory
+ # consuming and fragmenting process. To avoid this, we pick a random,
+ # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link
+ # time. Moving up from 0x10000000 also allows more sbrk(2) space.
+ archive_cmds_F77='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ archive_expsym_cmds_F77='sed "s,^,_," $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--retain-symbols-file,$output_objdir/$soname.expsym ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ ;;
+
+ gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu)
+ tmp_diet=no
+ if test "$host_os" = linux-dietlibc; then
+ case $cc_basename in
+ diet\ *) tmp_diet=yes;; # linux-dietlibc with static linking (!diet-dyn)
+ esac
+ fi
+ if $LD --help 2>&1 | $EGREP ': supported targets:.* elf' > /dev/null \
+ && test "$tmp_diet" = no
+ then
+ tmp_addflag=' $pic_flag'
+ tmp_sharedflag='-shared'
+ case $cc_basename,$host_cpu in
+ pgcc*) # Portland Group C compiler
+ whole_archive_flag_spec_F77='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ tmp_addflag=' $pic_flag'
+ ;;
+ pgf77* | pgf90* | pgf95* | pgfortran*)
+ # Portland Group f77 and f90 compilers
+ whole_archive_flag_spec_F77='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ tmp_addflag=' $pic_flag -Mnomain' ;;
+ ecc*,ia64* | icc*,ia64*) # Intel C compiler on ia64
+ tmp_addflag=' -i_dynamic' ;;
+ efc*,ia64* | ifort*,ia64*) # Intel Fortran compiler on ia64
+ tmp_addflag=' -i_dynamic -nofor_main' ;;
+ ifc* | ifort*) # Intel Fortran compiler
+ tmp_addflag=' -nofor_main' ;;
+ lf95*) # Lahey Fortran 8.1
+ whole_archive_flag_spec_F77=
+ tmp_sharedflag='--shared' ;;
+ xl[cC]* | bgxl[cC]* | mpixl[cC]*) # IBM XL C 8.0 on PPC (deal with xlf below)
+ tmp_sharedflag='-qmkshrobj'
+ tmp_addflag= ;;
+ nvcc*) # Cuda Compiler Driver 2.2
+ whole_archive_flag_spec_F77='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ compiler_needs_object_F77=yes
+ ;;
+ esac
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*) # Sun C 5.9
+ whole_archive_flag_spec_F77='${wl}--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ compiler_needs_object_F77=yes
+ tmp_sharedflag='-G' ;;
+ *Sun\ F*) # Sun Fortran 8.3
+ tmp_sharedflag='-G' ;;
+ esac
+ archive_cmds_F77='$CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+
+ if test "x$supports_anon_versioning" = xyes; then
+ archive_expsym_cmds_F77='echo "{ global:" > $output_objdir/$libname.ver~
+ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~
+ echo "local: *; };" >> $output_objdir/$libname.ver~
+ $CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-version-script ${wl}$output_objdir/$libname.ver -o $lib'
+ fi
+
+ case $cc_basename in
+ xlf* | bgf* | bgxlf* | mpixlf*)
+ # IBM XL Fortran 10.1 on PPC cannot create shared libs itself
+ whole_archive_flag_spec_F77='--whole-archive$convenience --no-whole-archive'
+ hardcode_libdir_flag_spec_F77=
+ hardcode_libdir_flag_spec_ld_F77='-rpath $libdir'
+ archive_cmds_F77='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib'
+ if test "x$supports_anon_versioning" = xyes; then
+ archive_expsym_cmds_F77='echo "{ global:" > $output_objdir/$libname.ver~
+ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~
+ echo "local: *; };" >> $output_objdir/$libname.ver~
+ $LD -shared $libobjs $deplibs $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib'
+ fi
+ ;;
+ esac
+ else
+ ld_shlibs_F77=no
+ fi
+ ;;
+
+ netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ archive_cmds_F77='$LD -Bshareable $libobjs $deplibs $linker_flags -o $lib'
+ wlarc=
+ else
+ archive_cmds_F77='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_F77='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ fi
+ ;;
+
+ solaris*)
+ if $LD -v 2>&1 | $GREP 'BFD 2\.8' > /dev/null; then
+ ld_shlibs_F77=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: The releases 2.8.* of the GNU linker cannot reliably
+*** create shared libraries on Solaris systems. Therefore, libtool
+*** is disabling shared libraries support. We urge you to upgrade GNU
+*** binutils to release 2.9.1 or newer. Another option is to modify
+*** your PATH or compiler configuration so that the native linker is
+*** used, and then restart.
+
+_LT_EOF
+ elif $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ archive_cmds_F77='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_F77='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ ld_shlibs_F77=no
+ fi
+ ;;
+
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*)
+ case `$LD -v 2>&1` in
+ *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*)
+ ld_shlibs_F77=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: Releases of the GNU linker prior to 2.16.91.0.3 can not
+*** reliably create shared libraries on SCO systems. Therefore, libtool
+*** is disabling shared libraries support. We urge you to upgrade GNU
+*** binutils to release 2.16.91.0.3 or newer. Another option is to modify
+*** your PATH or compiler configuration so that the native linker is
+*** used, and then restart.
+
+_LT_EOF
+ ;;
+ *)
+ # For security reasons, it is highly recommended that you always
+ # use absolute paths for naming shared libraries, and exclude the
+ # DT_RUNPATH tag from executables and libraries. But doing so
+ # requires that you compile everything twice, which is a pain.
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ hardcode_libdir_flag_spec_F77='${wl}-rpath ${wl}$libdir'
+ archive_cmds_F77='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_F77='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ ld_shlibs_F77=no
+ fi
+ ;;
+ esac
+ ;;
+
+ sunos4*)
+ archive_cmds_F77='$LD -assert pure-text -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ wlarc=
+ hardcode_direct_F77=yes
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ *)
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ archive_cmds_F77='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_F77='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ ld_shlibs_F77=no
+ fi
+ ;;
+ esac
+
+ if test "$ld_shlibs_F77" = no; then
+ runpath_var=
+ hardcode_libdir_flag_spec_F77=
+ export_dynamic_flag_spec_F77=
+ whole_archive_flag_spec_F77=
+ fi
+ else
+ # PORTME fill in a description of your system's linker (not GNU ld)
+ case $host_os in
+ aix3*)
+ allow_undefined_flag_F77=unsupported
+ always_export_symbols_F77=yes
+ archive_expsym_cmds_F77='$LD -o $output_objdir/$soname $libobjs $deplibs $linker_flags -bE:$export_symbols -T512 -H512 -bM:SRE~$AR $AR_FLAGS $lib $output_objdir/$soname'
+ # Note: this linker hardcodes the directories in LIBPATH if there
+ # are no directories specified by -L.
+ hardcode_minus_L_F77=yes
+ if test "$GCC" = yes && test -z "$lt_prog_compiler_static"; then
+ # Neither direct hardcoding nor static linking is supported with a
+ # broken collect2.
+ hardcode_direct_F77=unsupported
+ fi
+ ;;
+
+ aix[4-9]*)
+ if test "$host_cpu" = ia64; then
+ # On IA64, the linker does run time linking by default, so we don't
+ # have to do anything special.
+ aix_use_runtimelinking=no
+ exp_sym_flag='-Bexport'
+ no_entry_flag=""
+ else
+ # If we're using GNU nm, then we don't want the "-C" option.
+ # -C means demangle to AIX nm, but means don't demangle with GNU nm
+ # Also, AIX nm treats weak defined symbols like other global
+ # defined symbols, whereas GNU nm marks them as "W".
+ if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then
+ export_symbols_cmds_F77='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && (substr(\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ else
+ export_symbols_cmds_F77='$NM -BCpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && (substr(\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ fi
+ aix_use_runtimelinking=no
+
+ # Test if we are trying to use run time linking or normal
+ # AIX style linking. If -brtl is somewhere in LDFLAGS, we
+ # need to do runtime linking.
+ case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*)
+ for ld_flag in $LDFLAGS; do
+ if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then
+ aix_use_runtimelinking=yes
+ break
+ fi
+ done
+ ;;
+ esac
+
+ exp_sym_flag='-bexport'
+ no_entry_flag='-bnoentry'
+ fi
+
+ # When large executables or shared objects are built, AIX ld can
+ # have problems creating the table of contents. If linking a library
+ # or program results in "error TOC overflow" add -mminimal-toc to
+ # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not
+ # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS.
+
+ archive_cmds_F77=''
+ hardcode_direct_F77=yes
+ hardcode_direct_absolute_F77=yes
+ hardcode_libdir_separator_F77=':'
+ link_all_deplibs_F77=yes
+ file_list_spec_F77='${wl}-f,'
+
+ if test "$GCC" = yes; then
+ case $host_os in aix4.[012]|aix4.[012].*)
+ # We only want to do this on AIX 4.2 and lower, the check
+ # below for broken collect2 doesn't work under 4.3+
+ collect2name=`${CC} -print-prog-name=collect2`
+ if test -f "$collect2name" &&
+ strings "$collect2name" | $GREP resolve_lib_name >/dev/null
+ then
+ # We have reworked collect2
+ :
+ else
+ # We have old collect2
+ hardcode_direct_F77=unsupported
+ # It fails to find uninstalled libraries when the uninstalled
+ # path is not listed in the libpath. Setting hardcode_minus_L
+ # to unsupported forces relinking
+ hardcode_minus_L_F77=yes
+ hardcode_libdir_flag_spec_F77='-L$libdir'
+ hardcode_libdir_separator_F77=
+ fi
+ ;;
+ esac
+ shared_flag='-shared'
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag="$shared_flag "'${wl}-G'
+ fi
+ else
+ # not using gcc
+ if test "$host_cpu" = ia64; then
+ # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release
+ # chokes on -Wl,-G. The following line is correct:
+ shared_flag='-G'
+ else
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag='${wl}-G'
+ else
+ shared_flag='${wl}-bM:SRE'
+ fi
+ fi
+ fi
+
+ export_dynamic_flag_spec_F77='${wl}-bexpall'
+ # It seems that -bexpall does not export symbols beginning with
+ # underscore (_), so it is better to generate a list of symbols to export.
+ always_export_symbols_F77=yes
+ if test "$aix_use_runtimelinking" = yes; then
+ # Warning - without using the other runtime loading flags (-brtl),
+ # -berok will link without error, but may produce a broken library.
+ allow_undefined_flag_F77='-berok'
+ # Determine the default libpath from the value encoded in an
+ # empty executable.
+ if test "${lt_cv_aix_libpath+set}" = set; then
+ aix_libpath=$lt_cv_aix_libpath
+else
+ if ${lt_cv_aix_libpath__F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_f77_try_link "$LINENO"; then :
+
+ lt_aix_libpath_sed='
+ /Import File Strings/,/^$/ {
+ /^0/ {
+ s/^0 *\([^ ]*\) *$/\1/
+ p
+ }
+ }'
+ lt_cv_aix_libpath__F77=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ # Check for a 64-bit object if we didn't find anything.
+ if test -z "$lt_cv_aix_libpath__F77"; then
+ lt_cv_aix_libpath__F77=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ fi
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ if test -z "$lt_cv_aix_libpath__F77"; then
+ lt_cv_aix_libpath__F77="/usr/lib:/lib"
+ fi
+
+fi
+
+ aix_libpath=$lt_cv_aix_libpath__F77
+fi
+
+ hardcode_libdir_flag_spec_F77='${wl}-blibpath:$libdir:'"$aix_libpath"
+ archive_expsym_cmds_F77='$CC -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags `if test "x${allow_undefined_flag}" != "x"; then func_echo_all "${wl}${allow_undefined_flag}"; else :; fi` '"\${wl}$exp_sym_flag:\$export_symbols $shared_flag"
+ else
+ if test "$host_cpu" = ia64; then
+ hardcode_libdir_flag_spec_F77='${wl}-R $libdir:/usr/lib:/lib'
+ allow_undefined_flag_F77="-z nodefs"
+ archive_expsym_cmds_F77="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags ${wl}${allow_undefined_flag} '"\${wl}$exp_sym_flag:\$export_symbols"
+ else
+ # Determine the default libpath from the value encoded in an
+ # empty executable.
+ if test "${lt_cv_aix_libpath+set}" = set; then
+ aix_libpath=$lt_cv_aix_libpath
+else
+ if ${lt_cv_aix_libpath__F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_f77_try_link "$LINENO"; then :
+
+ lt_aix_libpath_sed='
+ /Import File Strings/,/^$/ {
+ /^0/ {
+ s/^0 *\([^ ]*\) *$/\1/
+ p
+ }
+ }'
+ lt_cv_aix_libpath__F77=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ # Check for a 64-bit object if we didn't find anything.
+ if test -z "$lt_cv_aix_libpath__F77"; then
+ lt_cv_aix_libpath__F77=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ fi
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ if test -z "$lt_cv_aix_libpath__F77"; then
+ lt_cv_aix_libpath__F77="/usr/lib:/lib"
+ fi
+
+fi
+
+ aix_libpath=$lt_cv_aix_libpath__F77
+fi
+
+ hardcode_libdir_flag_spec_F77='${wl}-blibpath:$libdir:'"$aix_libpath"
+ # Warning - without using the other run time loading flags,
+ # -berok will link without error, but may produce a broken library.
+ no_undefined_flag_F77=' ${wl}-bernotok'
+ allow_undefined_flag_F77=' ${wl}-berok'
+ if test "$with_gnu_ld" = yes; then
+ # We only use this code for GNU lds that support --whole-archive.
+ whole_archive_flag_spec_F77='${wl}--whole-archive$convenience ${wl}--no-whole-archive'
+ else
+ # Exported symbols can be pulled into shared objects from archives
+ whole_archive_flag_spec_F77='$convenience'
+ fi
+ archive_cmds_need_lc_F77=yes
+ # This is similar to how AIX traditionally builds its shared libraries.
+ archive_expsym_cmds_F77="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs ${wl}-bnoentry $compiler_flags ${wl}-bE:$export_symbols${allow_undefined_flag}~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$soname'
+ fi
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ archive_cmds_F77='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_F77=''
+ ;;
+ m68k)
+ archive_cmds_F77='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)'
+ hardcode_libdir_flag_spec_F77='-L$libdir'
+ hardcode_minus_L_F77=yes
+ ;;
+ esac
+ ;;
+
+ bsdi[45]*)
+ export_dynamic_flag_spec_F77=-rdynamic
+ ;;
+
+ cygwin* | mingw* | pw32* | cegcc*)
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ case $cc_basename in
+ cl*)
+ # Native MSVC
+ hardcode_libdir_flag_spec_F77=' '
+ allow_undefined_flag_F77=unsupported
+ always_export_symbols_F77=yes
+ file_list_spec_F77='@'
+ # Tell ltmain to make .lib files, not .a files.
+ libext=lib
+ # Tell ltmain to make .dll files, not .so files.
+ shrext_cmds=".dll"
+ # FIXME: Setting linknames here is a bad hack.
+ archive_cmds_F77='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-dll~linknames='
+ archive_expsym_cmds_F77='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ sed -n -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' -e '1\\\!p' < $export_symbols > $output_objdir/$soname.exp;
+ else
+ sed -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' < $export_symbols > $output_objdir/$soname.exp;
+ fi~
+ $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~
+ linknames='
+ # The linker will not automatically build a static lib if we build a DLL.
+ # _LT_TAGVAR(old_archive_from_new_cmds, F77)='true'
+ enable_shared_with_static_runtimes_F77=yes
+ export_symbols_cmds_F77='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1,DATA/'\'' | $SED -e '\''/^[AITW][ ]/s/.*[ ]//'\'' | sort | uniq > $export_symbols'
+ # Don't use ranlib
+ old_postinstall_cmds_F77='chmod 644 $oldlib'
+ postlink_cmds_F77='lt_outputfile="@OUTPUT@"~
+ lt_tool_outputfile="@TOOL_OUTPUT@"~
+ case $lt_outputfile in
+ *.exe|*.EXE) ;;
+ *)
+ lt_outputfile="$lt_outputfile.exe"
+ lt_tool_outputfile="$lt_tool_outputfile.exe"
+ ;;
+ esac~
+ if test "$MANIFEST_TOOL" != ":" && test -f "$lt_outputfile.manifest"; then
+ $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1;
+ $RM "$lt_outputfile.manifest";
+ fi'
+ ;;
+ *)
+ # Assume MSVC wrapper
+ hardcode_libdir_flag_spec_F77=' '
+ allow_undefined_flag_F77=unsupported
+ # Tell ltmain to make .lib files, not .a files.
+ libext=lib
+ # Tell ltmain to make .dll files, not .so files.
+ shrext_cmds=".dll"
+ # FIXME: Setting linknames here is a bad hack.
+ archive_cmds_F77='$CC -o $lib $libobjs $compiler_flags `func_echo_all "$deplibs" | $SED '\''s/ -lc$//'\''` -link -dll~linknames='
+ # The linker will automatically build a .lib file if we build a DLL.
+ old_archive_from_new_cmds_F77='true'
+ # FIXME: Should let the user specify the lib program.
+ old_archive_cmds_F77='lib -OUT:$oldlib$oldobjs$old_deplibs'
+ enable_shared_with_static_runtimes_F77=yes
+ ;;
+ esac
+ ;;
+
+ darwin* | rhapsody*)
+
+
+ archive_cmds_need_lc_F77=no
+ hardcode_direct_F77=no
+ hardcode_automatic_F77=yes
+ hardcode_shlibpath_var_F77=unsupported
+ if test "$lt_cv_ld_force_load" = "yes"; then
+ whole_archive_flag_spec_F77='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience ${wl}-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`'
+ else
+ whole_archive_flag_spec_F77=''
+ fi
+ link_all_deplibs_F77=yes
+ allow_undefined_flag_F77="$_lt_dar_allow_undefined"
+ case $cc_basename in
+ ifort*) _lt_dar_can_shared=yes ;;
+ *) _lt_dar_can_shared=$GCC ;;
+ esac
+ if test "$_lt_dar_can_shared" = "yes"; then
+ output_verbose_link_cmd=func_echo_all
+ archive_cmds_F77="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod${_lt_dsymutil}"
+ module_cmds_F77="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dsymutil}"
+ archive_expsym_cmds_F77="sed 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring ${_lt_dar_single_mod}${_lt_dar_export_syms}${_lt_dsymutil}"
+ module_expsym_cmds_F77="sed -e 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dar_export_syms}${_lt_dsymutil}"
+
+ else
+ ld_shlibs_F77=no
+ fi
+
+ ;;
+
+ dgux*)
+ archive_cmds_F77='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_libdir_flag_spec_F77='-L$libdir'
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ freebsd1*)
+ ld_shlibs_F77=no
+ ;;
+
+ # FreeBSD 2.2.[012] allows us to include c++rt0.o to get C++ constructor
+ # support. Future versions do this automatically, but an explicit c++rt0.o
+ # does not break anything, and helps significantly (at the cost of a little
+ # extra space).
+ freebsd2.2*)
+ archive_cmds_F77='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags /usr/lib/c++rt0.o'
+ hardcode_libdir_flag_spec_F77='-R$libdir'
+ hardcode_direct_F77=yes
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ # Unfortunately, older versions of FreeBSD 2 do not have this feature.
+ freebsd2*)
+ archive_cmds_F77='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct_F77=yes
+ hardcode_minus_L_F77=yes
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ # FreeBSD 3 and greater uses gcc -shared to do shared libraries.
+ freebsd* | dragonfly*)
+ archive_cmds_F77='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ hardcode_libdir_flag_spec_F77='-R$libdir'
+ hardcode_direct_F77=yes
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ hpux9*)
+ if test "$GCC" = yes; then
+ archive_cmds_F77='$RM $output_objdir/$soname~$CC -shared $pic_flag ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ else
+ archive_cmds_F77='$RM $output_objdir/$soname~$LD -b +b $install_libdir -o $output_objdir/$soname $libobjs $deplibs $linker_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ fi
+ hardcode_libdir_flag_spec_F77='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator_F77=:
+ hardcode_direct_F77=yes
+
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L_F77=yes
+ export_dynamic_flag_spec_F77='${wl}-E'
+ ;;
+
+ hpux10*)
+ if test "$GCC" = yes && test "$with_gnu_ld" = no; then
+ archive_cmds_F77='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds_F77='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags'
+ fi
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec_F77='${wl}+b ${wl}$libdir'
+ hardcode_libdir_flag_spec_ld_F77='+b $libdir'
+ hardcode_libdir_separator_F77=:
+ hardcode_direct_F77=yes
+ hardcode_direct_absolute_F77=yes
+ export_dynamic_flag_spec_F77='${wl}-E'
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L_F77=yes
+ fi
+ ;;
+
+ hpux11*)
+ if test "$GCC" = yes && test "$with_gnu_ld" = no; then
+ case $host_cpu in
+ hppa*64*)
+ archive_cmds_F77='$CC -shared ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ ia64*)
+ archive_cmds_F77='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ *)
+ archive_cmds_F77='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ esac
+ else
+ case $host_cpu in
+ hppa*64*)
+ archive_cmds_F77='$CC -b ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ ia64*)
+ archive_cmds_F77='$CC -b ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ *)
+ archive_cmds_F77='$CC -b ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ esac
+ fi
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec_F77='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator_F77=:
+
+ case $host_cpu in
+ hppa*64*|ia64*)
+ hardcode_direct_F77=no
+ hardcode_shlibpath_var_F77=no
+ ;;
+ *)
+ hardcode_direct_F77=yes
+ hardcode_direct_absolute_F77=yes
+ export_dynamic_flag_spec_F77='${wl}-E'
+
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L_F77=yes
+ ;;
+ esac
+ fi
+ ;;
+
+ irix5* | irix6* | nonstopux*)
+ if test "$GCC" = yes; then
+ archive_cmds_F77='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ # Try to use the -exported_symbol ld option, if it does not
+ # work, assume that -exports_file does not work either and
+ # implicitly export all symbols.
+ # This should be the same for all languages, so no per-tag cache variable.
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $host_os linker accepts -exported_symbol" >&5
+$as_echo_n "checking whether the $host_os linker accepts -exported_symbol... " >&6; }
+if ${lt_cv_irix_exported_symbol+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS -shared ${wl}-exported_symbol ${wl}foo ${wl}-update_registry ${wl}/dev/null"
+ cat > conftest.$ac_ext <<_ACEOF
+
+ subroutine foo
+ end
+_ACEOF
+if ac_fn_f77_try_link "$LINENO"; then :
+ lt_cv_irix_exported_symbol=yes
+else
+ lt_cv_irix_exported_symbol=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ LDFLAGS="$save_LDFLAGS"
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_irix_exported_symbol" >&5
+$as_echo "$lt_cv_irix_exported_symbol" >&6; }
+ if test "$lt_cv_irix_exported_symbol" = yes; then
+ archive_expsym_cmds_F77='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations ${wl}-exports_file ${wl}$export_symbols -o $lib'
+ fi
+ else
+ archive_cmds_F77='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ archive_expsym_cmds_F77='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -exports_file $export_symbols -o $lib'
+ fi
+ archive_cmds_need_lc_F77='no'
+ hardcode_libdir_flag_spec_F77='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator_F77=:
+ inherit_rpath_F77=yes
+ link_all_deplibs_F77=yes
+ ;;
+
+ netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ archive_cmds_F77='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' # a.out
+ else
+ archive_cmds_F77='$LD -shared -o $lib $libobjs $deplibs $linker_flags' # ELF
+ fi
+ hardcode_libdir_flag_spec_F77='-R$libdir'
+ hardcode_direct_F77=yes
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ newsos6)
+ archive_cmds_F77='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct_F77=yes
+ hardcode_libdir_flag_spec_F77='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator_F77=:
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ *nto* | *qnx*)
+ ;;
+
+ openbsd*)
+ if test -f /usr/libexec/ld.so; then
+ hardcode_direct_F77=yes
+ hardcode_shlibpath_var_F77=no
+ hardcode_direct_absolute_F77=yes
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ archive_cmds_F77='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_F77='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags ${wl}-retain-symbols-file,$export_symbols'
+ hardcode_libdir_flag_spec_F77='${wl}-rpath,$libdir'
+ export_dynamic_flag_spec_F77='${wl}-E'
+ else
+ case $host_os in
+ openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*)
+ archive_cmds_F77='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_libdir_flag_spec_F77='-R$libdir'
+ ;;
+ *)
+ archive_cmds_F77='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ hardcode_libdir_flag_spec_F77='${wl}-rpath,$libdir'
+ ;;
+ esac
+ fi
+ else
+ ld_shlibs_F77=no
+ fi
+ ;;
+
+ os2*)
+ hardcode_libdir_flag_spec_F77='-L$libdir'
+ hardcode_minus_L_F77=yes
+ allow_undefined_flag_F77=unsupported
+ archive_cmds_F77='$ECHO "LIBRARY $libname INITINSTANCE" > $output_objdir/$libname.def~$ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~echo DATA >> $output_objdir/$libname.def~echo " SINGLE NONSHARED" >> $output_objdir/$libname.def~echo EXPORTS >> $output_objdir/$libname.def~emxexp $libobjs >> $output_objdir/$libname.def~$CC -Zdll -Zcrtdll -o $lib $libobjs $deplibs $compiler_flags $output_objdir/$libname.def'
+ old_archive_from_new_cmds_F77='emximp -o $output_objdir/$libname.a $output_objdir/$libname.def'
+ ;;
+
+ osf3*)
+ if test "$GCC" = yes; then
+ allow_undefined_flag_F77=' ${wl}-expect_unresolved ${wl}\*'
+ archive_cmds_F77='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ else
+ allow_undefined_flag_F77=' -expect_unresolved \*'
+ archive_cmds_F77='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ fi
+ archive_cmds_need_lc_F77='no'
+ hardcode_libdir_flag_spec_F77='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator_F77=:
+ ;;
+
+ osf4* | osf5*) # as osf3* with the addition of -msym flag
+ if test "$GCC" = yes; then
+ allow_undefined_flag_F77=' ${wl}-expect_unresolved ${wl}\*'
+ archive_cmds_F77='$CC -shared${allow_undefined_flag} $pic_flag $libobjs $deplibs $compiler_flags ${wl}-msym ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ hardcode_libdir_flag_spec_F77='${wl}-rpath ${wl}$libdir'
+ else
+ allow_undefined_flag_F77=' -expect_unresolved \*'
+ archive_cmds_F77='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ archive_expsym_cmds_F77='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done; printf "%s\\n" "-hidden">> $lib.exp~
+ $CC -shared${allow_undefined_flag} ${wl}-input ${wl}$lib.exp $compiler_flags $libobjs $deplibs -soname $soname `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib~$RM $lib.exp'
+
+ # Both c and cxx compiler support -rpath directly
+ hardcode_libdir_flag_spec_F77='-rpath $libdir'
+ fi
+ archive_cmds_need_lc_F77='no'
+ hardcode_libdir_separator_F77=:
+ ;;
+
+ solaris*)
+ no_undefined_flag_F77=' -z defs'
+ if test "$GCC" = yes; then
+ wlarc='${wl}'
+ archive_cmds_F77='$CC -shared $pic_flag ${wl}-z ${wl}text ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_F77='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -shared $pic_flag ${wl}-z ${wl}text ${wl}-M ${wl}$lib.exp ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp'
+ else
+ case `$CC -V 2>&1` in
+ *"Compilers 5.0"*)
+ wlarc=''
+ archive_cmds_F77='$LD -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ archive_expsym_cmds_F77='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $LD -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $linker_flags~$RM $lib.exp'
+ ;;
+ *)
+ wlarc='${wl}'
+ archive_cmds_F77='$CC -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_F77='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp'
+ ;;
+ esac
+ fi
+ hardcode_libdir_flag_spec_F77='-R$libdir'
+ hardcode_shlibpath_var_F77=no
+ case $host_os in
+ solaris2.[0-5] | solaris2.[0-5].*) ;;
+ *)
+ # The compiler driver will combine and reorder linker options,
+ # but understands `-z linker_flag'. GCC discards it without `$wl',
+ # but is careful enough not to reorder.
+ # Supported since Solaris 2.6 (maybe 2.5.1?)
+ if test "$GCC" = yes; then
+ whole_archive_flag_spec_F77='${wl}-z ${wl}allextract$convenience ${wl}-z ${wl}defaultextract'
+ else
+ whole_archive_flag_spec_F77='-z allextract$convenience -z defaultextract'
+ fi
+ ;;
+ esac
+ link_all_deplibs_F77=yes
+ ;;
+
+ sunos4*)
+ if test "x$host_vendor" = xsequent; then
+ # Use $CC to link under sequent, because it throws in some extra .o
+ # files that make .init and .fini sections work.
+ archive_cmds_F77='$CC -G ${wl}-h $soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds_F77='$LD -assert pure-text -Bstatic -o $lib $libobjs $deplibs $linker_flags'
+ fi
+ hardcode_libdir_flag_spec_F77='-L$libdir'
+ hardcode_direct_F77=yes
+ hardcode_minus_L_F77=yes
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ sysv4)
+ case $host_vendor in
+ sni)
+ archive_cmds_F77='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct_F77=yes # is this really true???
+ ;;
+ siemens)
+ ## LD is ld it makes a PLAMLIB
+ ## CC just makes a GrossModule.
+ archive_cmds_F77='$LD -G -o $lib $libobjs $deplibs $linker_flags'
+ reload_cmds_F77='$CC -r -o $output$reload_objs'
+ hardcode_direct_F77=no
+ ;;
+ motorola)
+ archive_cmds_F77='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct_F77=no #Motorola manual says yes, but my tests say they lie
+ ;;
+ esac
+ runpath_var='LD_RUN_PATH'
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ sysv4.3*)
+ archive_cmds_F77='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_shlibpath_var_F77=no
+ export_dynamic_flag_spec_F77='-Bexport'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ archive_cmds_F77='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_shlibpath_var_F77=no
+ runpath_var=LD_RUN_PATH
+ hardcode_runpath_var=yes
+ ld_shlibs_F77=yes
+ fi
+ ;;
+
+ sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*)
+ no_undefined_flag_F77='${wl}-z,text'
+ archive_cmds_need_lc_F77=no
+ hardcode_shlibpath_var_F77=no
+ runpath_var='LD_RUN_PATH'
+
+ if test "$GCC" = yes; then
+ archive_cmds_F77='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_F77='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds_F77='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_F77='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ fi
+ ;;
+
+ sysv5* | sco3.2v5* | sco5v6*)
+ # Note: We can NOT use -z defs as we might desire, because we do not
+ # link with -lc, and that would cause any symbols used from libc to
+ # always be unresolved, which means just about no library would
+ # ever link correctly. If we're not using GNU ld we use -z text
+ # though, which does catch some bad symbols but isn't as heavy-handed
+ # as -z defs.
+ no_undefined_flag_F77='${wl}-z,text'
+ allow_undefined_flag_F77='${wl}-z,nodefs'
+ archive_cmds_need_lc_F77=no
+ hardcode_shlibpath_var_F77=no
+ hardcode_libdir_flag_spec_F77='${wl}-R,$libdir'
+ hardcode_libdir_separator_F77=':'
+ link_all_deplibs_F77=yes
+ export_dynamic_flag_spec_F77='${wl}-Bexport'
+ runpath_var='LD_RUN_PATH'
+
+ if test "$GCC" = yes; then
+ archive_cmds_F77='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_F77='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds_F77='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_F77='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ fi
+ ;;
+
+ uts4*)
+ archive_cmds_F77='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_libdir_flag_spec_F77='-L$libdir'
+ hardcode_shlibpath_var_F77=no
+ ;;
+
+ *)
+ ld_shlibs_F77=no
+ ;;
+ esac
+
+ if test x$host_vendor = xsni; then
+ case $host in
+ sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*)
+ export_dynamic_flag_spec_F77='${wl}-Blargedynsym'
+ ;;
+ esac
+ fi
+ fi
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs_F77" >&5
+$as_echo "$ld_shlibs_F77" >&6; }
+test "$ld_shlibs_F77" = no && can_build_shared=no
+
+with_gnu_ld_F77=$with_gnu_ld
+
+
+
+
+
+
+#
+# Do we need to explicitly link libc?
+#
+case "x$archive_cmds_need_lc_F77" in
+x|xyes)
+ # Assume -lc should be added
+ archive_cmds_need_lc_F77=yes
+
+ if test "$enable_shared" = yes && test "$GCC" = yes; then
+ case $archive_cmds_F77 in
+ *'~'*)
+ # FIXME: we may have to deal with multi-command sequences.
+ ;;
+ '$CC '*)
+ # Test whether the compiler implicitly links with -lc since on some
+ # systems, -lgcc has to come before -lc. If gcc already passes -lc
+ # to ld, don't add -lc before -lgcc.
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether -lc should be explicitly linked in" >&5
+$as_echo_n "checking whether -lc should be explicitly linked in... " >&6; }
+if ${lt_cv_archive_cmds_need_lc_F77+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ $RM conftest*
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } 2>conftest.err; then
+ soname=conftest
+ lib=conftest
+ libobjs=conftest.$ac_objext
+ deplibs=
+ wl=$lt_prog_compiler_wl_F77
+ pic_flag=$lt_prog_compiler_pic_F77
+ compiler_flags=-v
+ linker_flags=-v
+ verstring=
+ output_objdir=.
+ libname=conftest
+ lt_save_allow_undefined_flag=$allow_undefined_flag_F77
+ allow_undefined_flag_F77=
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$archive_cmds_F77 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1\""; } >&5
+ (eval $archive_cmds_F77 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+ then
+ lt_cv_archive_cmds_need_lc_F77=no
+ else
+ lt_cv_archive_cmds_need_lc_F77=yes
+ fi
+ allow_undefined_flag_F77=$lt_save_allow_undefined_flag
+ else
+ cat conftest.err 1>&5
+ fi
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc_F77" >&5
+$as_echo "$lt_cv_archive_cmds_need_lc_F77" >&6; }
+ archive_cmds_need_lc_F77=$lt_cv_archive_cmds_need_lc_F77
+ ;;
+ esac
+ fi
+ ;;
+esac
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking dynamic linker characteristics" >&5
+$as_echo_n "checking dynamic linker characteristics... " >&6; }
+
+library_names_spec=
+libname_spec='lib$name'
+soname_spec=
+shrext_cmds=".so"
+postinstall_cmds=
+postuninstall_cmds=
+finish_cmds=
+finish_eval=
+shlibpath_var=
+shlibpath_overrides_runpath=unknown
+version_type=none
+dynamic_linker="$host_os ld.so"
+sys_lib_dlsearch_path_spec="/lib /usr/lib"
+need_lib_prefix=unknown
+hardcode_into_libs=no
+
+# when you set need_version to no, make sure it does not cause -set_version
+# flags to be left without arguments
+need_version=unknown
+
+case $host_os in
+aix3*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix $libname.a'
+ shlibpath_var=LIBPATH
+
+ # AIX 3 has no versioning support, so we append a major version to the name.
+ soname_spec='${libname}${release}${shared_ext}$major'
+ ;;
+
+aix[4-9]*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ hardcode_into_libs=yes
+ if test "$host_cpu" = ia64; then
+ # AIX 5 supports IA64
+ library_names_spec='${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext}$versuffix $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ else
+ # With GCC up to 2.95.x, collect2 would create an import file
+ # for dependence libraries. The import file would start with
+ # the line `#! .'. This would cause the generated library to
+ # depend on `.', always an invalid library. This was fixed in
+ # development snapshots of GCC prior to 3.0.
+ case $host_os in
+ aix4 | aix4.[01] | aix4.[01].*)
+ if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)'
+ echo ' yes '
+ echo '#endif'; } | ${CC} -E - | $GREP yes > /dev/null; then
+ :
+ else
+ can_build_shared=no
+ fi
+ ;;
+ esac
+ # AIX (on Power*) has no versioning support, so currently we can not hardcode correct
+ # soname into executable. Probably we can add versioning support to
+ # collect2, so additional links can be useful in future.
+ if test "$aix_use_runtimelinking" = yes; then
+ # If using run time linking (on AIX 4.2 or later) use lib<name>.so
+ # instead of lib<name>.a to let people know that these are not
+ # typical AIX shared libraries.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ else
+ # We preserve .a as extension for shared libraries through AIX4.2
+ # and later when we are not doing run time linking.
+ library_names_spec='${libname}${release}.a $libname.a'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ fi
+ shlibpath_var=LIBPATH
+ fi
+ ;;
+
+amigaos*)
+ case $host_cpu in
+ powerpc)
+ # Since July 2007 AmigaOS4 officially supports .so libraries.
+ # When compiling the executable, add -use-dynld -Lsobjs: to the compileline.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ ;;
+ m68k)
+ library_names_spec='$libname.ixlibrary $libname.a'
+ # Create ${libname}_ixlibrary.a entries in /sys/libs.
+ finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`func_echo_all "$lib" | $SED '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; test $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done'
+ ;;
+ esac
+ ;;
+
+beos*)
+ library_names_spec='${libname}${shared_ext}'
+ dynamic_linker="$host_os ld.so"
+ shlibpath_var=LIBRARY_PATH
+ ;;
+
+bsdi[45]*)
+ version_type=linux
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib"
+ sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib"
+ # the default ld.so.conf also contains /usr/contrib/lib and
+ # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow
+ # libtool to hard-code these into programs
+ ;;
+
+cygwin* | mingw* | pw32* | cegcc*)
+ version_type=windows
+ shrext_cmds=".dll"
+ need_version=no
+ need_lib_prefix=no
+
+ case $GCC,$cc_basename in
+ yes,*)
+ # gcc
+ library_names_spec='$libname.dll.a'
+ # DLL is installed to $(libdir)/../bin by postinstall_cmds
+ postinstall_cmds='base_file=`basename \${file}`~
+ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~
+ dldir=$destdir/`dirname \$dlpath`~
+ test -d \$dldir || mkdir -p \$dldir~
+ $install_prog $dir/$dlname \$dldir/$dlname~
+ chmod a+x \$dldir/$dlname~
+ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then
+ eval '\''$striplib \$dldir/$dlname'\'' || exit \$?;
+ fi'
+ postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~
+ dlpath=$dir/\$dldll~
+ $RM \$dlpath'
+ shlibpath_overrides_runpath=yes
+
+ case $host_os in
+ cygwin*)
+ # Cygwin DLLs use 'cyg' prefix rather than 'lib'
+ soname_spec='`echo ${libname} | sed -e 's/^lib/cyg/'``echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+
+ ;;
+ mingw* | cegcc*)
+ # MinGW DLLs use traditional 'lib' prefix
+ soname_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+ ;;
+ pw32*)
+ # pw32 DLLs use 'pw' prefix rather than 'lib'
+ library_names_spec='`echo ${libname} | sed -e 's/^lib/pw/'``echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+ ;;
+ esac
+ dynamic_linker='Win32 ld.exe'
+ ;;
+
+ *,cl*)
+ # Native MSVC
+ libname_spec='$name'
+ soname_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+ library_names_spec='${libname}.dll.lib'
+
+ case $build_os in
+ mingw*)
+ sys_lib_search_path_spec=
+ lt_save_ifs=$IFS
+ IFS=';'
+ for lt_path in $LIB
+ do
+ IFS=$lt_save_ifs
+ # Let DOS variable expansion print the short 8.3 style file name.
+ lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"`
+ sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path"
+ done
+ IFS=$lt_save_ifs
+ # Convert to MSYS style.
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([a-zA-Z]\\):| /\\1|g' -e 's|^ ||'`
+ ;;
+ cygwin*)
+ # Convert to unix form, then to dos form, then back to unix form
+ # but this time dos style (no spaces!) so that the unix form looks
+ # like /cygdrive/c/PROGRA~1:/cygdr...
+ sys_lib_search_path_spec=`cygpath --path --unix "$LIB"`
+ sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null`
+ sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"`
+ ;;
+ *)
+ sys_lib_search_path_spec="$LIB"
+ if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then
+ # It is most probably a Windows format PATH.
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'`
+ else
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"`
+ fi
+ # FIXME: find the short name or the path components, as spaces are
+ # common. (e.g. "Program Files" -> "PROGRA~1")
+ ;;
+ esac
+
+ # DLL is installed to $(libdir)/../bin by postinstall_cmds
+ postinstall_cmds='base_file=`basename \${file}`~
+ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~
+ dldir=$destdir/`dirname \$dlpath`~
+ test -d \$dldir || mkdir -p \$dldir~
+ $install_prog $dir/$dlname \$dldir/$dlname'
+ postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~
+ dlpath=$dir/\$dldll~
+ $RM \$dlpath'
+ shlibpath_overrides_runpath=yes
+ dynamic_linker='Win32 link.exe'
+ ;;
+
+ *)
+ # Assume MSVC wrapper
+ library_names_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext} $libname.lib'
+ dynamic_linker='Win32 ld.exe'
+ ;;
+ esac
+ # FIXME: first we should search . and the directory the executable is in
+ shlibpath_var=PATH
+ ;;
+
+darwin* | rhapsody*)
+ dynamic_linker="$host_os dyld"
+ version_type=darwin
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${major}$shared_ext ${libname}$shared_ext'
+ soname_spec='${libname}${release}${major}$shared_ext'
+ shlibpath_overrides_runpath=yes
+ shlibpath_var=DYLD_LIBRARY_PATH
+ shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`'
+
+ sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib'
+ ;;
+
+dgux*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname$shared_ext'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+freebsd1*)
+ dynamic_linker=no
+ ;;
+
+freebsd* | dragonfly*)
+ # DragonFly does not have aout. When/if they implement a new
+ # versioning mechanism, adjust this.
+ if test -x /usr/bin/objformat; then
+ objformat=`/usr/bin/objformat`
+ else
+ case $host_os in
+ freebsd[123]*) objformat=aout ;;
+ *) objformat=elf ;;
+ esac
+ fi
+ version_type=freebsd-$objformat
+ case $version_type in
+ freebsd-elf*)
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}'
+ need_version=no
+ need_lib_prefix=no
+ ;;
+ freebsd-*)
+ library_names_spec='${libname}${release}${shared_ext}$versuffix $libname${shared_ext}$versuffix'
+ need_version=yes
+ ;;
+ esac
+ shlibpath_var=LD_LIBRARY_PATH
+ case $host_os in
+ freebsd2*)
+ shlibpath_overrides_runpath=yes
+ ;;
+ freebsd3.[01]* | freebsdelf3.[01]*)
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+ freebsd3.[2-9]* | freebsdelf3.[2-9]* | \
+ freebsd4.[0-5] | freebsdelf4.[0-5] | freebsd4.1.1 | freebsdelf4.1.1)
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+ *) # from 4.6 on, and DragonFly
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+ esac
+ ;;
+
+gnu*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ hardcode_into_libs=yes
+ ;;
+
+haiku*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ dynamic_linker="$host_os runtime_loader"
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib'
+ hardcode_into_libs=yes
+ ;;
+
+hpux9* | hpux10* | hpux11*)
+ # Give a soname corresponding to the major version so that dld.sl refuses to
+ # link against other versions.
+ version_type=sunos
+ need_lib_prefix=no
+ need_version=no
+ case $host_cpu in
+ ia64*)
+ shrext_cmds='.so'
+ hardcode_into_libs=yes
+ dynamic_linker="$host_os dld.so"
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes # Unless +noenvvar is specified.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ if test "X$HPUX_IA64_MODE" = X32; then
+ sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib"
+ else
+ sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64"
+ fi
+ sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec
+ ;;
+ hppa*64*)
+ shrext_cmds='.sl'
+ hardcode_into_libs=yes
+ dynamic_linker="$host_os dld.sl"
+ shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH
+ shlibpath_overrides_runpath=yes # Unless +noenvvar is specified.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64"
+ sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec
+ ;;
+ *)
+ shrext_cmds='.sl'
+ dynamic_linker="$host_os dld.sl"
+ shlibpath_var=SHLIB_PATH
+ shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ ;;
+ esac
+ # HP-UX runs *really* slowly unless shared libraries are mode 555, ...
+ postinstall_cmds='chmod 555 $lib'
+ # or fails outright, so override atomically:
+ install_override_mode=555
+ ;;
+
+interix[3-9]*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+
+irix5* | irix6* | nonstopux*)
+ case $host_os in
+ nonstopux*) version_type=nonstopux ;;
+ *)
+ if test "$lt_cv_prog_gnu_ld" = yes; then
+ version_type=linux
+ else
+ version_type=irix
+ fi ;;
+ esac
+ need_lib_prefix=no
+ need_version=no
+ soname_spec='${libname}${release}${shared_ext}$major'
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext} $libname${shared_ext}'
+ case $host_os in
+ irix5* | nonstopux*)
+ libsuff= shlibsuff=
+ ;;
+ *)
+ case $LD in # libtool.m4 will add one of these switches to LD
+ *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ")
+ libsuff= shlibsuff= libmagic=32-bit;;
+ *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ")
+ libsuff=32 shlibsuff=N32 libmagic=N32;;
+ *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ")
+ libsuff=64 shlibsuff=64 libmagic=64-bit;;
+ *) libsuff= shlibsuff= libmagic=never-match;;
+ esac
+ ;;
+ esac
+ shlibpath_var=LD_LIBRARY${shlibsuff}_PATH
+ shlibpath_overrides_runpath=no
+ sys_lib_search_path_spec="/usr/lib${libsuff} /lib${libsuff} /usr/local/lib${libsuff}"
+ sys_lib_dlsearch_path_spec="/usr/lib${libsuff} /lib${libsuff}"
+ hardcode_into_libs=yes
+ ;;
+
+# No shared lib support for Linux oldld, aout, or coff.
+linux*oldld* | linux*aout* | linux*coff*)
+ dynamic_linker=no
+ ;;
+
+# This must be Linux ELF.
+linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+
+ # Some binutils ld are patched to set DT_RUNPATH
+ if ${lt_cv_shlibpath_overrides_runpath+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_shlibpath_overrides_runpath=no
+ save_LDFLAGS=$LDFLAGS
+ save_libdir=$libdir
+ eval "libdir=/foo; wl=\"$lt_prog_compiler_wl_F77\"; \
+ LDFLAGS=\"\$LDFLAGS $hardcode_libdir_flag_spec_F77\""
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_f77_try_link "$LINENO"; then :
+ if ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null; then :
+ lt_cv_shlibpath_overrides_runpath=yes
+fi
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ LDFLAGS=$save_LDFLAGS
+ libdir=$save_libdir
+
+fi
+
+ shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath
+
+ # This implies no fast_install, which is unacceptable.
+ # Some rework will be needed to allow for fast_install
+ # before this can be enabled.
+ hardcode_into_libs=yes
+
+ # Append ld.so.conf contents to the search path
+ if test -f /etc/ld.so.conf; then
+ lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \$2)); skip = 1; } { if (!skip) print \$0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;s/"//g;/^$/d' | tr '\n' ' '`
+ sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra"
+ fi
+
+ # We used to test for /lib/ld.so.1 and disable shared libraries on
+ # powerpc, because MkLinux only supported shared libraries with the
+ # GNU dynamic linker. Since this was broken with cross compilers,
+ # most powerpc-linux boxes support dynamic linking these days and
+ # people can always --disable-shared, the test was removed, and we
+ # assume the GNU/Linux dynamic linker is in use.
+ dynamic_linker='GNU/Linux ld.so'
+ ;;
+
+netbsd*)
+ version_type=sunos
+ need_lib_prefix=no
+ need_version=no
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir'
+ dynamic_linker='NetBSD (a.out) ld.so'
+ else
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ dynamic_linker='NetBSD ld.elf_so'
+ fi
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+
+newsos6)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ ;;
+
+*nto* | *qnx*)
+ version_type=qnx
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ dynamic_linker='ldqnx.so'
+ ;;
+
+openbsd*)
+ version_type=sunos
+ sys_lib_dlsearch_path_spec="/usr/lib"
+ need_lib_prefix=no
+ # Some older versions of OpenBSD (3.3 at least) *do* need versioned libs.
+ case $host_os in
+ openbsd3.3 | openbsd3.3.*) need_version=yes ;;
+ *) need_version=no ;;
+ esac
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ case $host_os in
+ openbsd2.[89] | openbsd2.[89].*)
+ shlibpath_overrides_runpath=no
+ ;;
+ *)
+ shlibpath_overrides_runpath=yes
+ ;;
+ esac
+ else
+ shlibpath_overrides_runpath=yes
+ fi
+ ;;
+
+os2*)
+ libname_spec='$name'
+ shrext_cmds=".dll"
+ need_lib_prefix=no
+ library_names_spec='$libname${shared_ext} $libname.a'
+ dynamic_linker='OS/2 ld.exe'
+ shlibpath_var=LIBPATH
+ ;;
+
+osf3* | osf4* | osf5*)
+ version_type=osf
+ need_lib_prefix=no
+ need_version=no
+ soname_spec='${libname}${release}${shared_ext}$major'
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib"
+ sys_lib_dlsearch_path_spec="$sys_lib_search_path_spec"
+ ;;
+
+rdos*)
+ dynamic_linker=no
+ ;;
+
+solaris*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ # ldd complains unless libraries are executable
+ postinstall_cmds='chmod +x $lib'
+ ;;
+
+sunos4*)
+ version_type=sunos
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ if test "$with_gnu_ld" = yes; then
+ need_lib_prefix=no
+ fi
+ need_version=yes
+ ;;
+
+sysv4 | sysv4.3*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ case $host_vendor in
+ sni)
+ shlibpath_overrides_runpath=no
+ need_lib_prefix=no
+ runpath_var=LD_RUN_PATH
+ ;;
+ siemens)
+ need_lib_prefix=no
+ ;;
+ motorola)
+ need_lib_prefix=no
+ need_version=no
+ shlibpath_overrides_runpath=no
+ sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib'
+ ;;
+ esac
+ ;;
+
+sysv4*MP*)
+ if test -d /usr/nec ;then
+ version_type=linux
+ library_names_spec='$libname${shared_ext}.$versuffix $libname${shared_ext}.$major $libname${shared_ext}'
+ soname_spec='$libname${shared_ext}.$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ fi
+ ;;
+
+sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
+ version_type=freebsd-elf
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ if test "$with_gnu_ld" = yes; then
+ sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib'
+ else
+ sys_lib_search_path_spec='/usr/ccs/lib /usr/lib'
+ case $host_os in
+ sco3.2v5*)
+ sys_lib_search_path_spec="$sys_lib_search_path_spec /lib"
+ ;;
+ esac
+ fi
+ sys_lib_dlsearch_path_spec='/usr/lib'
+ ;;
+
+tpf*)
+ # TPF is a cross-target only. Preferred cross-host = GNU/Linux.
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+
+uts4*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*)
+ dynamic_linker=no
+ ;;
+esac
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $dynamic_linker" >&5
+$as_echo "$dynamic_linker" >&6; }
+test "$dynamic_linker" = no && can_build_shared=no
+
+variables_saved_for_relink="PATH $shlibpath_var $runpath_var"
+if test "$GCC" = yes; then
+ variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH"
+fi
+
+if test "${lt_cv_sys_lib_search_path_spec+set}" = set; then
+ sys_lib_search_path_spec="$lt_cv_sys_lib_search_path_spec"
+fi
+if test "${lt_cv_sys_lib_dlsearch_path_spec+set}" = set; then
+ sys_lib_dlsearch_path_spec="$lt_cv_sys_lib_dlsearch_path_spec"
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to hardcode library paths into programs" >&5
+$as_echo_n "checking how to hardcode library paths into programs... " >&6; }
+hardcode_action_F77=
+if test -n "$hardcode_libdir_flag_spec_F77" ||
+ test -n "$runpath_var_F77" ||
+ test "X$hardcode_automatic_F77" = "Xyes" ; then
+
+ # We can hardcode non-existent directories.
+ if test "$hardcode_direct_F77" != no &&
+ # If the only mechanism to avoid hardcoding is shlibpath_var, we
+ # have to relink, otherwise we might link with an installed library
+ # when we should be linking with a yet-to-be-installed one
+ ## test "$_LT_TAGVAR(hardcode_shlibpath_var, F77)" != no &&
+ test "$hardcode_minus_L_F77" != no; then
+ # Linking always hardcodes the temporary library directory.
+ hardcode_action_F77=relink
+ else
+ # We can link without hardcoding, and we can hardcode nonexisting dirs.
+ hardcode_action_F77=immediate
+ fi
+else
+ # We cannot hardcode anything, or else we can only hardcode existing
+ # directories.
+ hardcode_action_F77=unsupported
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $hardcode_action_F77" >&5
+$as_echo "$hardcode_action_F77" >&6; }
+
+if test "$hardcode_action_F77" = relink ||
+ test "$inherit_rpath_F77" = yes; then
+ # Fast installation is not supported
+ enable_fast_install=no
+elif test "$shlibpath_overrides_runpath" = yes ||
+ test "$enable_shared" = no; then
+ # Fast installation is not necessary
+ enable_fast_install=needless
+fi
+
+
+
+
+
+
+
+ fi # test -n "$compiler"
+
+ GCC=$lt_save_GCC
+ CC="$lt_save_CC"
+ CFLAGS="$lt_save_CFLAGS"
+fi # test "$_lt_disable_F77" != yes
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+
+ ac_ext=${ac_fc_srcext-f}
+ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
+ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_fc_compiler_gnu
+
+
+if test -z "$FC" || test "X$FC" = "Xno"; then
+ _lt_disable_FC=yes
+fi
+
+archive_cmds_need_lc_FC=no
+allow_undefined_flag_FC=
+always_export_symbols_FC=no
+archive_expsym_cmds_FC=
+export_dynamic_flag_spec_FC=
+hardcode_direct_FC=no
+hardcode_direct_absolute_FC=no
+hardcode_libdir_flag_spec_FC=
+hardcode_libdir_flag_spec_ld_FC=
+hardcode_libdir_separator_FC=
+hardcode_minus_L_FC=no
+hardcode_automatic_FC=no
+inherit_rpath_FC=no
+module_cmds_FC=
+module_expsym_cmds_FC=
+link_all_deplibs_FC=unknown
+old_archive_cmds_FC=$old_archive_cmds
+reload_flag_FC=$reload_flag
+reload_cmds_FC=$reload_cmds
+no_undefined_flag_FC=
+whole_archive_flag_spec_FC=
+enable_shared_with_static_runtimes_FC=no
+
+# Source file extension for fc test sources.
+ac_ext=${ac_fc_srcext-f}
+
+# Object file extension for compiled fc test sources.
+objext=o
+objext_FC=$objext
+
+# No sense in running all these tests if we already determined that
+# the FC compiler isn't working. Some variables (like enable_shared)
+# are currently assumed to apply to all compilers on this platform,
+# and will be corrupted by setting them based on a non-working compiler.
+if test "$_lt_disable_FC" != yes; then
+ # Code to be used in simple compile tests
+ lt_simple_compile_test_code="\
+ subroutine t
+ return
+ end
+"
+
+ # Code to be used in simple link tests
+ lt_simple_link_test_code="\
+ program t
+ end
+"
+
+ # ltmain only uses $CC for tagged configurations so make sure $CC is set.
+
+
+
+
+
+
+# If no C compiler was specified, use CC.
+LTCC=${LTCC-"$CC"}
+
+# If no C compiler flags were specified, use CFLAGS.
+LTCFLAGS=${LTCFLAGS-"$CFLAGS"}
+
+# Allow CC to be a program name with arguments.
+compiler=$CC
+
+
+ # save warnings/boilerplate of simple test code
+ ac_outfile=conftest.$ac_objext
+echo "$lt_simple_compile_test_code" >conftest.$ac_ext
+eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err
+_lt_compiler_boilerplate=`cat conftest.err`
+$RM conftest*
+
+ ac_outfile=conftest.$ac_objext
+echo "$lt_simple_link_test_code" >conftest.$ac_ext
+eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err
+_lt_linker_boilerplate=`cat conftest.err`
+$RM -r conftest*
+
+
+ # Allow CC to be a program name with arguments.
+ lt_save_CC="$CC"
+ lt_save_GCC=$GCC
+ lt_save_CFLAGS=$CFLAGS
+ CC=${FC-"f95"}
+ CFLAGS=$FCFLAGS
+ compiler=$CC
+ GCC=$ac_cv_fc_compiler_gnu
+
+ compiler_FC=$CC
+ for cc_temp in $compiler""; do
+ case $cc_temp in
+ compile | *[\\/]compile | ccache | *[\\/]ccache ) ;;
+ distcc | *[\\/]distcc | purify | *[\\/]purify ) ;;
+ \-*) ;;
+ *) break;;
+ esac
+done
+cc_basename=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"`
+
+
+ if test -n "$compiler"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if libtool supports shared libraries" >&5
+$as_echo_n "checking if libtool supports shared libraries... " >&6; }
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $can_build_shared" >&5
+$as_echo "$can_build_shared" >&6; }
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries" >&5
+$as_echo_n "checking whether to build shared libraries... " >&6; }
+ test "$can_build_shared" = "no" && enable_shared=no
+
+ # On AIX, shared libraries and static libraries use the same namespace, and
+ # are all built from PIC.
+ case $host_os in
+ aix3*)
+ test "$enable_shared" = yes && enable_static=no
+ if test -n "$RANLIB"; then
+ archive_cmds="$archive_cmds~\$RANLIB \$lib"
+ postinstall_cmds='$RANLIB $lib'
+ fi
+ ;;
+ aix[4-9]*)
+ if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then
+ test "$enable_shared" = yes && enable_static=no
+ fi
+ ;;
+ esac
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_shared" >&5
+$as_echo "$enable_shared" >&6; }
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build static libraries" >&5
+$as_echo_n "checking whether to build static libraries... " >&6; }
+ # Make sure either enable_shared or enable_static is yes.
+ test "$enable_shared" = yes || enable_static=yes
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_static" >&5
+$as_echo "$enable_static" >&6; }
+
+ GCC_FC="$ac_cv_fc_compiler_gnu"
+ LD_FC="$LD"
+
+ ## CAVEAT EMPTOR:
+ ## There is no encapsulation within the following macros, do not change
+ ## the running order or otherwise move them around unless you know exactly
+ ## what you are doing...
+ # Dependencies to place before and after the object being linked:
+predep_objects_FC=
+postdep_objects_FC=
+predeps_FC=
+postdeps_FC=
+compiler_lib_search_path_FC=
+
+cat > conftest.$ac_ext <<_LT_EOF
+ subroutine foo
+ implicit none
+ integer a
+ a=0
+ return
+ end
+_LT_EOF
+
+
+_lt_libdeps_save_CFLAGS=$CFLAGS
+case "$CC $CFLAGS " in #(
+*\ -flto*\ *) CFLAGS="$CFLAGS -fno-lto" ;;
+*\ -fwhopr*\ *) CFLAGS="$CFLAGS -fno-whopr" ;;
+esac
+
+if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; then
+ # Parse the compiler output and extract the necessary
+ # objects, libraries and library flags.
+
+ # Sentinel used to keep track of whether or not we are before
+ # the conftest object file.
+ pre_test_object_deps_done=no
+
+ for p in `eval "$output_verbose_link_cmd"`; do
+ case ${prev}${p} in
+
+ -L* | -R* | -l*)
+ # Some compilers place space between "-{L,R}" and the path.
+ # Remove the space.
+ if test $p = "-L" ||
+ test $p = "-R"; then
+ prev=$p
+ continue
+ fi
+
+ # Expand the sysroot to ease extracting the directories later.
+ if test -z "$prev"; then
+ case $p in
+ -L*) func_stripname_cnf '-L' '' "$p"; prev=-L; p=$func_stripname_result ;;
+ -R*) func_stripname_cnf '-R' '' "$p"; prev=-R; p=$func_stripname_result ;;
+ -l*) func_stripname_cnf '-l' '' "$p"; prev=-l; p=$func_stripname_result ;;
+ esac
+ fi
+ case $p in
+ =*) func_stripname_cnf '=' '' "$p"; p=$lt_sysroot$func_stripname_result ;;
+ esac
+ if test "$pre_test_object_deps_done" = no; then
+ case ${prev} in
+ -L | -R)
+ # Internal compiler library paths should come after those
+ # provided the user. The postdeps already come after the
+ # user supplied libs so there is no need to process them.
+ if test -z "$compiler_lib_search_path_FC"; then
+ compiler_lib_search_path_FC="${prev}${p}"
+ else
+ compiler_lib_search_path_FC="${compiler_lib_search_path_FC} ${prev}${p}"
+ fi
+ ;;
+ # The "-l" case would never come before the object being
+ # linked, so don't bother handling this case.
+ esac
+ else
+ if test -z "$postdeps_FC"; then
+ postdeps_FC="${prev}${p}"
+ else
+ postdeps_FC="${postdeps_FC} ${prev}${p}"
+ fi
+ fi
+ prev=
+ ;;
+
+ *.lto.$objext) ;; # Ignore GCC LTO objects
+ *.$objext)
+ # This assumes that the test object file only shows up
+ # once in the compiler output.
+ if test "$p" = "conftest.$objext"; then
+ pre_test_object_deps_done=yes
+ continue
+ fi
+
+ if test "$pre_test_object_deps_done" = no; then
+ if test -z "$predep_objects_FC"; then
+ predep_objects_FC="$p"
+ else
+ predep_objects_FC="$predep_objects_FC $p"
+ fi
+ else
+ if test -z "$postdep_objects_FC"; then
+ postdep_objects_FC="$p"
+ else
+ postdep_objects_FC="$postdep_objects_FC $p"
+ fi
+ fi
+ ;;
+
+ *) ;; # Ignore the rest.
+
+ esac
+ done
+
+ # Clean up.
+ rm -f a.out a.exe
+else
+ echo "libtool.m4: error: problem compiling FC test program"
+fi
+
+$RM -f confest.$objext
+CFLAGS=$_lt_libdeps_save_CFLAGS
+
+# PORTME: override above test on systems where it is broken
+
+
+case " $postdeps_FC " in
+*" -lc "*) archive_cmds_need_lc_FC=no ;;
+esac
+ compiler_lib_search_dirs_FC=
+if test -n "${compiler_lib_search_path_FC}"; then
+ compiler_lib_search_dirs_FC=`echo " ${compiler_lib_search_path_FC}" | ${SED} -e 's! -L! !g' -e 's!^ !!'`
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ lt_prog_compiler_wl_FC=
+lt_prog_compiler_pic_FC=
+lt_prog_compiler_static_FC=
+
+
+ if test "$GCC" = yes; then
+ lt_prog_compiler_wl_FC='-Wl,'
+ lt_prog_compiler_static_FC='-static'
+
+ case $host_os in
+ aix*)
+ # All AIX code is PIC.
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ lt_prog_compiler_static_FC='-Bstatic'
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ lt_prog_compiler_pic_FC='-fPIC'
+ ;;
+ m68k)
+ # FIXME: we need at least 68020 code to build shared libraries, but
+ # adding the `-m68020' flag to GCC prevents building anything better,
+ # like `-m68040'.
+ lt_prog_compiler_pic_FC='-m68020 -resident32 -malways-restore-a4'
+ ;;
+ esac
+ ;;
+
+ beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*)
+ # PIC is the default for these OSes.
+ ;;
+
+ mingw* | cygwin* | pw32* | os2* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ # Although the cygwin gcc ignores -fPIC, still need this for old-style
+ # (--disable-auto-import) libraries
+ lt_prog_compiler_pic_FC='-DDLL_EXPORT'
+ ;;
+
+ darwin* | rhapsody*)
+ # PIC is the default on this platform
+ # Common symbols not allowed in MH_DYLIB files
+ lt_prog_compiler_pic_FC='-fno-common'
+ ;;
+
+ haiku*)
+ # PIC is the default for Haiku.
+ # The "-static" flag exists, but is broken.
+ lt_prog_compiler_static_FC=
+ ;;
+
+ hpux*)
+ # PIC is the default for 64-bit PA HP-UX, but not for 32-bit
+ # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag
+ # sets the default TLS model and affects inlining.
+ case $host_cpu in
+ hppa*64*)
+ # +Z the default
+ ;;
+ *)
+ lt_prog_compiler_pic_FC='-fPIC'
+ ;;
+ esac
+ ;;
+
+ interix[3-9]*)
+ # Interix 3.x gcc -fpic/-fPIC options generate broken code.
+ # Instead, we relocate shared libraries at runtime.
+ ;;
+
+ msdosdjgpp*)
+ # Just because we use GCC doesn't mean we suddenly get shared libraries
+ # on systems that don't support them.
+ lt_prog_compiler_can_build_shared_FC=no
+ enable_shared=no
+ ;;
+
+ *nto* | *qnx*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ lt_prog_compiler_pic_FC='-fPIC -shared'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ lt_prog_compiler_pic_FC=-Kconform_pic
+ fi
+ ;;
+
+ *)
+ lt_prog_compiler_pic_FC='-fPIC'
+ ;;
+ esac
+
+ case $cc_basename in
+ nvcc*) # Cuda Compiler Driver 2.2
+ lt_prog_compiler_wl_FC='-Xlinker '
+ lt_prog_compiler_pic_FC='-Xcompiler -fPIC'
+ ;;
+ esac
+ else
+ # PORTME Check for flag to pass linker flags through the system compiler.
+ case $host_os in
+ aix*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ lt_prog_compiler_static_FC='-Bstatic'
+ else
+ lt_prog_compiler_static_FC='-bnso -bI:/lib/syscalls.exp'
+ fi
+ ;;
+
+ mingw* | cygwin* | pw32* | os2* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ lt_prog_compiler_pic_FC='-DDLL_EXPORT'
+ ;;
+
+ hpux9* | hpux10* | hpux11*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ # PIC is the default for IA64 HP-UX and 64-bit HP-UX, but
+ # not for PA HP-UX.
+ case $host_cpu in
+ hppa*64*|ia64*)
+ # +Z the default
+ ;;
+ *)
+ lt_prog_compiler_pic_FC='+Z'
+ ;;
+ esac
+ # Is there a better lt_prog_compiler_static that works with the bundled CC?
+ lt_prog_compiler_static_FC='${wl}-a ${wl}archive'
+ ;;
+
+ irix5* | irix6* | nonstopux*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ # PIC (with -KPIC) is the default.
+ lt_prog_compiler_static_FC='-non_shared'
+ ;;
+
+ linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ case $cc_basename in
+ # old Intel for x86_64 which still supported -KPIC.
+ ecc*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ lt_prog_compiler_pic_FC='-KPIC'
+ lt_prog_compiler_static_FC='-static'
+ ;;
+ # icc used to be incompatible with GCC.
+ # ICC 10 doesn't accept -KPIC any more.
+ icc* | ifort*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ lt_prog_compiler_pic_FC='-fPIC'
+ lt_prog_compiler_static_FC='-static'
+ ;;
+ # Lahey Fortran 8.1.
+ lf95*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ lt_prog_compiler_pic_FC='--shared'
+ lt_prog_compiler_static_FC='--static'
+ ;;
+ nagfor*)
+ # NAG Fortran compiler
+ lt_prog_compiler_wl_FC='-Wl,-Wl,,'
+ lt_prog_compiler_pic_FC='-PIC'
+ lt_prog_compiler_static_FC='-Bstatic'
+ ;;
+ pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*)
+ # Portland Group compilers (*not* the Pentium gcc compiler,
+ # which looks to be a dead project)
+ lt_prog_compiler_wl_FC='-Wl,'
+ lt_prog_compiler_pic_FC='-fpic'
+ lt_prog_compiler_static_FC='-Bstatic'
+ ;;
+ ccc*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ # All Alpha code is PIC.
+ lt_prog_compiler_static_FC='-non_shared'
+ ;;
+ xl* | bgxl* | bgf* | mpixl*)
+ # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene
+ lt_prog_compiler_wl_FC='-Wl,'
+ lt_prog_compiler_pic_FC='-qpic'
+ lt_prog_compiler_static_FC='-qstaticlink'
+ ;;
+ *)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ F* | *Sun*Fortran*)
+ # Sun Fortran 8.3 passes all unrecognized flags to the linker
+ lt_prog_compiler_pic_FC='-KPIC'
+ lt_prog_compiler_static_FC='-Bstatic'
+ lt_prog_compiler_wl_FC=''
+ ;;
+ *Sun\ C*)
+ # Sun C 5.9
+ lt_prog_compiler_pic_FC='-KPIC'
+ lt_prog_compiler_static_FC='-Bstatic'
+ lt_prog_compiler_wl_FC='-Wl,'
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+
+ newsos6)
+ lt_prog_compiler_pic_FC='-KPIC'
+ lt_prog_compiler_static_FC='-Bstatic'
+ ;;
+
+ *nto* | *qnx*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ lt_prog_compiler_pic_FC='-fPIC -shared'
+ ;;
+
+ osf3* | osf4* | osf5*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ # All OSF/1 code is PIC.
+ lt_prog_compiler_static_FC='-non_shared'
+ ;;
+
+ rdos*)
+ lt_prog_compiler_static_FC='-non_shared'
+ ;;
+
+ solaris*)
+ lt_prog_compiler_pic_FC='-KPIC'
+ lt_prog_compiler_static_FC='-Bstatic'
+ case $cc_basename in
+ f77* | f90* | f95* | sunf77* | sunf90* | sunf95*)
+ lt_prog_compiler_wl_FC='-Qoption ld ';;
+ *)
+ lt_prog_compiler_wl_FC='-Wl,';;
+ esac
+ ;;
+
+ sunos4*)
+ lt_prog_compiler_wl_FC='-Qoption ld '
+ lt_prog_compiler_pic_FC='-PIC'
+ lt_prog_compiler_static_FC='-Bstatic'
+ ;;
+
+ sysv4 | sysv4.2uw2* | sysv4.3*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ lt_prog_compiler_pic_FC='-KPIC'
+ lt_prog_compiler_static_FC='-Bstatic'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec ;then
+ lt_prog_compiler_pic_FC='-Kconform_pic'
+ lt_prog_compiler_static_FC='-Bstatic'
+ fi
+ ;;
+
+ sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ lt_prog_compiler_pic_FC='-KPIC'
+ lt_prog_compiler_static_FC='-Bstatic'
+ ;;
+
+ unicos*)
+ lt_prog_compiler_wl_FC='-Wl,'
+ lt_prog_compiler_can_build_shared_FC=no
+ ;;
+
+ uts4*)
+ lt_prog_compiler_pic_FC='-pic'
+ lt_prog_compiler_static_FC='-Bstatic'
+ ;;
+
+ *)
+ lt_prog_compiler_can_build_shared_FC=no
+ ;;
+ esac
+ fi
+
+case $host_os in
+ # For platforms which do not support PIC, -DPIC is meaningless:
+ *djgpp*)
+ lt_prog_compiler_pic_FC=
+ ;;
+ *)
+ lt_prog_compiler_pic_FC="$lt_prog_compiler_pic_FC"
+ ;;
+esac
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $compiler option to produce PIC" >&5
+$as_echo_n "checking for $compiler option to produce PIC... " >&6; }
+if ${lt_cv_prog_compiler_pic_FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_pic_FC=$lt_prog_compiler_pic_FC
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_FC" >&5
+$as_echo "$lt_cv_prog_compiler_pic_FC" >&6; }
+lt_prog_compiler_pic_FC=$lt_cv_prog_compiler_pic_FC
+
+#
+# Check to make sure the PIC flag actually works.
+#
+if test -n "$lt_prog_compiler_pic_FC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler PIC flag $lt_prog_compiler_pic_FC works" >&5
+$as_echo_n "checking if $compiler PIC flag $lt_prog_compiler_pic_FC works... " >&6; }
+if ${lt_cv_prog_compiler_pic_works_FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_pic_works_FC=no
+ ac_outfile=conftest.$ac_objext
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+ lt_compiler_flag="$lt_prog_compiler_pic_FC"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ # The option is referenced via a variable to avoid confusing sed.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_pic_works_FC=yes
+ fi
+ fi
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_works_FC" >&5
+$as_echo "$lt_cv_prog_compiler_pic_works_FC" >&6; }
+
+if test x"$lt_cv_prog_compiler_pic_works_FC" = xyes; then
+ case $lt_prog_compiler_pic_FC in
+ "" | " "*) ;;
+ *) lt_prog_compiler_pic_FC=" $lt_prog_compiler_pic_FC" ;;
+ esac
+else
+ lt_prog_compiler_pic_FC=
+ lt_prog_compiler_can_build_shared_FC=no
+fi
+
+fi
+
+
+
+
+
+#
+# Check to make sure the static flag actually works.
+#
+wl=$lt_prog_compiler_wl_FC eval lt_tmp_static_flag=\"$lt_prog_compiler_static_FC\"
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler static flag $lt_tmp_static_flag works" >&5
+$as_echo_n "checking if $compiler static flag $lt_tmp_static_flag works... " >&6; }
+if ${lt_cv_prog_compiler_static_works_FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_static_works_FC=no
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS $lt_tmp_static_flag"
+ echo "$lt_simple_link_test_code" > conftest.$ac_ext
+ if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then
+ # The linker can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ if test -s conftest.err; then
+ # Append any errors to the config.log.
+ cat conftest.err 1>&5
+ $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if diff conftest.exp conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_static_works_FC=yes
+ fi
+ else
+ lt_cv_prog_compiler_static_works_FC=yes
+ fi
+ fi
+ $RM -r conftest*
+ LDFLAGS="$save_LDFLAGS"
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_static_works_FC" >&5
+$as_echo "$lt_cv_prog_compiler_static_works_FC" >&6; }
+
+if test x"$lt_cv_prog_compiler_static_works_FC" = xyes; then
+ :
+else
+ lt_prog_compiler_static_FC=
+fi
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5
+$as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; }
+if ${lt_cv_prog_compiler_c_o_FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_c_o_FC=no
+ $RM -r conftest 2>/dev/null
+ mkdir conftest
+ cd conftest
+ mkdir out
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ lt_compiler_flag="-o out/conftest2.$ac_objext"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp
+ $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2
+ if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_c_o_FC=yes
+ fi
+ fi
+ chmod u+w . 2>&5
+ $RM conftest*
+ # SGI C++ compiler will create directory out/ii_files/ for
+ # template instantiation
+ test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files
+ $RM out/* && rmdir out
+ cd ..
+ $RM -r conftest
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o_FC" >&5
+$as_echo "$lt_cv_prog_compiler_c_o_FC" >&6; }
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5
+$as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; }
+if ${lt_cv_prog_compiler_c_o_FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_prog_compiler_c_o_FC=no
+ $RM -r conftest 2>/dev/null
+ mkdir conftest
+ cd conftest
+ mkdir out
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ lt_compiler_flag="-o out/conftest2.$ac_objext"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp
+ $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2
+ if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then
+ lt_cv_prog_compiler_c_o_FC=yes
+ fi
+ fi
+ chmod u+w . 2>&5
+ $RM conftest*
+ # SGI C++ compiler will create directory out/ii_files/ for
+ # template instantiation
+ test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files
+ $RM out/* && rmdir out
+ cd ..
+ $RM -r conftest
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o_FC" >&5
+$as_echo "$lt_cv_prog_compiler_c_o_FC" >&6; }
+
+
+
+
+hard_links="nottested"
+if test "$lt_cv_prog_compiler_c_o_FC" = no && test "$need_locks" != no; then
+ # do not overwrite the value of need_locks provided by the user
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if we can lock with hard links" >&5
+$as_echo_n "checking if we can lock with hard links... " >&6; }
+ hard_links=yes
+ $RM conftest*
+ ln conftest.a conftest.b 2>/dev/null && hard_links=no
+ touch conftest.a
+ ln conftest.a conftest.b 2>&5 || hard_links=no
+ ln conftest.a conftest.b 2>/dev/null && hard_links=no
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hard_links" >&5
+$as_echo "$hard_links" >&6; }
+ if test "$hard_links" = no; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \`$CC' does not support \`-c -o', so \`make -j' may be unsafe" >&5
+$as_echo "$as_me: WARNING: \`$CC' does not support \`-c -o', so \`make -j' may be unsafe" >&2;}
+ need_locks=warn
+ fi
+else
+ need_locks=no
+fi
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $compiler linker ($LD) supports shared libraries" >&5
+$as_echo_n "checking whether the $compiler linker ($LD) supports shared libraries... " >&6; }
+
+ runpath_var=
+ allow_undefined_flag_FC=
+ always_export_symbols_FC=no
+ archive_cmds_FC=
+ archive_expsym_cmds_FC=
+ compiler_needs_object_FC=no
+ enable_shared_with_static_runtimes_FC=no
+ export_dynamic_flag_spec_FC=
+ export_symbols_cmds_FC='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols'
+ hardcode_automatic_FC=no
+ hardcode_direct_FC=no
+ hardcode_direct_absolute_FC=no
+ hardcode_libdir_flag_spec_FC=
+ hardcode_libdir_flag_spec_ld_FC=
+ hardcode_libdir_separator_FC=
+ hardcode_minus_L_FC=no
+ hardcode_shlibpath_var_FC=unsupported
+ inherit_rpath_FC=no
+ link_all_deplibs_FC=unknown
+ module_cmds_FC=
+ module_expsym_cmds_FC=
+ old_archive_from_new_cmds_FC=
+ old_archive_from_expsyms_cmds_FC=
+ thread_safe_flag_spec_FC=
+ whole_archive_flag_spec_FC=
+ # include_expsyms should be a list of space-separated symbols to be *always*
+ # included in the symbol list
+ include_expsyms_FC=
+ # exclude_expsyms can be an extended regexp of symbols to exclude
+ # it will be wrapped by ` (' and `)$', so one must not match beginning or
+ # end of line. Example: `a|bc|.*d.*' will exclude the symbols `a' and `bc',
+ # as well as any symbol that contains `d'.
+ exclude_expsyms_FC='_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*'
+ # Although _GLOBAL_OFFSET_TABLE_ is a valid symbol C name, most a.out
+ # platforms (ab)use it in PIC code, but their linkers get confused if
+ # the symbol is explicitly referenced. Since portable code cannot
+ # rely on this symbol name, it's probably fine to never include it in
+ # preloaded symbol tables.
+ # Exclude shared library initialization/finalization symbols.
+ extract_expsyms_cmds=
+
+ case $host_os in
+ cygwin* | mingw* | pw32* | cegcc*)
+ # FIXME: the MSVC++ port hasn't been tested in a loooong time
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ if test "$GCC" != yes; then
+ with_gnu_ld=no
+ fi
+ ;;
+ interix*)
+ # we just hope/assume this is gcc and not c89 (= MSVC++)
+ with_gnu_ld=yes
+ ;;
+ openbsd*)
+ with_gnu_ld=no
+ ;;
+ esac
+
+ ld_shlibs_FC=yes
+
+ # On some targets, GNU ld is compatible enough with the native linker
+ # that we're better off using the native interface for both.
+ lt_use_gnu_ld_interface=no
+ if test "$with_gnu_ld" = yes; then
+ case $host_os in
+ aix*)
+ # The AIX port of GNU ld has always aspired to compatibility
+ # with the native linker. However, as the warning in the GNU ld
+ # block says, versions before 2.19.5* couldn't really create working
+ # shared libraries, regardless of the interface used.
+ case `$LD -v 2>&1` in
+ *\ \(GNU\ Binutils\)\ 2.19.5*) ;;
+ *\ \(GNU\ Binutils\)\ 2.[2-9]*) ;;
+ *\ \(GNU\ Binutils\)\ [3-9]*) ;;
+ *)
+ lt_use_gnu_ld_interface=yes
+ ;;
+ esac
+ ;;
+ *)
+ lt_use_gnu_ld_interface=yes
+ ;;
+ esac
+ fi
+
+ if test "$lt_use_gnu_ld_interface" = yes; then
+ # If archive_cmds runs LD, not CC, wlarc should be empty
+ wlarc='${wl}'
+
+ # Set some defaults for GNU ld with shared library support. These
+ # are reset later if shared libraries are not supported. Putting them
+ # here allows them to be overridden if necessary.
+ runpath_var=LD_RUN_PATH
+ hardcode_libdir_flag_spec_FC='${wl}-rpath ${wl}$libdir'
+ export_dynamic_flag_spec_FC='${wl}--export-dynamic'
+ # ancient GNU ld didn't support --whole-archive et. al.
+ if $LD --help 2>&1 | $GREP 'no-whole-archive' > /dev/null; then
+ whole_archive_flag_spec_FC="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive'
+ else
+ whole_archive_flag_spec_FC=
+ fi
+ supports_anon_versioning=no
+ case `$LD -v 2>&1` in
+ *GNU\ gold*) supports_anon_versioning=yes ;;
+ *\ [01].* | *\ 2.[0-9].* | *\ 2.10.*) ;; # catch versions < 2.11
+ *\ 2.11.93.0.2\ *) supports_anon_versioning=yes ;; # RH7.3 ...
+ *\ 2.11.92.0.12\ *) supports_anon_versioning=yes ;; # Mandrake 8.2 ...
+ *\ 2.11.*) ;; # other 2.11 versions
+ *) supports_anon_versioning=yes ;;
+ esac
+
+ # See if GNU ld supports shared libraries.
+ case $host_os in
+ aix[3-9]*)
+ # On AIX/PPC, the GNU linker is very broken
+ if test "$host_cpu" != ia64; then
+ ld_shlibs_FC=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: the GNU linker, at least up to release 2.19, is reported
+*** to be unable to reliably create shared libraries on AIX.
+*** Therefore, libtool is disabling shared libraries support. If you
+*** really care for shared libraries, you may want to install binutils
+*** 2.20 or above, or modify your PATH so that a non-GNU linker is found.
+*** You will then need to restart the configuration process.
+
+_LT_EOF
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ archive_cmds_FC='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_FC=''
+ ;;
+ m68k)
+ archive_cmds_FC='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)'
+ hardcode_libdir_flag_spec_FC='-L$libdir'
+ hardcode_minus_L_FC=yes
+ ;;
+ esac
+ ;;
+
+ beos*)
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ allow_undefined_flag_FC=unsupported
+ # Joseph Beckenbach <jrb3@best.com> says some releases of gcc
+ # support --undefined. This deserves some investigation. FIXME
+ archive_cmds_FC='$CC -nostart $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ else
+ ld_shlibs_FC=no
+ fi
+ ;;
+
+ cygwin* | mingw* | pw32* | cegcc*)
+ # _LT_TAGVAR(hardcode_libdir_flag_spec, FC) is actually meaningless,
+ # as there is no search path for DLLs.
+ hardcode_libdir_flag_spec_FC='-L$libdir'
+ export_dynamic_flag_spec_FC='${wl}--export-all-symbols'
+ allow_undefined_flag_FC=unsupported
+ always_export_symbols_FC=no
+ enable_shared_with_static_runtimes_FC=yes
+ export_symbols_cmds_FC='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1 DATA/;s/^.*[ ]__nm__\([^ ]*\)[ ][^ ]*/\1 DATA/;/^I[ ]/d;/^[AITW][ ]/s/.* //'\'' | sort | uniq > $export_symbols'
+ exclude_expsyms_FC='[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname'
+
+ if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then
+ archive_cmds_FC='$CC -shared $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ # If the export-symbols file already is a .def file (1st line
+ # is EXPORTS), use it as is; otherwise, prepend...
+ archive_expsym_cmds_FC='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ cp $export_symbols $output_objdir/$soname.def;
+ else
+ echo EXPORTS > $output_objdir/$soname.def;
+ cat $export_symbols >> $output_objdir/$soname.def;
+ fi~
+ $CC -shared $output_objdir/$soname.def $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ else
+ ld_shlibs_FC=no
+ fi
+ ;;
+
+ haiku*)
+ archive_cmds_FC='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ link_all_deplibs_FC=yes
+ ;;
+
+ interix[3-9]*)
+ hardcode_direct_FC=no
+ hardcode_shlibpath_var_FC=no
+ hardcode_libdir_flag_spec_FC='${wl}-rpath,$libdir'
+ export_dynamic_flag_spec_FC='${wl}-E'
+ # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc.
+ # Instead, shared libraries are loaded at an image base (0x10000000 by
+ # default) and relocated if they conflict, which is a slow very memory
+ # consuming and fragmenting process. To avoid this, we pick a random,
+ # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link
+ # time. Moving up from 0x10000000 also allows more sbrk(2) space.
+ archive_cmds_FC='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ archive_expsym_cmds_FC='sed "s,^,_," $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--retain-symbols-file,$output_objdir/$soname.expsym ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ ;;
+
+ gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu)
+ tmp_diet=no
+ if test "$host_os" = linux-dietlibc; then
+ case $cc_basename in
+ diet\ *) tmp_diet=yes;; # linux-dietlibc with static linking (!diet-dyn)
+ esac
+ fi
+ if $LD --help 2>&1 | $EGREP ': supported targets:.* elf' > /dev/null \
+ && test "$tmp_diet" = no
+ then
+ tmp_addflag=' $pic_flag'
+ tmp_sharedflag='-shared'
+ case $cc_basename,$host_cpu in
+ pgcc*) # Portland Group C compiler
+ whole_archive_flag_spec_FC='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ tmp_addflag=' $pic_flag'
+ ;;
+ pgf77* | pgf90* | pgf95* | pgfortran*)
+ # Portland Group f77 and f90 compilers
+ whole_archive_flag_spec_FC='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ tmp_addflag=' $pic_flag -Mnomain' ;;
+ ecc*,ia64* | icc*,ia64*) # Intel C compiler on ia64
+ tmp_addflag=' -i_dynamic' ;;
+ efc*,ia64* | ifort*,ia64*) # Intel Fortran compiler on ia64
+ tmp_addflag=' -i_dynamic -nofor_main' ;;
+ ifc* | ifort*) # Intel Fortran compiler
+ tmp_addflag=' -nofor_main' ;;
+ lf95*) # Lahey Fortran 8.1
+ whole_archive_flag_spec_FC=
+ tmp_sharedflag='--shared' ;;
+ xl[cC]* | bgxl[cC]* | mpixl[cC]*) # IBM XL C 8.0 on PPC (deal with xlf below)
+ tmp_sharedflag='-qmkshrobj'
+ tmp_addflag= ;;
+ nvcc*) # Cuda Compiler Driver 2.2
+ whole_archive_flag_spec_FC='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ compiler_needs_object_FC=yes
+ ;;
+ esac
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*) # Sun C 5.9
+ whole_archive_flag_spec_FC='${wl}--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ compiler_needs_object_FC=yes
+ tmp_sharedflag='-G' ;;
+ *Sun\ F*) # Sun Fortran 8.3
+ tmp_sharedflag='-G' ;;
+ esac
+ archive_cmds_FC='$CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+
+ if test "x$supports_anon_versioning" = xyes; then
+ archive_expsym_cmds_FC='echo "{ global:" > $output_objdir/$libname.ver~
+ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~
+ echo "local: *; };" >> $output_objdir/$libname.ver~
+ $CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-version-script ${wl}$output_objdir/$libname.ver -o $lib'
+ fi
+
+ case $cc_basename in
+ xlf* | bgf* | bgxlf* | mpixlf*)
+ # IBM XL Fortran 10.1 on PPC cannot create shared libs itself
+ whole_archive_flag_spec_FC='--whole-archive$convenience --no-whole-archive'
+ hardcode_libdir_flag_spec_FC=
+ hardcode_libdir_flag_spec_ld_FC='-rpath $libdir'
+ archive_cmds_FC='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib'
+ if test "x$supports_anon_versioning" = xyes; then
+ archive_expsym_cmds_FC='echo "{ global:" > $output_objdir/$libname.ver~
+ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~
+ echo "local: *; };" >> $output_objdir/$libname.ver~
+ $LD -shared $libobjs $deplibs $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib'
+ fi
+ ;;
+ esac
+ else
+ ld_shlibs_FC=no
+ fi
+ ;;
+
+ netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ archive_cmds_FC='$LD -Bshareable $libobjs $deplibs $linker_flags -o $lib'
+ wlarc=
+ else
+ archive_cmds_FC='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_FC='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ fi
+ ;;
+
+ solaris*)
+ if $LD -v 2>&1 | $GREP 'BFD 2\.8' > /dev/null; then
+ ld_shlibs_FC=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: The releases 2.8.* of the GNU linker cannot reliably
+*** create shared libraries on Solaris systems. Therefore, libtool
+*** is disabling shared libraries support. We urge you to upgrade GNU
+*** binutils to release 2.9.1 or newer. Another option is to modify
+*** your PATH or compiler configuration so that the native linker is
+*** used, and then restart.
+
+_LT_EOF
+ elif $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ archive_cmds_FC='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_FC='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ ld_shlibs_FC=no
+ fi
+ ;;
+
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*)
+ case `$LD -v 2>&1` in
+ *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*)
+ ld_shlibs_FC=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: Releases of the GNU linker prior to 2.16.91.0.3 can not
+*** reliably create shared libraries on SCO systems. Therefore, libtool
+*** is disabling shared libraries support. We urge you to upgrade GNU
+*** binutils to release 2.16.91.0.3 or newer. Another option is to modify
+*** your PATH or compiler configuration so that the native linker is
+*** used, and then restart.
+
+_LT_EOF
+ ;;
+ *)
+ # For security reasons, it is highly recommended that you always
+ # use absolute paths for naming shared libraries, and exclude the
+ # DT_RUNPATH tag from executables and libraries. But doing so
+ # requires that you compile everything twice, which is a pain.
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ hardcode_libdir_flag_spec_FC='${wl}-rpath ${wl}$libdir'
+ archive_cmds_FC='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_FC='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ ld_shlibs_FC=no
+ fi
+ ;;
+ esac
+ ;;
+
+ sunos4*)
+ archive_cmds_FC='$LD -assert pure-text -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ wlarc=
+ hardcode_direct_FC=yes
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ *)
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ archive_cmds_FC='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_FC='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ ld_shlibs_FC=no
+ fi
+ ;;
+ esac
+
+ if test "$ld_shlibs_FC" = no; then
+ runpath_var=
+ hardcode_libdir_flag_spec_FC=
+ export_dynamic_flag_spec_FC=
+ whole_archive_flag_spec_FC=
+ fi
+ else
+ # PORTME fill in a description of your system's linker (not GNU ld)
+ case $host_os in
+ aix3*)
+ allow_undefined_flag_FC=unsupported
+ always_export_symbols_FC=yes
+ archive_expsym_cmds_FC='$LD -o $output_objdir/$soname $libobjs $deplibs $linker_flags -bE:$export_symbols -T512 -H512 -bM:SRE~$AR $AR_FLAGS $lib $output_objdir/$soname'
+ # Note: this linker hardcodes the directories in LIBPATH if there
+ # are no directories specified by -L.
+ hardcode_minus_L_FC=yes
+ if test "$GCC" = yes && test -z "$lt_prog_compiler_static"; then
+ # Neither direct hardcoding nor static linking is supported with a
+ # broken collect2.
+ hardcode_direct_FC=unsupported
+ fi
+ ;;
+
+ aix[4-9]*)
+ if test "$host_cpu" = ia64; then
+ # On IA64, the linker does run time linking by default, so we don't
+ # have to do anything special.
+ aix_use_runtimelinking=no
+ exp_sym_flag='-Bexport'
+ no_entry_flag=""
+ else
+ # If we're using GNU nm, then we don't want the "-C" option.
+ # -C means demangle to AIX nm, but means don't demangle with GNU nm
+ # Also, AIX nm treats weak defined symbols like other global
+ # defined symbols, whereas GNU nm marks them as "W".
+ if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then
+ export_symbols_cmds_FC='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && (substr(\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ else
+ export_symbols_cmds_FC='$NM -BCpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && (substr(\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ fi
+ aix_use_runtimelinking=no
+
+ # Test if we are trying to use run time linking or normal
+ # AIX style linking. If -brtl is somewhere in LDFLAGS, we
+ # need to do runtime linking.
+ case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*)
+ for ld_flag in $LDFLAGS; do
+ if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then
+ aix_use_runtimelinking=yes
+ break
+ fi
+ done
+ ;;
+ esac
+
+ exp_sym_flag='-bexport'
+ no_entry_flag='-bnoentry'
+ fi
+
+ # When large executables or shared objects are built, AIX ld can
+ # have problems creating the table of contents. If linking a library
+ # or program results in "error TOC overflow" add -mminimal-toc to
+ # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not
+ # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS.
+
+ archive_cmds_FC=''
+ hardcode_direct_FC=yes
+ hardcode_direct_absolute_FC=yes
+ hardcode_libdir_separator_FC=':'
+ link_all_deplibs_FC=yes
+ file_list_spec_FC='${wl}-f,'
+
+ if test "$GCC" = yes; then
+ case $host_os in aix4.[012]|aix4.[012].*)
+ # We only want to do this on AIX 4.2 and lower, the check
+ # below for broken collect2 doesn't work under 4.3+
+ collect2name=`${CC} -print-prog-name=collect2`
+ if test -f "$collect2name" &&
+ strings "$collect2name" | $GREP resolve_lib_name >/dev/null
+ then
+ # We have reworked collect2
+ :
+ else
+ # We have old collect2
+ hardcode_direct_FC=unsupported
+ # It fails to find uninstalled libraries when the uninstalled
+ # path is not listed in the libpath. Setting hardcode_minus_L
+ # to unsupported forces relinking
+ hardcode_minus_L_FC=yes
+ hardcode_libdir_flag_spec_FC='-L$libdir'
+ hardcode_libdir_separator_FC=
+ fi
+ ;;
+ esac
+ shared_flag='-shared'
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag="$shared_flag "'${wl}-G'
+ fi
+ else
+ # not using gcc
+ if test "$host_cpu" = ia64; then
+ # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release
+ # chokes on -Wl,-G. The following line is correct:
+ shared_flag='-G'
+ else
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag='${wl}-G'
+ else
+ shared_flag='${wl}-bM:SRE'
+ fi
+ fi
+ fi
+
+ export_dynamic_flag_spec_FC='${wl}-bexpall'
+ # It seems that -bexpall does not export symbols beginning with
+ # underscore (_), so it is better to generate a list of symbols to export.
+ always_export_symbols_FC=yes
+ if test "$aix_use_runtimelinking" = yes; then
+ # Warning - without using the other runtime loading flags (-brtl),
+ # -berok will link without error, but may produce a broken library.
+ allow_undefined_flag_FC='-berok'
+ # Determine the default libpath from the value encoded in an
+ # empty executable.
+ if test "${lt_cv_aix_libpath+set}" = set; then
+ aix_libpath=$lt_cv_aix_libpath
+else
+ if ${lt_cv_aix_libpath__FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_fc_try_link "$LINENO"; then :
+
+ lt_aix_libpath_sed='
+ /Import File Strings/,/^$/ {
+ /^0/ {
+ s/^0 *\([^ ]*\) *$/\1/
+ p
+ }
+ }'
+ lt_cv_aix_libpath__FC=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ # Check for a 64-bit object if we didn't find anything.
+ if test -z "$lt_cv_aix_libpath__FC"; then
+ lt_cv_aix_libpath__FC=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ fi
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ if test -z "$lt_cv_aix_libpath__FC"; then
+ lt_cv_aix_libpath__FC="/usr/lib:/lib"
+ fi
+
+fi
+
+ aix_libpath=$lt_cv_aix_libpath__FC
+fi
+
+ hardcode_libdir_flag_spec_FC='${wl}-blibpath:$libdir:'"$aix_libpath"
+ archive_expsym_cmds_FC='$CC -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags `if test "x${allow_undefined_flag}" != "x"; then func_echo_all "${wl}${allow_undefined_flag}"; else :; fi` '"\${wl}$exp_sym_flag:\$export_symbols $shared_flag"
+ else
+ if test "$host_cpu" = ia64; then
+ hardcode_libdir_flag_spec_FC='${wl}-R $libdir:/usr/lib:/lib'
+ allow_undefined_flag_FC="-z nodefs"
+ archive_expsym_cmds_FC="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags ${wl}${allow_undefined_flag} '"\${wl}$exp_sym_flag:\$export_symbols"
+ else
+ # Determine the default libpath from the value encoded in an
+ # empty executable.
+ if test "${lt_cv_aix_libpath+set}" = set; then
+ aix_libpath=$lt_cv_aix_libpath
+else
+ if ${lt_cv_aix_libpath__FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_fc_try_link "$LINENO"; then :
+
+ lt_aix_libpath_sed='
+ /Import File Strings/,/^$/ {
+ /^0/ {
+ s/^0 *\([^ ]*\) *$/\1/
+ p
+ }
+ }'
+ lt_cv_aix_libpath__FC=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ # Check for a 64-bit object if we didn't find anything.
+ if test -z "$lt_cv_aix_libpath__FC"; then
+ lt_cv_aix_libpath__FC=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ fi
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ if test -z "$lt_cv_aix_libpath__FC"; then
+ lt_cv_aix_libpath__FC="/usr/lib:/lib"
+ fi
+
+fi
+
+ aix_libpath=$lt_cv_aix_libpath__FC
+fi
+
+ hardcode_libdir_flag_spec_FC='${wl}-blibpath:$libdir:'"$aix_libpath"
+ # Warning - without using the other run time loading flags,
+ # -berok will link without error, but may produce a broken library.
+ no_undefined_flag_FC=' ${wl}-bernotok'
+ allow_undefined_flag_FC=' ${wl}-berok'
+ if test "$with_gnu_ld" = yes; then
+ # We only use this code for GNU lds that support --whole-archive.
+ whole_archive_flag_spec_FC='${wl}--whole-archive$convenience ${wl}--no-whole-archive'
+ else
+ # Exported symbols can be pulled into shared objects from archives
+ whole_archive_flag_spec_FC='$convenience'
+ fi
+ archive_cmds_need_lc_FC=yes
+ # This is similar to how AIX traditionally builds its shared libraries.
+ archive_expsym_cmds_FC="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs ${wl}-bnoentry $compiler_flags ${wl}-bE:$export_symbols${allow_undefined_flag}~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$soname'
+ fi
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ archive_cmds_FC='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ archive_expsym_cmds_FC=''
+ ;;
+ m68k)
+ archive_cmds_FC='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)'
+ hardcode_libdir_flag_spec_FC='-L$libdir'
+ hardcode_minus_L_FC=yes
+ ;;
+ esac
+ ;;
+
+ bsdi[45]*)
+ export_dynamic_flag_spec_FC=-rdynamic
+ ;;
+
+ cygwin* | mingw* | pw32* | cegcc*)
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ case $cc_basename in
+ cl*)
+ # Native MSVC
+ hardcode_libdir_flag_spec_FC=' '
+ allow_undefined_flag_FC=unsupported
+ always_export_symbols_FC=yes
+ file_list_spec_FC='@'
+ # Tell ltmain to make .lib files, not .a files.
+ libext=lib
+ # Tell ltmain to make .dll files, not .so files.
+ shrext_cmds=".dll"
+ # FIXME: Setting linknames here is a bad hack.
+ archive_cmds_FC='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-dll~linknames='
+ archive_expsym_cmds_FC='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ sed -n -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' -e '1\\\!p' < $export_symbols > $output_objdir/$soname.exp;
+ else
+ sed -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' < $export_symbols > $output_objdir/$soname.exp;
+ fi~
+ $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~
+ linknames='
+ # The linker will not automatically build a static lib if we build a DLL.
+ # _LT_TAGVAR(old_archive_from_new_cmds, FC)='true'
+ enable_shared_with_static_runtimes_FC=yes
+ export_symbols_cmds_FC='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1,DATA/'\'' | $SED -e '\''/^[AITW][ ]/s/.*[ ]//'\'' | sort | uniq > $export_symbols'
+ # Don't use ranlib
+ old_postinstall_cmds_FC='chmod 644 $oldlib'
+ postlink_cmds_FC='lt_outputfile="@OUTPUT@"~
+ lt_tool_outputfile="@TOOL_OUTPUT@"~
+ case $lt_outputfile in
+ *.exe|*.EXE) ;;
+ *)
+ lt_outputfile="$lt_outputfile.exe"
+ lt_tool_outputfile="$lt_tool_outputfile.exe"
+ ;;
+ esac~
+ if test "$MANIFEST_TOOL" != ":" && test -f "$lt_outputfile.manifest"; then
+ $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1;
+ $RM "$lt_outputfile.manifest";
+ fi'
+ ;;
+ *)
+ # Assume MSVC wrapper
+ hardcode_libdir_flag_spec_FC=' '
+ allow_undefined_flag_FC=unsupported
+ # Tell ltmain to make .lib files, not .a files.
+ libext=lib
+ # Tell ltmain to make .dll files, not .so files.
+ shrext_cmds=".dll"
+ # FIXME: Setting linknames here is a bad hack.
+ archive_cmds_FC='$CC -o $lib $libobjs $compiler_flags `func_echo_all "$deplibs" | $SED '\''s/ -lc$//'\''` -link -dll~linknames='
+ # The linker will automatically build a .lib file if we build a DLL.
+ old_archive_from_new_cmds_FC='true'
+ # FIXME: Should let the user specify the lib program.
+ old_archive_cmds_FC='lib -OUT:$oldlib$oldobjs$old_deplibs'
+ enable_shared_with_static_runtimes_FC=yes
+ ;;
+ esac
+ ;;
+
+ darwin* | rhapsody*)
+
+
+ archive_cmds_need_lc_FC=no
+ hardcode_direct_FC=no
+ hardcode_automatic_FC=yes
+ hardcode_shlibpath_var_FC=unsupported
+ if test "$lt_cv_ld_force_load" = "yes"; then
+ whole_archive_flag_spec_FC='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience ${wl}-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`'
+ else
+ whole_archive_flag_spec_FC=''
+ fi
+ link_all_deplibs_FC=yes
+ allow_undefined_flag_FC="$_lt_dar_allow_undefined"
+ case $cc_basename in
+ ifort*) _lt_dar_can_shared=yes ;;
+ *) _lt_dar_can_shared=$GCC ;;
+ esac
+ if test "$_lt_dar_can_shared" = "yes"; then
+ output_verbose_link_cmd=func_echo_all
+ archive_cmds_FC="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod${_lt_dsymutil}"
+ module_cmds_FC="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dsymutil}"
+ archive_expsym_cmds_FC="sed 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring ${_lt_dar_single_mod}${_lt_dar_export_syms}${_lt_dsymutil}"
+ module_expsym_cmds_FC="sed -e 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dar_export_syms}${_lt_dsymutil}"
+
+ else
+ ld_shlibs_FC=no
+ fi
+
+ ;;
+
+ dgux*)
+ archive_cmds_FC='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_libdir_flag_spec_FC='-L$libdir'
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ freebsd1*)
+ ld_shlibs_FC=no
+ ;;
+
+ # FreeBSD 2.2.[012] allows us to include c++rt0.o to get C++ constructor
+ # support. Future versions do this automatically, but an explicit c++rt0.o
+ # does not break anything, and helps significantly (at the cost of a little
+ # extra space).
+ freebsd2.2*)
+ archive_cmds_FC='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags /usr/lib/c++rt0.o'
+ hardcode_libdir_flag_spec_FC='-R$libdir'
+ hardcode_direct_FC=yes
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ # Unfortunately, older versions of FreeBSD 2 do not have this feature.
+ freebsd2*)
+ archive_cmds_FC='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct_FC=yes
+ hardcode_minus_L_FC=yes
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ # FreeBSD 3 and greater uses gcc -shared to do shared libraries.
+ freebsd* | dragonfly*)
+ archive_cmds_FC='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ hardcode_libdir_flag_spec_FC='-R$libdir'
+ hardcode_direct_FC=yes
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ hpux9*)
+ if test "$GCC" = yes; then
+ archive_cmds_FC='$RM $output_objdir/$soname~$CC -shared $pic_flag ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ else
+ archive_cmds_FC='$RM $output_objdir/$soname~$LD -b +b $install_libdir -o $output_objdir/$soname $libobjs $deplibs $linker_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ fi
+ hardcode_libdir_flag_spec_FC='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator_FC=:
+ hardcode_direct_FC=yes
+
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L_FC=yes
+ export_dynamic_flag_spec_FC='${wl}-E'
+ ;;
+
+ hpux10*)
+ if test "$GCC" = yes && test "$with_gnu_ld" = no; then
+ archive_cmds_FC='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds_FC='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags'
+ fi
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec_FC='${wl}+b ${wl}$libdir'
+ hardcode_libdir_flag_spec_ld_FC='+b $libdir'
+ hardcode_libdir_separator_FC=:
+ hardcode_direct_FC=yes
+ hardcode_direct_absolute_FC=yes
+ export_dynamic_flag_spec_FC='${wl}-E'
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L_FC=yes
+ fi
+ ;;
+
+ hpux11*)
+ if test "$GCC" = yes && test "$with_gnu_ld" = no; then
+ case $host_cpu in
+ hppa*64*)
+ archive_cmds_FC='$CC -shared ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ ia64*)
+ archive_cmds_FC='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ *)
+ archive_cmds_FC='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ esac
+ else
+ case $host_cpu in
+ hppa*64*)
+ archive_cmds_FC='$CC -b ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ ia64*)
+ archive_cmds_FC='$CC -b ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ *)
+ archive_cmds_FC='$CC -b ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ esac
+ fi
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec_FC='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator_FC=:
+
+ case $host_cpu in
+ hppa*64*|ia64*)
+ hardcode_direct_FC=no
+ hardcode_shlibpath_var_FC=no
+ ;;
+ *)
+ hardcode_direct_FC=yes
+ hardcode_direct_absolute_FC=yes
+ export_dynamic_flag_spec_FC='${wl}-E'
+
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L_FC=yes
+ ;;
+ esac
+ fi
+ ;;
+
+ irix5* | irix6* | nonstopux*)
+ if test "$GCC" = yes; then
+ archive_cmds_FC='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ # Try to use the -exported_symbol ld option, if it does not
+ # work, assume that -exports_file does not work either and
+ # implicitly export all symbols.
+ # This should be the same for all languages, so no per-tag cache variable.
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $host_os linker accepts -exported_symbol" >&5
+$as_echo_n "checking whether the $host_os linker accepts -exported_symbol... " >&6; }
+if ${lt_cv_irix_exported_symbol+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS -shared ${wl}-exported_symbol ${wl}foo ${wl}-update_registry ${wl}/dev/null"
+ cat > conftest.$ac_ext <<_ACEOF
+
+ subroutine foo
+ end
+_ACEOF
+if ac_fn_fc_try_link "$LINENO"; then :
+ lt_cv_irix_exported_symbol=yes
+else
+ lt_cv_irix_exported_symbol=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ LDFLAGS="$save_LDFLAGS"
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_irix_exported_symbol" >&5
+$as_echo "$lt_cv_irix_exported_symbol" >&6; }
+ if test "$lt_cv_irix_exported_symbol" = yes; then
+ archive_expsym_cmds_FC='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations ${wl}-exports_file ${wl}$export_symbols -o $lib'
+ fi
+ else
+ archive_cmds_FC='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ archive_expsym_cmds_FC='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -exports_file $export_symbols -o $lib'
+ fi
+ archive_cmds_need_lc_FC='no'
+ hardcode_libdir_flag_spec_FC='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator_FC=:
+ inherit_rpath_FC=yes
+ link_all_deplibs_FC=yes
+ ;;
+
+ netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ archive_cmds_FC='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' # a.out
+ else
+ archive_cmds_FC='$LD -shared -o $lib $libobjs $deplibs $linker_flags' # ELF
+ fi
+ hardcode_libdir_flag_spec_FC='-R$libdir'
+ hardcode_direct_FC=yes
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ newsos6)
+ archive_cmds_FC='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct_FC=yes
+ hardcode_libdir_flag_spec_FC='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator_FC=:
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ *nto* | *qnx*)
+ ;;
+
+ openbsd*)
+ if test -f /usr/libexec/ld.so; then
+ hardcode_direct_FC=yes
+ hardcode_shlibpath_var_FC=no
+ hardcode_direct_absolute_FC=yes
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ archive_cmds_FC='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_FC='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags ${wl}-retain-symbols-file,$export_symbols'
+ hardcode_libdir_flag_spec_FC='${wl}-rpath,$libdir'
+ export_dynamic_flag_spec_FC='${wl}-E'
+ else
+ case $host_os in
+ openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*)
+ archive_cmds_FC='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_libdir_flag_spec_FC='-R$libdir'
+ ;;
+ *)
+ archive_cmds_FC='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ hardcode_libdir_flag_spec_FC='${wl}-rpath,$libdir'
+ ;;
+ esac
+ fi
+ else
+ ld_shlibs_FC=no
+ fi
+ ;;
+
+ os2*)
+ hardcode_libdir_flag_spec_FC='-L$libdir'
+ hardcode_minus_L_FC=yes
+ allow_undefined_flag_FC=unsupported
+ archive_cmds_FC='$ECHO "LIBRARY $libname INITINSTANCE" > $output_objdir/$libname.def~$ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~echo DATA >> $output_objdir/$libname.def~echo " SINGLE NONSHARED" >> $output_objdir/$libname.def~echo EXPORTS >> $output_objdir/$libname.def~emxexp $libobjs >> $output_objdir/$libname.def~$CC -Zdll -Zcrtdll -o $lib $libobjs $deplibs $compiler_flags $output_objdir/$libname.def'
+ old_archive_from_new_cmds_FC='emximp -o $output_objdir/$libname.a $output_objdir/$libname.def'
+ ;;
+
+ osf3*)
+ if test "$GCC" = yes; then
+ allow_undefined_flag_FC=' ${wl}-expect_unresolved ${wl}\*'
+ archive_cmds_FC='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ else
+ allow_undefined_flag_FC=' -expect_unresolved \*'
+ archive_cmds_FC='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ fi
+ archive_cmds_need_lc_FC='no'
+ hardcode_libdir_flag_spec_FC='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator_FC=:
+ ;;
+
+ osf4* | osf5*) # as osf3* with the addition of -msym flag
+ if test "$GCC" = yes; then
+ allow_undefined_flag_FC=' ${wl}-expect_unresolved ${wl}\*'
+ archive_cmds_FC='$CC -shared${allow_undefined_flag} $pic_flag $libobjs $deplibs $compiler_flags ${wl}-msym ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ hardcode_libdir_flag_spec_FC='${wl}-rpath ${wl}$libdir'
+ else
+ allow_undefined_flag_FC=' -expect_unresolved \*'
+ archive_cmds_FC='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ archive_expsym_cmds_FC='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done; printf "%s\\n" "-hidden">> $lib.exp~
+ $CC -shared${allow_undefined_flag} ${wl}-input ${wl}$lib.exp $compiler_flags $libobjs $deplibs -soname $soname `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib~$RM $lib.exp'
+
+ # Both c and cxx compiler support -rpath directly
+ hardcode_libdir_flag_spec_FC='-rpath $libdir'
+ fi
+ archive_cmds_need_lc_FC='no'
+ hardcode_libdir_separator_FC=:
+ ;;
+
+ solaris*)
+ no_undefined_flag_FC=' -z defs'
+ if test "$GCC" = yes; then
+ wlarc='${wl}'
+ archive_cmds_FC='$CC -shared $pic_flag ${wl}-z ${wl}text ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_FC='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -shared $pic_flag ${wl}-z ${wl}text ${wl}-M ${wl}$lib.exp ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp'
+ else
+ case `$CC -V 2>&1` in
+ *"Compilers 5.0"*)
+ wlarc=''
+ archive_cmds_FC='$LD -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ archive_expsym_cmds_FC='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $LD -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $linker_flags~$RM $lib.exp'
+ ;;
+ *)
+ wlarc='${wl}'
+ archive_cmds_FC='$CC -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_FC='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp'
+ ;;
+ esac
+ fi
+ hardcode_libdir_flag_spec_FC='-R$libdir'
+ hardcode_shlibpath_var_FC=no
+ case $host_os in
+ solaris2.[0-5] | solaris2.[0-5].*) ;;
+ *)
+ # The compiler driver will combine and reorder linker options,
+ # but understands `-z linker_flag'. GCC discards it without `$wl',
+ # but is careful enough not to reorder.
+ # Supported since Solaris 2.6 (maybe 2.5.1?)
+ if test "$GCC" = yes; then
+ whole_archive_flag_spec_FC='${wl}-z ${wl}allextract$convenience ${wl}-z ${wl}defaultextract'
+ else
+ whole_archive_flag_spec_FC='-z allextract$convenience -z defaultextract'
+ fi
+ ;;
+ esac
+ link_all_deplibs_FC=yes
+ ;;
+
+ sunos4*)
+ if test "x$host_vendor" = xsequent; then
+ # Use $CC to link under sequent, because it throws in some extra .o
+ # files that make .init and .fini sections work.
+ archive_cmds_FC='$CC -G ${wl}-h $soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds_FC='$LD -assert pure-text -Bstatic -o $lib $libobjs $deplibs $linker_flags'
+ fi
+ hardcode_libdir_flag_spec_FC='-L$libdir'
+ hardcode_direct_FC=yes
+ hardcode_minus_L_FC=yes
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ sysv4)
+ case $host_vendor in
+ sni)
+ archive_cmds_FC='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct_FC=yes # is this really true???
+ ;;
+ siemens)
+ ## LD is ld it makes a PLAMLIB
+ ## CC just makes a GrossModule.
+ archive_cmds_FC='$LD -G -o $lib $libobjs $deplibs $linker_flags'
+ reload_cmds_FC='$CC -r -o $output$reload_objs'
+ hardcode_direct_FC=no
+ ;;
+ motorola)
+ archive_cmds_FC='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_direct_FC=no #Motorola manual says yes, but my tests say they lie
+ ;;
+ esac
+ runpath_var='LD_RUN_PATH'
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ sysv4.3*)
+ archive_cmds_FC='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_shlibpath_var_FC=no
+ export_dynamic_flag_spec_FC='-Bexport'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ archive_cmds_FC='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_shlibpath_var_FC=no
+ runpath_var=LD_RUN_PATH
+ hardcode_runpath_var=yes
+ ld_shlibs_FC=yes
+ fi
+ ;;
+
+ sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*)
+ no_undefined_flag_FC='${wl}-z,text'
+ archive_cmds_need_lc_FC=no
+ hardcode_shlibpath_var_FC=no
+ runpath_var='LD_RUN_PATH'
+
+ if test "$GCC" = yes; then
+ archive_cmds_FC='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_FC='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds_FC='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_FC='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ fi
+ ;;
+
+ sysv5* | sco3.2v5* | sco5v6*)
+ # Note: We can NOT use -z defs as we might desire, because we do not
+ # link with -lc, and that would cause any symbols used from libc to
+ # always be unresolved, which means just about no library would
+ # ever link correctly. If we're not using GNU ld we use -z text
+ # though, which does catch some bad symbols but isn't as heavy-handed
+ # as -z defs.
+ no_undefined_flag_FC='${wl}-z,text'
+ allow_undefined_flag_FC='${wl}-z,nodefs'
+ archive_cmds_need_lc_FC=no
+ hardcode_shlibpath_var_FC=no
+ hardcode_libdir_flag_spec_FC='${wl}-R,$libdir'
+ hardcode_libdir_separator_FC=':'
+ link_all_deplibs_FC=yes
+ export_dynamic_flag_spec_FC='${wl}-Bexport'
+ runpath_var='LD_RUN_PATH'
+
+ if test "$GCC" = yes; then
+ archive_cmds_FC='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_FC='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ archive_cmds_FC='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ archive_expsym_cmds_FC='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ fi
+ ;;
+
+ uts4*)
+ archive_cmds_FC='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ hardcode_libdir_flag_spec_FC='-L$libdir'
+ hardcode_shlibpath_var_FC=no
+ ;;
+
+ *)
+ ld_shlibs_FC=no
+ ;;
+ esac
+
+ if test x$host_vendor = xsni; then
+ case $host in
+ sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*)
+ export_dynamic_flag_spec_FC='${wl}-Blargedynsym'
+ ;;
+ esac
+ fi
+ fi
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs_FC" >&5
+$as_echo "$ld_shlibs_FC" >&6; }
+test "$ld_shlibs_FC" = no && can_build_shared=no
+
+with_gnu_ld_FC=$with_gnu_ld
+
+
+
+
+
+
+#
+# Do we need to explicitly link libc?
+#
+case "x$archive_cmds_need_lc_FC" in
+x|xyes)
+ # Assume -lc should be added
+ archive_cmds_need_lc_FC=yes
+
+ if test "$enable_shared" = yes && test "$GCC" = yes; then
+ case $archive_cmds_FC in
+ *'~'*)
+ # FIXME: we may have to deal with multi-command sequences.
+ ;;
+ '$CC '*)
+ # Test whether the compiler implicitly links with -lc since on some
+ # systems, -lgcc has to come before -lc. If gcc already passes -lc
+ # to ld, don't add -lc before -lgcc.
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether -lc should be explicitly linked in" >&5
+$as_echo_n "checking whether -lc should be explicitly linked in... " >&6; }
+if ${lt_cv_archive_cmds_need_lc_FC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ $RM conftest*
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } 2>conftest.err; then
+ soname=conftest
+ lib=conftest
+ libobjs=conftest.$ac_objext
+ deplibs=
+ wl=$lt_prog_compiler_wl_FC
+ pic_flag=$lt_prog_compiler_pic_FC
+ compiler_flags=-v
+ linker_flags=-v
+ verstring=
+ output_objdir=.
+ libname=conftest
+ lt_save_allow_undefined_flag=$allow_undefined_flag_FC
+ allow_undefined_flag_FC=
+ if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$archive_cmds_FC 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1\""; } >&5
+ (eval $archive_cmds_FC 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1) 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+ then
+ lt_cv_archive_cmds_need_lc_FC=no
+ else
+ lt_cv_archive_cmds_need_lc_FC=yes
+ fi
+ allow_undefined_flag_FC=$lt_save_allow_undefined_flag
+ else
+ cat conftest.err 1>&5
+ fi
+ $RM conftest*
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc_FC" >&5
+$as_echo "$lt_cv_archive_cmds_need_lc_FC" >&6; }
+ archive_cmds_need_lc_FC=$lt_cv_archive_cmds_need_lc_FC
+ ;;
+ esac
+ fi
+ ;;
+esac
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking dynamic linker characteristics" >&5
+$as_echo_n "checking dynamic linker characteristics... " >&6; }
+
+library_names_spec=
+libname_spec='lib$name'
+soname_spec=
+shrext_cmds=".so"
+postinstall_cmds=
+postuninstall_cmds=
+finish_cmds=
+finish_eval=
+shlibpath_var=
+shlibpath_overrides_runpath=unknown
+version_type=none
+dynamic_linker="$host_os ld.so"
+sys_lib_dlsearch_path_spec="/lib /usr/lib"
+need_lib_prefix=unknown
+hardcode_into_libs=no
+
+# when you set need_version to no, make sure it does not cause -set_version
+# flags to be left without arguments
+need_version=unknown
+
+case $host_os in
+aix3*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix $libname.a'
+ shlibpath_var=LIBPATH
+
+ # AIX 3 has no versioning support, so we append a major version to the name.
+ soname_spec='${libname}${release}${shared_ext}$major'
+ ;;
+
+aix[4-9]*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ hardcode_into_libs=yes
+ if test "$host_cpu" = ia64; then
+ # AIX 5 supports IA64
+ library_names_spec='${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext}$versuffix $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ else
+ # With GCC up to 2.95.x, collect2 would create an import file
+ # for dependence libraries. The import file would start with
+ # the line `#! .'. This would cause the generated library to
+ # depend on `.', always an invalid library. This was fixed in
+ # development snapshots of GCC prior to 3.0.
+ case $host_os in
+ aix4 | aix4.[01] | aix4.[01].*)
+ if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)'
+ echo ' yes '
+ echo '#endif'; } | ${CC} -E - | $GREP yes > /dev/null; then
+ :
+ else
+ can_build_shared=no
+ fi
+ ;;
+ esac
+ # AIX (on Power*) has no versioning support, so currently we can not hardcode correct
+ # soname into executable. Probably we can add versioning support to
+ # collect2, so additional links can be useful in future.
+ if test "$aix_use_runtimelinking" = yes; then
+ # If using run time linking (on AIX 4.2 or later) use lib<name>.so
+ # instead of lib<name>.a to let people know that these are not
+ # typical AIX shared libraries.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ else
+ # We preserve .a as extension for shared libraries through AIX4.2
+ # and later when we are not doing run time linking.
+ library_names_spec='${libname}${release}.a $libname.a'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ fi
+ shlibpath_var=LIBPATH
+ fi
+ ;;
+
+amigaos*)
+ case $host_cpu in
+ powerpc)
+ # Since July 2007 AmigaOS4 officially supports .so libraries.
+ # When compiling the executable, add -use-dynld -Lsobjs: to the compileline.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ ;;
+ m68k)
+ library_names_spec='$libname.ixlibrary $libname.a'
+ # Create ${libname}_ixlibrary.a entries in /sys/libs.
+ finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`func_echo_all "$lib" | $SED '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; test $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done'
+ ;;
+ esac
+ ;;
+
+beos*)
+ library_names_spec='${libname}${shared_ext}'
+ dynamic_linker="$host_os ld.so"
+ shlibpath_var=LIBRARY_PATH
+ ;;
+
+bsdi[45]*)
+ version_type=linux
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib"
+ sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib"
+ # the default ld.so.conf also contains /usr/contrib/lib and
+ # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow
+ # libtool to hard-code these into programs
+ ;;
+
+cygwin* | mingw* | pw32* | cegcc*)
+ version_type=windows
+ shrext_cmds=".dll"
+ need_version=no
+ need_lib_prefix=no
+
+ case $GCC,$cc_basename in
+ yes,*)
+ # gcc
+ library_names_spec='$libname.dll.a'
+ # DLL is installed to $(libdir)/../bin by postinstall_cmds
+ postinstall_cmds='base_file=`basename \${file}`~
+ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~
+ dldir=$destdir/`dirname \$dlpath`~
+ test -d \$dldir || mkdir -p \$dldir~
+ $install_prog $dir/$dlname \$dldir/$dlname~
+ chmod a+x \$dldir/$dlname~
+ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then
+ eval '\''$striplib \$dldir/$dlname'\'' || exit \$?;
+ fi'
+ postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~
+ dlpath=$dir/\$dldll~
+ $RM \$dlpath'
+ shlibpath_overrides_runpath=yes
+
+ case $host_os in
+ cygwin*)
+ # Cygwin DLLs use 'cyg' prefix rather than 'lib'
+ soname_spec='`echo ${libname} | sed -e 's/^lib/cyg/'``echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+
+ ;;
+ mingw* | cegcc*)
+ # MinGW DLLs use traditional 'lib' prefix
+ soname_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+ ;;
+ pw32*)
+ # pw32 DLLs use 'pw' prefix rather than 'lib'
+ library_names_spec='`echo ${libname} | sed -e 's/^lib/pw/'``echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+ ;;
+ esac
+ dynamic_linker='Win32 ld.exe'
+ ;;
+
+ *,cl*)
+ # Native MSVC
+ libname_spec='$name'
+ soname_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext}'
+ library_names_spec='${libname}.dll.lib'
+
+ case $build_os in
+ mingw*)
+ sys_lib_search_path_spec=
+ lt_save_ifs=$IFS
+ IFS=';'
+ for lt_path in $LIB
+ do
+ IFS=$lt_save_ifs
+ # Let DOS variable expansion print the short 8.3 style file name.
+ lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"`
+ sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path"
+ done
+ IFS=$lt_save_ifs
+ # Convert to MSYS style.
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([a-zA-Z]\\):| /\\1|g' -e 's|^ ||'`
+ ;;
+ cygwin*)
+ # Convert to unix form, then to dos form, then back to unix form
+ # but this time dos style (no spaces!) so that the unix form looks
+ # like /cygdrive/c/PROGRA~1:/cygdr...
+ sys_lib_search_path_spec=`cygpath --path --unix "$LIB"`
+ sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null`
+ sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"`
+ ;;
+ *)
+ sys_lib_search_path_spec="$LIB"
+ if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then
+ # It is most probably a Windows format PATH.
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'`
+ else
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"`
+ fi
+ # FIXME: find the short name or the path components, as spaces are
+ # common. (e.g. "Program Files" -> "PROGRA~1")
+ ;;
+ esac
+
+ # DLL is installed to $(libdir)/../bin by postinstall_cmds
+ postinstall_cmds='base_file=`basename \${file}`~
+ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~
+ dldir=$destdir/`dirname \$dlpath`~
+ test -d \$dldir || mkdir -p \$dldir~
+ $install_prog $dir/$dlname \$dldir/$dlname'
+ postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~
+ dlpath=$dir/\$dldll~
+ $RM \$dlpath'
+ shlibpath_overrides_runpath=yes
+ dynamic_linker='Win32 link.exe'
+ ;;
+
+ *)
+ # Assume MSVC wrapper
+ library_names_spec='${libname}`echo ${release} | $SED -e 's/[.]/-/g'`${versuffix}${shared_ext} $libname.lib'
+ dynamic_linker='Win32 ld.exe'
+ ;;
+ esac
+ # FIXME: first we should search . and the directory the executable is in
+ shlibpath_var=PATH
+ ;;
+
+darwin* | rhapsody*)
+ dynamic_linker="$host_os dyld"
+ version_type=darwin
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${major}$shared_ext ${libname}$shared_ext'
+ soname_spec='${libname}${release}${major}$shared_ext'
+ shlibpath_overrides_runpath=yes
+ shlibpath_var=DYLD_LIBRARY_PATH
+ shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`'
+
+ sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib'
+ ;;
+
+dgux*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname$shared_ext'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+freebsd1*)
+ dynamic_linker=no
+ ;;
+
+freebsd* | dragonfly*)
+ # DragonFly does not have aout. When/if they implement a new
+ # versioning mechanism, adjust this.
+ if test -x /usr/bin/objformat; then
+ objformat=`/usr/bin/objformat`
+ else
+ case $host_os in
+ freebsd[123]*) objformat=aout ;;
+ *) objformat=elf ;;
+ esac
+ fi
+ version_type=freebsd-$objformat
+ case $version_type in
+ freebsd-elf*)
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}'
+ need_version=no
+ need_lib_prefix=no
+ ;;
+ freebsd-*)
+ library_names_spec='${libname}${release}${shared_ext}$versuffix $libname${shared_ext}$versuffix'
+ need_version=yes
+ ;;
+ esac
+ shlibpath_var=LD_LIBRARY_PATH
+ case $host_os in
+ freebsd2*)
+ shlibpath_overrides_runpath=yes
+ ;;
+ freebsd3.[01]* | freebsdelf3.[01]*)
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+ freebsd3.[2-9]* | freebsdelf3.[2-9]* | \
+ freebsd4.[0-5] | freebsdelf4.[0-5] | freebsd4.1.1 | freebsdelf4.1.1)
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+ *) # from 4.6 on, and DragonFly
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+ esac
+ ;;
+
+gnu*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ hardcode_into_libs=yes
+ ;;
+
+haiku*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ dynamic_linker="$host_os runtime_loader"
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib'
+ hardcode_into_libs=yes
+ ;;
+
+hpux9* | hpux10* | hpux11*)
+ # Give a soname corresponding to the major version so that dld.sl refuses to
+ # link against other versions.
+ version_type=sunos
+ need_lib_prefix=no
+ need_version=no
+ case $host_cpu in
+ ia64*)
+ shrext_cmds='.so'
+ hardcode_into_libs=yes
+ dynamic_linker="$host_os dld.so"
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes # Unless +noenvvar is specified.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ if test "X$HPUX_IA64_MODE" = X32; then
+ sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib"
+ else
+ sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64"
+ fi
+ sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec
+ ;;
+ hppa*64*)
+ shrext_cmds='.sl'
+ hardcode_into_libs=yes
+ dynamic_linker="$host_os dld.sl"
+ shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH
+ shlibpath_overrides_runpath=yes # Unless +noenvvar is specified.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64"
+ sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec
+ ;;
+ *)
+ shrext_cmds='.sl'
+ dynamic_linker="$host_os dld.sl"
+ shlibpath_var=SHLIB_PATH
+ shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ ;;
+ esac
+ # HP-UX runs *really* slowly unless shared libraries are mode 555, ...
+ postinstall_cmds='chmod 555 $lib'
+ # or fails outright, so override atomically:
+ install_override_mode=555
+ ;;
+
+interix[3-9]*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+
+irix5* | irix6* | nonstopux*)
+ case $host_os in
+ nonstopux*) version_type=nonstopux ;;
+ *)
+ if test "$lt_cv_prog_gnu_ld" = yes; then
+ version_type=linux
+ else
+ version_type=irix
+ fi ;;
+ esac
+ need_lib_prefix=no
+ need_version=no
+ soname_spec='${libname}${release}${shared_ext}$major'
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext} $libname${shared_ext}'
+ case $host_os in
+ irix5* | nonstopux*)
+ libsuff= shlibsuff=
+ ;;
+ *)
+ case $LD in # libtool.m4 will add one of these switches to LD
+ *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ")
+ libsuff= shlibsuff= libmagic=32-bit;;
+ *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ")
+ libsuff=32 shlibsuff=N32 libmagic=N32;;
+ *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ")
+ libsuff=64 shlibsuff=64 libmagic=64-bit;;
+ *) libsuff= shlibsuff= libmagic=never-match;;
+ esac
+ ;;
+ esac
+ shlibpath_var=LD_LIBRARY${shlibsuff}_PATH
+ shlibpath_overrides_runpath=no
+ sys_lib_search_path_spec="/usr/lib${libsuff} /lib${libsuff} /usr/local/lib${libsuff}"
+ sys_lib_dlsearch_path_spec="/usr/lib${libsuff} /lib${libsuff}"
+ hardcode_into_libs=yes
+ ;;
+
+# No shared lib support for Linux oldld, aout, or coff.
+linux*oldld* | linux*aout* | linux*coff*)
+ dynamic_linker=no
+ ;;
+
+# This must be Linux ELF.
+linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+
+ # Some binutils ld are patched to set DT_RUNPATH
+ if ${lt_cv_shlibpath_overrides_runpath+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ lt_cv_shlibpath_overrides_runpath=no
+ save_LDFLAGS=$LDFLAGS
+ save_libdir=$libdir
+ eval "libdir=/foo; wl=\"$lt_prog_compiler_wl_FC\"; \
+ LDFLAGS=\"\$LDFLAGS $hardcode_libdir_flag_spec_FC\""
+ cat > conftest.$ac_ext <<_ACEOF
+ program main
+
+ end
+_ACEOF
+if ac_fn_fc_try_link "$LINENO"; then :
+ if ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null; then :
+ lt_cv_shlibpath_overrides_runpath=yes
+fi
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ LDFLAGS=$save_LDFLAGS
+ libdir=$save_libdir
+
+fi
+
+ shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath
+
+ # This implies no fast_install, which is unacceptable.
+ # Some rework will be needed to allow for fast_install
+ # before this can be enabled.
+ hardcode_into_libs=yes
+
+ # Append ld.so.conf contents to the search path
+ if test -f /etc/ld.so.conf; then
+ lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \$2)); skip = 1; } { if (!skip) print \$0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;s/"//g;/^$/d' | tr '\n' ' '`
+ sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra"
+ fi
+
+ # We used to test for /lib/ld.so.1 and disable shared libraries on
+ # powerpc, because MkLinux only supported shared libraries with the
+ # GNU dynamic linker. Since this was broken with cross compilers,
+ # most powerpc-linux boxes support dynamic linking these days and
+ # people can always --disable-shared, the test was removed, and we
+ # assume the GNU/Linux dynamic linker is in use.
+ dynamic_linker='GNU/Linux ld.so'
+ ;;
+
+netbsd*)
+ version_type=sunos
+ need_lib_prefix=no
+ need_version=no
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir'
+ dynamic_linker='NetBSD (a.out) ld.so'
+ else
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ dynamic_linker='NetBSD ld.elf_so'
+ fi
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+
+newsos6)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ ;;
+
+*nto* | *qnx*)
+ version_type=qnx
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ dynamic_linker='ldqnx.so'
+ ;;
+
+openbsd*)
+ version_type=sunos
+ sys_lib_dlsearch_path_spec="/usr/lib"
+ need_lib_prefix=no
+ # Some older versions of OpenBSD (3.3 at least) *do* need versioned libs.
+ case $host_os in
+ openbsd3.3 | openbsd3.3.*) need_version=yes ;;
+ *) need_version=no ;;
+ esac
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ case $host_os in
+ openbsd2.[89] | openbsd2.[89].*)
+ shlibpath_overrides_runpath=no
+ ;;
+ *)
+ shlibpath_overrides_runpath=yes
+ ;;
+ esac
+ else
+ shlibpath_overrides_runpath=yes
+ fi
+ ;;
+
+os2*)
+ libname_spec='$name'
+ shrext_cmds=".dll"
+ need_lib_prefix=no
+ library_names_spec='$libname${shared_ext} $libname.a'
+ dynamic_linker='OS/2 ld.exe'
+ shlibpath_var=LIBPATH
+ ;;
+
+osf3* | osf4* | osf5*)
+ version_type=osf
+ need_lib_prefix=no
+ need_version=no
+ soname_spec='${libname}${release}${shared_ext}$major'
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib"
+ sys_lib_dlsearch_path_spec="$sys_lib_search_path_spec"
+ ;;
+
+rdos*)
+ dynamic_linker=no
+ ;;
+
+solaris*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ # ldd complains unless libraries are executable
+ postinstall_cmds='chmod +x $lib'
+ ;;
+
+sunos4*)
+ version_type=sunos
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ if test "$with_gnu_ld" = yes; then
+ need_lib_prefix=no
+ fi
+ need_version=yes
+ ;;
+
+sysv4 | sysv4.3*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ case $host_vendor in
+ sni)
+ shlibpath_overrides_runpath=no
+ need_lib_prefix=no
+ runpath_var=LD_RUN_PATH
+ ;;
+ siemens)
+ need_lib_prefix=no
+ ;;
+ motorola)
+ need_lib_prefix=no
+ need_version=no
+ shlibpath_overrides_runpath=no
+ sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib'
+ ;;
+ esac
+ ;;
+
+sysv4*MP*)
+ if test -d /usr/nec ;then
+ version_type=linux
+ library_names_spec='$libname${shared_ext}.$versuffix $libname${shared_ext}.$major $libname${shared_ext}'
+ soname_spec='$libname${shared_ext}.$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ fi
+ ;;
+
+sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
+ version_type=freebsd-elf
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ if test "$with_gnu_ld" = yes; then
+ sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib'
+ else
+ sys_lib_search_path_spec='/usr/ccs/lib /usr/lib'
+ case $host_os in
+ sco3.2v5*)
+ sys_lib_search_path_spec="$sys_lib_search_path_spec /lib"
+ ;;
+ esac
+ fi
+ sys_lib_dlsearch_path_spec='/usr/lib'
+ ;;
+
+tpf*)
+ # TPF is a cross-target only. Preferred cross-host = GNU/Linux.
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+
+uts4*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*)
+ dynamic_linker=no
+ ;;
+esac
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $dynamic_linker" >&5
+$as_echo "$dynamic_linker" >&6; }
+test "$dynamic_linker" = no && can_build_shared=no
+
+variables_saved_for_relink="PATH $shlibpath_var $runpath_var"
+if test "$GCC" = yes; then
+ variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH"
+fi
+
+if test "${lt_cv_sys_lib_search_path_spec+set}" = set; then
+ sys_lib_search_path_spec="$lt_cv_sys_lib_search_path_spec"
+fi
+if test "${lt_cv_sys_lib_dlsearch_path_spec+set}" = set; then
+ sys_lib_dlsearch_path_spec="$lt_cv_sys_lib_dlsearch_path_spec"
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to hardcode library paths into programs" >&5
+$as_echo_n "checking how to hardcode library paths into programs... " >&6; }
+hardcode_action_FC=
+if test -n "$hardcode_libdir_flag_spec_FC" ||
+ test -n "$runpath_var_FC" ||
+ test "X$hardcode_automatic_FC" = "Xyes" ; then
+
+ # We can hardcode non-existent directories.
+ if test "$hardcode_direct_FC" != no &&
+ # If the only mechanism to avoid hardcoding is shlibpath_var, we
+ # have to relink, otherwise we might link with an installed library
+ # when we should be linking with a yet-to-be-installed one
+ ## test "$_LT_TAGVAR(hardcode_shlibpath_var, FC)" != no &&
+ test "$hardcode_minus_L_FC" != no; then
+ # Linking always hardcodes the temporary library directory.
+ hardcode_action_FC=relink
+ else
+ # We can link without hardcoding, and we can hardcode nonexisting dirs.
+ hardcode_action_FC=immediate
+ fi
+else
+ # We cannot hardcode anything, or else we can only hardcode existing
+ # directories.
+ hardcode_action_FC=unsupported
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $hardcode_action_FC" >&5
+$as_echo "$hardcode_action_FC" >&6; }
+
+if test "$hardcode_action_FC" = relink ||
+ test "$inherit_rpath_FC" = yes; then
+ # Fast installation is not supported
+ enable_fast_install=no
+elif test "$shlibpath_overrides_runpath" = yes ||
+ test "$enable_shared" = no; then
+ # Fast installation is not necessary
+ enable_fast_install=needless
+fi
+
+
+
+
+
+
+
+ fi # test -n "$compiler"
+
+ GCC=$lt_save_GCC
+ CC=$lt_save_CC
+ CFLAGS=$lt_save_CFLAGS
+fi # test "$_lt_disable_FC" != yes
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+
+
+
+
+
+
+
+ ac_config_commands="$ac_config_commands libtool"
+
+
+
+
+# Only expand once:
+
+
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether build environment is sane" >&5
+$as_echo_n "checking whether build environment is sane... " >&6; }
+# Just in case
+sleep 1
+echo timestamp > conftest.file
+# Reject unsafe characters in $srcdir or the absolute working directory
+# name. Accept space and tab only in the latter.
+am_lf='
+'
+case `pwd` in
+ *[\\\"\#\$\&\'\`$am_lf]*)
+ as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;;
+esac
+case $srcdir in
+ *[\\\"\#\$\&\'\`$am_lf\ \ ]*)
+ as_fn_error $? "unsafe srcdir value: \`$srcdir'" "$LINENO" 5;;
+esac
+
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments. Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+ set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null`
+ if test "$*" = "X"; then
+ # -L didn't work.
+ set X `ls -t "$srcdir/configure" conftest.file`
+ fi
+ rm -f conftest.file
+ if test "$*" != "X $srcdir/configure conftest.file" \
+ && test "$*" != "X conftest.file $srcdir/configure"; then
+
+ # If neither matched, then we have a broken ls. This can happen
+ # if, for instance, CONFIG_SHELL is bash and it inherits a
+ # broken ls alias from the environment. This has actually
+ # happened. Such a system could not be considered "sane".
+ as_fn_error $? "ls -t appears to fail. Make sure there is not a broken
+alias in your environment" "$LINENO" 5
+ fi
+
+ test "$2" = conftest.file
+ )
+then
+ # Ok.
+ :
+else
+ as_fn_error $? "newly created file is older than distributed files!
+Check your system clock" "$LINENO" 5
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+
+
+
+
+
+ prefix_NONE=
+ exec_prefix_NONE=
+ test "x$prefix" = xNONE && prefix_NONE=yes && prefix=$ac_default_prefix
+ test "x$exec_prefix" = xNONE && exec_prefix_NONE=yes && exec_prefix=$prefix
+ eval ac_define_dir="\"$datadir\""
+ eval ac_define_dir="\"$ac_define_dir\""
+ DATADIR="$ac_define_dir"
+
+ cat >>confdefs.h <<_ACEOF
+#define DATADIR "$ac_define_dir"
+_ACEOF
+
+ test "$prefix_NONE" && prefix=NONE
+ test "$exec_prefix_NONE" && exec_prefix=NONE
+
+
+
+# Check whether --with-precision was given.
+if test "${with_precision+set}" = set; then :
+ withval=$with_precision;
+else
+ with_precision=double
+fi
+
+if test "x$with_precision" == xquadruple; then :
+ fortran_real_kind="selected_real_kind(32,50)"
+
+elif test "x$with_precision" == xquad; then :
+ fortran_real_kind="selected_real_kind(32,50)"
+
+elif test "x$with_precision" == xdouble; then :
+ fortran_real_kind="kind(1.0d0)"
+
+elif test "x$with_precision" == xintermediate; then :
+ fortran_real_kind="selected_real_kind(18,4931)"
+
+else
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "--with-precision was given with an unrecognized
+ parameter
+See \`config.log' for more details" "$LINENO" 5; }
+fi
+
+# Check whether --enable-ff was given.
+if test "${enable_ff+set}" = set; then :
+ enableval=$enable_ff;
+fi
+
+
+ if test "x$enable_ff" != xno; then
+ COMPILE_FF_TRUE=
+ COMPILE_FF_FALSE='#'
+else
+ COMPILE_FF_TRUE='#'
+ COMPILE_FF_FALSE=
+fi
+
+
+if test "x$enable_ff" != xno; then :
+ conf_with_ff=""
+
+else
+ conf_with_ff="# "
+
+fi
+if test "x$enable_ff" != xno; then :
+ conf_wout_ff="# "
+
+else
+ conf_wout_ff=""
+
+fi
+if test "x$enable_ff" != xno; then :
+ case_with_ff=" "
+
+else
+ case_with_ff="!AC!"
+
+fi
+if test "x$enable_ff" != xno; then :
+ case_wout_ff="!AC!"
+
+else
+ case_wout_ff=" "
+
+fi
+
+# Check whether --enable-ql was given.
+if test "${enable_ql+set}" = set; then :
+ enableval=$enable_ql;
+fi
+
+
+ if test "x$enable_ql" != xno; then
+ COMPILE_QL_TRUE=
+ COMPILE_QL_FALSE='#'
+else
+ COMPILE_QL_TRUE='#'
+ COMPILE_QL_FALSE=
+fi
+
+
+if test "x$enable_ql" != xno; then :
+ conf_with_ql=""
+
+else
+ conf_with_ql="# "
+
+fi
+if test "x$enable_ql" != xno; then :
+ conf_wout_ql="# "
+
+else
+ conf_wout_ql=""
+
+fi
+if test "x$enable_ql" != xno; then :
+ case_with_ql=" "
+
+else
+ case_with_ql="!AC!"
+
+fi
+if test "x$enable_ql" != xno; then :
+ case_wout_ql="!AC!"
+
+else
+ case_wout_ql=" "
+
+fi
+
+# Check whether --enable-olo was given.
+if test "${enable_olo+set}" = set; then :
+ enableval=$enable_olo;
+fi
+
+
+ if test "x$enable_olo" != xno; then
+ COMPILE_OLO_TRUE=
+ COMPILE_OLO_FALSE='#'
+else
+ COMPILE_OLO_TRUE='#'
+ COMPILE_OLO_FALSE=
+fi
+
+avh_olo_real_kind="$fortran_real_kind"
+
+
+if test "x$enable_olo" != xno; then :
+ conf_with_olo=""
+
+else
+ conf_with_olo="# "
+
+fi
+if test "x$enable_olo" != xno; then :
+ conf_wout_olo="# "
+
+else
+ conf_wout_olo=""
+
+fi
+if test "x$enable_olo" != xno; then :
+ case_with_olo=" "
+
+else
+ case_with_olo="!AC!"
+
+fi
+if test "x$enable_olo" != xno; then :
+ case_wout_olo="!AC!"
+
+else
+ case_wout_olo=" "
+
+fi
+if test "x$enable_olo" != xno; then :
+ case_with_avh=" "
+
+else
+ case_with_avh="!AC!"
+
+fi
+if test "x$enable_olo" != xno; then :
+ case_wout_avh="!AC!"
+
+else
+ case_wout_avh=" "
+
+fi
+
+# Check whether --enable-golem95 was given.
+if test "${enable_golem95+set}" = set; then :
+ enableval=$enable_golem95;
+fi
+
+
+ if test "x$enable_golem95" != xno; then
+ COMPILE_GOLEM95C_TRUE=
+ COMPILE_GOLEM95C_FALSE='#'
+else
+ COMPILE_GOLEM95C_TRUE='#'
+ COMPILE_GOLEM95C_FALSE=
+fi
+
+
+if test "x$enable_golem95" != xno; then :
+ conf_with_golem95=""
+
+else
+ conf_with_golem95="# "
+
+fi
+if test "x$enable_golem95" != xno; then :
+ conf_wout_golem95="# "
+
+else
+ conf_wout_golem95=""
+
+fi
+if test "x$enable_golem95" != xno; then :
+ case_with_golem=" "
+
+else
+ case_with_golem="!AC!"
+
+fi
+if test "x$enable_golem95" != xno; then :
+ case_wout_golem="!AC!"
+
+else
+ case_wout_golem=" "
+
+fi
+
+ if test "x" == "x"; then
+ COMPILE_TENSREC_TRUE=
+ COMPILE_TENSREC_FALSE='#'
+else
+ COMPILE_TENSREC_TRUE='#'
+ COMPILE_TENSREC_FALSE=
+fi
+
+
+SAMURAIVERSION=2.1.1
+
+# Check whether --enable-samurai was given.
+if test "${enable_samurai+set}" = set; then :
+ enableval=$enable_samurai;
+fi
+
+
+ if test "x$enable_golem95" != xno; then
+ COMPILE_SAMURAI_TRUE=
+ COMPILE_SAMURAI_FALSE='#'
+else
+ COMPILE_SAMURAI_TRUE='#'
+ COMPILE_SAMURAI_FALSE=
+fi
+
+
+if test "x$enable_samurai" != xno; then :
+ conf_with_samurai=""
+
+else
+ conf_with_samurai="# "
+
+fi
+if test "x$enable_samurai" != xno; then :
+ conf_wout_samurai="# "
+
+else
+ conf_wout_samurai=""
+
+fi
+if test "x$enable_samurai" != xno; then :
+ case_with_samurai=" "
+
+else
+ case_with_samurai="!AC!"
+
+fi
+if test "x$enable_samurai" != xno; then :
+ case_wout_samurai="!AC!"
+
+else
+ case_wout_samurai=" "
+
+fi
+
+
+
+# Check whether --with-looptools was given.
+if test "${with_looptools+set}" = set; then :
+ withval=$with_looptools;
+else
+ with_looptools=no
+fi
+
+
+LIBLOOPTOOLS=
+if test "x$with_looptools" == xyes; then :
+ as_ac_Lib=`$as_echo "ac_cv_lib_ooptools -lgfortran''_ltexi_" | $as_tr_sh`
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ltexi_ in -looptools -lgfortran" >&5
+$as_echo_n "checking for ltexi_ in -looptools -lgfortran... " >&6; }
+if eval \${$as_ac_Lib+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-looptools -lgfortran -looptools $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char ltexi_ ();
+#ifdef FC_DUMMY_MAIN
+#ifndef FC_DUMMY_MAIN_EQ_F77
+# ifdef __cplusplus
+ extern "C"
+# endif
+ int FC_DUMMY_MAIN() { return 1; }
+#endif
+#endif
+int
+main ()
+{
+return ltexi_ ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ eval "$as_ac_Lib=yes"
+else
+ eval "$as_ac_Lib=no"
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+eval ac_res=\$$as_ac_Lib
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then :
+ LIBLOOPTOOLS="-looptools"
+
+
+$as_echo "#define HAVE_LT 1" >>confdefs.h
+
+
+else
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "--with-looptools was given, but test for -looptools failed. \
+ Consider using --with-looptools=path/libooptools.a .
+See \`config.log' for more details" "$LINENO" 5; }
+fi
+
+elif test "x$with_looptools" != xno; then :
+ as_ac_File=`$as_echo "ac_cv_file_$with_looptools" | $as_tr_sh`
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $with_looptools" >&5
+$as_echo_n "checking for $with_looptools... " >&6; }
+if eval \${$as_ac_File+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ test "$cross_compiling" = yes &&
+ as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5
+if test -r "$with_looptools"; then
+ eval "$as_ac_File=yes"
+else
+ eval "$as_ac_File=no"
+fi
+fi
+eval ac_res=\$$as_ac_File
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+if eval test \"x\$"$as_ac_File"\" = x"yes"; then :
+ LIBLOOPTOOLS="$with_looptools"
+
+
+$as_echo "#define HAVE_LT 1" >>confdefs.h
+
+
+else
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "--with-looptools was given, but location '$with_looptools' \
+ is wrong.
+See \`config.log' for more details" "$LINENO" 5; }
+fi
+
+
+fi
+
+if test "x$with_looptools" != xno; then :
+ conf_with_lt=""
+
+else
+ conf_with_lt="#"
+
+fi
+if test "x$with_looptools" != xno; then :
+ conf_wout_lt="#"
+
+else
+ conf_wout_lt=""
+
+fi
+
+if test "x$with_looptools" != xno; then :
+ case_with_lt=" "
+
+else
+ case_with_lt="!AC!"
+
+fi
+if test "x$with_looptools" != xno; then :
+ case_wout_lt="!AC!"
+
+else
+ case_wout_lt=" "
+
+fi
+
+
+# Check whether --with-lt-precision was given.
+if test "${with_lt_precision+set}" = set; then :
+ withval=$with_lt_precision;
+else
+ with_lt_precision=double
+fi
+
+
+if test "x$with_lt_precision" == xquadruple; then :
+ lt_real_kind="selected_real_kind(32,50)"
+
+elif test "x$with_lt_precision" == xquad; then :
+ lt_real_kind="selected_real_kind(32,50)"
+
+elif test "x$with_lt_precision" == xdouble; then :
+ lt_real_kind="kind(1.0d0)"
+
+else
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "--with-lt-precision was given with an
+ unrecognized parameter
+See \`config.log' for more details" "$LINENO" 5; }
+fi
+
+ac_config_files="$ac_config_files gosam.conf samurai.pc Makefile ff-2.0/Makefile ff-2.0/ffinit.f qcdloop-1.9/Makefile avh_olo-2.2.1/Makefile golem95c-1.2.1/Makefile golem95c-1.2.1/module/Makefile golem95c-1.2.1/module/precision_golem.f90 golem95c-1.2.1/integrals/Makefile golem95c-1.2.1/integrals/two_point/Makefile golem95c-1.2.1/integrals/one_point/Makefile golem95c-1.2.1/integrals/three_point/Makefile golem95c-1.2.1/integrals/four_point/Makefile golem95c-1.2.1/integrals/four_point/generic_function_4p.f90 golem95c-1.2.1/interface/Makefile golem95c-1.2.1/numerical/Makefile golem95c-1.2.1/kinematic/Makefile golem95c-1.2.1/form_factor/Makefile samurai-2.1.1/Makefile samurai-2.1.1/madds.f90 samurai-2.1.1/msamurai.f90 samurai-2.1.1/precision.f90"
+
+cat >confcache <<\_ACEOF
+# This file is a shell script that caches the results of configure
+# tests run on this system so they can be shared between configure
+# scripts and configure runs, see configure's option --config-cache.
+# It is not useful on other systems. If it contains results you don't
+# want to keep, you may remove or edit it.
+#
+# config.status only pays attention to the cache file if you give it
+# the --recheck option to rerun configure.
+#
+# `ac_cv_env_foo' variables (set or unset) will be overridden when
+# loading this file, other *unset* `ac_cv_foo' will be assigned the
+# following values.
+
+_ACEOF
+
+# The following way of writing the cache mishandles newlines in values,
+# but we know of no workaround that is simple, portable, and efficient.
+# So, we kill variables containing newlines.
+# Ultrix sh set writes to stderr and can't be redirected directly,
+# and sets the high bit in the cache file unless we assign to the vars.
+(
+ for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
+ *) { eval $ac_var=; unset $ac_var;} ;;
+ esac ;;
+ esac
+ done
+
+ (set) 2>&1 |
+ case $as_nl`(ac_space=' '; set) 2>&1` in #(
+ *${as_nl}ac_space=\ *)
+ # `set' does not quote correctly, so add quotes: double-quote
+ # substitution turns \\\\ into \\, and sed turns \\ into \.
+ sed -n \
+ "s/'/'\\\\''/g;
+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
+ ;; #(
+ *)
+ # `set' quotes correctly as required by POSIX, so do not add quotes.
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
+ ;;
+ esac |
+ sort
+) |
+ sed '
+ /^ac_cv_env_/b end
+ t clear
+ :clear
+ s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
+ t end
+ s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
+ :end' >>confcache
+if diff "$cache_file" confcache >/dev/null 2>&1; then :; else
+ if test -w "$cache_file"; then
+ if test "x$cache_file" != "x/dev/null"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5
+$as_echo "$as_me: updating cache $cache_file" >&6;}
+ if test ! -f "$cache_file" || test -h "$cache_file"; then
+ cat confcache >"$cache_file"
+ else
+ case $cache_file in #(
+ */* | ?:*)
+ mv -f confcache "$cache_file"$$ &&
+ mv -f "$cache_file"$$ "$cache_file" ;; #(
+ *)
+ mv -f confcache "$cache_file" ;;
+ esac
+ fi
+ fi
+ else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5
+$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;}
+ fi
+fi
+rm -f confcache
+
+test "x$prefix" = xNONE && prefix=$ac_default_prefix
+# Let make expand exec_prefix.
+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
+
+# Transform confdefs.h into DEFS.
+# Protect against shell expansion while executing Makefile rules.
+# Protect against Makefile macro expansion.
+#
+# If the first sed substitution is executed (which looks for macros that
+# take arguments), then branch to the quote section. Otherwise,
+# look for a macro that doesn't take arguments.
+ac_script='
+:mline
+/\\$/{
+ N
+ s,\\\n,,
+ b mline
+}
+t clear
+:clear
+s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g
+t quote
+s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g
+t quote
+b any
+:quote
+s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g
+s/\[/\\&/g
+s/\]/\\&/g
+s/\$/$$/g
+H
+:any
+${
+ g
+ s/^\n//
+ s/\n/ /g
+ p
+}
+'
+DEFS=`sed -n "$ac_script" confdefs.h`
+
+
+ac_libobjs=
+ac_ltlibobjs=
+U=
+for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
+ # 1. Remove the extension, and $U if already installed.
+ ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'
+ ac_i=`$as_echo "$ac_i" | sed "$ac_script"`
+ # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR
+ # will be set to the directory where LIBOBJS objects are built.
+ as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext"
+ as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo'
+done
+LIBOBJS=$ac_libobjs
+
+LTLIBOBJS=$ac_ltlibobjs
+
+
+ if test -n "$EXEEXT"; then
+ am__EXEEXT_TRUE=
+ am__EXEEXT_FALSE='#'
+else
+ am__EXEEXT_TRUE='#'
+ am__EXEEXT_FALSE=
+fi
+
+if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then
+ as_fn_error $? "conditional \"AMDEP\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
+if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then
+ as_fn_error $? "conditional \"am__fastdepCC\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
+if test -z "${COMPILE_FF_TRUE}" && test -z "${COMPILE_FF_FALSE}"; then
+ as_fn_error $? "conditional \"COMPILE_FF\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
+if test -z "${COMPILE_QL_TRUE}" && test -z "${COMPILE_QL_FALSE}"; then
+ as_fn_error $? "conditional \"COMPILE_QL\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
+if test -z "${COMPILE_OLO_TRUE}" && test -z "${COMPILE_OLO_FALSE}"; then
+ as_fn_error $? "conditional \"COMPILE_OLO\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
+if test -z "${COMPILE_GOLEM95C_TRUE}" && test -z "${COMPILE_GOLEM95C_FALSE}"; then
+ as_fn_error $? "conditional \"COMPILE_GOLEM95C\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
+if test -z "${COMPILE_TENSREC_TRUE}" && test -z "${COMPILE_TENSREC_FALSE}"; then
+ as_fn_error $? "conditional \"COMPILE_TENSREC\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
+if test -z "${COMPILE_SAMURAI_TRUE}" && test -z "${COMPILE_SAMURAI_FALSE}"; then
+ as_fn_error $? "conditional \"COMPILE_SAMURAI\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
+
+: "${CONFIG_STATUS=./config.status}"
+ac_write_fail=0
+ac_clean_files_save=$ac_clean_files
+ac_clean_files="$ac_clean_files $CONFIG_STATUS"
+{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5
+$as_echo "$as_me: creating $CONFIG_STATUS" >&6;}
+as_write_fail=0
+cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1
+#! $SHELL
+# Generated by $as_me.
+# Run this file to recreate the current configuration.
+# Compiler output produced by configure, useful for debugging
+# configure, is in config.log if it exists.
+
+debug=false
+ac_cs_recheck=false
+ac_cs_silent=false
+
+SHELL=\${CONFIG_SHELL-$SHELL}
+export SHELL
+_ASEOF
+cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1
+## -------------------- ##
+## M4sh Initialization. ##
+## -------------------- ##
+
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then :
+ emulate sh
+ NULLCMD=:
+ # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in #(
+ *posix*) :
+ set -o posix ;; #(
+ *) :
+ ;;
+esac
+fi
+
+
+as_nl='
+'
+export as_nl
+# Printing a long string crashes Solaris 7 /usr/bin/printf.
+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo
+# Prefer a ksh shell builtin over an external printf program on Solaris,
+# but without wasting forks for bash or zsh.
+if test -z "$BASH_VERSION$ZSH_VERSION" \
+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='print -r --'
+ as_echo_n='print -rn --'
+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='printf %s\n'
+ as_echo_n='printf %s'
+else
+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then
+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'
+ as_echo_n='/usr/ucb/echo -n'
+ else
+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'
+ as_echo_n_body='eval
+ arg=$1;
+ case $arg in #(
+ *"$as_nl"*)
+ expr "X$arg" : "X\\(.*\\)$as_nl";
+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;
+ esac;
+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"
+ '
+ export as_echo_n_body
+ as_echo_n='sh -c $as_echo_n_body as_echo'
+ fi
+ export as_echo_body
+ as_echo='sh -c $as_echo_body as_echo'
+fi
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; then
+ PATH_SEPARATOR=:
+ (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
+ (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
+ PATH_SEPARATOR=';'
+ }
+fi
+
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+IFS=" "" $as_nl"
+
+# Find who we are. Look in the path if we contain no directory separator.
+as_myself=
+case $0 in #((
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+ done
+IFS=$as_save_IFS
+
+ ;;
+esac
+# We did not find ourselves, most probably we were run as `sh COMMAND'
+# in which case we are not to be found in the path.
+if test "x$as_myself" = x; then
+ as_myself=$0
+fi
+if test ! -f "$as_myself"; then
+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+# Unset variables that we do not need and which cause bugs (e.g. in
+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"
+# suppresses any "Segmentation fault" message there. '((' could
+# trigger a bug in pdksh 5.2.14.
+for as_var in BASH_ENV ENV MAIL MAILPATH
+do eval test x\${$as_var+set} = xset \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
+PS1='$ '
+PS2='> '
+PS4='+ '
+
+# NLS nuisances.
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# CDPATH.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+
+# as_fn_error STATUS ERROR [LINENO LOG_FD]
+# ----------------------------------------
+# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
+# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
+# script with STATUS, using 1 if that was 0.
+as_fn_error ()
+{
+ as_status=$1; test $as_status -eq 0 && as_status=1
+ if test "$4"; then
+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
+ fi
+ $as_echo "$as_me: error: $2" >&2
+ as_fn_exit $as_status
+} # as_fn_error
+
+
+# as_fn_set_status STATUS
+# -----------------------
+# Set $? to STATUS, without forking.
+as_fn_set_status ()
+{
+ return $1
+} # as_fn_set_status
+
+# as_fn_exit STATUS
+# -----------------
+# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
+as_fn_exit ()
+{
+ set +e
+ as_fn_set_status $1
+ exit $1
+} # as_fn_exit
+
+# as_fn_unset VAR
+# ---------------
+# Portably unset VAR.
+as_fn_unset ()
+{
+ { eval $1=; unset $1;}
+}
+as_unset=as_fn_unset
+# as_fn_append VAR VALUE
+# ----------------------
+# Append the text in VALUE to the end of the definition contained in VAR. Take
+# advantage of any shell optimizations that allow amortized linear growth over
+# repeated appends, instead of the typical quadratic growth present in naive
+# implementations.
+if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then :
+ eval 'as_fn_append ()
+ {
+ eval $1+=\$2
+ }'
+else
+ as_fn_append ()
+ {
+ eval $1=\$$1\$2
+ }
+fi # as_fn_append
+
+# as_fn_arith ARG...
+# ------------------
+# Perform arithmetic evaluation on the ARGs, and store the result in the
+# global $as_val. Take advantage of shells that can avoid forks. The arguments
+# must be portable across $(()) and expr.
+if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then :
+ eval 'as_fn_arith ()
+ {
+ as_val=$(( $* ))
+ }'
+else
+ as_fn_arith ()
+ {
+ as_val=`expr "$@" || test $? -eq 1`
+ }
+fi # as_fn_arith
+
+
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
+ as_basename=basename
+else
+ as_basename=false
+fi
+
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
+
+as_me=`$as_basename -- "$0" ||
+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X/"$0" |
+ sed '/^.*\/\([^/][^/]*\)\/*$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+
+# Avoid depending upon Character Ranges.
+as_cr_letters='abcdefghijklmnopqrstuvwxyz'
+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+as_cr_Letters=$as_cr_letters$as_cr_LETTERS
+as_cr_digits='0123456789'
+as_cr_alnum=$as_cr_Letters$as_cr_digits
+
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in #(((((
+-n*)
+ case `echo 'xy\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ xy) ECHO_C='\c';;
+ *) echo `echo ksh88 bug on AIX 6.1` > /dev/null
+ ECHO_T=' ';;
+ esac;;
+*)
+ ECHO_N='-n';;
+esac
+
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
+fi
+if (echo >conf$$.file) 2>/dev/null; then
+ if ln -s conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -p'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -p'
+ elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+ else
+ as_ln_s='cp -p'
+ fi
+else
+ as_ln_s='cp -p'
+fi
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
+
+
+# as_fn_mkdir_p
+# -------------
+# Create "$as_dir" as a directory, including parents if necessary.
+as_fn_mkdir_p ()
+{
+
+ case $as_dir in #(
+ -*) as_dir=./$as_dir;;
+ esac
+ test -d "$as_dir" || eval $as_mkdir_p || {
+ as_dirs=
+ while :; do
+ case $as_dir in #(
+ *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
+ *) as_qdir=$as_dir;;
+ esac
+ as_dirs="'$as_qdir' $as_dirs"
+ as_dir=`$as_dirname -- "$as_dir" ||
+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_dir" : 'X\(//\)[^/]' \| \
+ X"$as_dir" : 'X\(//\)$' \| \
+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X"$as_dir" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ test -d "$as_dir" && break
+ done
+ test -z "$as_dirs" || eval "mkdir $as_dirs"
+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"
+
+
+} # as_fn_mkdir_p
+if mkdir -p . 2>/dev/null; then
+ as_mkdir_p='mkdir -p "$as_dir"'
+else
+ test -d ./-p && rmdir ./-p
+ as_mkdir_p=false
+fi
+
+if test -x / >/dev/null 2>&1; then
+ as_test_x='test -x'
+else
+ if ls -dL / >/dev/null 2>&1; then
+ as_ls_L_option=L
+ else
+ as_ls_L_option=
+ fi
+ as_test_x='
+ eval sh -c '\''
+ if test -d "$1"; then
+ test -d "$1/.";
+ else
+ case $1 in #(
+ -*)set "./$1";;
+ esac;
+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #((
+ ???[sx]*):;;*)false;;esac;fi
+ '\'' sh
+ '
+fi
+as_executable_p=$as_test_x
+
+# Sed expression to map a string onto a valid CPP name.
+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
+
+# Sed expression to map a string onto a valid variable name.
+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
+
+
+exec 6>&1
+## ----------------------------------- ##
+## Main body of $CONFIG_STATUS script. ##
+## ----------------------------------- ##
+_ASEOF
+test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1
+
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+# Save the log message, to keep $0 and so on meaningful, and to
+# report actual input values of CONFIG_FILES etc. instead of their
+# values after options handling.
+ac_log="
+This file was extended by GoSam Convenience Package $as_me 1.0, which was
+generated by GNU Autoconf 2.68. Invocation command line was
+
+ CONFIG_FILES = $CONFIG_FILES
+ CONFIG_HEADERS = $CONFIG_HEADERS
+ CONFIG_LINKS = $CONFIG_LINKS
+ CONFIG_COMMANDS = $CONFIG_COMMANDS
+ $ $0 $@
+
+on `(hostname || uname -n) 2>/dev/null | sed 1q`
+"
+
+_ACEOF
+
+case $ac_config_files in *"
+"*) set x $ac_config_files; shift; ac_config_files=$*;;
+esac
+
+
+
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+# Files that config.status was made for.
+config_files="$ac_config_files"
+config_commands="$ac_config_commands"
+
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+ac_cs_usage="\
+\`$as_me' instantiates files and other configuration actions
+from templates according to the current configuration. Unless the files
+and actions are specified as TAGs, all are instantiated by default.
+
+Usage: $0 [OPTION]... [TAG]...
+
+ -h, --help print this help, then exit
+ -V, --version print version number and configuration settings, then exit
+ --config print configuration, then exit
+ -q, --quiet, --silent
+ do not print progress messages
+ -d, --debug don't remove temporary files
+ --recheck update $as_me by reconfiguring in the same conditions
+ --file=FILE[:TEMPLATE]
+ instantiate the configuration file FILE
+
+Configuration files:
+$config_files
+
+Configuration commands:
+$config_commands
+
+Report bugs to <reiterth@mpp.mpg.de>.
+GoSam Convenience Package home page: <http://projects.hepforge.org/golem/gosam-contrib/>."
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
+ac_cs_version="\\
+GoSam Convenience Package config.status 1.0
+configured by $0, generated by GNU Autoconf 2.68,
+ with options \\"\$ac_cs_config\\"
+
+Copyright (C) 2010 Free Software Foundation, Inc.
+This config.status script is free software; the Free Software Foundation
+gives unlimited permission to copy, distribute and modify it."
+
+ac_pwd='$ac_pwd'
+srcdir='$srcdir'
+INSTALL='$INSTALL'
+MKDIR_P='$MKDIR_P'
+AWK='$AWK'
+test -n "\$AWK" || AWK=awk
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+# The default lists apply if the user does not specify any file.
+ac_need_defaults=:
+while test $# != 0
+do
+ case $1 in
+ --*=?*)
+ ac_option=`expr "X$1" : 'X\([^=]*\)='`
+ ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`
+ ac_shift=:
+ ;;
+ --*=)
+ ac_option=`expr "X$1" : 'X\([^=]*\)='`
+ ac_optarg=
+ ac_shift=:
+ ;;
+ *)
+ ac_option=$1
+ ac_optarg=$2
+ ac_shift=shift
+ ;;
+ esac
+
+ case $ac_option in
+ # Handling of the options.
+ -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
+ ac_cs_recheck=: ;;
+ --version | --versio | --versi | --vers | --ver | --ve | --v | -V )
+ $as_echo "$ac_cs_version"; exit ;;
+ --config | --confi | --conf | --con | --co | --c )
+ $as_echo "$ac_cs_config"; exit ;;
+ --debug | --debu | --deb | --de | --d | -d )
+ debug=: ;;
+ --file | --fil | --fi | --f )
+ $ac_shift
+ case $ac_optarg in
+ *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ '') as_fn_error $? "missing file argument" ;;
+ esac
+ as_fn_append CONFIG_FILES " '$ac_optarg'"
+ ac_need_defaults=false;;
+ --he | --h | --help | --hel | -h )
+ $as_echo "$ac_cs_usage"; exit ;;
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil | --si | --s)
+ ac_cs_silent=: ;;
+
+ # This is an error.
+ -*) as_fn_error $? "unrecognized option: \`$1'
+Try \`$0 --help' for more information." ;;
+
+ *) as_fn_append ac_config_targets " $1"
+ ac_need_defaults=false ;;
+
+ esac
+ shift
+done
+
+ac_configure_extra_args=
+
+if $ac_cs_silent; then
+ exec 6>/dev/null
+ ac_configure_extra_args="$ac_configure_extra_args --silent"
+fi
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+if \$ac_cs_recheck; then
+ set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
+ shift
+ \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6
+ CONFIG_SHELL='$SHELL'
+ export CONFIG_SHELL
+ exec "\$@"
+fi
+
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+exec 5>>config.log
+{
+ echo
+ sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
+## Running $as_me. ##
+_ASBOX
+ $as_echo "$ac_log"
+} >&5
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+#
+# INIT-COMMANDS
+#
+AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir"
+
+
+# The HP-UX ksh and POSIX shell print the target directory to stdout
+# if CDPATH is set.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+sed_quote_subst='$sed_quote_subst'
+double_quote_subst='$double_quote_subst'
+delay_variable_subst='$delay_variable_subst'
+macro_version='`$ECHO "$macro_version" | $SED "$delay_single_quote_subst"`'
+macro_revision='`$ECHO "$macro_revision" | $SED "$delay_single_quote_subst"`'
+enable_shared='`$ECHO "$enable_shared" | $SED "$delay_single_quote_subst"`'
+enable_static='`$ECHO "$enable_static" | $SED "$delay_single_quote_subst"`'
+pic_mode='`$ECHO "$pic_mode" | $SED "$delay_single_quote_subst"`'
+enable_fast_install='`$ECHO "$enable_fast_install" | $SED "$delay_single_quote_subst"`'
+SHELL='`$ECHO "$SHELL" | $SED "$delay_single_quote_subst"`'
+ECHO='`$ECHO "$ECHO" | $SED "$delay_single_quote_subst"`'
+host_alias='`$ECHO "$host_alias" | $SED "$delay_single_quote_subst"`'
+host='`$ECHO "$host" | $SED "$delay_single_quote_subst"`'
+host_os='`$ECHO "$host_os" | $SED "$delay_single_quote_subst"`'
+build_alias='`$ECHO "$build_alias" | $SED "$delay_single_quote_subst"`'
+build='`$ECHO "$build" | $SED "$delay_single_quote_subst"`'
+build_os='`$ECHO "$build_os" | $SED "$delay_single_quote_subst"`'
+SED='`$ECHO "$SED" | $SED "$delay_single_quote_subst"`'
+Xsed='`$ECHO "$Xsed" | $SED "$delay_single_quote_subst"`'
+GREP='`$ECHO "$GREP" | $SED "$delay_single_quote_subst"`'
+EGREP='`$ECHO "$EGREP" | $SED "$delay_single_quote_subst"`'
+FGREP='`$ECHO "$FGREP" | $SED "$delay_single_quote_subst"`'
+LD='`$ECHO "$LD" | $SED "$delay_single_quote_subst"`'
+NM='`$ECHO "$NM" | $SED "$delay_single_quote_subst"`'
+LN_S='`$ECHO "$LN_S" | $SED "$delay_single_quote_subst"`'
+max_cmd_len='`$ECHO "$max_cmd_len" | $SED "$delay_single_quote_subst"`'
+ac_objext='`$ECHO "$ac_objext" | $SED "$delay_single_quote_subst"`'
+exeext='`$ECHO "$exeext" | $SED "$delay_single_quote_subst"`'
+lt_unset='`$ECHO "$lt_unset" | $SED "$delay_single_quote_subst"`'
+lt_SP2NL='`$ECHO "$lt_SP2NL" | $SED "$delay_single_quote_subst"`'
+lt_NL2SP='`$ECHO "$lt_NL2SP" | $SED "$delay_single_quote_subst"`'
+lt_cv_to_host_file_cmd='`$ECHO "$lt_cv_to_host_file_cmd" | $SED "$delay_single_quote_subst"`'
+lt_cv_to_tool_file_cmd='`$ECHO "$lt_cv_to_tool_file_cmd" | $SED "$delay_single_quote_subst"`'
+reload_flag='`$ECHO "$reload_flag" | $SED "$delay_single_quote_subst"`'
+reload_cmds='`$ECHO "$reload_cmds" | $SED "$delay_single_quote_subst"`'
+OBJDUMP='`$ECHO "$OBJDUMP" | $SED "$delay_single_quote_subst"`'
+deplibs_check_method='`$ECHO "$deplibs_check_method" | $SED "$delay_single_quote_subst"`'
+file_magic_cmd='`$ECHO "$file_magic_cmd" | $SED "$delay_single_quote_subst"`'
+file_magic_glob='`$ECHO "$file_magic_glob" | $SED "$delay_single_quote_subst"`'
+want_nocaseglob='`$ECHO "$want_nocaseglob" | $SED "$delay_single_quote_subst"`'
+DLLTOOL='`$ECHO "$DLLTOOL" | $SED "$delay_single_quote_subst"`'
+sharedlib_from_linklib_cmd='`$ECHO "$sharedlib_from_linklib_cmd" | $SED "$delay_single_quote_subst"`'
+AR='`$ECHO "$AR" | $SED "$delay_single_quote_subst"`'
+AR_FLAGS='`$ECHO "$AR_FLAGS" | $SED "$delay_single_quote_subst"`'
+archiver_list_spec='`$ECHO "$archiver_list_spec" | $SED "$delay_single_quote_subst"`'
+STRIP='`$ECHO "$STRIP" | $SED "$delay_single_quote_subst"`'
+RANLIB='`$ECHO "$RANLIB" | $SED "$delay_single_quote_subst"`'
+old_postinstall_cmds='`$ECHO "$old_postinstall_cmds" | $SED "$delay_single_quote_subst"`'
+old_postuninstall_cmds='`$ECHO "$old_postuninstall_cmds" | $SED "$delay_single_quote_subst"`'
+old_archive_cmds='`$ECHO "$old_archive_cmds" | $SED "$delay_single_quote_subst"`'
+lock_old_archive_extraction='`$ECHO "$lock_old_archive_extraction" | $SED "$delay_single_quote_subst"`'
+CC='`$ECHO "$CC" | $SED "$delay_single_quote_subst"`'
+CFLAGS='`$ECHO "$CFLAGS" | $SED "$delay_single_quote_subst"`'
+compiler='`$ECHO "$compiler" | $SED "$delay_single_quote_subst"`'
+GCC='`$ECHO "$GCC" | $SED "$delay_single_quote_subst"`'
+lt_cv_sys_global_symbol_pipe='`$ECHO "$lt_cv_sys_global_symbol_pipe" | $SED "$delay_single_quote_subst"`'
+lt_cv_sys_global_symbol_to_cdecl='`$ECHO "$lt_cv_sys_global_symbol_to_cdecl" | $SED "$delay_single_quote_subst"`'
+lt_cv_sys_global_symbol_to_c_name_address='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address" | $SED "$delay_single_quote_subst"`'
+lt_cv_sys_global_symbol_to_c_name_address_lib_prefix='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address_lib_prefix" | $SED "$delay_single_quote_subst"`'
+nm_file_list_spec='`$ECHO "$nm_file_list_spec" | $SED "$delay_single_quote_subst"`'
+lt_sysroot='`$ECHO "$lt_sysroot" | $SED "$delay_single_quote_subst"`'
+objdir='`$ECHO "$objdir" | $SED "$delay_single_quote_subst"`'
+MAGIC_CMD='`$ECHO "$MAGIC_CMD" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_no_builtin_flag='`$ECHO "$lt_prog_compiler_no_builtin_flag" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_pic='`$ECHO "$lt_prog_compiler_pic" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_wl='`$ECHO "$lt_prog_compiler_wl" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_static='`$ECHO "$lt_prog_compiler_static" | $SED "$delay_single_quote_subst"`'
+lt_cv_prog_compiler_c_o='`$ECHO "$lt_cv_prog_compiler_c_o" | $SED "$delay_single_quote_subst"`'
+need_locks='`$ECHO "$need_locks" | $SED "$delay_single_quote_subst"`'
+MANIFEST_TOOL='`$ECHO "$MANIFEST_TOOL" | $SED "$delay_single_quote_subst"`'
+DSYMUTIL='`$ECHO "$DSYMUTIL" | $SED "$delay_single_quote_subst"`'
+NMEDIT='`$ECHO "$NMEDIT" | $SED "$delay_single_quote_subst"`'
+LIPO='`$ECHO "$LIPO" | $SED "$delay_single_quote_subst"`'
+OTOOL='`$ECHO "$OTOOL" | $SED "$delay_single_quote_subst"`'
+OTOOL64='`$ECHO "$OTOOL64" | $SED "$delay_single_quote_subst"`'
+libext='`$ECHO "$libext" | $SED "$delay_single_quote_subst"`'
+shrext_cmds='`$ECHO "$shrext_cmds" | $SED "$delay_single_quote_subst"`'
+extract_expsyms_cmds='`$ECHO "$extract_expsyms_cmds" | $SED "$delay_single_quote_subst"`'
+archive_cmds_need_lc='`$ECHO "$archive_cmds_need_lc" | $SED "$delay_single_quote_subst"`'
+enable_shared_with_static_runtimes='`$ECHO "$enable_shared_with_static_runtimes" | $SED "$delay_single_quote_subst"`'
+export_dynamic_flag_spec='`$ECHO "$export_dynamic_flag_spec" | $SED "$delay_single_quote_subst"`'
+whole_archive_flag_spec='`$ECHO "$whole_archive_flag_spec" | $SED "$delay_single_quote_subst"`'
+compiler_needs_object='`$ECHO "$compiler_needs_object" | $SED "$delay_single_quote_subst"`'
+old_archive_from_new_cmds='`$ECHO "$old_archive_from_new_cmds" | $SED "$delay_single_quote_subst"`'
+old_archive_from_expsyms_cmds='`$ECHO "$old_archive_from_expsyms_cmds" | $SED "$delay_single_quote_subst"`'
+archive_cmds='`$ECHO "$archive_cmds" | $SED "$delay_single_quote_subst"`'
+archive_expsym_cmds='`$ECHO "$archive_expsym_cmds" | $SED "$delay_single_quote_subst"`'
+module_cmds='`$ECHO "$module_cmds" | $SED "$delay_single_quote_subst"`'
+module_expsym_cmds='`$ECHO "$module_expsym_cmds" | $SED "$delay_single_quote_subst"`'
+with_gnu_ld='`$ECHO "$with_gnu_ld" | $SED "$delay_single_quote_subst"`'
+allow_undefined_flag='`$ECHO "$allow_undefined_flag" | $SED "$delay_single_quote_subst"`'
+no_undefined_flag='`$ECHO "$no_undefined_flag" | $SED "$delay_single_quote_subst"`'
+hardcode_libdir_flag_spec='`$ECHO "$hardcode_libdir_flag_spec" | $SED "$delay_single_quote_subst"`'
+hardcode_libdir_flag_spec_ld='`$ECHO "$hardcode_libdir_flag_spec_ld" | $SED "$delay_single_quote_subst"`'
+hardcode_libdir_separator='`$ECHO "$hardcode_libdir_separator" | $SED "$delay_single_quote_subst"`'
+hardcode_direct='`$ECHO "$hardcode_direct" | $SED "$delay_single_quote_subst"`'
+hardcode_direct_absolute='`$ECHO "$hardcode_direct_absolute" | $SED "$delay_single_quote_subst"`'
+hardcode_minus_L='`$ECHO "$hardcode_minus_L" | $SED "$delay_single_quote_subst"`'
+hardcode_shlibpath_var='`$ECHO "$hardcode_shlibpath_var" | $SED "$delay_single_quote_subst"`'
+hardcode_automatic='`$ECHO "$hardcode_automatic" | $SED "$delay_single_quote_subst"`'
+inherit_rpath='`$ECHO "$inherit_rpath" | $SED "$delay_single_quote_subst"`'
+link_all_deplibs='`$ECHO "$link_all_deplibs" | $SED "$delay_single_quote_subst"`'
+always_export_symbols='`$ECHO "$always_export_symbols" | $SED "$delay_single_quote_subst"`'
+export_symbols_cmds='`$ECHO "$export_symbols_cmds" | $SED "$delay_single_quote_subst"`'
+exclude_expsyms='`$ECHO "$exclude_expsyms" | $SED "$delay_single_quote_subst"`'
+include_expsyms='`$ECHO "$include_expsyms" | $SED "$delay_single_quote_subst"`'
+prelink_cmds='`$ECHO "$prelink_cmds" | $SED "$delay_single_quote_subst"`'
+postlink_cmds='`$ECHO "$postlink_cmds" | $SED "$delay_single_quote_subst"`'
+file_list_spec='`$ECHO "$file_list_spec" | $SED "$delay_single_quote_subst"`'
+variables_saved_for_relink='`$ECHO "$variables_saved_for_relink" | $SED "$delay_single_quote_subst"`'
+need_lib_prefix='`$ECHO "$need_lib_prefix" | $SED "$delay_single_quote_subst"`'
+need_version='`$ECHO "$need_version" | $SED "$delay_single_quote_subst"`'
+version_type='`$ECHO "$version_type" | $SED "$delay_single_quote_subst"`'
+runpath_var='`$ECHO "$runpath_var" | $SED "$delay_single_quote_subst"`'
+shlibpath_var='`$ECHO "$shlibpath_var" | $SED "$delay_single_quote_subst"`'
+shlibpath_overrides_runpath='`$ECHO "$shlibpath_overrides_runpath" | $SED "$delay_single_quote_subst"`'
+libname_spec='`$ECHO "$libname_spec" | $SED "$delay_single_quote_subst"`'
+library_names_spec='`$ECHO "$library_names_spec" | $SED "$delay_single_quote_subst"`'
+soname_spec='`$ECHO "$soname_spec" | $SED "$delay_single_quote_subst"`'
+install_override_mode='`$ECHO "$install_override_mode" | $SED "$delay_single_quote_subst"`'
+postinstall_cmds='`$ECHO "$postinstall_cmds" | $SED "$delay_single_quote_subst"`'
+postuninstall_cmds='`$ECHO "$postuninstall_cmds" | $SED "$delay_single_quote_subst"`'
+finish_cmds='`$ECHO "$finish_cmds" | $SED "$delay_single_quote_subst"`'
+finish_eval='`$ECHO "$finish_eval" | $SED "$delay_single_quote_subst"`'
+hardcode_into_libs='`$ECHO "$hardcode_into_libs" | $SED "$delay_single_quote_subst"`'
+sys_lib_search_path_spec='`$ECHO "$sys_lib_search_path_spec" | $SED "$delay_single_quote_subst"`'
+sys_lib_dlsearch_path_spec='`$ECHO "$sys_lib_dlsearch_path_spec" | $SED "$delay_single_quote_subst"`'
+hardcode_action='`$ECHO "$hardcode_action" | $SED "$delay_single_quote_subst"`'
+enable_dlopen='`$ECHO "$enable_dlopen" | $SED "$delay_single_quote_subst"`'
+enable_dlopen_self='`$ECHO "$enable_dlopen_self" | $SED "$delay_single_quote_subst"`'
+enable_dlopen_self_static='`$ECHO "$enable_dlopen_self_static" | $SED "$delay_single_quote_subst"`'
+old_striplib='`$ECHO "$old_striplib" | $SED "$delay_single_quote_subst"`'
+striplib='`$ECHO "$striplib" | $SED "$delay_single_quote_subst"`'
+compiler_lib_search_dirs='`$ECHO "$compiler_lib_search_dirs" | $SED "$delay_single_quote_subst"`'
+predep_objects='`$ECHO "$predep_objects" | $SED "$delay_single_quote_subst"`'
+postdep_objects='`$ECHO "$postdep_objects" | $SED "$delay_single_quote_subst"`'
+predeps='`$ECHO "$predeps" | $SED "$delay_single_quote_subst"`'
+postdeps='`$ECHO "$postdeps" | $SED "$delay_single_quote_subst"`'
+compiler_lib_search_path='`$ECHO "$compiler_lib_search_path" | $SED "$delay_single_quote_subst"`'
+LD_F77='`$ECHO "$LD_F77" | $SED "$delay_single_quote_subst"`'
+LD_FC='`$ECHO "$LD_FC" | $SED "$delay_single_quote_subst"`'
+reload_flag_F77='`$ECHO "$reload_flag_F77" | $SED "$delay_single_quote_subst"`'
+reload_flag_FC='`$ECHO "$reload_flag_FC" | $SED "$delay_single_quote_subst"`'
+reload_cmds_F77='`$ECHO "$reload_cmds_F77" | $SED "$delay_single_quote_subst"`'
+reload_cmds_FC='`$ECHO "$reload_cmds_FC" | $SED "$delay_single_quote_subst"`'
+old_archive_cmds_F77='`$ECHO "$old_archive_cmds_F77" | $SED "$delay_single_quote_subst"`'
+old_archive_cmds_FC='`$ECHO "$old_archive_cmds_FC" | $SED "$delay_single_quote_subst"`'
+compiler_F77='`$ECHO "$compiler_F77" | $SED "$delay_single_quote_subst"`'
+compiler_FC='`$ECHO "$compiler_FC" | $SED "$delay_single_quote_subst"`'
+GCC_F77='`$ECHO "$GCC_F77" | $SED "$delay_single_quote_subst"`'
+GCC_FC='`$ECHO "$GCC_FC" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_no_builtin_flag_F77='`$ECHO "$lt_prog_compiler_no_builtin_flag_F77" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_no_builtin_flag_FC='`$ECHO "$lt_prog_compiler_no_builtin_flag_FC" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_pic_F77='`$ECHO "$lt_prog_compiler_pic_F77" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_pic_FC='`$ECHO "$lt_prog_compiler_pic_FC" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_wl_F77='`$ECHO "$lt_prog_compiler_wl_F77" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_wl_FC='`$ECHO "$lt_prog_compiler_wl_FC" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_static_F77='`$ECHO "$lt_prog_compiler_static_F77" | $SED "$delay_single_quote_subst"`'
+lt_prog_compiler_static_FC='`$ECHO "$lt_prog_compiler_static_FC" | $SED "$delay_single_quote_subst"`'
+lt_cv_prog_compiler_c_o_F77='`$ECHO "$lt_cv_prog_compiler_c_o_F77" | $SED "$delay_single_quote_subst"`'
+lt_cv_prog_compiler_c_o_FC='`$ECHO "$lt_cv_prog_compiler_c_o_FC" | $SED "$delay_single_quote_subst"`'
+archive_cmds_need_lc_F77='`$ECHO "$archive_cmds_need_lc_F77" | $SED "$delay_single_quote_subst"`'
+archive_cmds_need_lc_FC='`$ECHO "$archive_cmds_need_lc_FC" | $SED "$delay_single_quote_subst"`'
+enable_shared_with_static_runtimes_F77='`$ECHO "$enable_shared_with_static_runtimes_F77" | $SED "$delay_single_quote_subst"`'
+enable_shared_with_static_runtimes_FC='`$ECHO "$enable_shared_with_static_runtimes_FC" | $SED "$delay_single_quote_subst"`'
+export_dynamic_flag_spec_F77='`$ECHO "$export_dynamic_flag_spec_F77" | $SED "$delay_single_quote_subst"`'
+export_dynamic_flag_spec_FC='`$ECHO "$export_dynamic_flag_spec_FC" | $SED "$delay_single_quote_subst"`'
+whole_archive_flag_spec_F77='`$ECHO "$whole_archive_flag_spec_F77" | $SED "$delay_single_quote_subst"`'
+whole_archive_flag_spec_FC='`$ECHO "$whole_archive_flag_spec_FC" | $SED "$delay_single_quote_subst"`'
+compiler_needs_object_F77='`$ECHO "$compiler_needs_object_F77" | $SED "$delay_single_quote_subst"`'
+compiler_needs_object_FC='`$ECHO "$compiler_needs_object_FC" | $SED "$delay_single_quote_subst"`'
+old_archive_from_new_cmds_F77='`$ECHO "$old_archive_from_new_cmds_F77" | $SED "$delay_single_quote_subst"`'
+old_archive_from_new_cmds_FC='`$ECHO "$old_archive_from_new_cmds_FC" | $SED "$delay_single_quote_subst"`'
+old_archive_from_expsyms_cmds_F77='`$ECHO "$old_archive_from_expsyms_cmds_F77" | $SED "$delay_single_quote_subst"`'
+old_archive_from_expsyms_cmds_FC='`$ECHO "$old_archive_from_expsyms_cmds_FC" | $SED "$delay_single_quote_subst"`'
+archive_cmds_F77='`$ECHO "$archive_cmds_F77" | $SED "$delay_single_quote_subst"`'
+archive_cmds_FC='`$ECHO "$archive_cmds_FC" | $SED "$delay_single_quote_subst"`'
+archive_expsym_cmds_F77='`$ECHO "$archive_expsym_cmds_F77" | $SED "$delay_single_quote_subst"`'
+archive_expsym_cmds_FC='`$ECHO "$archive_expsym_cmds_FC" | $SED "$delay_single_quote_subst"`'
+module_cmds_F77='`$ECHO "$module_cmds_F77" | $SED "$delay_single_quote_subst"`'
+module_cmds_FC='`$ECHO "$module_cmds_FC" | $SED "$delay_single_quote_subst"`'
+module_expsym_cmds_F77='`$ECHO "$module_expsym_cmds_F77" | $SED "$delay_single_quote_subst"`'
+module_expsym_cmds_FC='`$ECHO "$module_expsym_cmds_FC" | $SED "$delay_single_quote_subst"`'
+with_gnu_ld_F77='`$ECHO "$with_gnu_ld_F77" | $SED "$delay_single_quote_subst"`'
+with_gnu_ld_FC='`$ECHO "$with_gnu_ld_FC" | $SED "$delay_single_quote_subst"`'
+allow_undefined_flag_F77='`$ECHO "$allow_undefined_flag_F77" | $SED "$delay_single_quote_subst"`'
+allow_undefined_flag_FC='`$ECHO "$allow_undefined_flag_FC" | $SED "$delay_single_quote_subst"`'
+no_undefined_flag_F77='`$ECHO "$no_undefined_flag_F77" | $SED "$delay_single_quote_subst"`'
+no_undefined_flag_FC='`$ECHO "$no_undefined_flag_FC" | $SED "$delay_single_quote_subst"`'
+hardcode_libdir_flag_spec_F77='`$ECHO "$hardcode_libdir_flag_spec_F77" | $SED "$delay_single_quote_subst"`'
+hardcode_libdir_flag_spec_FC='`$ECHO "$hardcode_libdir_flag_spec_FC" | $SED "$delay_single_quote_subst"`'
+hardcode_libdir_flag_spec_ld_F77='`$ECHO "$hardcode_libdir_flag_spec_ld_F77" | $SED "$delay_single_quote_subst"`'
+hardcode_libdir_flag_spec_ld_FC='`$ECHO "$hardcode_libdir_flag_spec_ld_FC" | $SED "$delay_single_quote_subst"`'
+hardcode_libdir_separator_F77='`$ECHO "$hardcode_libdir_separator_F77" | $SED "$delay_single_quote_subst"`'
+hardcode_libdir_separator_FC='`$ECHO "$hardcode_libdir_separator_FC" | $SED "$delay_single_quote_subst"`'
+hardcode_direct_F77='`$ECHO "$hardcode_direct_F77" | $SED "$delay_single_quote_subst"`'
+hardcode_direct_FC='`$ECHO "$hardcode_direct_FC" | $SED "$delay_single_quote_subst"`'
+hardcode_direct_absolute_F77='`$ECHO "$hardcode_direct_absolute_F77" | $SED "$delay_single_quote_subst"`'
+hardcode_direct_absolute_FC='`$ECHO "$hardcode_direct_absolute_FC" | $SED "$delay_single_quote_subst"`'
+hardcode_minus_L_F77='`$ECHO "$hardcode_minus_L_F77" | $SED "$delay_single_quote_subst"`'
+hardcode_minus_L_FC='`$ECHO "$hardcode_minus_L_FC" | $SED "$delay_single_quote_subst"`'
+hardcode_shlibpath_var_F77='`$ECHO "$hardcode_shlibpath_var_F77" | $SED "$delay_single_quote_subst"`'
+hardcode_shlibpath_var_FC='`$ECHO "$hardcode_shlibpath_var_FC" | $SED "$delay_single_quote_subst"`'
+hardcode_automatic_F77='`$ECHO "$hardcode_automatic_F77" | $SED "$delay_single_quote_subst"`'
+hardcode_automatic_FC='`$ECHO "$hardcode_automatic_FC" | $SED "$delay_single_quote_subst"`'
+inherit_rpath_F77='`$ECHO "$inherit_rpath_F77" | $SED "$delay_single_quote_subst"`'
+inherit_rpath_FC='`$ECHO "$inherit_rpath_FC" | $SED "$delay_single_quote_subst"`'
+link_all_deplibs_F77='`$ECHO "$link_all_deplibs_F77" | $SED "$delay_single_quote_subst"`'
+link_all_deplibs_FC='`$ECHO "$link_all_deplibs_FC" | $SED "$delay_single_quote_subst"`'
+always_export_symbols_F77='`$ECHO "$always_export_symbols_F77" | $SED "$delay_single_quote_subst"`'
+always_export_symbols_FC='`$ECHO "$always_export_symbols_FC" | $SED "$delay_single_quote_subst"`'
+export_symbols_cmds_F77='`$ECHO "$export_symbols_cmds_F77" | $SED "$delay_single_quote_subst"`'
+export_symbols_cmds_FC='`$ECHO "$export_symbols_cmds_FC" | $SED "$delay_single_quote_subst"`'
+exclude_expsyms_F77='`$ECHO "$exclude_expsyms_F77" | $SED "$delay_single_quote_subst"`'
+exclude_expsyms_FC='`$ECHO "$exclude_expsyms_FC" | $SED "$delay_single_quote_subst"`'
+include_expsyms_F77='`$ECHO "$include_expsyms_F77" | $SED "$delay_single_quote_subst"`'
+include_expsyms_FC='`$ECHO "$include_expsyms_FC" | $SED "$delay_single_quote_subst"`'
+prelink_cmds_F77='`$ECHO "$prelink_cmds_F77" | $SED "$delay_single_quote_subst"`'
+prelink_cmds_FC='`$ECHO "$prelink_cmds_FC" | $SED "$delay_single_quote_subst"`'
+postlink_cmds_F77='`$ECHO "$postlink_cmds_F77" | $SED "$delay_single_quote_subst"`'
+postlink_cmds_FC='`$ECHO "$postlink_cmds_FC" | $SED "$delay_single_quote_subst"`'
+file_list_spec_F77='`$ECHO "$file_list_spec_F77" | $SED "$delay_single_quote_subst"`'
+file_list_spec_FC='`$ECHO "$file_list_spec_FC" | $SED "$delay_single_quote_subst"`'
+hardcode_action_F77='`$ECHO "$hardcode_action_F77" | $SED "$delay_single_quote_subst"`'
+hardcode_action_FC='`$ECHO "$hardcode_action_FC" | $SED "$delay_single_quote_subst"`'
+compiler_lib_search_dirs_F77='`$ECHO "$compiler_lib_search_dirs_F77" | $SED "$delay_single_quote_subst"`'
+compiler_lib_search_dirs_FC='`$ECHO "$compiler_lib_search_dirs_FC" | $SED "$delay_single_quote_subst"`'
+predep_objects_F77='`$ECHO "$predep_objects_F77" | $SED "$delay_single_quote_subst"`'
+predep_objects_FC='`$ECHO "$predep_objects_FC" | $SED "$delay_single_quote_subst"`'
+postdep_objects_F77='`$ECHO "$postdep_objects_F77" | $SED "$delay_single_quote_subst"`'
+postdep_objects_FC='`$ECHO "$postdep_objects_FC" | $SED "$delay_single_quote_subst"`'
+predeps_F77='`$ECHO "$predeps_F77" | $SED "$delay_single_quote_subst"`'
+predeps_FC='`$ECHO "$predeps_FC" | $SED "$delay_single_quote_subst"`'
+postdeps_F77='`$ECHO "$postdeps_F77" | $SED "$delay_single_quote_subst"`'
+postdeps_FC='`$ECHO "$postdeps_FC" | $SED "$delay_single_quote_subst"`'
+compiler_lib_search_path_F77='`$ECHO "$compiler_lib_search_path_F77" | $SED "$delay_single_quote_subst"`'
+compiler_lib_search_path_FC='`$ECHO "$compiler_lib_search_path_FC" | $SED "$delay_single_quote_subst"`'
+
+LTCC='$LTCC'
+LTCFLAGS='$LTCFLAGS'
+compiler='$compiler_DEFAULT'
+
+# A function that is used when there is no print builtin or printf.
+func_fallback_echo ()
+{
+ eval 'cat <<_LTECHO_EOF
+\$1
+_LTECHO_EOF'
+}
+
+# Quote evaled strings.
+for var in SHELL \
+ECHO \
+SED \
+GREP \
+EGREP \
+FGREP \
+LD \
+NM \
+LN_S \
+lt_SP2NL \
+lt_NL2SP \
+reload_flag \
+OBJDUMP \
+deplibs_check_method \
+file_magic_cmd \
+file_magic_glob \
+want_nocaseglob \
+DLLTOOL \
+sharedlib_from_linklib_cmd \
+AR \
+AR_FLAGS \
+archiver_list_spec \
+STRIP \
+RANLIB \
+CC \
+CFLAGS \
+compiler \
+lt_cv_sys_global_symbol_pipe \
+lt_cv_sys_global_symbol_to_cdecl \
+lt_cv_sys_global_symbol_to_c_name_address \
+lt_cv_sys_global_symbol_to_c_name_address_lib_prefix \
+nm_file_list_spec \
+lt_prog_compiler_no_builtin_flag \
+lt_prog_compiler_pic \
+lt_prog_compiler_wl \
+lt_prog_compiler_static \
+lt_cv_prog_compiler_c_o \
+need_locks \
+MANIFEST_TOOL \
+DSYMUTIL \
+NMEDIT \
+LIPO \
+OTOOL \
+OTOOL64 \
+shrext_cmds \
+export_dynamic_flag_spec \
+whole_archive_flag_spec \
+compiler_needs_object \
+with_gnu_ld \
+allow_undefined_flag \
+no_undefined_flag \
+hardcode_libdir_flag_spec \
+hardcode_libdir_flag_spec_ld \
+hardcode_libdir_separator \
+exclude_expsyms \
+include_expsyms \
+file_list_spec \
+variables_saved_for_relink \
+libname_spec \
+library_names_spec \
+soname_spec \
+install_override_mode \
+finish_eval \
+old_striplib \
+striplib \
+compiler_lib_search_dirs \
+predep_objects \
+postdep_objects \
+predeps \
+postdeps \
+compiler_lib_search_path \
+LD_F77 \
+LD_FC \
+reload_flag_F77 \
+reload_flag_FC \
+compiler_F77 \
+compiler_FC \
+lt_prog_compiler_no_builtin_flag_F77 \
+lt_prog_compiler_no_builtin_flag_FC \
+lt_prog_compiler_pic_F77 \
+lt_prog_compiler_pic_FC \
+lt_prog_compiler_wl_F77 \
+lt_prog_compiler_wl_FC \
+lt_prog_compiler_static_F77 \
+lt_prog_compiler_static_FC \
+lt_cv_prog_compiler_c_o_F77 \
+lt_cv_prog_compiler_c_o_FC \
+export_dynamic_flag_spec_F77 \
+export_dynamic_flag_spec_FC \
+whole_archive_flag_spec_F77 \
+whole_archive_flag_spec_FC \
+compiler_needs_object_F77 \
+compiler_needs_object_FC \
+with_gnu_ld_F77 \
+with_gnu_ld_FC \
+allow_undefined_flag_F77 \
+allow_undefined_flag_FC \
+no_undefined_flag_F77 \
+no_undefined_flag_FC \
+hardcode_libdir_flag_spec_F77 \
+hardcode_libdir_flag_spec_FC \
+hardcode_libdir_flag_spec_ld_F77 \
+hardcode_libdir_flag_spec_ld_FC \
+hardcode_libdir_separator_F77 \
+hardcode_libdir_separator_FC \
+exclude_expsyms_F77 \
+exclude_expsyms_FC \
+include_expsyms_F77 \
+include_expsyms_FC \
+file_list_spec_F77 \
+file_list_spec_FC \
+compiler_lib_search_dirs_F77 \
+compiler_lib_search_dirs_FC \
+predep_objects_F77 \
+predep_objects_FC \
+postdep_objects_F77 \
+postdep_objects_FC \
+predeps_F77 \
+predeps_FC \
+postdeps_F77 \
+postdeps_FC \
+compiler_lib_search_path_F77 \
+compiler_lib_search_path_FC; do
+ case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in
+ *[\\\\\\\`\\"\\\$]*)
+ eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED \\"\\\$sed_quote_subst\\"\\\`\\\\\\""
+ ;;
+ *)
+ eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\""
+ ;;
+ esac
+done
+
+# Double-quote double-evaled strings.
+for var in reload_cmds \
+old_postinstall_cmds \
+old_postuninstall_cmds \
+old_archive_cmds \
+extract_expsyms_cmds \
+old_archive_from_new_cmds \
+old_archive_from_expsyms_cmds \
+archive_cmds \
+archive_expsym_cmds \
+module_cmds \
+module_expsym_cmds \
+export_symbols_cmds \
+prelink_cmds \
+postlink_cmds \
+postinstall_cmds \
+postuninstall_cmds \
+finish_cmds \
+sys_lib_search_path_spec \
+sys_lib_dlsearch_path_spec \
+reload_cmds_F77 \
+reload_cmds_FC \
+old_archive_cmds_F77 \
+old_archive_cmds_FC \
+old_archive_from_new_cmds_F77 \
+old_archive_from_new_cmds_FC \
+old_archive_from_expsyms_cmds_F77 \
+old_archive_from_expsyms_cmds_FC \
+archive_cmds_F77 \
+archive_cmds_FC \
+archive_expsym_cmds_F77 \
+archive_expsym_cmds_FC \
+module_cmds_F77 \
+module_cmds_FC \
+module_expsym_cmds_F77 \
+module_expsym_cmds_FC \
+export_symbols_cmds_F77 \
+export_symbols_cmds_FC \
+prelink_cmds_F77 \
+prelink_cmds_FC \
+postlink_cmds_F77 \
+postlink_cmds_FC; do
+ case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in
+ *[\\\\\\\`\\"\\\$]*)
+ eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\""
+ ;;
+ *)
+ eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\""
+ ;;
+ esac
+done
+
+ac_aux_dir='$ac_aux_dir'
+xsi_shell='$xsi_shell'
+lt_shell_append='$lt_shell_append'
+
+# See if we are running on zsh, and set the options which allow our
+# commands through without removal of \ escapes INIT.
+if test -n "\${ZSH_VERSION+set}" ; then
+ setopt NO_GLOB_SUBST
+fi
+
+
+ PACKAGE='$PACKAGE'
+ VERSION='$VERSION'
+ TIMESTAMP='$TIMESTAMP'
+ RM='$RM'
+ ofile='$ofile'
+
+
+
+
+
+
+
+
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+
+# Handling of arguments.
+for ac_config_target in $ac_config_targets
+do
+ case $ac_config_target in
+ "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;;
+ "libtool") CONFIG_COMMANDS="$CONFIG_COMMANDS libtool" ;;
+ "gosam.conf") CONFIG_FILES="$CONFIG_FILES gosam.conf" ;;
+ "samurai.pc") CONFIG_FILES="$CONFIG_FILES samurai.pc" ;;
+ "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
+ "ff-2.0/Makefile") CONFIG_FILES="$CONFIG_FILES ff-2.0/Makefile" ;;
+ "ff-2.0/ffinit.f") CONFIG_FILES="$CONFIG_FILES ff-2.0/ffinit.f" ;;
+ "qcdloop-1.9/Makefile") CONFIG_FILES="$CONFIG_FILES qcdloop-1.9/Makefile" ;;
+ "avh_olo-2.2.1/Makefile") CONFIG_FILES="$CONFIG_FILES avh_olo-2.2.1/Makefile" ;;
+ "golem95c-1.2.1/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/Makefile" ;;
+ "golem95c-1.2.1/module/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/module/Makefile" ;;
+ "golem95c-1.2.1/module/precision_golem.f90") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/module/precision_golem.f90" ;;
+ "golem95c-1.2.1/integrals/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/integrals/Makefile" ;;
+ "golem95c-1.2.1/integrals/two_point/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/integrals/two_point/Makefile" ;;
+ "golem95c-1.2.1/integrals/one_point/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/integrals/one_point/Makefile" ;;
+ "golem95c-1.2.1/integrals/three_point/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/integrals/three_point/Makefile" ;;
+ "golem95c-1.2.1/integrals/four_point/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/integrals/four_point/Makefile" ;;
+ "golem95c-1.2.1/integrals/four_point/generic_function_4p.f90") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/integrals/four_point/generic_function_4p.f90" ;;
+ "golem95c-1.2.1/interface/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/interface/Makefile" ;;
+ "golem95c-1.2.1/numerical/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/numerical/Makefile" ;;
+ "golem95c-1.2.1/kinematic/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/kinematic/Makefile" ;;
+ "golem95c-1.2.1/form_factor/Makefile") CONFIG_FILES="$CONFIG_FILES golem95c-1.2.1/form_factor/Makefile" ;;
+ "samurai-2.1.1/Makefile") CONFIG_FILES="$CONFIG_FILES samurai-2.1.1/Makefile" ;;
+ "samurai-2.1.1/madds.f90") CONFIG_FILES="$CONFIG_FILES samurai-2.1.1/madds.f90" ;;
+ "samurai-2.1.1/msamurai.f90") CONFIG_FILES="$CONFIG_FILES samurai-2.1.1/msamurai.f90" ;;
+ "samurai-2.1.1/precision.f90") CONFIG_FILES="$CONFIG_FILES samurai-2.1.1/precision.f90" ;;
+
+ *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
+ esac
+done
+
+
+# If the user did not use the arguments to specify the items to instantiate,
+# then the envvar interface is used. Set only those that are not.
+# We use the long form for the default assignment because of an extremely
+# bizarre bug on SunOS 4.1.3.
+if $ac_need_defaults; then
+ test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files
+ test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands
+fi
+
+# Have a temporary directory for convenience. Make it in the build tree
+# simply because there is no reason against having it here, and in addition,
+# creating and moving files from /tmp can sometimes cause problems.
+# Hook for its removal unless debugging.
+# Note that there is a small window in which the directory will not be cleaned:
+# after its creation but before its name has been assigned to `$tmp'.
+$debug ||
+{
+ tmp= ac_tmp=
+ trap 'exit_status=$?
+ : "${ac_tmp:=$tmp}"
+ { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status
+' 0
+ trap 'as_fn_exit 1' 1 2 13 15
+}
+# Create a (secure) tmp directory for tmp files.
+
+{
+ tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&
+ test -d "$tmp"
+} ||
+{
+ tmp=./conf$$-$RANDOM
+ (umask 077 && mkdir "$tmp")
+} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5
+ac_tmp=$tmp
+
+# Set up the scripts for CONFIG_FILES section.
+# No need to generate them if there are no CONFIG_FILES.
+# This happens for instance with `./config.status config.h'.
+if test -n "$CONFIG_FILES"; then
+
+
+ac_cr=`echo X | tr X '\015'`
+# On cygwin, bash can eat \r inside `` if the user requested igncr.
+# But we know of no other shell where ac_cr would be empty at this
+# point, so we can use a bashism as a fallback.
+if test "x$ac_cr" = x; then
+ eval ac_cr=\$\'\\r\'
+fi
+ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 2>/dev/null`
+if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then
+ ac_cs_awk_cr='\\r'
+else
+ ac_cs_awk_cr=$ac_cr
+fi
+
+echo 'BEGIN {' >"$ac_tmp/subs1.awk" &&
+_ACEOF
+
+
+{
+ echo "cat >conf$$subs.awk <<_ACEOF" &&
+ echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' &&
+ echo "_ACEOF"
+} >conf$$subs.sh ||
+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5
+ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'`
+ac_delim='%!_!# '
+for ac_last_try in false false false false false :; do
+ . ./conf$$subs.sh ||
+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5
+
+ ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X`
+ if test $ac_delim_n = $ac_delim_num; then
+ break
+ elif $ac_last_try; then
+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5
+ else
+ ac_delim="$ac_delim!$ac_delim _$ac_delim!! "
+ fi
+done
+rm -f conf$$subs.sh
+
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK &&
+_ACEOF
+sed -n '
+h
+s/^/S["/; s/!.*/"]=/
+p
+g
+s/^[^!]*!//
+:repl
+t repl
+s/'"$ac_delim"'$//
+t delim
+:nl
+h
+s/\(.\{148\}\)..*/\1/
+t more1
+s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/
+p
+n
+b repl
+:more1
+s/["\\]/\\&/g; s/^/"/; s/$/"\\/
+p
+g
+s/.\{148\}//
+t nl
+:delim
+h
+s/\(.\{148\}\)..*/\1/
+t more2
+s/["\\]/\\&/g; s/^/"/; s/$/"/
+p
+b
+:more2
+s/["\\]/\\&/g; s/^/"/; s/$/"\\/
+p
+g
+s/.\{148\}//
+t delim
+' <conf$$subs.awk | sed '
+/^[^""]/{
+ N
+ s/\n//
+}
+' >>$CONFIG_STATUS || ac_write_fail=1
+rm -f conf$$subs.awk
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+_ACAWK
+cat >>"\$ac_tmp/subs1.awk" <<_ACAWK &&
+ for (key in S) S_is_set[key] = 1
+ FS = ""
+
+}
+{
+ line = $ 0
+ nfields = split(line, field, "@")
+ substed = 0
+ len = length(field[1])
+ for (i = 2; i < nfields; i++) {
+ key = field[i]
+ keylen = length(key)
+ if (S_is_set[key]) {
+ value = S[key]
+ line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3)
+ len += length(value) + length(field[++i])
+ substed = 1
+ } else
+ len += 1 + keylen
+ }
+
+ print line
+}
+
+_ACAWK
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then
+ sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g"
+else
+ cat
+fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \
+ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5
+_ACEOF
+
+# VPATH may cause trouble with some makes, so we remove sole $(srcdir),
+# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and
+# trailing colons and then remove the whole line if VPATH becomes empty
+# (actually we leave an empty line to preserve line numbers).
+if test "x$srcdir" = x.; then
+ ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{
+h
+s///
+s/^/:/
+s/[ ]*$/:/
+s/:\$(srcdir):/:/g
+s/:\${srcdir}:/:/g
+s/:@srcdir@:/:/g
+s/^:*//
+s/:*$//
+x
+s/\(=[ ]*\).*/\1/
+G
+s/\n//
+s/^[^=]*=[ ]*$//
+}'
+fi
+
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+fi # test -n "$CONFIG_FILES"
+
+
+eval set X " :F $CONFIG_FILES :C $CONFIG_COMMANDS"
+shift
+for ac_tag
+do
+ case $ac_tag in
+ :[FHLC]) ac_mode=$ac_tag; continue;;
+ esac
+ case $ac_mode$ac_tag in
+ :[FHL]*:*);;
+ :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;;
+ :[FH]-) ac_tag=-:-;;
+ :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;
+ esac
+ ac_save_IFS=$IFS
+ IFS=:
+ set x $ac_tag
+ IFS=$ac_save_IFS
+ shift
+ ac_file=$1
+ shift
+
+ case $ac_mode in
+ :L) ac_source=$1;;
+ :[FH])
+ ac_file_inputs=
+ for ac_f
+ do
+ case $ac_f in
+ -) ac_f="$ac_tmp/stdin";;
+ *) # Look for the file first in the build tree, then in the source tree
+ # (if the path is not absolute). The absolute path cannot be DOS-style,
+ # because $ac_f cannot contain `:'.
+ test -f "$ac_f" ||
+ case $ac_f in
+ [\\/$]*) false;;
+ *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
+ esac ||
+ as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;
+ esac
+ case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac
+ as_fn_append ac_file_inputs " '$ac_f'"
+ done
+
+ # Let's still pretend it is `configure' which instantiates (i.e., don't
+ # use $as_me), people would be surprised to read:
+ # /* config.h. Generated by config.status. */
+ configure_input='Generated from '`
+ $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'
+ `' by configure.'
+ if test x"$ac_file" != x-; then
+ configure_input="$ac_file. $configure_input"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5
+$as_echo "$as_me: creating $ac_file" >&6;}
+ fi
+ # Neutralize special characters interpreted by sed in replacement strings.
+ case $configure_input in #(
+ *\&* | *\|* | *\\* )
+ ac_sed_conf_input=`$as_echo "$configure_input" |
+ sed 's/[\\\\&|]/\\\\&/g'`;; #(
+ *) ac_sed_conf_input=$configure_input;;
+ esac
+
+ case $ac_tag in
+ *:-:* | *:-) cat >"$ac_tmp/stdin" \
+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;;
+ esac
+ ;;
+ esac
+
+ ac_dir=`$as_dirname -- "$ac_file" ||
+$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$ac_file" : 'X\(//\)[^/]' \| \
+ X"$ac_file" : 'X\(//\)$' \| \
+ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X"$ac_file" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ as_dir="$ac_dir"; as_fn_mkdir_p
+ ac_builddir=.
+
+case "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
+
+case $srcdir in
+ .) # We are building in place.
+ ac_srcdir=.
+ ac_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
+ ac_srcdir=$srcdir$ac_dir_suffix;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
+esac
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
+
+
+ case $ac_mode in
+ :F)
+ #
+ # CONFIG_FILE
+ #
+
+ case $INSTALL in
+ [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;;
+ *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;;
+ esac
+ ac_MKDIR_P=$MKDIR_P
+ case $MKDIR_P in
+ [\\/$]* | ?:[\\/]* ) ;;
+ */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;;
+ esac
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+# If the template does not know about datarootdir, expand it.
+# FIXME: This hack should be removed a few years after 2.60.
+ac_datarootdir_hack=; ac_datarootdir_seen=
+ac_sed_dataroot='
+/datarootdir/ {
+ p
+ q
+}
+/@datadir@/p
+/@docdir@/p
+/@infodir@/p
+/@localedir@/p
+/@mandir@/p'
+case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in
+*datarootdir*) ac_datarootdir_seen=yes;;
+*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
+$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ ac_datarootdir_hack='
+ s&@datadir@&$datadir&g
+ s&@docdir@&$docdir&g
+ s&@infodir@&$infodir&g
+ s&@localedir@&$localedir&g
+ s&@mandir@&$mandir&g
+ s&\\\${datarootdir}&$datarootdir&g' ;;
+esac
+_ACEOF
+
+# Neutralize VPATH when `$srcdir' = `.'.
+# Shell code in configure.ac might set extrasub.
+# FIXME: do we really want to maintain this feature?
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ac_sed_extra="$ac_vpsub
+$extrasub
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+:t
+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
+s|@configure_input@|$ac_sed_conf_input|;t t
+s&@top_builddir@&$ac_top_builddir_sub&;t t
+s&@top_build_prefix@&$ac_top_build_prefix&;t t
+s&@srcdir@&$ac_srcdir&;t t
+s&@abs_srcdir@&$ac_abs_srcdir&;t t
+s&@top_srcdir@&$ac_top_srcdir&;t t
+s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t
+s&@builddir@&$ac_builddir&;t t
+s&@abs_builddir@&$ac_abs_builddir&;t t
+s&@abs_top_builddir@&$ac_abs_top_builddir&;t t
+s&@INSTALL@&$ac_INSTALL&;t t
+s&@MKDIR_P@&$ac_MKDIR_P&;t t
+$ac_datarootdir_hack
+"
+eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \
+ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5
+
+test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
+ { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&
+ { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \
+ "$ac_tmp/out"`; test -z "$ac_out"; } &&
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined" >&5
+$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined" >&2;}
+
+ rm -f "$ac_tmp/stdin"
+ case $ac_file in
+ -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";;
+ *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";;
+ esac \
+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5
+ ;;
+
+
+ :C) { $as_echo "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5
+$as_echo "$as_me: executing $ac_file commands" >&6;}
+ ;;
+ esac
+
+
+ case $ac_file$ac_mode in
+ "depfiles":C) test x"$AMDEP_TRUE" != x"" || {
+ # Autoconf 2.62 quotes --file arguments for eval, but not when files
+ # are listed without --file. Let's play safe and only enable the eval
+ # if we detect the quoting.
+ case $CONFIG_FILES in
+ *\'*) eval set x "$CONFIG_FILES" ;;
+ *) set x $CONFIG_FILES ;;
+ esac
+ shift
+ for mf
+ do
+ # Strip MF so we end up with the name of the file.
+ mf=`echo "$mf" | sed -e 's/:.*$//'`
+ # Check whether this is an Automake generated Makefile or not.
+ # We used to match only the files named `Makefile.in', but
+ # some people rename them; so instead we look at the file content.
+ # Grep'ing the first line is not enough: some people post-process
+ # each Makefile.in and add a new line on top of each file to say so.
+ # Grep'ing the whole file is not good either: AIX grep has a line
+ # limit of 2048, but all sed's we know have understand at least 4000.
+ if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then
+ dirpart=`$as_dirname -- "$mf" ||
+$as_expr X"$mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$mf" : 'X\(//\)[^/]' \| \
+ X"$mf" : 'X\(//\)$' \| \
+ X"$mf" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X"$mf" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ else
+ continue
+ fi
+ # Extract the definition of DEPDIR, am__include, and am__quote
+ # from the Makefile without running `make'.
+ DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"`
+ test -z "$DEPDIR" && continue
+ am__include=`sed -n 's/^am__include = //p' < "$mf"`
+ test -z "am__include" && continue
+ am__quote=`sed -n 's/^am__quote = //p' < "$mf"`
+ # When using ansi2knr, U may be empty or an underscore; expand it
+ U=`sed -n 's/^U = //p' < "$mf"`
+ # Find all dependency output files, they are included files with
+ # $(DEPDIR) in their names. We invoke sed twice because it is the
+ # simplest approach to changing $(DEPDIR) to its actual value in the
+ # expansion.
+ for file in `sed -n "
+ s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \
+ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do
+ # Make sure the directory exists.
+ test -f "$dirpart/$file" && continue
+ fdir=`$as_dirname -- "$file" ||
+$as_expr X"$file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$file" : 'X\(//\)[^/]' \| \
+ X"$file" : 'X\(//\)$' \| \
+ X"$file" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X"$file" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ as_dir=$dirpart/$fdir; as_fn_mkdir_p
+ # echo "creating $dirpart/$file"
+ echo '# dummy' > "$dirpart/$file"
+ done
+ done
+}
+ ;;
+ "libtool":C)
+
+ # See if we are running on zsh, and set the options which allow our
+ # commands through without removal of \ escapes.
+ if test -n "${ZSH_VERSION+set}" ; then
+ setopt NO_GLOB_SUBST
+ fi
+
+ cfgfile="${ofile}T"
+ trap "$RM \"$cfgfile\"; exit 1" 1 2 15
+ $RM "$cfgfile"
+
+ cat <<_LT_EOF >> "$cfgfile"
+#! $SHELL
+
+# `$ECHO "$ofile" | sed 's%^.*/%%'` - Provide generalized library-building support services.
+# Generated automatically by $as_me ($PACKAGE$TIMESTAMP) $VERSION
+# Libtool was configured on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
+# NOTE: Changes made to this file will be lost: look at ltmain.sh.
+#
+# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2005,
+# 2006, 2007, 2008, 2009, 2010 Free Software Foundation,
+# Inc.
+# Written by Gordon Matzigkeit, 1996
+#
+# This file is part of GNU Libtool.
+#
+# GNU Libtool is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of
+# the License, or (at your option) any later version.
+#
+# As a special exception to the GNU General Public License,
+# if you distribute this file as part of a program or library that
+# is built using GNU Libtool, you may include this file under the
+# same distribution terms that you use for the rest of that program.
+#
+# GNU Libtool is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GNU Libtool; see the file COPYING. If not, a copy
+# can be downloaded from http://www.gnu.org/licenses/gpl.html, or
+# obtained by writing to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+
+# The names of the tagged configurations supported by this script.
+available_tags="F77 FC "
+
+# ### BEGIN LIBTOOL CONFIG
+
+# Which release of libtool.m4 was used?
+macro_version=$macro_version
+macro_revision=$macro_revision
+
+# Whether or not to build shared libraries.
+build_libtool_libs=$enable_shared
+
+# Whether or not to build static libraries.
+build_old_libs=$enable_static
+
+# What type of objects to build.
+pic_mode=$pic_mode
+
+# Whether or not to optimize for fast installation.
+fast_install=$enable_fast_install
+
+# Shell to use when invoking shell scripts.
+SHELL=$lt_SHELL
+
+# An echo program that protects backslashes.
+ECHO=$lt_ECHO
+
+# The host system.
+host_alias=$host_alias
+host=$host
+host_os=$host_os
+
+# The build system.
+build_alias=$build_alias
+build=$build
+build_os=$build_os
+
+# A sed program that does not truncate output.
+SED=$lt_SED
+
+# Sed that helps us avoid accidentally triggering echo(1) options like -n.
+Xsed="\$SED -e 1s/^X//"
+
+# A grep program that handles long lines.
+GREP=$lt_GREP
+
+# An ERE matcher.
+EGREP=$lt_EGREP
+
+# A literal string matcher.
+FGREP=$lt_FGREP
+
+# A BSD- or MS-compatible name lister.
+NM=$lt_NM
+
+# Whether we need soft or hard links.
+LN_S=$lt_LN_S
+
+# What is the maximum length of a command?
+max_cmd_len=$max_cmd_len
+
+# Object file suffix (normally "o").
+objext=$ac_objext
+
+# Executable file suffix (normally "").
+exeext=$exeext
+
+# whether the shell understands "unset".
+lt_unset=$lt_unset
+
+# turn spaces into newlines.
+SP2NL=$lt_lt_SP2NL
+
+# turn newlines into spaces.
+NL2SP=$lt_lt_NL2SP
+
+# convert \$build file names to \$host format.
+to_host_file_cmd=$lt_cv_to_host_file_cmd
+
+# convert \$build files to toolchain format.
+to_tool_file_cmd=$lt_cv_to_tool_file_cmd
+
+# An object symbol dumper.
+OBJDUMP=$lt_OBJDUMP
+
+# Method to check whether dependent libraries are shared objects.
+deplibs_check_method=$lt_deplibs_check_method
+
+# Command to use when deplibs_check_method = "file_magic".
+file_magic_cmd=$lt_file_magic_cmd
+
+# How to find potential files when deplibs_check_method = "file_magic".
+file_magic_glob=$lt_file_magic_glob
+
+# Find potential files using nocaseglob when deplibs_check_method = "file_magic".
+want_nocaseglob=$lt_want_nocaseglob
+
+# DLL creation program.
+DLLTOOL=$lt_DLLTOOL
+
+# Command to associate shared and link libraries.
+sharedlib_from_linklib_cmd=$lt_sharedlib_from_linklib_cmd
+
+# The archiver.
+AR=$lt_AR
+
+# Flags to create an archive.
+AR_FLAGS=$lt_AR_FLAGS
+
+# How to feed a file listing to the archiver.
+archiver_list_spec=$lt_archiver_list_spec
+
+# A symbol stripping program.
+STRIP=$lt_STRIP
+
+# Commands used to install an old-style archive.
+RANLIB=$lt_RANLIB
+old_postinstall_cmds=$lt_old_postinstall_cmds
+old_postuninstall_cmds=$lt_old_postuninstall_cmds
+
+# Whether to use a lock for old archive extraction.
+lock_old_archive_extraction=$lock_old_archive_extraction
+
+# A C compiler.
+LTCC=$lt_CC
+
+# LTCC compiler flags.
+LTCFLAGS=$lt_CFLAGS
+
+# Take the output of nm and produce a listing of raw symbols and C names.
+global_symbol_pipe=$lt_lt_cv_sys_global_symbol_pipe
+
+# Transform the output of nm in a proper C declaration.
+global_symbol_to_cdecl=$lt_lt_cv_sys_global_symbol_to_cdecl
+
+# Transform the output of nm in a C name address pair.
+global_symbol_to_c_name_address=$lt_lt_cv_sys_global_symbol_to_c_name_address
+
+# Transform the output of nm in a C name address pair when lib prefix is needed.
+global_symbol_to_c_name_address_lib_prefix=$lt_lt_cv_sys_global_symbol_to_c_name_address_lib_prefix
+
+# Specify filename containing input files for \$NM.
+nm_file_list_spec=$lt_nm_file_list_spec
+
+# The root where to search for dependent libraries,and in which our libraries should be installed.
+lt_sysroot=$lt_sysroot
+
+# The name of the directory that contains temporary libtool files.
+objdir=$objdir
+
+# Used to examine libraries when file_magic_cmd begins with "file".
+MAGIC_CMD=$MAGIC_CMD
+
+# Must we lock files when doing compilation?
+need_locks=$lt_need_locks
+
+# Manifest tool.
+MANIFEST_TOOL=$lt_MANIFEST_TOOL
+
+# Tool to manipulate archived DWARF debug symbol files on Mac OS X.
+DSYMUTIL=$lt_DSYMUTIL
+
+# Tool to change global to local symbols on Mac OS X.
+NMEDIT=$lt_NMEDIT
+
+# Tool to manipulate fat objects and archives on Mac OS X.
+LIPO=$lt_LIPO
+
+# ldd/readelf like tool for Mach-O binaries on Mac OS X.
+OTOOL=$lt_OTOOL
+
+# ldd/readelf like tool for 64 bit Mach-O binaries on Mac OS X 10.4.
+OTOOL64=$lt_OTOOL64
+
+# Old archive suffix (normally "a").
+libext=$libext
+
+# Shared library suffix (normally ".so").
+shrext_cmds=$lt_shrext_cmds
+
+# The commands to extract the exported symbol list from a shared archive.
+extract_expsyms_cmds=$lt_extract_expsyms_cmds
+
+# Variables whose values should be saved in libtool wrapper scripts and
+# restored at link time.
+variables_saved_for_relink=$lt_variables_saved_for_relink
+
+# Do we need the "lib" prefix for modules?
+need_lib_prefix=$need_lib_prefix
+
+# Do we need a version for libraries?
+need_version=$need_version
+
+# Library versioning type.
+version_type=$version_type
+
+# Shared library runtime path variable.
+runpath_var=$runpath_var
+
+# Shared library path variable.
+shlibpath_var=$shlibpath_var
+
+# Is shlibpath searched before the hard-coded library search path?
+shlibpath_overrides_runpath=$shlibpath_overrides_runpath
+
+# Format of library name prefix.
+libname_spec=$lt_libname_spec
+
+# List of archive names. First name is the real one, the rest are links.
+# The last name is the one that the linker finds with -lNAME
+library_names_spec=$lt_library_names_spec
+
+# The coded name of the library, if different from the real name.
+soname_spec=$lt_soname_spec
+
+# Permission mode override for installation of shared libraries.
+install_override_mode=$lt_install_override_mode
+
+# Command to use after installation of a shared archive.
+postinstall_cmds=$lt_postinstall_cmds
+
+# Command to use after uninstallation of a shared archive.
+postuninstall_cmds=$lt_postuninstall_cmds
+
+# Commands used to finish a libtool library installation in a directory.
+finish_cmds=$lt_finish_cmds
+
+# As "finish_cmds", except a single script fragment to be evaled but
+# not shown.
+finish_eval=$lt_finish_eval
+
+# Whether we should hardcode library paths into libraries.
+hardcode_into_libs=$hardcode_into_libs
+
+# Compile-time system search path for libraries.
+sys_lib_search_path_spec=$lt_sys_lib_search_path_spec
+
+# Run-time system search path for libraries.
+sys_lib_dlsearch_path_spec=$lt_sys_lib_dlsearch_path_spec
+
+# Whether dlopen is supported.
+dlopen_support=$enable_dlopen
+
+# Whether dlopen of programs is supported.
+dlopen_self=$enable_dlopen_self
+
+# Whether dlopen of statically linked programs is supported.
+dlopen_self_static=$enable_dlopen_self_static
+
+# Commands to strip libraries.
+old_striplib=$lt_old_striplib
+striplib=$lt_striplib
+
+
+# The linker used to build libraries.
+LD=$lt_LD
+
+# How to create reloadable object files.
+reload_flag=$lt_reload_flag
+reload_cmds=$lt_reload_cmds
+
+# Commands used to build an old-style archive.
+old_archive_cmds=$lt_old_archive_cmds
+
+# A language specific compiler.
+CC=$lt_compiler
+
+# Is the compiler the GNU compiler?
+with_gcc=$GCC
+
+# Compiler flag to turn off builtin functions.
+no_builtin_flag=$lt_lt_prog_compiler_no_builtin_flag
+
+# Additional compiler flags for building library objects.
+pic_flag=$lt_lt_prog_compiler_pic
+
+# How to pass a linker flag through the compiler.
+wl=$lt_lt_prog_compiler_wl
+
+# Compiler flag to prevent dynamic linking.
+link_static_flag=$lt_lt_prog_compiler_static
+
+# Does compiler simultaneously support -c and -o options?
+compiler_c_o=$lt_lt_cv_prog_compiler_c_o
+
+# Whether or not to add -lc for building shared libraries.
+build_libtool_need_lc=$archive_cmds_need_lc
+
+# Whether or not to disallow shared libs when runtime libs are static.
+allow_libtool_libs_with_static_runtimes=$enable_shared_with_static_runtimes
+
+# Compiler flag to allow reflexive dlopens.
+export_dynamic_flag_spec=$lt_export_dynamic_flag_spec
+
+# Compiler flag to generate shared objects directly from archives.
+whole_archive_flag_spec=$lt_whole_archive_flag_spec
+
+# Whether the compiler copes with passing no objects directly.
+compiler_needs_object=$lt_compiler_needs_object
+
+# Create an old-style archive from a shared archive.
+old_archive_from_new_cmds=$lt_old_archive_from_new_cmds
+
+# Create a temporary old-style archive to link instead of a shared archive.
+old_archive_from_expsyms_cmds=$lt_old_archive_from_expsyms_cmds
+
+# Commands used to build a shared archive.
+archive_cmds=$lt_archive_cmds
+archive_expsym_cmds=$lt_archive_expsym_cmds
+
+# Commands used to build a loadable module if different from building
+# a shared archive.
+module_cmds=$lt_module_cmds
+module_expsym_cmds=$lt_module_expsym_cmds
+
+# Whether we are building with GNU ld or not.
+with_gnu_ld=$lt_with_gnu_ld
+
+# Flag that allows shared libraries with undefined symbols to be built.
+allow_undefined_flag=$lt_allow_undefined_flag
+
+# Flag that enforces no undefined symbols.
+no_undefined_flag=$lt_no_undefined_flag
+
+# Flag to hardcode \$libdir into a binary during linking.
+# This must work even if \$libdir does not exist
+hardcode_libdir_flag_spec=$lt_hardcode_libdir_flag_spec
+
+# If ld is used when linking, flag to hardcode \$libdir into a binary
+# during linking. This must work even if \$libdir does not exist.
+hardcode_libdir_flag_spec_ld=$lt_hardcode_libdir_flag_spec_ld
+
+# Whether we need a single "-rpath" flag with a separated argument.
+hardcode_libdir_separator=$lt_hardcode_libdir_separator
+
+# Set to "yes" if using DIR/libNAME\${shared_ext} during linking hardcodes
+# DIR into the resulting binary.
+hardcode_direct=$hardcode_direct
+
+# Set to "yes" if using DIR/libNAME\${shared_ext} during linking hardcodes
+# DIR into the resulting binary and the resulting library dependency is
+# "absolute",i.e impossible to change by setting \${shlibpath_var} if the
+# library is relocated.
+hardcode_direct_absolute=$hardcode_direct_absolute
+
+# Set to "yes" if using the -LDIR flag during linking hardcodes DIR
+# into the resulting binary.
+hardcode_minus_L=$hardcode_minus_L
+
+# Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR
+# into the resulting binary.
+hardcode_shlibpath_var=$hardcode_shlibpath_var
+
+# Set to "yes" if building a shared library automatically hardcodes DIR
+# into the library and all subsequent libraries and executables linked
+# against it.
+hardcode_automatic=$hardcode_automatic
+
+# Set to yes if linker adds runtime paths of dependent libraries
+# to runtime path list.
+inherit_rpath=$inherit_rpath
+
+# Whether libtool must link a program against all its dependency libraries.
+link_all_deplibs=$link_all_deplibs
+
+# Set to "yes" if exported symbols are required.
+always_export_symbols=$always_export_symbols
+
+# The commands to list exported symbols.
+export_symbols_cmds=$lt_export_symbols_cmds
+
+# Symbols that should not be listed in the preloaded symbols.
+exclude_expsyms=$lt_exclude_expsyms
+
+# Symbols that must always be exported.
+include_expsyms=$lt_include_expsyms
+
+# Commands necessary for linking programs (against libraries) with templates.
+prelink_cmds=$lt_prelink_cmds
+
+# Commands necessary for finishing linking programs.
+postlink_cmds=$lt_postlink_cmds
+
+# Specify filename containing input files.
+file_list_spec=$lt_file_list_spec
+
+# How to hardcode a shared library path into an executable.
+hardcode_action=$hardcode_action
+
+# The directories searched by this compiler when creating a shared library.
+compiler_lib_search_dirs=$lt_compiler_lib_search_dirs
+
+# Dependencies to place before and after the objects being linked to
+# create a shared library.
+predep_objects=$lt_predep_objects
+postdep_objects=$lt_postdep_objects
+predeps=$lt_predeps
+postdeps=$lt_postdeps
+
+# The library search path used internally by the compiler when linking
+# a shared library.
+compiler_lib_search_path=$lt_compiler_lib_search_path
+
+# ### END LIBTOOL CONFIG
+
+_LT_EOF
+
+ case $host_os in
+ aix3*)
+ cat <<\_LT_EOF >> "$cfgfile"
+# AIX sometimes has problems with the GCC collect2 program. For some
+# reason, if we set the COLLECT_NAMES environment variable, the problems
+# vanish in a puff of smoke.
+if test "X${COLLECT_NAMES+set}" != Xset; then
+ COLLECT_NAMES=
+ export COLLECT_NAMES
+fi
+_LT_EOF
+ ;;
+ esac
+
+
+ltmain="$ac_aux_dir/ltmain.sh"
+
+
+ # We use sed instead of cat because bash on DJGPP gets confused if
+ # if finds mixed CR/LF and LF-only lines. Since sed operates in
+ # text mode, it properly converts lines to CR/LF. This bash problem
+ # is reportedly fixed, but why not run on old versions too?
+ sed '$q' "$ltmain" >> "$cfgfile" \
+ || (rm -f "$cfgfile"; exit 1)
+
+ if test x"$xsi_shell" = xyes; then
+ sed -e '/^func_dirname ()$/,/^} # func_dirname /c\
+func_dirname ()\
+{\
+\ case ${1} in\
+\ */*) func_dirname_result="${1%/*}${2}" ;;\
+\ * ) func_dirname_result="${3}" ;;\
+\ esac\
+} # Extended-shell func_dirname implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_basename ()$/,/^} # func_basename /c\
+func_basename ()\
+{\
+\ func_basename_result="${1##*/}"\
+} # Extended-shell func_basename implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_dirname_and_basename ()$/,/^} # func_dirname_and_basename /c\
+func_dirname_and_basename ()\
+{\
+\ case ${1} in\
+\ */*) func_dirname_result="${1%/*}${2}" ;;\
+\ * ) func_dirname_result="${3}" ;;\
+\ esac\
+\ func_basename_result="${1##*/}"\
+} # Extended-shell func_dirname_and_basename implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_stripname ()$/,/^} # func_stripname /c\
+func_stripname ()\
+{\
+\ # pdksh 5.2.14 does not do ${X%$Y} correctly if both X and Y are\
+\ # positional parameters, so assign one to ordinary parameter first.\
+\ func_stripname_result=${3}\
+\ func_stripname_result=${func_stripname_result#"${1}"}\
+\ func_stripname_result=${func_stripname_result%"${2}"}\
+} # Extended-shell func_stripname implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_split_long_opt ()$/,/^} # func_split_long_opt /c\
+func_split_long_opt ()\
+{\
+\ func_split_long_opt_name=${1%%=*}\
+\ func_split_long_opt_arg=${1#*=}\
+} # Extended-shell func_split_long_opt implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_split_short_opt ()$/,/^} # func_split_short_opt /c\
+func_split_short_opt ()\
+{\
+\ func_split_short_opt_arg=${1#??}\
+\ func_split_short_opt_name=${1%"$func_split_short_opt_arg"}\
+} # Extended-shell func_split_short_opt implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_lo2o ()$/,/^} # func_lo2o /c\
+func_lo2o ()\
+{\
+\ case ${1} in\
+\ *.lo) func_lo2o_result=${1%.lo}.${objext} ;;\
+\ *) func_lo2o_result=${1} ;;\
+\ esac\
+} # Extended-shell func_lo2o implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_xform ()$/,/^} # func_xform /c\
+func_xform ()\
+{\
+ func_xform_result=${1%.*}.lo\
+} # Extended-shell func_xform implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_arith ()$/,/^} # func_arith /c\
+func_arith ()\
+{\
+ func_arith_result=$(( $* ))\
+} # Extended-shell func_arith implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_len ()$/,/^} # func_len /c\
+func_len ()\
+{\
+ func_len_result=${#1}\
+} # Extended-shell func_len implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+fi
+
+if test x"$lt_shell_append" = xyes; then
+ sed -e '/^func_append ()$/,/^} # func_append /c\
+func_append ()\
+{\
+ eval "${1}+=\\${2}"\
+} # Extended-shell func_append implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ sed -e '/^func_append_quoted ()$/,/^} # func_append_quoted /c\
+func_append_quoted ()\
+{\
+\ func_quote_for_eval "${2}"\
+\ eval "${1}+=\\\\ \\$func_quote_for_eval_result"\
+} # Extended-shell func_append_quoted implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+
+
+ # Save a `func_append' function call where possible by direct use of '+='
+ sed -e 's%func_append \([a-zA-Z_]\{1,\}\) "%\1+="%g' $cfgfile > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+ test 0 -eq $? || _lt_function_replace_fail=:
+else
+ # Save a `func_append' function call even when '+=' is not available
+ sed -e 's%func_append \([a-zA-Z_]\{1,\}\) "%\1="$\1%g' $cfgfile > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+ test 0 -eq $? || _lt_function_replace_fail=:
+fi
+
+if test x"$_lt_function_replace_fail" = x":"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Unable to substitute extended shell functions in $ofile" >&5
+$as_echo "$as_me: WARNING: Unable to substitute extended shell functions in $ofile" >&2;}
+fi
+
+
+ mv -f "$cfgfile" "$ofile" ||
+ (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile")
+ chmod +x "$ofile"
+
+
+ cat <<_LT_EOF >> "$ofile"
+
+# ### BEGIN LIBTOOL TAG CONFIG: F77
+
+# The linker used to build libraries.
+LD=$lt_LD_F77
+
+# How to create reloadable object files.
+reload_flag=$lt_reload_flag_F77
+reload_cmds=$lt_reload_cmds_F77
+
+# Commands used to build an old-style archive.
+old_archive_cmds=$lt_old_archive_cmds_F77
+
+# A language specific compiler.
+CC=$lt_compiler_F77
+
+# Is the compiler the GNU compiler?
+with_gcc=$GCC_F77
+
+# Compiler flag to turn off builtin functions.
+no_builtin_flag=$lt_lt_prog_compiler_no_builtin_flag_F77
+
+# Additional compiler flags for building library objects.
+pic_flag=$lt_lt_prog_compiler_pic_F77
+
+# How to pass a linker flag through the compiler.
+wl=$lt_lt_prog_compiler_wl_F77
+
+# Compiler flag to prevent dynamic linking.
+link_static_flag=$lt_lt_prog_compiler_static_F77
+
+# Does compiler simultaneously support -c and -o options?
+compiler_c_o=$lt_lt_cv_prog_compiler_c_o_F77
+
+# Whether or not to add -lc for building shared libraries.
+build_libtool_need_lc=$archive_cmds_need_lc_F77
+
+# Whether or not to disallow shared libs when runtime libs are static.
+allow_libtool_libs_with_static_runtimes=$enable_shared_with_static_runtimes_F77
+
+# Compiler flag to allow reflexive dlopens.
+export_dynamic_flag_spec=$lt_export_dynamic_flag_spec_F77
+
+# Compiler flag to generate shared objects directly from archives.
+whole_archive_flag_spec=$lt_whole_archive_flag_spec_F77
+
+# Whether the compiler copes with passing no objects directly.
+compiler_needs_object=$lt_compiler_needs_object_F77
+
+# Create an old-style archive from a shared archive.
+old_archive_from_new_cmds=$lt_old_archive_from_new_cmds_F77
+
+# Create a temporary old-style archive to link instead of a shared archive.
+old_archive_from_expsyms_cmds=$lt_old_archive_from_expsyms_cmds_F77
+
+# Commands used to build a shared archive.
+archive_cmds=$lt_archive_cmds_F77
+archive_expsym_cmds=$lt_archive_expsym_cmds_F77
+
+# Commands used to build a loadable module if different from building
+# a shared archive.
+module_cmds=$lt_module_cmds_F77
+module_expsym_cmds=$lt_module_expsym_cmds_F77
+
+# Whether we are building with GNU ld or not.
+with_gnu_ld=$lt_with_gnu_ld_F77
+
+# Flag that allows shared libraries with undefined symbols to be built.
+allow_undefined_flag=$lt_allow_undefined_flag_F77
+
+# Flag that enforces no undefined symbols.
+no_undefined_flag=$lt_no_undefined_flag_F77
+
+# Flag to hardcode \$libdir into a binary during linking.
+# This must work even if \$libdir does not exist
+hardcode_libdir_flag_spec=$lt_hardcode_libdir_flag_spec_F77
+
+# If ld is used when linking, flag to hardcode \$libdir into a binary
+# during linking. This must work even if \$libdir does not exist.
+hardcode_libdir_flag_spec_ld=$lt_hardcode_libdir_flag_spec_ld_F77
+
+# Whether we need a single "-rpath" flag with a separated argument.
+hardcode_libdir_separator=$lt_hardcode_libdir_separator_F77
+
+# Set to "yes" if using DIR/libNAME\${shared_ext} during linking hardcodes
+# DIR into the resulting binary.
+hardcode_direct=$hardcode_direct_F77
+
+# Set to "yes" if using DIR/libNAME\${shared_ext} during linking hardcodes
+# DIR into the resulting binary and the resulting library dependency is
+# "absolute",i.e impossible to change by setting \${shlibpath_var} if the
+# library is relocated.
+hardcode_direct_absolute=$hardcode_direct_absolute_F77
+
+# Set to "yes" if using the -LDIR flag during linking hardcodes DIR
+# into the resulting binary.
+hardcode_minus_L=$hardcode_minus_L_F77
+
+# Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR
+# into the resulting binary.
+hardcode_shlibpath_var=$hardcode_shlibpath_var_F77
+
+# Set to "yes" if building a shared library automatically hardcodes DIR
+# into the library and all subsequent libraries and executables linked
+# against it.
+hardcode_automatic=$hardcode_automatic_F77
+
+# Set to yes if linker adds runtime paths of dependent libraries
+# to runtime path list.
+inherit_rpath=$inherit_rpath_F77
+
+# Whether libtool must link a program against all its dependency libraries.
+link_all_deplibs=$link_all_deplibs_F77
+
+# Set to "yes" if exported symbols are required.
+always_export_symbols=$always_export_symbols_F77
+
+# The commands to list exported symbols.
+export_symbols_cmds=$lt_export_symbols_cmds_F77
+
+# Symbols that should not be listed in the preloaded symbols.
+exclude_expsyms=$lt_exclude_expsyms_F77
+
+# Symbols that must always be exported.
+include_expsyms=$lt_include_expsyms_F77
+
+# Commands necessary for linking programs (against libraries) with templates.
+prelink_cmds=$lt_prelink_cmds_F77
+
+# Commands necessary for finishing linking programs.
+postlink_cmds=$lt_postlink_cmds_F77
+
+# Specify filename containing input files.
+file_list_spec=$lt_file_list_spec_F77
+
+# How to hardcode a shared library path into an executable.
+hardcode_action=$hardcode_action_F77
+
+# The directories searched by this compiler when creating a shared library.
+compiler_lib_search_dirs=$lt_compiler_lib_search_dirs_F77
+
+# Dependencies to place before and after the objects being linked to
+# create a shared library.
+predep_objects=$lt_predep_objects_F77
+postdep_objects=$lt_postdep_objects_F77
+predeps=$lt_predeps_F77
+postdeps=$lt_postdeps_F77
+
+# The library search path used internally by the compiler when linking
+# a shared library.
+compiler_lib_search_path=$lt_compiler_lib_search_path_F77
+
+# ### END LIBTOOL TAG CONFIG: F77
+_LT_EOF
+
+
+ cat <<_LT_EOF >> "$ofile"
+
+# ### BEGIN LIBTOOL TAG CONFIG: FC
+
+# The linker used to build libraries.
+LD=$lt_LD_FC
+
+# How to create reloadable object files.
+reload_flag=$lt_reload_flag_FC
+reload_cmds=$lt_reload_cmds_FC
+
+# Commands used to build an old-style archive.
+old_archive_cmds=$lt_old_archive_cmds_FC
+
+# A language specific compiler.
+CC=$lt_compiler_FC
+
+# Is the compiler the GNU compiler?
+with_gcc=$GCC_FC
+
+# Compiler flag to turn off builtin functions.
+no_builtin_flag=$lt_lt_prog_compiler_no_builtin_flag_FC
+
+# Additional compiler flags for building library objects.
+pic_flag=$lt_lt_prog_compiler_pic_FC
+
+# How to pass a linker flag through the compiler.
+wl=$lt_lt_prog_compiler_wl_FC
+
+# Compiler flag to prevent dynamic linking.
+link_static_flag=$lt_lt_prog_compiler_static_FC
+
+# Does compiler simultaneously support -c and -o options?
+compiler_c_o=$lt_lt_cv_prog_compiler_c_o_FC
+
+# Whether or not to add -lc for building shared libraries.
+build_libtool_need_lc=$archive_cmds_need_lc_FC
+
+# Whether or not to disallow shared libs when runtime libs are static.
+allow_libtool_libs_with_static_runtimes=$enable_shared_with_static_runtimes_FC
+
+# Compiler flag to allow reflexive dlopens.
+export_dynamic_flag_spec=$lt_export_dynamic_flag_spec_FC
+
+# Compiler flag to generate shared objects directly from archives.
+whole_archive_flag_spec=$lt_whole_archive_flag_spec_FC
+
+# Whether the compiler copes with passing no objects directly.
+compiler_needs_object=$lt_compiler_needs_object_FC
+
+# Create an old-style archive from a shared archive.
+old_archive_from_new_cmds=$lt_old_archive_from_new_cmds_FC
+
+# Create a temporary old-style archive to link instead of a shared archive.
+old_archive_from_expsyms_cmds=$lt_old_archive_from_expsyms_cmds_FC
+
+# Commands used to build a shared archive.
+archive_cmds=$lt_archive_cmds_FC
+archive_expsym_cmds=$lt_archive_expsym_cmds_FC
+
+# Commands used to build a loadable module if different from building
+# a shared archive.
+module_cmds=$lt_module_cmds_FC
+module_expsym_cmds=$lt_module_expsym_cmds_FC
+
+# Whether we are building with GNU ld or not.
+with_gnu_ld=$lt_with_gnu_ld_FC
+
+# Flag that allows shared libraries with undefined symbols to be built.
+allow_undefined_flag=$lt_allow_undefined_flag_FC
+
+# Flag that enforces no undefined symbols.
+no_undefined_flag=$lt_no_undefined_flag_FC
+
+# Flag to hardcode \$libdir into a binary during linking.
+# This must work even if \$libdir does not exist
+hardcode_libdir_flag_spec=$lt_hardcode_libdir_flag_spec_FC
+
+# If ld is used when linking, flag to hardcode \$libdir into a binary
+# during linking. This must work even if \$libdir does not exist.
+hardcode_libdir_flag_spec_ld=$lt_hardcode_libdir_flag_spec_ld_FC
+
+# Whether we need a single "-rpath" flag with a separated argument.
+hardcode_libdir_separator=$lt_hardcode_libdir_separator_FC
+
+# Set to "yes" if using DIR/libNAME\${shared_ext} during linking hardcodes
+# DIR into the resulting binary.
+hardcode_direct=$hardcode_direct_FC
+
+# Set to "yes" if using DIR/libNAME\${shared_ext} during linking hardcodes
+# DIR into the resulting binary and the resulting library dependency is
+# "absolute",i.e impossible to change by setting \${shlibpath_var} if the
+# library is relocated.
+hardcode_direct_absolute=$hardcode_direct_absolute_FC
+
+# Set to "yes" if using the -LDIR flag during linking hardcodes DIR
+# into the resulting binary.
+hardcode_minus_L=$hardcode_minus_L_FC
+
+# Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR
+# into the resulting binary.
+hardcode_shlibpath_var=$hardcode_shlibpath_var_FC
+
+# Set to "yes" if building a shared library automatically hardcodes DIR
+# into the library and all subsequent libraries and executables linked
+# against it.
+hardcode_automatic=$hardcode_automatic_FC
+
+# Set to yes if linker adds runtime paths of dependent libraries
+# to runtime path list.
+inherit_rpath=$inherit_rpath_FC
+
+# Whether libtool must link a program against all its dependency libraries.
+link_all_deplibs=$link_all_deplibs_FC
+
+# Set to "yes" if exported symbols are required.
+always_export_symbols=$always_export_symbols_FC
+
+# The commands to list exported symbols.
+export_symbols_cmds=$lt_export_symbols_cmds_FC
+
+# Symbols that should not be listed in the preloaded symbols.
+exclude_expsyms=$lt_exclude_expsyms_FC
+
+# Symbols that must always be exported.
+include_expsyms=$lt_include_expsyms_FC
+
+# Commands necessary for linking programs (against libraries) with templates.
+prelink_cmds=$lt_prelink_cmds_FC
+
+# Commands necessary for finishing linking programs.
+postlink_cmds=$lt_postlink_cmds_FC
+
+# Specify filename containing input files.
+file_list_spec=$lt_file_list_spec_FC
+
+# How to hardcode a shared library path into an executable.
+hardcode_action=$hardcode_action_FC
+
+# The directories searched by this compiler when creating a shared library.
+compiler_lib_search_dirs=$lt_compiler_lib_search_dirs_FC
+
+# Dependencies to place before and after the objects being linked to
+# create a shared library.
+predep_objects=$lt_predep_objects_FC
+postdep_objects=$lt_postdep_objects_FC
+predeps=$lt_predeps_FC
+postdeps=$lt_postdeps_FC
+
+# The library search path used internally by the compiler when linking
+# a shared library.
+compiler_lib_search_path=$lt_compiler_lib_search_path_FC
+
+# ### END LIBTOOL TAG CONFIG: FC
+_LT_EOF
+
+ ;;
+
+ esac
+done # for ac_tag
+
+
+as_fn_exit 0
+_ACEOF
+ac_clean_files=$ac_clean_files_save
+
+test $ac_write_fail = 0 ||
+ as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5
+
+
+# configure is writing to config.log, and then calls config.status.
+# config.status does its own redirection, appending to config.log.
+# Unfortunately, on DOS this fails, as config.log is still kept open
+# by configure, so config.status won't be able to write to it; its
+# output is simply discarded. So we exec the FD to /dev/null,
+# effectively closing config.log, so it can be properly (re)opened and
+# appended to by config.status. When coming back to configure, we
+# need to make the FD available again.
+if test "$no_create" != yes; then
+ ac_cs_success=:
+ ac_config_status_args=
+ test "$silent" = yes &&
+ ac_config_status_args="$ac_config_status_args --quiet"
+ exec 5>/dev/null
+ $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false
+ exec 5>>config.log
+ # Use ||, not &&, to avoid exiting from the if with $? = 1, which
+ # would make configure fail if this is the last instruction.
+ $ac_cs_success || as_fn_exit 1
+fi
+if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
+$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
+fi
+
diff --git a/configure.ac b/configure.ac
new file mode 100644
index 0000000..e1afa34
--- /dev/null
+++ b/configure.ac
@@ -0,0 +1,344 @@
+AC_INIT([GoSam Convenience Package],[1.0],[reiterth@mpp.mpg.de],[gosam-contrib],[http://projects.hepforge.org/golem/gosam-contrib/])
+AC_PREREQ(2.65)
+
+AC_CONFIG_MACRO_DIR([m4])
+AC_CONFIG_AUX_DIR([config.aux])
+
+dnl -----------------------------------------------
+dnl Package name and version number (user defined)
+dnl -----------------------------------------------
+VERSION=1.0
+PACKAGE=gosam-contrib
+
+
+dnl -----------------------------------------------
+dnl ---#[ Checks for programs:
+dnl -----------------------------------------------
+AM_INIT_AUTOMAKE($PACKAGE, $VERSION, no-define, no-dependencies)
+
+AC_LANG_PUSH([Fortran])
+
+AC_PROG_F77([gfortran ifort g77 f77 xlf frt pgf77 fort77 fl32 af77])
+AC_PROG_FC([gfortran ifort g77 f77 xlf frt pgf77 fort77 fl32 af77])
+
+dnl Check the flags needed to link fc programs with ld (i.e. cc)
+AC_FC_LIBRARY_LDFLAGS
+dnl Check for underscoring of external names
+AC_FC_WRAPPERS
+dnl We need to use .f90 and not .f to enable Automake FC support
+dnl Some Intel ifc/ifort do not understand .f95. :-/
+AC_FC_SRCEXT([f90])
+dnl AC_FC_FIXEDFORM
+dnl AC_FC_LINE_LENGTH([unlimited],[],[])
+AC_FC_FREEFORM
+dnl Enable long line support if available
+AC_FC_LINE_LENGTH([unlimited],[],[AC_MSG_WARN([Fortran compiler does not accept long source lines], 77)])
+AC_LANG_POP
+
+AC_LANG_PUSH([Fortran 77])
+MY_F77_LINE_LENGTH([132],[],[AC_MSG_WARN([Fortran 77 compiler does not accept long source lines], 77)])
+AC_LANG_POP
+
+LT_INIT
+LT_INIT
+
+AM_SANITY_CHECK
+dnl -----------------------------------------------
+dnl ---#] Checks for programs:
+dnl -----------------------------------------------
+
+dnl -----------------------------------------------
+dnl ---#[ Setup datadir variable:
+dnl -----------------------------------------------
+dnl @synopsis AC_DEFINE_DIR(VARNAME, DIR [, DESCRIPTION])
+dnl
+dnl This macro sets VARNAME to the expansion of the DIR variable,
+dnl taking care of fixing up ${prefix} and such.
+dnl
+dnl VARNAME is then offered as both an output variable and a C
+dnl preprocessor symbol.
+dnl
+dnl Example:
+dnl
+dnl AC_DEFINE_DIR([DATADIR], [datadir], [Where data are placed to.])
+dnl
+dnl @category Misc
+dnl @author Stepan Kasal <kasal@ucw.cz>
+dnl @author Andreas Schwab <schwab@suse.de>
+dnl @author Guido U. Draheim <guidod@gmx.de>
+dnl @author Alexandre Oliva
+dnl @version 2006-10-13
+dnl @license AllPermissive
+
+AC_DEFUN([AC_DEFINE_DIR], [
+ prefix_NONE=
+ exec_prefix_NONE=
+ test "x$prefix" = xNONE && prefix_NONE=yes && prefix=$ac_default_prefix
+ test "x$exec_prefix" = xNONE && exec_prefix_NONE=yes && exec_prefix=$prefix
+dnl In Autoconf 2.60, ${datadir} refers to ${datarootdir}, which in turn
+dnl refers to ${prefix}. Thus we have to use `eval' twice.
+ eval ac_define_dir="\"[$]$2\""
+ eval ac_define_dir="\"$ac_define_dir\""
+ AC_SUBST($1, "$ac_define_dir")
+ AC_DEFINE_UNQUOTED($1, "$ac_define_dir", [$3])
+ test "$prefix_NONE" && prefix=NONE
+ test "$exec_prefix_NONE" && exec_prefix=NONE
+])
+
+AC_DEFINE_DIR([DATADIR], [datadir])
+dnl -----------------------------------------------
+dnl ---#] Setup datadir variable:
+dnl -----------------------------------------------
+
+dnl ---------------------------------------------------------------------
+dnl ---#[ Set Precision:
+dnl ---------------------------------------------------------------------
+AC_ARG_WITH([precision], [AS_HELP_STRING([--with-precision],
+ [set the precision of the library to either
+ 'double' or 'quadruple'. @<:@default=double@:>@])],
+ [], [with_precision=double])
+AS_IF(
+ [test "x$with_precision" == xquadruple],
+ [AC_SUBST([fortran_real_kind], ["selected_real_kind(32,50)"])],
+ [test "x$with_precision" == xquad],
+ [AC_SUBST([fortran_real_kind], ["selected_real_kind(32,50)"])],
+ [test "x$with_precision" == xdouble],
+ [AC_SUBST([fortran_real_kind], ["kind(1.0d0)"])],
+ [test "x$with_precision" == xintermediate],
+ [AC_SUBST([fortran_real_kind], ["selected_real_kind(18,4931)"])],
+ [AC_MSG_FAILURE([--with-precision was given with an unrecognized
+ parameter])])
+dnl ---------------------------------------------------------------------
+dnl ---#] Set Precision:
+dnl ---------------------------------------------------------------------
+
+dnl ---------------------------------------------------------------------
+dnl ---#[ Configure FF:
+dnl ---------------------------------------------------------------------
+AC_ARG_ENABLE([ff],
+ AS_HELP_STRING([--disable-ff], [do not compile and install FF]))
+
+AM_CONDITIONAL(COMPILE_FF, [test "x$enable_ff" != xno])
+
+AS_IF([test "x$enable_ff" != xno],
+ [AC_SUBST([conf_with_ff], [""])],
+ [AC_SUBST([conf_with_ff], ["# "])])
+AS_IF([test "x$enable_ff" != xno],
+ [AC_SUBST([conf_wout_ff], ["# "])],
+ [AC_SUBST([conf_wout_ff], [""])])
+AS_IF([test "x$enable_ff" != xno],
+ [AC_SUBST([case_with_ff], [" "])],
+ [AC_SUBST([case_with_ff], ["!AC!"])])
+AS_IF([test "x$enable_ff" != xno],
+ [AC_SUBST([case_wout_ff], ["!AC!"])],
+ [AC_SUBST([case_wout_ff], [" "])])
+dnl ---------------------------------------------------------------------
+dnl ---#] Configure FF:
+dnl ---------------------------------------------------------------------
+
+dnl ---------------------------------------------------------------------
+dnl ---#[ Configure QCDLoop:
+dnl ---------------------------------------------------------------------
+AC_ARG_ENABLE([ql],
+ AS_HELP_STRING([--disable-ql], [do not compile and install QCDLoop]))
+
+AM_CONDITIONAL(COMPILE_QL, [test "x$enable_ql" != xno])
+
+AS_IF([test "x$enable_ql" != xno],
+ [AC_SUBST([conf_with_ql], [""])],
+ [AC_SUBST([conf_with_ql], ["# "])])
+AS_IF([test "x$enable_ql" != xno],
+ [AC_SUBST([conf_wout_ql], ["# "])],
+ [AC_SUBST([conf_wout_ql], [""])])
+AS_IF([test "x$enable_ql" != xno],
+ [AC_SUBST([case_with_ql], [" "])],
+ [AC_SUBST([case_with_ql], ["!AC!"])])
+AS_IF([test "x$enable_ql" != xno],
+ [AC_SUBST([case_wout_ql], ["!AC!"])],
+ [AC_SUBST([case_wout_ql], [" "])])
+dnl ---------------------------------------------------------------------
+dnl ---#] Configure QCDLoop:
+dnl ---------------------------------------------------------------------
+
+dnl ---------------------------------------------------------------------
+dnl ---#[ Configure AVH OneLOop:
+dnl ---------------------------------------------------------------------
+AC_ARG_ENABLE([olo],
+ AS_HELP_STRING([--disable-olo], [do not compile and install AVH OneLOop]))
+
+AM_CONDITIONAL(COMPILE_OLO, [test "x$enable_olo" != xno])
+AC_SUBST([avh_olo_real_kind],["$fortran_real_kind"])
+
+AS_IF([test "x$enable_olo" != xno],
+ [AC_SUBST([conf_with_olo], [""])],
+ [AC_SUBST([conf_with_olo], ["# "])])
+AS_IF([test "x$enable_olo" != xno],
+ [AC_SUBST([conf_wout_olo], ["# "])],
+ [AC_SUBST([conf_wout_olo], [""])])
+AS_IF([test "x$enable_olo" != xno],
+ [AC_SUBST([case_with_olo], [" "])],
+ [AC_SUBST([case_with_olo], ["!AC!"])])
+AS_IF([test "x$enable_olo" != xno],
+ [AC_SUBST([case_wout_olo], ["!AC!"])],
+ [AC_SUBST([case_wout_olo], [" "])])
+AS_IF([test "x$enable_olo" != xno],
+ [AC_SUBST([case_with_avh], [" "])],
+ [AC_SUBST([case_with_avh], ["!AC!"])])
+AS_IF([test "x$enable_olo" != xno],
+ [AC_SUBST([case_wout_avh], ["!AC!"])],
+ [AC_SUBST([case_wout_avh], [" "])])
+dnl ---------------------------------------------------------------------
+dnl ---#] Configure AVH OneLOop:
+dnl ---------------------------------------------------------------------
+
+dnl ---------------------------------------------------------------------
+dnl ---#[ Configure Golem95C:
+dnl ---------------------------------------------------------------------
+AC_ARG_ENABLE([golem95],
+ AS_HELP_STRING([--disable-golem95], [do not compile and install Golem95C]))
+
+AM_CONDITIONAL(COMPILE_GOLEM95C, [test "x$enable_golem95" != xno])
+
+AS_IF([test "x$enable_golem95" != xno],
+ [AC_SUBST([conf_with_golem95], [""])],
+ [AC_SUBST([conf_with_golem95], ["# "])])
+AS_IF([test "x$enable_golem95" != xno],
+ [AC_SUBST([conf_wout_golem95], ["# "])],
+ [AC_SUBST([conf_wout_golem95], [""])])
+AS_IF([test "x$enable_golem95" != xno],
+ [AC_SUBST([case_with_golem], [" "])],
+ [AC_SUBST([case_with_golem], ["!AC!"])])
+AS_IF([test "x$enable_golem95" != xno],
+ [AC_SUBST([case_wout_golem], ["!AC!"])],
+ [AC_SUBST([case_wout_golem], [" "])])
+
+AM_CONDITIONAL(COMPILE_TENSREC, [test "x" == "x"])
+dnl ---------------------------------------------------------------------
+dnl ---#] Configure Golem95C:
+dnl ---------------------------------------------------------------------
+
+dnl ---------------------------------------------------------------------
+dnl ---#[ Configure Samurai:
+dnl ---------------------------------------------------------------------
+SAMURAIVERSION=2.1.1
+
+AC_ARG_ENABLE([samurai],
+ AS_HELP_STRING([--disable-samurai], [do not compile and install Samurai]))
+
+AM_CONDITIONAL(COMPILE_SAMURAI, [test "x$enable_golem95" != xno])
+
+AS_IF([test "x$enable_samurai" != xno],
+ [AC_SUBST([conf_with_samurai], [""])],
+ [AC_SUBST([conf_with_samurai], ["# "])])
+AS_IF([test "x$enable_samurai" != xno],
+ [AC_SUBST([conf_wout_samurai], ["# "])],
+ [AC_SUBST([conf_wout_samurai], [""])])
+AS_IF([test "x$enable_samurai" != xno],
+ [AC_SUBST([case_with_samurai], [" "])],
+ [AC_SUBST([case_with_samurai], ["!AC!"])])
+AS_IF([test "x$enable_samurai" != xno],
+ [AC_SUBST([case_wout_samurai], ["!AC!"])],
+ [AC_SUBST([case_wout_samurai], [" "])])
+AC_SUBST(SAMURAIVERSION)
+dnl ---------------------------------------------------------------------
+dnl ---#] Configure Samurai:
+dnl ---------------------------------------------------------------------
+
+dnl ---------------------------------------------------------------------
+dnl ---#[ Configure LoopTools (external):
+dnl ---------------------------------------------------------------------
+AC_ARG_WITH([looptools],
+ [AS_HELP_STRING([--with-looptools],
+ [enable linking to LoopTools])],
+ [],
+ [with_looptools=no])
+
+LIBLOOPTOOLS=
+AS_IF(
+ [test "x$with_looptools" == xyes],
+ [AC_CHECK_LIB([ooptools -lgfortran], [ltexi_],
+ [AC_SUBST([LIBLOOPTOOLS], ["-looptools"])
+ AC_DEFINE([HAVE_LT], [1], [Define if you have Looptools])
+ ],
+ [AC_MSG_FAILURE(
+ [--with-looptools was given, but test for -looptools failed. \
+ Consider using --with-looptools=path/libooptools.a .])],
+ [-looptools])],
+ [test "x$with_looptools" != xno],
+ [AC_CHECK_FILE([$with_looptools],
+ [AC_SUBST([LIBLOOPTOOLS], ["$with_looptools"])
+ AC_DEFINE([HAVE_LT], [1], [Define if you have Looptools])
+ ],
+ [AC_MSG_FAILURE(
+ [--with-looptools was given, but location '$with_looptools' \
+ is wrong.])])]
+ )
+
+AS_IF([test "x$with_looptools" != xno],
+ [AC_SUBST([conf_with_lt], [""])],
+ [AC_SUBST([conf_with_lt], ["#"])])
+AS_IF([test "x$with_looptools" != xno],
+ [AC_SUBST([conf_wout_lt], ["#"])],
+ [AC_SUBST([conf_wout_lt], [""])])
+
+AS_IF([test "x$with_looptools" != xno],
+ [AC_SUBST([case_with_lt], [" "])],
+ [AC_SUBST([case_with_lt], ["!AC!"])])
+AS_IF([test "x$with_looptools" != xno],
+ [AC_SUBST([case_wout_lt], ["!AC!"])],
+ [AC_SUBST([case_wout_lt], [" "])])
+
+dnl -----------------------------------------------
+dnl Set the precision used by LoopTools
+dnl -----------------------------------------------
+AC_ARG_WITH([lt-precision], [AS_HELP_STRING([--with-lt-precision],
+ [set the precision used by LoopTools to either
+ 'double' or 'quadruple'. @<:@default=double@:>@])],
+ [], [with_lt_precision=double])
+
+AS_IF(
+ [test "x$with_lt_precision" == xquadruple],
+ [AC_SUBST([lt_real_kind], ["selected_real_kind(32,50)"])],
+ [test "x$with_lt_precision" == xquad],
+ [AC_SUBST([lt_real_kind], ["selected_real_kind(32,50)"])],
+ [test "x$with_lt_precision" == xdouble],
+ [AC_SUBST([lt_real_kind], ["kind(1.0d0)"])],
+ [AC_MSG_FAILURE([--with-lt-precision was given with an
+ unrecognized parameter])])
+dnl ---------------------------------------------------------------------
+dnl ---#] Configure LoopTools (external):
+dnl ---------------------------------------------------------------------
+
+dnl ---------------------------------------------------------------------
+dnl ---#[ Generates Makefile's, configuration files and scripts:
+dnl ---------------------------------------------------------------------
+AC_CONFIG_FILES([\
+ gosam.conf \
+ samurai.pc \
+ Makefile \
+ ff-2.0/Makefile \
+ ff-2.0/ffinit.f \
+ qcdloop-1.9/Makefile \
+ avh_olo-2.2.1/Makefile \
+ golem95c-1.2.1/Makefile \
+ golem95c-1.2.1/module/Makefile \
+ golem95c-1.2.1/module/precision_golem.f90 \
+ golem95c-1.2.1/integrals/Makefile \
+ golem95c-1.2.1/integrals/two_point/Makefile \
+ golem95c-1.2.1/integrals/one_point/Makefile \
+ golem95c-1.2.1/integrals/three_point/Makefile \
+ golem95c-1.2.1/integrals/four_point/Makefile \
+ golem95c-1.2.1/integrals/four_point/generic_function_4p.f90 \
+ golem95c-1.2.1/interface/Makefile \
+ golem95c-1.2.1/numerical/Makefile \
+ golem95c-1.2.1/kinematic/Makefile \
+ golem95c-1.2.1/form_factor/Makefile \
+ samurai-2.1.1/Makefile \
+ samurai-2.1.1/madds.f90 \
+ samurai-2.1.1/msamurai.f90 \
+ samurai-2.1.1/precision.f90 \
+])
+AC_OUTPUT
+dnl ---------------------------------------------------------------------
+dnl ---#] Generates Makefile's, configuration files and scripts:
+dnl ---------------------------------------------------------------------
diff --git a/ff-2.0/Makefile.am b/ff-2.0/Makefile.am
new file mode 100644
index 0000000..e61fae7
--- /dev/null
+++ b/ff-2.0/Makefile.am
@@ -0,0 +1,18 @@
+lib_LTLIBRARIES=libff.la
+libff_la_SOURCES= \
+ aaxbx.f aaxcx.f aaxdx.f aaxinv.f aacbc.f aaccc.f aacinv.f \
+ spence.f npoin.f ff2dl2.f ffabcd.f ffca0.f ffcb0.f ffcb1.f \
+ ffcb2p.f ffcdb0.f ffcc0.f ffcc0p.f ffcc1.f ffcel2.f ffcel3.f ffcel4.f \
+ ffcel5.f ffceta.f ffcli2.f ffcrr.f ffcxr.f ffcxs3.f ffcxs4.f ffcxyz.f \
+ ffdcc0.f ffdcxs.f ffdel2.f ffdel3.f ffdel4.f ffdel5.f ffdel6.f ffdl2i.f \
+ ffdl5p.f ffdxc0.f ffinit.f ffrcvr.f fftran.f ffxb0.f ffxb1.f ffxb2p.f \
+ ffxc0.f ffxc0i.f ffxc0p.f ffxc1.f ffxd0.f ffxd0h.f ffxd0i.f ffxd0p.f \
+ ffxd1.f ffxdb0.f ffxdbd.f ffxdi.f ffxdpv.f ffxe0.f ffxe1.f ffxf0.f \
+ ffxf0h.f ffxli2.f ffxxyz.f
+# ffcb2.f aaxex.f
+
+dist_pkginclude_HEADERS= aa.h ff.h ffs.h
+
+AM_FFLAGS=-I$(srcdir)
+
+include Makefile.dep
diff --git a/ff-2.0/Makefile.dep b/ff-2.0/Makefile.dep
new file mode 100644
index 0000000..5746dc2
--- /dev/null
+++ b/ff-2.0/Makefile.dep
@@ -0,0 +1 @@
+# Module dependencies
diff --git a/ff-2.0/Makefile.in b/ff-2.0/Makefile.in
new file mode 100644
index 0000000..7c23d70
--- /dev/null
+++ b/ff-2.0/Makefile.in
@@ -0,0 +1,588 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = README $(dist_pkginclude_HEADERS) $(srcdir)/Makefile.am \
+ $(srcdir)/Makefile.dep $(srcdir)/Makefile.in \
+ $(srcdir)/ffinit.f.in
+subdir = ff-2.0
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES = ffinit.f
+CONFIG_CLEAN_VPATH_FILES =
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgincludedir)"
+LTLIBRARIES = $(lib_LTLIBRARIES)
+libff_la_LIBADD =
+am_libff_la_OBJECTS = aaxbx.lo aaxcx.lo aaxdx.lo aaxinv.lo aacbc.lo \
+ aaccc.lo aacinv.lo spence.lo npoin.lo ff2dl2.lo ffabcd.lo \
+ ffca0.lo ffcb0.lo ffcb1.lo ffcb2p.lo ffcdb0.lo ffcc0.lo \
+ ffcc0p.lo ffcc1.lo ffcel2.lo ffcel3.lo ffcel4.lo ffcel5.lo \
+ ffceta.lo ffcli2.lo ffcrr.lo ffcxr.lo ffcxs3.lo ffcxs4.lo \
+ ffcxyz.lo ffdcc0.lo ffdcxs.lo ffdel2.lo ffdel3.lo ffdel4.lo \
+ ffdel5.lo ffdel6.lo ffdl2i.lo ffdl5p.lo ffdxc0.lo ffinit.lo \
+ ffrcvr.lo fftran.lo ffxb0.lo ffxb1.lo ffxb2p.lo ffxc0.lo \
+ ffxc0i.lo ffxc0p.lo ffxc1.lo ffxd0.lo ffxd0h.lo ffxd0i.lo \
+ ffxd0p.lo ffxd1.lo ffxdb0.lo ffxdbd.lo ffxdi.lo ffxdpv.lo \
+ ffxe0.lo ffxe1.lo ffxf0.lo ffxf0h.lo ffxli2.lo ffxxyz.lo
+libff_la_OBJECTS = $(am_libff_la_OBJECTS)
+DEFAULT_INCLUDES = -I.@am__isrc@
+F77COMPILE = $(F77) $(AM_FFLAGS) $(FFLAGS)
+LTF77COMPILE = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS)
+F77LD = $(F77)
+F77LINK = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(F77LD) $(AM_FFLAGS) $(FFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libff_la_SOURCES)
+DIST_SOURCES = $(libff_la_SOURCES)
+HEADERS = $(dist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+lib_LTLIBRARIES = libff.la
+libff_la_SOURCES = \
+ aaxbx.f aaxcx.f aaxdx.f aaxinv.f aacbc.f aaccc.f aacinv.f \
+ spence.f npoin.f ff2dl2.f ffabcd.f ffca0.f ffcb0.f ffcb1.f \
+ ffcb2p.f ffcdb0.f ffcc0.f ffcc0p.f ffcc1.f ffcel2.f ffcel3.f ffcel4.f \
+ ffcel5.f ffceta.f ffcli2.f ffcrr.f ffcxr.f ffcxs3.f ffcxs4.f ffcxyz.f \
+ ffdcc0.f ffdcxs.f ffdel2.f ffdel3.f ffdel4.f ffdel5.f ffdel6.f ffdl2i.f \
+ ffdl5p.f ffdxc0.f ffinit.f ffrcvr.f fftran.f ffxb0.f ffxb1.f ffxb2p.f \
+ ffxc0.f ffxc0i.f ffxc0p.f ffxc1.f ffxd0.f ffxd0h.f ffxd0i.f ffxd0p.f \
+ ffxd1.f ffxdb0.f ffxdbd.f ffxdi.f ffxdpv.f ffxe0.f ffxe1.f ffxf0.f \
+ ffxf0h.f ffxli2.f ffxxyz.f
+
+# ffcb2.f aaxex.f
+dist_pkginclude_HEADERS = aa.h ff.h ffs.h
+AM_FFLAGS = -I$(srcdir)
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu ff-2.0/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu ff-2.0/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+ffinit.f: $(top_builddir)/config.status $(srcdir)/ffinit.f.in
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
+install-libLTLIBRARIES: $(lib_LTLIBRARIES)
+ @$(NORMAL_INSTALL)
+ test -z "$(libdir)" || $(MKDIR_P) "$(DESTDIR)$(libdir)"
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ list2=; for p in $$list; do \
+ if test -f $$p; then \
+ list2="$$list2 $$p"; \
+ else :; fi; \
+ done; \
+ test -z "$$list2" || { \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \
+ }
+
+uninstall-libLTLIBRARIES:
+ @$(NORMAL_UNINSTALL)
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ for p in $$list; do \
+ $(am__strip_dir) \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \
+ done
+
+clean-libLTLIBRARIES:
+ -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES)
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libff.la: $(libff_la_OBJECTS) $(libff_la_DEPENDENCIES)
+ $(F77LINK) -rpath $(libdir) $(libff_la_OBJECTS) $(libff_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f.o:
+ $(F77COMPILE) -c -o $@ $<
+
+.f.obj:
+ $(F77COMPILE) -c -o $@ `$(CYGPATH_W) '$<'`
+
+.f.lo:
+ $(LTF77COMPILE) -c -o $@ $<
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-dist_pkgincludeHEADERS: $(dist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(dist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-dist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(dist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libLTLIBRARIES clean-libtool \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-dist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am: install-libLTLIBRARIES
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-dist_pkgincludeHEADERS \
+ uninstall-libLTLIBRARIES
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libLTLIBRARIES clean-libtool ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am \
+ install-dist_pkgincludeHEADERS install-dvi install-dvi-am \
+ install-exec install-exec-am install-html install-html-am \
+ install-info install-info-am install-libLTLIBRARIES \
+ install-man install-pdf install-pdf-am install-ps \
+ install-ps-am install-strip installcheck installcheck-am \
+ installdirs maintainer-clean maintainer-clean-generic \
+ mostlyclean mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool pdf pdf-am ps ps-am tags uninstall \
+ uninstall-am uninstall-dist_pkgincludeHEADERS \
+ uninstall-libLTLIBRARIES
+
+
+# Module dependencies
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/ff-2.0/README b/ff-2.0/README
new file mode 100644
index 0000000..40dac08
--- /dev/null
+++ b/ff-2.0/README
@@ -0,0 +1,103 @@
+8-sep-2003. A special case in C11 was found to be wrongly coded (thanks Andre van Hameren). In rare circumstances thtis would give the wrong value for C11. New ffxc1.f
+
+1-sept-1996. In spite of my new job at the KNMI, I still fully support
+the FF library.
+
+This is the prerelease of the new version of FF, version 2.0. The complex
+routines are being held back, as these are as yet completely untested. The
+main differences with the normal version are:
+- better handling of non-IR masses which are zero (typically neutrinos)
+- faster IR divergent boxes using the algorithms of Beenakker & Denner
+- B0' (ffxdb0, note that it also returns p^2*B0' to avoid an undefined result
+ for p^2=0)
+- the sixpoint function F0
+- some tensor functions: B2, D2 (the others will follow)
+- hooks for complex functions
+- possibility to input the dotproducts (ffxd0d); experimental.
+Please report any problems you might have to me, gjvo@xs4all.nl or
+t19@nikhef.nl. Without this feedback I have a hard time killing all bugs.
+
+The calling sequences for internal functions have been changed completely, so
+it is not possible to mix routines from theis version with previous ones.
+Also some error messages have been renumbered, so you cannot even mix the
+ffwarn.dat and fferr.dat files.
+
+Geert Jan van Oldenborgh
+
+Bug fixes:
+- 12-07-1991: inconsistent flagging in ffxc0p.f and ffxdi.f caused undefined
+ arguments to be used in some cases. l4also=.FALSE. helps, or the new files.
+- 15-07-1993: better error messages in case of dependent momenta.
+- 19-07-1993: fixed typo in ffzdbd which caused ffzzdl to be called with one
+ argument too many. new file ffzdbd.f
+- 12-10-1993: ffxc0 gave a spurious error when called with 3 spacelike momenta
+- 1-dec-1993: fixed many problems with the error system, for the time being
+ only in the routines with real masses. Added B2. B1' arguments changed!
+ Also added the possibility to input the dotproducts: ffxd0d, ffxc0d. Please
+ report problems with this scheme if you use it. Fixed bug in B0' for
+ xp=0.
+- 1-dec-1993. AA routines added (tensor reduction). The B-reduction is now
+ completely stable; I am working on the other ones. Note that instabilities
+ in the aa routines are not yet reported. B1' still missing.
+- 1-dec-1993. As the new ff.h file is different from the old one you'll have
+ to recompile everything.
+- 2-dec-1993. Further cleaning in the error reports.
+- 18-jan-1994. Fixed a few typos in ffzb0 (file ffcb0.f), wrong # of args.
+- mrt-1994. Fixed a bug in ffxb0 which caused spurious error messages when
+ lwarn was off.
+- 8-aug-1994. Fixed a stupid bug in ffcxyz.f, which caused undefined values to
+ be used, thus giving (very) wrong answers if l4also was .true.. Updated
+ some files to use input ier when checking to beat back on spurious error
+ messages.
+- 25-mar-1995. Fixed a bug in ffcxr.f, when a Taylor expansion was made some
+ eta terms could be undefined.
+- 19-apr-1995. Fixed a bug in ffxd0, if a host of conditions was met the
+ imaginary part would be off by a term i\pi^2. Improved error checking.
+- 22-aug-1995. Fixed a row of bugs which appeared in Z -> gamma gamma gamma
+ with equal masses, mainly extra terms 2\pi^2 which caused the answer to be 4
+ orders of magnitude too large. Some of these gave error messages; other did
+ not. New ffxd0.f, ffdel4.f, ffdcxs.f, ffcxs3.f, ffxc0p.f, ffdxc0.f.
+- 22-sep-1995. Fixed another bug in Z->3gammma, close together algorithm did
+ not check for different i*pi^2. Still wrong for on-shell photons, use
+ p^2=-1d-10 for the time being.
+- 3-oct-1995. Fixed rare bug that caused the Hill identity to be used when it
+ should not, giving an error message from ffzli2 that the argument is too
+ large. Actually harmless numericallyy. New ffcrr.f
+- 6-oct-1995. Fixed another equal-masses bug in the C0, answer was off by
+ pi^2/3 due to typo. New ffxc0p.f.
+- 16-oct-1995. An i*eps problem which occurred in the equal masses case gave
+ the wrong imaginary part. CHECK AGAINST l4also=.FALSE, ldc3c4=.FALSE.
+ New ffcxs4.f, ffcrr.f; put warning in ffxd0h.f
+- 1-dec-1995. When p4^2=0, m2>m1 the IR C0 (using delta) would have the wrong
+ sign.
+- 9-mar-1996: added the complex tensor reduction functions aacbc.f, aaccc.f,
+ ffcb2.f ffcb2p.f, aacinv.f, ffcdb0.f
+- 13-mar-1996: killed a bug in ffdcxs, would appear in cases with equal masses
+ in versions newer than 22-aug-1995. New ffdcxs.f. Also synchronized with
+ my private copy, this entails a new ff.h for the 6-point function. Please
+ recompile everything.
+- 18-mar-1996: Fixed a stupid typo bug in ffcb0, up to now all quantities with
+ complex p^2 but real m^2 would use only the real part of p^2. New ffcb0.f
+- 22-mar-1996: Killed a bug in 13-mar's bugfix in ffdcxs.f. Should really be
+ OK now. Fixed a few warnings with ftnchk'ing, and a typo in the testing in
+ ffxdi.f
+- 27-mar-1996: On request of CERN people, changed ffinit to ffini to avoid
+ conflict with the FFREAD tape handling package. A dummy subroutine ffinit
+ that just calls ffini is included for older programs, if you want to link
+ against the CERN paclib you should NOT include file ffini.o in ff.a!
+- 28-mar-1996. I think I have all the continuations for p^2 complex correct
+ now. New ffcb0.f
+- 4-jun-1996: Added a few safety checks in ffxc0, ffcb0, fxc0i.
+- 16-jul-1996: Added a check in ffxb2q to not use an algorithm which divides
+ by xm1 when xm1.eq.0. New ffxb1p.f
+- 15-aug-1996. Got rid of the last two instances of ffinit.
+- 23-jan-1997. The IR-divergent routines now complain when the user attempts
+ to evaluate a mass singular D0.
+- 21-jul-1997. Moved the archive back to NIKHEF; I hope for good.
+- friday-13-mar-1998: Set xalogm, xclogm to their IEEE value when the
+ optimizer kills the loop and returns zero ffini (ffinit.f)
+ Added word 'path' to ffopen (ffinit.f)
+ Put lwrite on warning (ffxb1.f)
+- 1-oct-1998: Fixed ier bug in aaxcx (was too high for level=3), fixed
+ makefile problems, updated ffmanual.tex, updated npointes slightly.
+
diff --git a/ff-2.0/aa.h b/ff-2.0/aa.h
new file mode 100644
index 0000000..5ff7c82
--- /dev/null
+++ b/ff-2.0/aa.h
@@ -0,0 +1,2 @@
+ logical awrite,atest,aderiv
+ common /aaflag/ awrite,atest,aderiv
diff --git a/ff-2.0/aacbc.f b/ff-2.0/aacbc.f
new file mode 100644
index 0000000..1c97f7b
--- /dev/null
+++ b/ff-2.0/aacbc.f
@@ -0,0 +1,220 @@
+
+* file aacbc.for 16-jul-1990
+
+*###[ aacbc :
+ subroutine aacbc(caxi,cbxi,acbxi,d0,xmu,cp,cma,cmb,level,ier)
+***#[ comment:***********************************************************
+* *
+* Calculation of two point formfactors for complex arguments. *
+* Calls ffcb0, ffcb1, ffcb2p, ffcdb0. *
+* *
+* Input: cp,cma,cmb complex p^2 (B&D), ma^2, mb^2 *
+* d0,xmu real renormalisation constants *
+* level integer rank of tensor(integral) *
+* /aaflag/aderiv logical whether or not to compute B0' *
+* *
+* Output: caxi(2) complex A0(i) (with ma, mb resp.) *
+* cbxi(4) complex B0,B11,B21,B22 *
+* B1 = B11*p *
+* B2 = B21*p*p + B21*g *
+* acbxi(2) complex B0',B11'(not computed) *
+* *
+***#] comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION d0,xmu
+ DOUBLE COMPLEX cp,cma,cmb
+ DOUBLE COMPLEX caxi(2),cbxi(4),acbxi(2)
+*
+* local variables
+*
+ DOUBLE PRECISION maxi(2),mbxi(4),mabxi(2)
+* #] declarations:
+* #[ call ffcbc:
+ call ffcbc(caxi,maxi,cbxi,mbxi,acbxi,mabxi,d0,xmu,cp,cma,cmb,
+ + level,ier)
+* #] call ffcbc:
+*###] aacbc :
+ end
+*###[ ffcbc :
+ subroutine ffcbc(caxi,maxi,cbxi,mbxi,acbxi,mabxi,
+ + d0,xmu,cp,cma,cmb,level,ier)
+***#[ comment:***********************************************************
+* *
+* Calculation of two point formfactors with more accurate errors *
+* Calls ffcb0, ffcb1, ffcb2p, ffcdb0. *
+* *
+* Input: cp,cma,cmb complex p^2 (B&D), ma^2, mb^2 *
+* d0,xmu real renormalisation constants *
+* level integer rank of tensor(integral) *
+* /aaflag/aderiv logical whether or not to compute B0' *
+* *
+* Output: caxi(2) complex A0(i) (with ma, mb resp.) *
+* maxi(2) real maximal partial sum in A0i *
+* cbxi(4) complex B0,B11,B21,B22 *
+* B1 = B11*p *
+* B2 = B21*p*p + B21*g *
+* mbxi(4) real maximal partial sum in B0... *
+* acbxi(2) complex B0',B11'(not computed) *
+* mabxi(2) real maximal partial sum in B0' *
+* *
+***#] comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION maxi(2),mbxi(4),mabxi(2),d0,xmu
+ DOUBLE COMPLEX cp,cma,cmb
+ DOUBLE COMPLEX caxi(2),cbxi(4),acbxi(2)
+*
+* local variables
+*
+ integer i,ier0,ier1
+ DOUBLE PRECISION big,absc,xma,xmb,xp
+ DOUBLE COMPLEX acb0p,cc
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ really real?:
+*
+ if ( DIMAG(cma).eq.0 .and. DIMAG(cmb).eq.0 .and. DIMAG(cp).eq.0
+ + ) then
+ xp = DBLE(cp)
+ xma = DBLE(cma)
+ xmb = DBLE(cmb)
+ if ( awrite ) print *,'ffcbc: calling ffxbx'
+ call ffxbx(caxi,maxi,cbxi,mbxi,acbxi,mabxi,
+ + d0,xmu,xp,xma,xmb,level,ier)
+ return
+ endif
+*
+* #] really real?:
+* #[ init:
+*
+* initialization to nonsense to prevent use of uncomputed vars
+*
+ big = 1/(1d20*xclogm)
+ if ( ltest ) then
+ do 10 i=1,2
+ caxi(i) = big
+ 10 continue
+ do 11 i=1,4
+ cbxi(i) = big
+ 11 continue
+ do 12 i=1,2
+ acbxi(i) = big
+ 12 continue
+ endif
+* #] init:
+* #[ level 0 : B0
+*
+* B0
+*
+ ldot = .TRUE.
+ ier1 = ier
+ call ffcb0(cbxi(1),d0,xmu,cp,cma,cmb,ier1)
+* note that this may be off by a fctor 1/xloss
+ mbxi(1) = absc(cbxi(1))*DBLE(10)**mod(ier1,50)
+ if ( awrite ) then
+ print *,' '
+ print *,'ffcbc : level 0: id,nevent ',id,nevent
+ print *,'B0 =',cbxi(1),mbxi(1),ier1
+ print *,'cfpij2 = '
+ print '(6g12.6)',cfpij2
+ endif
+ if (level .eq. 0 .and. .NOT. aderiv ) goto 990
+* #] level 0 :
+* #[ level 1/2 : B0':
+ if (aderiv) then
+ ier0 = ier
+ call ffcdb0(acbxi(1),acb0p,cp,cma,cmb,ier0)
+ mabxi(1) = absc(acbxi(1))*DBLE(10)**mod(ier0,50)
+ ier1 = max(ier1,ier0)
+ if ( lwarn .and. atest ) then
+ if ( abs(cp*acbxi(1)-acb0p) .gt. precc*abs(acb0p) )
+ + print *,'ffcbc: error: B0'' not consistent: ',
+ + cp*acbxi(1),acb0p,cp*acbxi(1)-acb0p,ier0
+ endif
+ if ( awrite ) then
+ print *,'AB0 =',acbxi(1),mabxi(1),ier0
+ print *,'AB11= not yet implemented'
+ endif
+ endif
+
+ if ( level .eq. 0 ) return
+* #] level 1/2 : B0'
+* #[ level 1 : B11
+*
+* first get the needed A0's
+*
+ ier0 = ier
+ call ffca0(caxi(1),d0,xmu,cma,ier0)
+ maxi(1) = absc(caxi(1))*DBLE(10)**mod(ier0,50)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ffca0(caxi(2),d0,xmu,cmb,ier0)
+ maxi(2) = absc(caxi(2))*DBLE(10)**mod(ier0,50)
+ ier1 = max(ier1,ier0)
+ ier = ier1
+*
+* and get the B11
+*
+ call ffcb1(cbxi(2),cbxi(1),caxi,cp,cma,cmb,cfpij2,ier1)
+ mbxi(2) = absc(cbxi(2))*DBLE(10)**mod(ier1,50)
+*
+* debug output
+*
+ if ( awrite ) then
+ print *,' '
+ print *,'ffcbc : level 1: id,nevent ',id,nevent
+ print *,'B11 = ',cbxi(2),mbxi(2),ier1
+ print *,' A0(1) =',caxi(1),maxi(1)
+ print *,' A0(2) =',caxi(2),maxi(2)
+ endif
+*
+* finished?
+*
+ if (level .eq. 1 ) goto 990
+*
+* #] level 1 :
+* #[ level 2 : B21,B22
+*
+* just a simple call...
+*
+ call ffcb2p(cbxi(3),cbxi(2),cbxi(1),caxi,cp,cma,cmb,cfpij2,ier1)
+ mbxi(3) = absc(cbxi(3))*DBLE(10)**mod(ier1,50)
+ mbxi(4) = absc(cbxi(4))*DBLE(10)**mod(ier1,50)
+*
+* debug output
+*
+ if ( awrite ) then
+ print *,' '
+ print *,'ffcbc : level 2: id,nevent ',id,nevent
+ print *,'B21 = ',cbxi(3),ier1
+ print *,'B22 = ',cbxi(4),ier1
+ endif
+*
+ if (level .eq. 2) goto 990
+*
+* #] level 2 :
+ print *,'ffcbc: error: level ',level,' not supported'
+ stop
+
+ 990 continue
+ ier = max(ier1,ier)
+*###] ffcbc :
+ end
diff --git a/ff-2.0/aaccc.f b/ff-2.0/aaccc.f
new file mode 100644
index 0000000..098aa47
--- /dev/null
+++ b/ff-2.0/aaccc.f
@@ -0,0 +1,583 @@
+*###[ aaccc :
+ subroutine aaccc(caxi,cbxi,ccxi,d0,xmm,cpi,level,ier)
+***#[*comment:***********************************************************
+* *
+* Calculation of formfactors resulting from decvert.sub *
+* or decvert.frm (up to third rank) *
+* 21-dec-1993: switched to ffxc1 for C1, added numerical checks. *
+* Definitions: *
+* C0 = 1/(i pi^2)*\int d^4 Q *
+* 1/((Q^2-m_1^2)((Q+p1)^2-m2^2)((Q-p3)^2-m3^2)) *
+* C1 = 1/(i pi^2)*\int d^n Q Q(mu)/(...) *
+* = C11*p1 + C12*p2 *
+* C2 = C21*p1*p1 + C22*p2*p2 + C23*(p1*p2+p2*p1) + C24*g *
+* C3 = C31*p1*p1*p1 + C32*p2*p2*p2 + C33*(p1*p1*p2 + p1*p2*p1 + *
+* p2*p1*p1) + C34*(p1*p2*p2 + p2*p1*p2 + p1*p2*p2) + C35* *
+* (p1*g + g*p1 + 'g*p1*g') + C36*(p2*g + g*p2 + 'g*p2*g') *
+* *
+* Input: cpi the same as in Geert Jan's routines *
+* level rank of tensor(integral) *
+* Output: caxi(3) : ca0i i=1,2,3 *
+* cbxi(12) : (cb0i,cb11i,cb21i,cb22i) i=1,2,3 *
+* ccxi(13) : cc0,cc1(2),cc2(4),cc3(6) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations :
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION d0,xmm
+ DOUBLE COMPLEX cpi(6)
+ DOUBLE COMPLEX caxi(3),cbxi(12),ccxi(13)
+*
+* local variables
+*
+ DOUBLE PRECISION maxi(3),mbxi(12),mcxi(13)
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* #] declarations :
+* #[ call ffccc:
+*
+ call ffccc(caxi,maxi,cbxi,mbxi,ccxi,mcxi,d0,xmm,cpi,level,ier)
+*
+* #] call ffccc:
+*###] aaccc :
+ end
+*###[ ffccc:
+ subroutine ffccc(caxi,maxi,cbxi,mbxi,ccxi,mcxi,d0,xmm,cpi,level,
+ + ier)
+***#[*comment:***********************************************************
+* *
+* Calculation of three point form factors with more accurate *
+* error estimates. Calls ffxc1, the rest is still here. *
+* Definitions: *
+* C0 = 1/(i pi^2)*\int d^4 Q *
+* 1/((Q^2-m_1^2)((Q+p1)^2-m2^2)((Q-p3)^2-m3^2)) *
+* C1 = 1/(i pi^2)*\int d^n Q Q(mu)/(...) *
+* = C11*p1 + C12*p2 *
+* C2 = C21*p1*p1 + C22*p2*p2 + C23*(p1*p2+p2*p1) + C24*g *
+* C3 = C31*p1*p1*p1 + C32*p2*p2*p2 + C33*(p1*p1*p2 + p1*p2*p1 + *
+* p2*p1*p1) + C34*(p1*p2*p2 + p2*p1*p2 + p1*p2*p2) + C35* *
+* (p1*g + g*p1 + 'g*p1*g') + C36*(p2*g + g*p2 + 'g*p2*g') *
+* *
+* Input: cpi(6) complex m_i^2 (1:3), p_{i-3}^2 (4:6) *
+* d0,xmu real renormalisation constants *
+* level integer rank of tensor (integral) *
+* Output: caxi(3) complex A0(m_i^2) *
+* maxi(3) real max term in sum to caxi() *
+* cbxi(12) complex 3x(B0,B11,B21,B22)(p_i^2) *
+* mbxi(12) real max term in sum to cbxi() *
+* ccxi(13) complex C0,C1(2),C2(4),C3(6) *
+* mcxi(13) real max term in sum to ccxi() *
+* Note that if level<3 some of these are not defined. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION maxi(3),mbxi(12),mcxi(13),d0,xmm
+ DOUBLE COMPLEX caxi(3),cbxi(12),ccxi(13),cpi(6)
+*
+* local variables
+*
+ integer i,bl,ier0,ier1
+ logical adesav
+ DOUBLE PRECISION absc,ma0i(6),mabxi(2),big,xpi(6)
+ DOUBLE COMPLEX acbxi(2),ca0i(6),cc,cc0
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ really real?:
+*
+ if ( DIMAG(cpi(1)).eq.0 .and. DIMAG(cpi(2)).eq.0 .and.
+ + DIMAG(cpi(3)).eq.0 ) then
+ do i=1,6
+ xpi(i) = DBLE(cpi(i))
+ enddo
+ if ( awrite ) print *,'ffccc: calling ffxcx'
+ call ffxcx(caxi,maxi,cbxi,mbxi,ccxi,mcxi,d0,xmm,xpi,level,
+ + ier)
+ return
+ endif
+*
+* #] really real?:
+* #[ initialisations:
+*
+* initialization to nonsense
+*
+ big = 1/(1d20*xclogm)
+ if ( ltest ) then
+ do 10 i=1,3
+ caxi(i) = big
+ 10 continue
+ do 20 i=1,12
+ cbxi(i) = big
+ 20 continue
+ do 30 i=1,13
+ ccxi(i) = big
+ 30 continue
+ endif
+*
+* #] initialisations:
+* #[ get C0:
+*
+* C0-function
+*
+ ldot=.TRUE.
+ ier1 = ier
+ call ffcc0(ccxi(1),cpi,ier1)
+ if ( ier1.gt.10 ) then
+ if ( ltest ) then
+ print *,'ffccc: id = ',id,', nevent = ',nevent
+ print *,'ffccc: lost ',ier1,' digits in C0 with isgnal '
+ + ,isgnal,', trying other roots, isgnal ',-isgnal
+ print *,' if OK (no further messages) adding this'
+ + ,' to your code will improve speed'
+ endif
+ isgnal = -isgnal
+ ier0 = ier
+ call ffcc0(cc0,cpi,ier0)
+ isgnal = -isgnal
+ if ( ier0.lt.ier1 ) then
+ ier1 = ier0
+ ccxi(1) = cc0
+ endif
+ endif
+ if ( ier1 .gt. 10 ) then
+ print *,'ffccc: id = ',id,', nevent = ',nevent
+ print *,'ffccc: error: C0 not stable, lost ',ier1,' digits'
+ print *,' please contact author (t19@nikhef.nl)'
+ print *,'cpi = ',cpi
+ endif
+* note that we may have lost another factor xloss**3 or so
+ mcxi(1) = absc(ccxi(1))*DBLE(10)**mod(ier1,50)
+ if ( awrite ) then
+* #[ for debugging: imported stuff from ff
+ print *,' '
+ print *,'ffccc : level 0 '
+ print *,'C0 =',ccxi(1),mcxi(1),ier1
+ print *,'used:',( cpi(i),i=1,3 )
+ print *,' ',( cpi(i),i=4,6 )
+ print *,'imported stuff via ff.h:'
+ print *,'kin det = ',fdel2
+ print *,'dotpr1,1= ',cfpij3(4,4)
+ print *,'dotpr2,2= ',cfpij3(5,5)
+ print *,'dotpr1,2= ',cfpij3(4,5)
+* #] for debugging:
+ endif
+
+ if ( level.eq.0 ) goto 990
+*
+* #] get C0:
+* #[ need B-functions till b-level=(level-1):
+ bl=level-1
+ if ( awrite ) then
+ print '(a,i1)',' ##[ B-function output: up to level ',bl
+ endif
+ adesav = aderiv
+ aderiv = .FALSE.
+ ier0 = ier
+ call ffcbc( ca0i(1),ma0i(1),cbxi(1),mbxi(1),acbxi,mabxi,
+ + d0,xmm,cpi(5),cpi(2),cpi(3),bl,ier0)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ffcbc( ca0i(3),ma0i(3),cbxi(5),mbxi(5),acbxi,mabxi,
+ + d0,xmm,cpi(6),cpi(1),cpi(3),bl,ier0)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ffcbc( ca0i(5),ma0i(5),cbxi(9),mbxi(9),acbxi,mabxi,
+ + d0,xmm,cpi(4),cpi(1),cpi(2),bl,ier0)
+ ier1 = max(ier1,ier0)
+ aderiv = adesav
+ if ( awrite ) then
+ print '(a)',' ##] B-function output:'
+ endif
+* symmetry in A0(i,j)
+ caxi(1)=ca0i(1)
+ caxi(2)=ca0i(2)
+ caxi(3)=ca0i(3)
+ maxi(1)=ma0i(1)
+ maxi(2)=ma0i(2)
+ maxi(3)=ma0i(3)
+ if ( lwarn .and. atest ) then
+ if ((ca0i(4)-ca0i(2)) .ne. 0. .or.
+ + (ca0i(5)-ca0i(3)) .ne. 0. .or.
+ + (ca0i(6)-ca0i(1)) .ne. 0. ) then
+ print *,'error in A0-calculations in aaxbx.for'
+ endif
+ endif
+* #] need B-functions till b-level=(level-1):
+* #[ break to let ffzcz tie in:
+ call ffcccp(caxi,maxi,cbxi,mbxi,ccxi,mcxi,cpi,level,ier1)
+* #] break to let ffzcz tie in:
+ 990 ier = ier1
+ end
+ subroutine ffcccp(caxi,maxi,cbxi,mbxi,ccxi,mcxi,cpi,level,ier)
+* #[ declarations :
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION maxi(3),mbxi(12),mcxi(13)
+ DOUBLE COMPLEX cpi(6),caxi(3),cbxi(12),ccxi(13)
+*
+* local variables
+*
+ integer i,j,ier1,ier2
+ DOUBLE PRECISION absc,xmax,R1m,R2m,R3m,R4m,
+ + R5m,R6m,R11m,R12m,R13m,R14m,R15m,R16m
+ DOUBLE PRECISION mb0i(3),mb11i(3),mxy(2),mb21i(3),mb22i(3)
+ DOUBLE COMPLEX ci3(3),cf1,cf2
+ DOUBLE COMPLEX R1,R2,R3,R4,R5,R6,R11,R12,R13,R14,R15,R16,R17,
+ + R18,cb0i(3),cb11i(3),cb21i(3),cb22i(3),cc,cxy(2)
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations :
+* #[ kinematical quantities for 3pv-red :
+* inverse kinematical matrix ci3 (2X2)
+ ier2 = ier
+ call aaci3(ci3,cpi,ier2)
+ ier2 = ier2 - ier
+*
+* f-functions:
+ cf1 = 2*cfpij3(1,4)
+ cf2 = 2*cfpij3(1,5)
+* #] kinematical quantities for 3pv-red :
+* #[ level 1 : C11,C12,B0(I)
+* need 3 diff B0(I)-functions,I=1,2,3
+ cb0i(1)=cbxi(1)
+ cb0i(2)=cbxi(5)
+ cb0i(3)=cbxi(9)
+ mb0i(1)=mbxi(1)
+ mb0i(2)=mbxi(5)
+ mb0i(3)=mbxi(9)
+ call ffcc1a(ccxi(2),mcxi(2),ccxi(1),mcxi(1),cb0i,mb0i,
+ + cpi,cfpij3,fdel2,ier)
+ if ( awrite ) then
+ print *,'GEERT JANs-scheme:'
+ print *,'C11=',ccxi(2),mcxi(2),ier
+ print *,'C12=',ccxi(3),mcxi(3),ier
+ print *,' '
+ endif
+ if ( lwarn .and. atest ) then
+* PV-reduction
+ R1=( cf1*ccxi(1)+cb0i(2)-cb0i(1) )/2
+ R2=( cf2*ccxi(1)+cb0i(3)-cb0i(2) )/2
+ R1m=max(absc(cf1)*mcxi(1),mb0i(2),mb0i(1))/2
+ R2m=max(absc(cf2)*mcxi(1),mb0i(3),mb0i(2))/2
+ cxy(1)=ci3(1)*R1+ci3(3)*R2
+ cxy(2)=ci3(3)*R1+ci3(2)*R2
+ mxy(1)=max(absc(ci3(1))*R1m,absc(ci3(3))*R2m)
+ mxy(2)=max(absc(ci3(3))*R1m,absc(ci3(2))*R2m)
+ if ( xloss*absc(ccxi(2)-cxy(1)) .gt. precc*
+ + max(mcxi(2),mxy(1)) )
+ + print *,'ffcccp: error: FF C11 disagrees with PV: ',
+ + ccxi(2),cxy(1),ccxi(2)-cxy(1),ier
+ if ( xloss*absc(ccxi(3)-cxy(2)) .gt. precc*
+ + max(mcxi(3),mxy(2)) )
+ + print *,'ffcccp: error: FF C12 disagrees with PV: ',
+ + ccxi(3),cxy(2),ccxi(3)-cxy(2),ier
+ if (awrite) then
+ print *,' '
+ print *,'ffcccp : level 1: id,nevent ',id,nevent
+ print *,'C11=',ccxi(2)
+ print *,'C12=',ccxi(3)
+ endif
+ endif
+*
+ if ( level.eq.1 ) then
+ if ( lwarn ) then
+ xmax = 0
+ do i=1,3
+ if ( absc(ccxi(i)).ne.0 ) then
+ xmax = max(xmax,mcxi(i)/absc(ccxi(i)))
+ elseif ( mcxi(i).ne.0 ) then
+ xmax = max(xmax,1/precc)
+ endif
+ enddo
+ ier1 = int(log10(xmax))
+ if ( awrite ) print *,'ier = ',ier1
+ else
+ ier1 = 0
+ endif
+ goto 990
+ endif
+*
+* #] level 1 :
+* #[ level 2 : C21,C22,C23,C24,B11(I),A0(I,J)
+* need 3 diff B1-functions and 3 diff A0-fuctions
+ do 12 i=1,3
+ j=(i+1)+(i-1)*3
+ cb11i(i) = cbxi(j)
+ mb11i(i) = mbxi(j)
+ 12 continue
+* PV-reduction
+ ccxi(7)=1/4.d0 + 1/2.d0*cpi(1)*ccxi(1) -
+ + 1/4.d0*( cf1*ccxi(2)+cf2*ccxi(3)-cb0i(1) )
+ ier1 = ier
+ if ( lwarn ) then
+*** c7max = max(x1,2*cpi(1)*absc(ccxi(1)),absc(cf1*ccxi(2)),
+*** + absc(cf2*ccxi(3)),absc(cb0i(1)))/4
+*** if ( absc(ccxi(7)) .lt. xloss*c7max ) then
+*** call ffwarn(293,ier1,absc(ccxi(7)),c7max)
+*** endif
+ mcxi(7) = max(x1,2*absc(cpi(1))*mcxi(1),absc(cf1)*mcxi(2),
+ + absc(cf2)*mcxi(3),mb0i(1))/4
+ endif
+ R3=( cf1*ccxi(2) + cb11i(2) + cb0i(1) )/2 - ccxi(7)
+ R4=( cf2*ccxi(2) + cb11i(3) - cb11i(2) )/2
+ R5=( cf1*ccxi(3) + cb11i(2) - cb11i(1) )/2
+ R6=( cf2*ccxi(3) - cb11i(2) )/2 - ccxi(7)
+ ccxi(4)=ci3(1)*R3 + ci3(3)*R4
+ ccxi(5)=ci3(3)*R5 + ci3(2)*R6
+ ccxi(6)=ci3(3)*R3 + ci3(2)*R4
+ if ( lwarn ) then
+*** R3m = max(absc(cf1*ccxi(2)),absc(cb11i(2)),absc(cb0i(1)),
+*** + 2*c7max)/2
+*** R4m = max(absc(cf2*ccxi(2)),absc(cb11i(3)),absc(cb11i(2)))/2
+*** R5m = max(absc(cf1*ccxi(3)),absc(cb11i(2)),absc(cb11i(1)))/2
+*** R6m = max(absc(cf2*ccxi(3)),absc(cb11i(2)),2*c7max)/2
+*** xmax = max(abs(ci3(1))*R3m,abs(ci3(3))*R4m)
+*** if ( absc(ccxi(4)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(292,ier0,absc(ccxi(4)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(ci3(3))*R5m,abs(ci3(2))*R6m)
+*** if ( absc(ccxi(5)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(291,ier0,absc(ccxi(5)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(ci3(3))*R3m,abs(ci3(2))*R4m)
+*** if ( absc(ccxi(6)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(290,ier0,absc(ccxi(6)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*
+* for the whole chain
+*
+ R3m = max(absc(cf1)*mcxi(2),mb11i(2),mb0i(1),2*mcxi(7))/2
+ R4m = max(absc(cf2)*mcxi(2),mb11i(3),mb11i(2))/2
+ R5m = max(absc(cf1)*mcxi(3),mb11i(2),mb11i(1))/2
+ R6m = max(absc(cf2)*mcxi(3),mb11i(2),2*mcxi(7))/2
+ mcxi(4) = max(absc(ci3(1))*R3m,absc(ci3(3))*R4m)
+ mcxi(5) = max(absc(ci3(3))*R5m,absc(ci3(2))*R6m)
+ mcxi(6) = max(absc(ci3(3))*R3m,absc(ci3(2))*R4m)
+ endif
+ if ( lwarn .and. atest ) then
+ cxy(1) = ci3(1)*R5 + ci3(3)*R6
+ mxy(1) = absc(ci3(1))*R5m + absc(ci3(3))*R6m
+ if ( xloss*absc(cxy(1)-ccxi(6)).gt.precc*max(mcxi(6),mxy(1))
+ + ) then
+ print *,'ffcccp: error: id/nevent ',id,'/',nevent
+ print *,'redundancy check at level 2 failed: '
+ print *,cxy(1),mxy(1)
+ print *,ccxi(6),mcxi(6)
+ print *,absc(cxy(1)-ccxi(6))
+ endif
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'ffcccp : level 2: id,nevent ',id,nevent
+ print *,'C21=',ccxi(4),mcxi(4)
+ print *,'C22=',ccxi(5),mcxi(5)
+ print *,'C23=',ccxi(6),mcxi(6)
+ print *,' ',cxy(1),mxy(1)
+ print *,'C24=',ccxi(7),mcxi(7)
+ endif
+
+ if ( level.eq.2 ) then
+ if ( lwarn ) then
+ xmax = 0
+ do i=1,7
+ if ( absc(ccxi(i)).ne.0 ) then
+ xmax = max(xmax,mcxi(i)/absc(ccxi(i)))
+ elseif ( mcxi(i).ne.0 ) then
+ xmax = max(xmax,1/precc)
+ endif
+ enddo
+ ier1 = int(log10(xmax))
+ if ( awrite ) print *,'ier = ',ier1
+ else
+ ier1 = 0
+ endif
+ goto 990
+ endif
+
+* #] level 2 :
+* #[ level 3 : C31,C32,C33,C34,C35,C36,B21(I),B22(I)
+ do 13 i=1,3
+ j = (i+1)+(i-1)*3
+ cb21i(i)=cbxi(j+1)
+ cb22i(i)=cbxi(j+2)
+ mb21i(i)=mbxi(j+1)
+ mb22i(i)=mbxi(j+2)
+ 13 continue
+* PV-reduction
+ R17=( cf1*ccxi(7)+cb22i(2)-cb22i(1) )/2
+ R18=( cf2*ccxi(7)+cb22i(3)-cb22i(2) )/2
+ ccxi(12)=ci3(1)*R17+ci3(3)*R18
+ ccxi(13)=ci3(3)*R17+ci3(2)*R18
+ if ( lwarn ) then
+*** R17m = max(abs(cf1)*c7max,absc(cb22i(2)),absc(cb22i(1)))/2
+*** R18m = max(abs(cf2)*c7max,absc(cb22i(3)),absc(cb22i(2)))/2
+*** c12max = max(abs(ci3(1))*R17m,abs(ci3(3))*R18m)
+*** if ( absc(ccxi(12)).lt.xloss*c12max ) then
+*** ier0 = ier
+*** call ffwarn(289,ier0,absc(ccxi(12)),c12max)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** c13max = max(abs(ci3(3))*R17m,abs(ci3(2))*R18m)
+*** if ( absc(ccxi(13)).lt.xloss*c13max ) then
+*** ier0 = ier
+*** call ffwarn(288,ier0,absc(ccxi(13)),c13max)
+*** ier1 = max(ier1,ier0)
+*** endif
+ mcxi(12) = max(absc(cf1)*mcxi(7),mb22i(2),mb22i(1))/2
+ mcxi(13) = max(absc(cf2)*mcxi(7),mb22i(3),mb22i(2))/2
+ endif
+ R11=( cf1*ccxi(4)+cb21i(2)-cb0i(1) )/2 - 2*ccxi(12)
+ R12=( cf2*ccxi(4)+cb21i(3)-cb21i(2) )/2
+ R13=( cf1*ccxi(5)+cb21i(2)-cb21i(1) )/2
+ R14=( cf2*ccxi(5) -cb21i(2) )/2 - 2*ccxi(13)
+ R15=( cf1*ccxi(6)+cb21i(2)+cb11i(1) )/2 - ccxi(13)
+ R16=( cf2*ccxi(6) -cb21i(2) )/2 - ccxi(12)
+ ccxi(8) =ci3(1)*R11 + ci3(3)*R12
+ ccxi(9) =ci3(3)*R13 + ci3(2)*R14
+ ccxi(10)=ci3(3)*R11 + ci3(2)*R12
+ ccxi(11)=ci3(1)*R13 + ci3(3)*R14
+ if ( lwarn ) then
+*** R11m = max(absc(cf1*ccxi(4)),absc(cb21i(2)),absc(cb0i(1)),
+*** + 2*c12max)/2
+*** R12m = max(absc(cf2*ccxi(4)),absc(cb21i(3)),absc(cb21i(2)))/2
+*** R13m = max(absc(cf1*ccxi(5)),absc(cb21i(2)),absc(cb21i(1)))/2
+*** R14m = max(absc(cf2*ccxi(5)),absc(cb21i(2)),4*c13max)/2
+*** R15m = max(absc(cf1*ccxi(6)),absc(cb21i(2)),absc(cb11i(1)),
+*** + 2*c13max)/2
+*** R16m = max(absc(cf2*ccxi(6)),absc(cb21i(2)),2*c12max)/2
+*** xmax = max(abs(ci3(1))*R11m,abs(ci3(3))*R12m)
+*** if ( absc(ccxi(8)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(287,ier0,absc(ccxi(8)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(ci3(3))*R13m,abs(ci3(2))*R14m)
+*** if ( absc(ccxi(9)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(286,ier0,absc(ccxi(9)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(ci3(3))*R11m,abs(ci3(2))*R12m)
+*** if ( absc(ccxi(10)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(285,ier0,absc(ccxi(10)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(ci3(1))*R13m,abs(ci3(3))*R14m)
+*** if ( absc(ccxi(11)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(284,ier0,absc(ccxi(11)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*
+* for the whole chain
+*
+ R11m = max(absc(cf1)*mcxi(4),mb21i(2),mb0i(1),2*mcxi(12))/2
+ R12m = max(absc(cf2)*mcxi(4),mb21i(3),mb21i(2))/2
+ R13m = max(absc(cf1)*mcxi(5),mb21i(2),mb21i(1))/2
+ R14m = max(absc(cf2)*mcxi(5),mb21i(2),4*mcxi(13))/2
+ R15m = max(absc(cf1)*mcxi(6),mb21i(2),mb11i(1),2*mcxi(13))/2
+ R16m = max(absc(cf2)*mcxi(6),mb21i(2),2*mcxi(12))/2
+ mcxi(8) = max(absc(ci3(1))*R11m,absc(ci3(3))*R12m)
+ mcxi(9) = max(absc(ci3(3))*R13m,absc(ci3(2))*R14m)
+ mcxi(10)= max(absc(ci3(3))*R11m,absc(ci3(2))*R12m)
+ mcxi(11)= max(absc(ci3(1))*R13m,absc(ci3(3))*R14m)
+ endif
+* redundancy check
+ if ( lwarn .and. atest ) then
+ cxy(1) = ci3(1)*R15 + ci3(3)*R16
+ cxy(2) = ci3(3)*R15 + ci3(2)*R16
+ mxy(1) = absc(ci3(1))*R15m + absc(ci3(3))*R16m
+ mxy(2) = absc(ci3(3))*R15m + absc(ci3(2))*R16m
+ if ( xloss*absc(cxy(1)-ccxi(10)).gt.precc*max(mxy(1),
+ + mcxi(10))
+ + .or. xloss*absc(cxy(2)-ccxi(11)).gt.precc*max(mxy(2),
+ + mcxi(11)) ) then
+ print *,'ffcccp: error: id/nevent ',id,'/',nevent
+ print *,'redundancy check at level 3 failed: '
+ print *,cxy(1),mxy(1)
+ print *,ccxi(10),mcxi(10)
+ print *,absc(cxy(1)-ccxi(10))
+ print *,cxy(2),mxy(2)
+ print *,ccxi(11),mcxi(11)
+ print *,absc(cxy(1)-ccxi(11))
+ endif
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'ffcccp : level 3: id,nevent ',id,nevent
+ print *,'C31=',ccxi(8),mcxi(8)
+ print *,'C32=',ccxi(9),mcxi(9)
+ print *,'C33=',ccxi(10),mcxi(10)
+ print *,' ',cxy(1),mxy(1)
+ print *,'C34=',ccxi(11),mcxi(11)
+ print *,' ',cxy(2),mxy(2)
+ print *,'C35=',ccxi(12),mcxi(12)
+ print *,'C36=',ccxi(13),mcxi(13)
+ endif
+
+ if ( level.eq.3 ) then
+ if ( lwarn ) then
+ xmax = 0
+ do i=1,13
+ if ( absc(ccxi(i)).ne.0 ) then
+ xmax = max(xmax,mcxi(i)/absc(ccxi(i)))
+ elseif ( mcxi(i).ne.0 ) then
+ xmax = max(xmax,1/precc)
+ endif
+ enddo
+ ier1 = int(log10(xmax))
+ if ( awrite ) print *,'ier = ',ier1
+ else
+ ier1 = 0
+ endif
+ goto 990
+ endif
+
+* #] level 3 :
+* #[ end:
+ print *,'ffcccp: level ',level,' not supported.'
+ stop
+ 990 continue
+ ier = ier1 + ier2
+* #] end:
+*###] ffccc:
+ end
diff --git a/ff-2.0/aacinv.f b/ff-2.0/aacinv.f
new file mode 100644
index 0000000..1b39cb0
--- /dev/null
+++ b/ff-2.0/aacinv.f
@@ -0,0 +1,186 @@
+
+* file aaxinv 4-oct-1990
+
+*###[ : aaci3 :
+ subroutine aaci3(ci3,cpi,ier)
+*###[ : comment:*******************************************************
+*###] : comment:**********************************************************
+*###[ : declarations :
+ implicit none
+* arguments
+ DOUBLE COMPLEX ci3(3),cpi(6)
+ integer ier
+* local variables
+ integer i
+ DOUBLE PRECISION xmax,absc
+ DOUBLE COMPLEX e3(3),s1,s2,s3,cnul,cc
+* common blocks
+ include 'ff.h'
+ include 'aa.h'
+* statement function
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*###] : declarations :
+*###[ : kinematical matrix x3 and inverse ci3:
+* the dotproducts are imported via ff.h
+* definition see ffxc0.ffdot3:comment
+ s1=cfpij3(4,4)
+ s2=cfpij3(5,5)
+ s3=cfpij3(4,5)
+* inverse kinematical matrix ci3
+* the determinant is also provided by ff
+ if ( fdel2.eq.0 ) then
+ call fferr(89,ier)
+ return
+ endif
+ if ( atest ) then
+* make sure that they are correct.
+ do i=4,5
+ cnul = cfpij3(i,i) - cpi(i)
+ if ( xloss*absc(cnul).gt.precc*absc(cpi(i)) ) then
+ print *,'aaci3: error: saved cfpij3(',i,i,
+ + ') does not agree with recomputed: ',
+ + cfpij3(4,4),cpi(4),cnul
+ endif
+ enddo
+ cnul = 2*cfpij3(4,5) + cpi(4) + cpi(5) - cpi(6)
+ xmax = max(absc(cpi(4)),absc(cpi(5)),absc(cpi(6)))
+ if ( xloss*absc(cnul).gt.precc*xmax ) then
+ print *,'aaci3: error: saved cfpij3(4,5) does not ',
+ + 'agree with recomputed: ',2*cfpij3(4,5),
+ + cpi(6)-cpi(4)-cpi(5),cnul,xmax
+ endif
+ cnul = fdel2 - cpi(4)*cpi(5) + cfpij3(4,5)**2
+ xmax = max(abs(fdel2),absc(cfpij3(4,5)**2))
+ if ( xloss*absc(cnul).gt.precc*xmax ) then
+ print *,'aaci3: error: saved fdel2 does not ',
+ + 'agree with recomputed: ',fdel2,
+ + cpi(4)*cpi(5) - cfpij3(4,5)**2,cnul,xmax
+ endif
+ endif
+ ci3(1)= s2*DBLE(1/fdel2)
+ ci3(3)=-s3*DBLE(1/fdel2)
+ ci3(2)= s1*DBLE(1/fdel2)
+*###] : kinematical matrix x3 and inverse ci3:
+*###[ : check: on accuracy
+ if ( atest ) then
+ e3(1)= s1*ci3(1)+s3*ci3(3)
+ e3(2)= s3*ci3(3)+s2*ci3(2)
+ e3(3)= s1*ci3(3)+s3*ci3(2)
+ if ( absc(e3(1)-1) .gt. .1d-4 ) then
+ print *,'aaci3: error in ci3(1) or ci3(3): ',e3(1)-1,ci3
+ endif
+ if ( absc(e3(2)-1) .gt. .1d-4 ) then
+ print *,'aaci3: error in ci3(2) or ci3(3): ',e3(2)-1,ci3
+ endif
+ if ( absc(e3(3)) .gt. .1d-4 ) then
+ print *,'aaci3: error in ci3(2) or ci3(3): ',e3(3),ci3
+ endif
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'aaci3:imported dots and inv:'
+ print *,'s..ci3 ',s1,ci3(1)
+ print *,' ',s2,ci3(2)
+ print *,' ',s3,ci3(3)
+ print *,' '
+ endif
+*###] : check:
+*###] : aaci3 :
+ end
+
+*###[ : aaci4 :
+ subroutine aaci4(ci4,ier)
+*###[ : comment:*******************************************************
+*###] : comment:**********************************************************
+*###[ : declarations :
+ implicit none
+* arguments
+ DOUBLE COMPLEX ci4(6)
+ integer ier
+* local variables
+ integer i,ier0,ier1
+ DOUBLE COMPLEX e4(6),s1,s2,s3,s4,s5,s6,cdel2,cc
+ DOUBLE PRECISION absc
+* common blocks
+ include 'ff.h'
+ include 'aa.h'
+* statement function
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*###] : declarations :
+*###[ : kinematical matrix x4 and inverse ci4:
+ if ( fdel3.eq.0 ) then
+ call fferr(90,ier)
+ return
+ endif
+* the dotproducts are imported via ff.h
+* definition see ffxd0.ffdot4:comment
+* inverse kinematical matrix ci4
+* the determinant is also provided by ff
+* ci4(1)=( +s2*s3-s6**2 )/fdel3
+* ci4(4)=( -s3*s4+s5*s6 )/fdel3
+* ci4(5)=( -s2*s5+s4*s6 )/fdel3
+* ci4(2)=( +s1*s3-s5**2 )/fdel3
+* ci4(6)=( -s1*s6+s4*s5 )/fdel3
+* ci4(3)=( +s1*s2-s4**2 )/fdel3
+ ier1 = ier
+*
+ ier0 = ier
+ call ffcel2(cdel2,cfpij4,10,6,7,10,1,ier0)
+ ier1 = max(ier0,ier1)
+ ci4(1) = +cdel2*(1/fdel3)
+*
+ cdel2 = cfpij4(5,5)*cfpij4(7,7) - cfpij4(5,7)**2
+ if ( lwarn .and. absc(cdel2).lt.xloss*absc(cfpij4(5,7)**2) )
+ + then
+ ier0 = ier
+ call ffwarn(263,ier0,cdel2,absc(cfpij4(5,7)**2))
+ ier1 = max(ier0,ier1)
+ endif
+ ci4(2) = +cdel2*(1/fdel3)
+*
+ ier0 = ier
+ call ffdel2(cdel2,cfpij4,10,5,6,9,1,ier0)
+ ier1 = max(ier0,ier1)
+ ci4(3) = +cdel2*(1/fdel3)
+*
+ ier0 = ier
+ call ffdl2t(cdel2,cfpij4,5,7,6,7,10,-1,-1,10,ier0)
+ ier1 = max(ier1,ier0)
+ ci4(4) = -cdel2*(1/fdel3)
+*
+ ier0 = ier
+ call ffdl2i(cdel2,cfpij4,10,5,6,9,-1,6,7,10,+1,ier0)
+ ier1 = max(ier1,ier0)
+ ci4(5) = +cdel2*(1/fdel3)
+*
+ ier0 = ier
+ call ffdl2t(cdel2,cfpij4,5,7,5,6,9,+1,-1,10,ier0)
+ ier1 = max(ier1,ier0)
+ ci4(6) = -cdel2*(1/fdel3)
+*
+*###] : kinematical matrix x4 and inverse ci4:
+*###[ : check:
+ if ( atest ) then
+ s1=cfpij4(5,5)
+ s2=cfpij4(6,6)
+ s3=cfpij4(7,7)
+ s4=cfpij4(5,6)
+ s5=cfpij4(5,7)
+ s6=cfpij4(6,7)
+ e4(1) = ( s1*ci4(1)+s4*ci4(4)+s5*ci4(5) )
+ e4(2) = ( s4*ci4(4)+s2*ci4(2)+s6*ci4(6) )
+ e4(3) = ( s5*ci4(5)+s6*ci4(6)+s3*ci4(3) )
+ e4(4) = ( s1*ci4(4)+s4*ci4(2)+s5*ci4(6) )
+ e4(5) = ( s1*ci4(5)+s4*ci4(6)+s5*ci4(3) )
+ e4(6) = ( s4*ci4(5)+s2*ci4(6)+s6*ci4(3) )
+ do 12 i=1,3
+ if ( absc(e4(i)-1.d0) .gt. .1d-5 .or.
+ + absc(e4(i+3) ) .gt. .1d-5 ) then
+ print *,'aaci4: error in ci4'
+ return
+ endif
+ 12 continue
+ endif
+*###] : check:
+*###] : aaci4 :
+ end
diff --git a/ff-2.0/aaxbx.f b/ff-2.0/aaxbx.f
new file mode 100644
index 0000000..ccb9cab
--- /dev/null
+++ b/ff-2.0/aaxbx.f
@@ -0,0 +1,201 @@
+
+* file aaxbx.for 16-jul-1990
+
+*###[ aaxbx :
+ subroutine aaxbx(caxi,cbxi,acbxi,d0,xmu,xp,xma,xmb,level,ier)
+***#[ comment:***********************************************************
+* *
+* Calculation of two point formfactors. *
+* Calls ffxb0, ffxb1, ffxb2p, ffxdb0. *
+* *
+* Input: xp,xma,xmb real p^2 (B&D), ma^2, mb^2 *
+* d0,xmu real renormalisation constants *
+* level integer rank of tensor(integral) *
+* /aaflag/aderiv logical whether or not to compute B0' *
+* *
+* Output: caxi(2) complex A0(i) (with ma, mb resp.) *
+* cbxi(4) complex B0,B11,B21,B22 *
+* B1 = B11*p *
+* B2 = B21*p*p + B21*g *
+* acbxi(2) complex B0',B11'(not computed) *
+* *
+***#] comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION xp,xma,xmb,d0,xmu
+ DOUBLE COMPLEX caxi(2),cbxi(4),acbxi(2)
+*
+* local variables
+*
+ DOUBLE PRECISION maxi(2),mbxi(4),mabxi(2)
+* #] declarations:
+* #[ call ffxbx:
+ call ffxbx(caxi,maxi,cbxi,mbxi,acbxi,mabxi,d0,xmu,xp,xma,xmb,
+ + level,ier)
+* #] call ffxbx:
+*###] aaxbx :
+ end
+*###[ ffxbx :
+ subroutine ffxbx(caxi,maxi,cbxi,mbxi,acbxi,mabxi,
+ + d0,xmu,xp,xma,xmb,level,ier)
+***#[ comment:***********************************************************
+* *
+* Calculation of two point formfactors with more accurate errors *
+* Calls ffxb0, ffxb1, ffxb2p, ffxdb0. *
+* *
+* Input: xp,xma,xmb real p^2 (B&D), ma^2, mb^2 *
+* d0,xmu real renormalisation constants *
+* level integer rank of tensor(integral) *
+* /aaflag/aderiv logical whether or not to compute B0' *
+* *
+* Output: caxi(2) complex A0(i) (with ma, mb resp.) *
+* maxi(2) real maximal partial sum in A0i *
+* cbxi(4) complex B0,B11,B21,B22 *
+* B1 = B11*p *
+* B2 = B21*p*p + B21*g *
+* mbxi(4) real maximal partial sum in B0... *
+* acbxi(2) complex B0',B11'(not computed) *
+* mabxi(2) real maximal partial sum in B0' *
+* *
+***#] comment:***********************************************************
+* #[ declarations :
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION maxi(2),mbxi(4),mabxi(2),xp,xma,xmb,d0,xmu
+ DOUBLE COMPLEX caxi(2),cbxi(4),acbxi(2)
+*
+* local variables
+*
+ integer i,ier0,ier1
+ DOUBLE PRECISION big
+ DOUBLE COMPLEX acb0p,absc
+ DOUBLE COMPLEX cc
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* initialization to nonsense to prevent use of uncomputed vars
+*
+ big = 1/(1d20*xclogm)
+ if ( ltest ) then
+ do 10 i=1,2
+ caxi(i) = big
+ 10 continue
+ do 11 i=1,4
+ cbxi(i) = big
+ 11 continue
+ do 12 i=1,2
+ acbxi(i) = big
+ 12 continue
+ endif
+*
+* #] declarations :
+* #[ level 0 : B0
+*
+* B0
+*
+ ldot = .TRUE.
+ ier1 = ier
+ call ffxb0(cbxi(1),d0,xmu,xp,xma,xmb,ier1)
+* note that this may be off by a fctor 1/xloss
+ mbxi(1) = absc(cbxi(1))*DBLE(10)**mod(ier1,50)
+ if ( awrite ) then
+ print *,' '
+ print *,'ffxbx : level 0: id,nevent ',id,nevent
+ print *,'B0 =',cbxi(1),mbxi(1),ier1
+ endif
+ if (level .eq. 0 .and. .NOT. aderiv ) goto 990
+* #] level 0 :
+* #[ level 1/2 : B0':
+ if (aderiv) then
+ ier0 = ier
+ call ffxdb0(acbxi(1),acb0p,xp,xma,xmb,ier0)
+ mabxi(1) = absc(acbxi(1))*DBLE(10)**mod(ier0,50)
+ ier1 = max(ier1,ier0)
+ if ( lwarn .and. atest ) then
+ if ( abs(xp*acbxi(1)-acb0p) .gt. precc*abs(acb0p) )
+ + print *,'ffxbx: error: B0'' not consistent: ',
+ + xp*acbxi(1),acb0p,xp*acbxi(1)-acb0p,ier0
+ endif
+ if ( awrite ) then
+ print *,'AB0 =',acbxi(1),mabxi(1),ier0
+ print *,'AB11= not yet implemented'
+ endif
+ endif
+
+ if ( level .eq. 0 ) return
+* #] level 1/2 : B0'
+* #[ level 1 : B11
+*
+* first get the needed A0's
+*
+ ier0 = ier
+ call ffxa0(caxi(1),d0,xmu,xma,ier0)
+ maxi(1) = absc(caxi(1))*DBLE(10)**mod(ier0,50)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ffxa0(caxi(2),d0,xmu,xmb,ier0)
+ maxi(2) = absc(caxi(2))*DBLE(10)**mod(ier0,50)
+ ier1 = max(ier1,ier0)
+ ier = ier1
+*
+* and get the B11
+*
+ call ffxb1(cbxi(2),cbxi(1),caxi,xp,xma,xmb,fpij2,ier1)
+ mbxi(2) = absc(cbxi(2))*DBLE(10)**mod(ier1,50)
+*
+* debug output
+*
+ if ( awrite ) then
+ print *,' '
+ print *,'ffxbx : level 1: id,nevent ',id,nevent
+ print *,'B11 = ',cbxi(2),mbxi(2),ier1
+ print *,' A0(1) =',caxi(1),maxi(1)
+ print *,' A0(2) =',caxi(2),maxi(2)
+ endif
+*
+* finished?
+*
+ if (level .eq. 1 ) goto 990
+*
+* #] level 1 :
+* #[ level 2 : B21,B22
+*
+* just a simple call...
+*
+ call ffxb2p(cbxi(3),cbxi(2),cbxi(1),caxi,xp,xma,xmb,fpij2,ier1)
+ mbxi(3) = absc(cbxi(3))*DBLE(10)**mod(ier1,50)
+ mbxi(4) = absc(cbxi(4))*DBLE(10)**mod(ier1,50)
+*
+* debug output
+*
+ if ( awrite ) then
+ print *,' '
+ print *,'ffxbx : level 2: id,nevent ',id,nevent
+ print *,'B21 = ',cbxi(3),ier1
+ print *,'B22 = ',cbxi(4),ier1
+ endif
+*
+ if (level .eq. 2) goto 990
+*
+* #] level 2 :
+ print *,'ffxbx: error: level ',level,' not supported'
+ stop
+
+ 990 continue
+ ier = max(ier1,ier)
+*###] ffxbx :
+ end
diff --git a/ff-2.0/aaxcx.f b/ff-2.0/aaxcx.f
new file mode 100644
index 0000000..116977b
--- /dev/null
+++ b/ff-2.0/aaxcx.f
@@ -0,0 +1,569 @@
+*###[ aaxcx :
+ subroutine aaxcx(caxi,cbxi,ccxi,d0,xmm,xpi,level,ier)
+***#[*comment:***********************************************************
+* *
+* Calculation of formfactors resulting from decvert.sub *
+* or decvert.frm (up to third rank) *
+* 21-dec-1993: switched to ffxc1 for C1, added numerical checks. *
+* Definitions: *
+* C0 = 1/(i pi^2)*\int d^4 Q *
+* 1/((Q^2-m_1^2)((Q+p1)^2-m2^2)((Q-p3)^2-m3^2)) *
+* C1 = 1/(i pi^2)*\int d^n Q Q(mu)/(...) *
+* = C11*p1 + C12*p2 *
+* C2 = C21*p1*p1 + C22*p2*p2 + C23*(p1*p2+p2*p1) + C24*g *
+* C3 = C31*p1*p1*p1 + C32*p2*p2*p2 + C33*(p1*p1*p2 + p1*p2*p1 + *
+* p2*p1*p1) + C34*(p1*p2*p2 + p2*p1*p2 + p1*p2*p2) + C35* *
+* (p1*g + g*p1 + 'g*p1*g') + C36*(p2*g + g*p2 + 'g*p2*g') *
+* *
+* Input: xpi the same as in Geert Jan's routines *
+* level rank of tensor(integral) *
+* Output: caxi(3) : ca0i i=1,2,3 *
+* cbxi(12) : (cb0i,cb11i,cb21i,cb22i) i=1,2,3 *
+* ccxi(13) : cc0,cc1(2),cc2(4),cc3(6) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations :
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION xpi(6),d0,xmm
+ DOUBLE COMPLEX caxi(3),cbxi(12),ccxi(13)
+*
+* local variables
+*
+ DOUBLE PRECISION maxi(3),mbxi(12),mcxi(13)
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* #] declarations :
+* #[ call ffxcx:
+*
+ call ffxcx(caxi,maxi,cbxi,mbxi,ccxi,mcxi,d0,xmm,xpi,level,ier)
+*
+* #] call ffxcx:
+*###] aaxcx :
+ end
+*###[ ffxcx:
+ subroutine ffxcx(caxi,maxi,cbxi,mbxi,ccxi,mcxi,d0,xmm,xpi,level,
+ + ier)
+***#[*comment:***********************************************************
+* *
+* Calculation of three point form factors with more accurate *
+* error estimates. Calls ffxc1, the rest is still here. *
+* Definitions: *
+* C0 = 1/(i pi^2)*\int d^4 Q *
+* 1/((Q^2-m_1^2)((Q+p1)^2-m2^2)((Q-p3)^2-m3^2)) *
+* C1 = 1/(i pi^2)*\int d^n Q Q(mu)/(...) *
+* = C11*p1 + C12*p2 *
+* C2 = C21*p1*p1 + C22*p2*p2 + C23*(p1*p2+p2*p1) + C24*g *
+* C3 = C31*p1*p1*p1 + C32*p2*p2*p2 + C33*(p1*p1*p2 + p1*p2*p1 + *
+* p2*p1*p1) + C34*(p1*p2*p2 + p2*p1*p2 + p1*p2*p2) + C35* *
+* (p1*g + g*p1 + 'g*p1*g') + C36*(p2*g + g*p2 + 'g*p2*g') *
+* *
+* Input: xpi(6) real m_i^2 (1:3), p_{i-3}^2 (4:6) *
+* d0,xmu real renormalisation constants *
+* level integer rank of tensor (integral) *
+* Output: caxi(3) complex A0(m_i^2) *
+* maxi(3) real max term in sum to caxi() *
+* cbxi(12) complex 3x(B0,B11,B21,B22)(p_i^2) *
+* mbxi(12) real max term in sum to cbxi() *
+* ccxi(13) complex C0,C1(2),C2(4),C3(6) *
+* mcxi(13) real max term in sum to ccxi() *
+* Note that if level<3 some of these are not defined. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations :
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION maxi(3),mbxi(12),mcxi(13),xpi(6),d0,xmm
+ DOUBLE COMPLEX caxi(3),cbxi(12),ccxi(13)
+*
+* local variables
+*
+ integer i,bl,ier0,ier1
+ logical adesav
+ DOUBLE PRECISION absc,ma0i(6),mabxi(2),big
+ DOUBLE COMPLEX acbxi(2),ca0i(6),cc,cc0
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations :
+* #[ initialisations:
+*
+* initialization to nonsense
+*
+ big = 1/(1d20*xclogm)
+ if ( ltest ) then
+ do 10 i=1,3
+ caxi(i) = big
+ 10 continue
+ do 20 i=1,12
+ cbxi(i) = big
+ 20 continue
+ do 30 i=1,13
+ ccxi(i) = big
+ 30 continue
+ endif
+*
+* #] initialisations:
+* #[ get C0:
+*
+* C0-function
+*
+ ldot=.TRUE.
+ ier1 = ier
+ call ffxc0(ccxi(1),xpi,ier1)
+ if ( ier1.gt.10 ) then
+ if ( ltest ) then
+ print *,'ffxcx: id = ',id,', nevent = ',nevent
+ print *,'ffxcx: lost ',ier1,' digits in C0 with isgnal '
+ + ,isgnal,', trying other roots, isgnal ',-isgnal
+ print *,' if OK (no further messages) adding this'
+ + ,' to your code will improve speed'
+ endif
+ isgnal = -isgnal
+ ier0 = ier
+ call ffxc0(cc0,xpi,ier0)
+ isgnal = -isgnal
+ if ( ier0.lt.ier1 ) then
+ ier1 = ier0
+ ccxi(1) = cc0
+ endif
+ endif
+ if ( ier1 .gt. 10 ) then
+ print *,'ffxcx: id = ',id,', nevent = ',nevent
+ print *,'ffxcx: error: C0 not stable, lost ',ier1,' digits'
+ print *,' please contact author (t19@nikhef.nl)'
+ print *,'xpi = ',xpi
+ endif
+* note that we may have lost another factor xloss**3 or so
+ mcxi(1) = absc(ccxi(1))*DBLE(10)**mod(ier1,50)
+ if ( awrite ) then
+* #[ for debugging: imported stuff from ff
+ print *,' '
+ print *,'ffxcx : level 0 '
+ print *,'C0 =',ccxi(1),mcxi(1),ier1
+ print *,'used:',( xpi(i),i=1,3 )
+ print *,' ',( xpi(i),i=4,6 )
+ print *,'imported stuff via ff.h:'
+ print *,'kin det = ',fdel2
+ print *,'dotpr1,1= ',fpij3(4,4)
+ print *,'dotpr2,2= ',fpij3(5,5)
+ print *,'dotpr1,2= ',fpij3(4,5)
+* #] for debugging:
+ endif
+
+ if ( level.eq.0 ) goto 990
+*
+* #] get C0:
+* #[ need B-functions till b-level=(level-1):
+ bl=level-1
+ if ( awrite ) then
+ print '(a,i1)',' ##[ B-function output: up to level ',bl
+ endif
+ adesav = aderiv
+ aderiv = .FALSE.
+ ier0 = ier
+ call ffxbx( ca0i(1),ma0i(1),cbxi(1),mbxi(1),acbxi,mabxi,
+ + d0,xmm,xpi(5),xpi(2),xpi(3),bl,ier0)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ffxbx( ca0i(3),ma0i(3),cbxi(5),mbxi(5),acbxi,mabxi,
+ + d0,xmm,xpi(6),xpi(1),xpi(3),bl,ier0)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ffxbx( ca0i(5),ma0i(5),cbxi(9),mbxi(9),acbxi,mabxi,
+ + d0,xmm,xpi(4),xpi(1),xpi(2),bl,ier0)
+ ier1 = max(ier1,ier0)
+ aderiv = adesav
+ if ( awrite ) then
+ print '(a)',' ##] B-function output:'
+ endif
+* symmetry in A0(i,j)
+ caxi(1)=ca0i(1)
+ caxi(2)=ca0i(2)
+ caxi(3)=ca0i(3)
+ maxi(1)=ma0i(1)
+ maxi(2)=ma0i(2)
+ maxi(3)=ma0i(3)
+ if ( lwarn .and. atest ) then
+ if ((ca0i(4)-ca0i(2)) .ne. 0. .or.
+ + (ca0i(5)-ca0i(3)) .ne. 0. .or.
+ + (ca0i(6)-ca0i(1)) .ne. 0. ) then
+ print *,'error in A0-calculations in aaxbx.for'
+ endif
+ endif
+* #] need B-functions till b-level=(level-1):
+* #[ break to let ffzcz tie in:
+ call ffxcxp(caxi,maxi,cbxi,mbxi,ccxi,mcxi,xpi,level,ier1)
+* #] break to let ffzcz tie in:
+ 990 ier = ier1
+ end
+ subroutine ffxcxp(caxi,maxi,cbxi,mbxi,ccxi,mcxi,xpi,level,ier)
+* #[ declarations :
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION maxi(3),mbxi(12),mcxi(13),xpi(6)
+ DOUBLE COMPLEX caxi(3),cbxi(12),ccxi(13)
+*
+* local variables
+*
+ integer i,j,ier1,ier2
+ DOUBLE PRECISION xi3(3),f1,f2,absc,xmax,R1m,R2m,R3m,R4m,
+ + R5m,R6m,R11m,R12m,R13m,R14m,R15m,R16m,R17m,R18m
+ DOUBLE PRECISION mb0i(3),mb11i(3),mxy(2),mb21i(3),mb22i(3)
+ DOUBLE COMPLEX R1,R2,R3,R4,R5,R6,R11,R12,R13,R14,R15,R16,R17,
+ + R18,cb0i(3),cb11i(3),cb21i(3),cb22i(3),cc,cxy(2)
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations :
+* #[ kinematical quantities for 3pv-red :
+* inverse kinematical matrix xi3 (2X2)
+ ier2 = ier
+ call aaxi3(xi3,xpi,ier2)
+ ier2 = ier2 - ier
+*
+* f-functions:
+ f1 = 2*fpij3(1,4)
+ f2 = 2*fpij3(1,5)
+* #] kinematical quantities for 3pv-red :
+* #[ level 1 : C11,C12,B0(I)
+* need 3 diff B0(I)-functions,I=1,2,3
+ cb0i(1)=cbxi(1)
+ cb0i(2)=cbxi(5)
+ cb0i(3)=cbxi(9)
+ mb0i(1)=mbxi(1)
+ mb0i(2)=mbxi(5)
+ mb0i(3)=mbxi(9)
+ call ffxc1a(ccxi(2),mcxi(2),ccxi(1),mcxi(1),cb0i,mb0i,
+ + xpi,fpij3,fdel2,ier)
+ if ( awrite ) then
+ print *,'GEERT JANs-scheme:'
+ print *,'C11=',ccxi(2),mcxi(2),ier
+ print *,'C12=',ccxi(3),mcxi(3),ier
+ print *,' '
+ endif
+ if ( lwarn .and. atest ) then
+* PV-reduction
+ R1=( f1*ccxi(1)+cb0i(2)-cb0i(1) )/2
+ R2=( f2*ccxi(1)+cb0i(3)-cb0i(2) )/2
+ R1m=max(abs(f1)*mcxi(1),mb0i(2),mb0i(1))/2
+ R2m=max(abs(f2)*mcxi(1),mb0i(3),mb0i(2))/2
+ cxy(1)=xi3(1)*R1+xi3(3)*R2
+ cxy(2)=xi3(3)*R1+xi3(2)*R2
+ mxy(1)=max(abs(xi3(1))*R1m,abs(xi3(3))*R2m)
+ mxy(2)=max(abs(xi3(3))*R1m,abs(xi3(2))*R2m)
+ if ( xloss*absc(ccxi(2)-cxy(1)) .gt. precc*
+ + max(mcxi(2),mxy(1)) )
+ + print *,'ffxcxp: error: FF C11 disagrees with PV: ',
+ + ccxi(2),cxy(1),ccxi(2)-cxy(1),ier
+ if ( xloss*absc(ccxi(3)-cxy(2)) .gt. precc*
+ + max(mcxi(3),mxy(2)) )
+ + print *,'ffxcxp: error: FF C12 disagrees with PV: ',
+ + ccxi(3),cxy(2),ccxi(3)-cxy(2),ier
+ if (awrite) then
+ print *,' '
+ print *,'ffxcxp : level 1: id,nevent ',id,nevent
+ print *,'C11=',ccxi(2)
+ print *,'C12=',ccxi(3)
+ endif
+ endif
+*
+ if ( level.eq.1 ) then
+ if ( lwarn ) then
+ xmax = 0
+ do i=1,3
+ if ( absc(ccxi(i)).ne.0 ) then
+ xmax = max(xmax,mcxi(i)/absc(ccxi(i)))
+ elseif ( mcxi(i).ne.0 ) then
+ xmax = max(xmax,1/precc)
+ endif
+ enddo
+ ier1 = int(log10(xmax))
+ if ( awrite ) print *,'ier = ',ier1
+ else
+ ier1 = 0
+ endif
+ goto 990
+ endif
+*
+* #] level 1 :
+* #[ level 2 : C21,C22,C23,C24,B11(I),A0(I,J)
+* need 3 diff B1-functions and 3 diff A0-fuctions
+ do 12 i=1,3
+ j=(i+1)+(i-1)*3
+ cb11i(i) = cbxi(j)
+ mb11i(i) = mbxi(j)
+ 12 continue
+* PV-reduction
+ ccxi(7)=1/4.d0 + 1/2.d0*xpi(1)*ccxi(1) -
+ + 1/4.d0*( f1*ccxi(2)+f2*ccxi(3)-cb0i(1) )
+ ier1 = ier
+ if ( lwarn ) then
+*** c7max = max(x1,2*xpi(1)*absc(ccxi(1)),absc(f1*ccxi(2)),
+*** + absc(f2*ccxi(3)),absc(cb0i(1)))/4
+*** if ( absc(ccxi(7)) .lt. xloss*c7max ) then
+*** call ffwarn(293,ier1,absc(ccxi(7)),c7max)
+*** endif
+ mcxi(7) = max(x1,2*xpi(1)*mcxi(1),abs(f1)*mcxi(2),
+ + abs(f2)*mcxi(3),mb0i(1))/4
+ endif
+ R3=( f1*ccxi(2) + cb11i(2) + cb0i(1) )/2 - ccxi(7)
+ R4=( f2*ccxi(2) + cb11i(3) - cb11i(2) )/2
+ R5=( f1*ccxi(3) + cb11i(2) - cb11i(1) )/2
+ R6=( f2*ccxi(3) - cb11i(2) )/2 - ccxi(7)
+ ccxi(4)=xi3(1)*R3 + xi3(3)*R4
+ ccxi(5)=xi3(3)*R5 + xi3(2)*R6
+ ccxi(6)=xi3(3)*R3 + xi3(2)*R4
+ if ( lwarn ) then
+*** R3m = max(absc(f1*ccxi(2)),absc(cb11i(2)),absc(cb0i(1)),
+*** + 2*c7max)/2
+*** R4m = max(absc(f2*ccxi(2)),absc(cb11i(3)),absc(cb11i(2)))/2
+*** R5m = max(absc(f1*ccxi(3)),absc(cb11i(2)),absc(cb11i(1)))/2
+*** R6m = max(absc(f2*ccxi(3)),absc(cb11i(2)),2*c7max)/2
+*** xmax = max(abs(xi3(1))*R3m,abs(xi3(3))*R4m)
+*** if ( absc(ccxi(4)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(292,ier0,absc(ccxi(4)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi3(3))*R5m,abs(xi3(2))*R6m)
+*** if ( absc(ccxi(5)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(291,ier0,absc(ccxi(5)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi3(3))*R3m,abs(xi3(2))*R4m)
+*** if ( absc(ccxi(6)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(290,ier0,absc(ccxi(6)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*
+* for the whole chain
+*
+ R3m = max(abs(f1)*mcxi(2),mb11i(2),mb0i(1),2*mcxi(7))/2
+ R4m = max(abs(f2)*mcxi(2),mb11i(3),mb11i(2))/2
+ R5m = max(abs(f1)*mcxi(3),mb11i(2),mb11i(1))/2
+ R6m = max(abs(f2)*mcxi(3),mb11i(2),2*mcxi(7))/2
+ mcxi(4) = max(abs(xi3(1))*R3m,abs(xi3(3))*R4m)
+ mcxi(5) = max(abs(xi3(3))*R5m,abs(xi3(2))*R6m)
+ mcxi(6) = max(abs(xi3(3))*R3m,abs(xi3(2))*R4m)
+ endif
+ if ( lwarn .and. atest ) then
+ cxy(1) = xi3(1)*R5 + xi3(3)*R6
+ mxy(1) = abs(xi3(1))*R5m + abs(xi3(3))*R6m
+ if ( xloss*absc(cxy(1)-ccxi(6)).gt.precc*max(mcxi(6),mxy(1))
+ + ) then
+ print *,'ffxcxp: error: id/nevent ',id,'/',nevent
+ print *,'redundancy check at level 2 failed: '
+ print *,cxy(1),mxy(1)
+ print *,ccxi(6),mcxi(6)
+ print *,absc(cxy(1)-ccxi(6))
+ endif
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'ffxcxp : level 2: id,nevent ',id,nevent
+ print *,'C21=',ccxi(4),mcxi(4)
+ print *,'C22=',ccxi(5),mcxi(5)
+ print *,'C23=',ccxi(6),mcxi(6)
+ print *,' ',cxy(1),mxy(1)
+ print *,'C24=',ccxi(7),mcxi(7)
+ endif
+
+ if ( level.eq.2 ) then
+ if ( lwarn ) then
+ xmax = 0
+ do i=1,7
+ if ( absc(ccxi(i)).ne.0 ) then
+ xmax = max(xmax,mcxi(i)/absc(ccxi(i)))
+ elseif ( mcxi(i).ne.0 ) then
+ xmax = max(xmax,1/precc)
+ endif
+ enddo
+ ier1 = int(log10(xmax))
+ if ( awrite ) print *,'ier = ',ier1
+ else
+ ier1 = 0
+ endif
+ goto 990
+ endif
+
+* #] level 2 :
+* #[ level 3 : C31,C32,C33,C34,C35,C36,B21(I),B22(I)
+ do 13 i=1,3
+ j = (i+1)+(i-1)*3
+ cb21i(i)=cbxi(j+1)
+ cb22i(i)=cbxi(j+2)
+ mb21i(i)=mbxi(j+1)
+ mb22i(i)=mbxi(j+2)
+ 13 continue
+* PV-reduction
+ R17=( f1*ccxi(7)+cb22i(2)-cb22i(1) )/2
+ R18=( f2*ccxi(7)+cb22i(3)-cb22i(2) )/2
+ ccxi(12)=xi3(1)*R17+xi3(3)*R18
+ ccxi(13)=xi3(3)*R17+xi3(2)*R18
+ if ( lwarn ) then
+*** R17m = max(abs(f1)*c7max,absc(cb22i(2)),absc(cb22i(1)))/2
+*** R18m = max(abs(f2)*c7max,absc(cb22i(3)),absc(cb22i(2)))/2
+*** c12max = max(abs(xi3(1))*R17m,abs(xi3(3))*R18m)
+*** if ( absc(ccxi(12)).lt.xloss*c12max ) then
+*** ier0 = ier
+*** call ffwarn(289,ier0,absc(ccxi(12)),c12max)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** c13max = max(abs(xi3(3))*R17m,abs(xi3(2))*R18m)
+*** if ( absc(ccxi(13)).lt.xloss*c13max ) then
+*** ier0 = ier
+*** call ffwarn(288,ier0,absc(ccxi(13)),c13max)
+*** ier1 = max(ier1,ier0)
+*** endif
+ R17m = max(abs(f1)*mcxi(7),mb22i(2),mb22i(1))/2
+ R18m = max(abs(f2)*mcxi(7),mb22i(3),mb22i(2))/2
+ mcxi(12) = max(abs(xi3(1))*R17m,abs(xi3(3))*R18m)
+ mcxi(13) = max(abs(xi3(3))*R17m,abs(xi3(2))*R18m)
+ endif
+ R11=( f1*ccxi(4)+cb21i(2)-cb0i(1) )/2 - 2*ccxi(12)
+ R12=( f2*ccxi(4)+cb21i(3)-cb21i(2) )/2
+ R13=( f1*ccxi(5)+cb21i(2)-cb21i(1) )/2
+ R14=( f2*ccxi(5) -cb21i(2) )/2 - 2*ccxi(13)
+ R15=( f1*ccxi(6)+cb21i(2)+cb11i(1) )/2 - ccxi(13)
+ R16=( f2*ccxi(6) -cb21i(2) )/2 - ccxi(12)
+ ccxi(8) =xi3(1)*R11 + xi3(3)*R12
+ ccxi(9) =xi3(3)*R13 + xi3(2)*R14
+ ccxi(10)=xi3(3)*R11 + xi3(2)*R12
+ ccxi(11)=xi3(1)*R13 + xi3(3)*R14
+ if ( lwarn ) then
+*** R11m = max(absc(f1*ccxi(4)),absc(cb21i(2)),absc(cb0i(1)),
+*** + 2*c12max)/2
+*** R12m = max(absc(f2*ccxi(4)),absc(cb21i(3)),absc(cb21i(2)))/2
+*** R13m = max(absc(f1*ccxi(5)),absc(cb21i(2)),absc(cb21i(1)))/2
+*** R14m = max(absc(f2*ccxi(5)),absc(cb21i(2)),4*c13max)/2
+*** R15m = max(absc(f1*ccxi(6)),absc(cb21i(2)),absc(cb11i(1)),
+*** + 2*c13max)/2
+*** R16m = max(absc(f2*ccxi(6)),absc(cb21i(2)),2*c12max)/2
+*** xmax = max(abs(xi3(1))*R11m,abs(xi3(3))*R12m)
+*** if ( absc(ccxi(8)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(287,ier0,absc(ccxi(8)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi3(3))*R13m,abs(xi3(2))*R14m)
+*** if ( absc(ccxi(9)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(286,ier0,absc(ccxi(9)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi3(3))*R11m,abs(xi3(2))*R12m)
+*** if ( absc(ccxi(10)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(285,ier0,absc(ccxi(10)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi3(1))*R13m,abs(xi3(3))*R14m)
+*** if ( absc(ccxi(11)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(284,ier0,absc(ccxi(11)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*
+* for the whole chain
+*
+ R11m = max(abs(f1)*mcxi(4),mb21i(2),mb0i(1),2*mcxi(12))/2
+ R12m = max(abs(f2)*mcxi(4),mb21i(3),mb21i(2))/2
+ R13m = max(abs(f1)*mcxi(5),mb21i(2),mb21i(1))/2
+ R14m = max(abs(f2)*mcxi(5),mb21i(2),4*mcxi(13))/2
+ R15m = max(abs(f1)*mcxi(6),mb21i(2),mb11i(1),2*mcxi(13))/2
+ R16m = max(abs(f2)*mcxi(6),mb21i(2),2*mcxi(12))/2
+ mcxi(8) = max(abs(xi3(1))*R11m,abs(xi3(3))*R12m)
+ mcxi(9) = max(abs(xi3(3))*R13m,abs(xi3(2))*R14m)
+ mcxi(10)= max(abs(xi3(3))*R11m,abs(xi3(2))*R12m)
+ mcxi(11)= max(abs(xi3(1))*R13m,abs(xi3(3))*R14m)
+ endif
+* redundancy check
+ if ( lwarn .and. atest ) then
+ cxy(1) = xi3(1)*R15 + xi3(3)*R16
+ cxy(2) = xi3(3)*R15 + xi3(2)*R16
+ mxy(1) = abs(xi3(1))*R15m + abs(xi3(3))*R16m
+ mxy(2) = abs(xi3(3))*R15m + abs(xi3(2))*R16m
+ if ( xloss*absc(cxy(1)-ccxi(10)).gt.precc*max(mxy(1),
+ + mcxi(10))
+ + .or. xloss*absc(cxy(2)-ccxi(11)).gt.precc*max(mxy(2),
+ + mcxi(11)) ) then
+ print *,'ffxcxp: error: id/nevent ',id,'/',nevent
+ print *,'redundancy check at level 3 failed: '
+ print *,cxy(1),mxy(1)
+ print *,ccxi(10),mcxi(10)
+ print *,absc(cxy(1)-ccxi(10))
+ print *,cxy(2),mxy(2)
+ print *,ccxi(11),mcxi(11)
+ print *,absc(cxy(1)-ccxi(11))
+ endif
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'ffxcxp: level 3: id,nevent ',id,nevent
+ print *,'C31=',ccxi(8),mcxi(8)
+ print *,'C32=',ccxi(9),mcxi(9)
+ print *,'C33=',ccxi(10),mcxi(10)
+ print *,' ',cxy(1),mxy(1)
+ print *,'C34=',ccxi(11),mcxi(11)
+ print *,' ',cxy(2),mxy(2)
+ print *,'C35=',ccxi(12),mcxi(12)
+ print *,'C36=',ccxi(13),mcxi(13)
+ endif
+
+ if ( level.eq.3 ) then
+ if ( lwarn ) then
+ xmax = 0
+ do i=1,13
+ if ( absc(ccxi(i)).ne.0 ) then
+ xmax = max(xmax,mcxi(i)/absc(ccxi(i)))
+ elseif ( mcxi(i).ne.0 ) then
+ xmax = max(xmax,1/precc)
+ endif
+ enddo
+ ier1 = int(log10(xmax))
+ if ( awrite ) print *,'ier = ',ier1
+ else
+ ier1 = 0
+ endif
+ goto 990
+ endif
+
+* #] level 3 :
+* #[ end:
+ print *,'ffxcxp: level ',level,' not supported.'
+ stop
+ 990 continue
+ ier = ier1 + ier2
+* #] end:
+*###] ffxcx:
+ end
diff --git a/ff-2.0/aaxdx.f b/ff-2.0/aaxdx.f
new file mode 100644
index 0000000..e7907d4
--- /dev/null
+++ b/ff-2.0/aaxdx.f
@@ -0,0 +1,976 @@
+*###[ aaxdx :
+ subroutine aaxdx(cbxi,ccxi,cdxi,d0,xmm,xpi,level,ier)
+***#[*comment:***********************************************************
+* *
+* Calculation of four point tensor integrals. Just a wrapper *
+* for ffxdx nowadays, see there for the real description. *
+* *
+* Input: *
+* xpi the same as in Geert Jan's routines *
+* level rank of tensor(integral) *
+* Output: *
+* cbxi(12) cb0(1),cb1(1),[cb2(2)] x 6 *
+* ccxi(28) cc0(1),cc1(2),cc2(4),[cc3(6)] x 4 *
+* cdxi(24) cd0(1),cd1(3),cd2(7),cd3(13) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations :
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION xpi(13),d0,xmm
+ DOUBLE COMPLEX cbxi(12),ccxi(28),cdxi(24)
+*
+* local variables
+*
+ DOUBLE COMPLEX caxi(4)
+ DOUBLE PRECISION maxi(4),mbxi(12),mcxi(28),mdxi(24)
+*
+* #] declarations :
+* #[ call ffxdx:
+*
+ call ffxdx(caxi,maxi,cbxi,mbxi,ccxi,mcxi,cdxi,mdxi,d0,xmm,xpi,
+ + level,ier)
+*
+* #] call ffxdx:
+*###] aaxdx :
+ end
+*###[ ffxdx:
+ subroutine ffxdx(caxi,maxi,cbxi,mbxi,ccxi,mcxi,cdxi,mdxi,d0,xmm,
+ + xpi,level,ier)
+***#[*comment:***********************************************************
+* *
+* Calculation of four point form factors with more accurate *
+* error estimates. Calls ffxd1, the rest is still here. *
+* Definitions: *
+* D0 = 1/(i pi^2)*\int d^4 Q 1/((Q^2-m_1^2)((Q+p1)^2-m2^2) *
+* ((Q+p1+p2)^2-m3^2))((Q-p4)^2-m4^2)) *
+* D1 = 1/(i pi^2)*\int d^n Q Q(mu)/(...) *
+* = D11*p1 + D12*p2 + D13*p3 *
+* D2 = D21*p1*p1 + D22*p2*p2 + D23*p3*p3 + D24*(p1*p2+p2*p1) + *
+* D25*(p1*p3+p3*p1) + D26*(p2*p3+p3*p2) + D27*g *
+* D3 = D31*p1*p1*p1 + D32*p2*p2*p2 + D33*p3*p3*p3 + D34*(p1*p1*p2+*
+* p1*p2*p1+p2*p1*p1) + D35*(p1*p1*p3+p1*p3*p1+p3*p1*p1) + D36*
+* *(p1*p2*p2+p2*p1*p2+p1*p2*p2) + D37*(p1*p3*p3+p3*p1*p3+p1* *
+* p3*p3) + D38*(p2*p2*p3+p2*p3*p2+p3*p2*p2) + D39*(p2*p3*p3+ *
+* p3*p2*p3+p2*p3*p3) + D310*(p1*p2*p3+p2*p3*p1+p3*p1*p2+p1*p3*
+* *p2+p3*p2*p1+p2*p1*p3) + D311*(p1*g+g*p1+'g*p1*g') + D312* *
+* (p2*g+g*p2+'g*p2*g') + D313*(p3*g+g*p3+'g*p3*g') *
+* D4 has not yet been implemented *
+* *
+* Input: xpi(13) real m_i^2 (1:4), p_{i-4}^2 (4:8),s,t*
+* optionally u,v,w (see ffxd0a) *
+* d0,xmm real renormalisation constants *
+* level integer rank of tensor (integral) *
+* Output: caxi(4) complex A0(m_i^2) only when level>3 *
+* maxi(12) real max term in sum to caxi() *
+* cbxi(12) complex 6x(B0,B11,B21,B22)(p_i^2) *
+* mbxi(12) real max term in sum to cbxi() *
+* ccxi(28) complex 4x(C0,C1(2),C2(4)) *
+* mcxi(28) real max term in sum to ccxi() *
+* cdxi(24) complex D0,D1(3),D2(7),D3(13) *
+* mdxi(24) real max term in sum to cdxi() *
+* Note that if level<3 some of these are not defined. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations :
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION xpi(13),d0,xmm
+ DOUBLE COMPLEX caxi(4),cbxi(12),ccxi(28),cdxi(24)
+ DOUBLE PRECISION maxi(4),mbxi(12),mcxi(28),mdxi(24)
+*
+* local variables
+*
+ integer i,j,cl,ier0,ier1,iinx(6,4)
+ DOUBLE PRECISION xpi3(6),fdel2i(4),absc,big
+ DOUBLE COMPLEX caxj(12),cbxj(48),ccxj(52),cc,cd0
+ DOUBLE PRECISION maxj(12),mbxj(48),mcxj(52)
+ save iinx
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* data
+*
+ data iinx /2,3,4,6,7,10,
+ + 1,3,4,9,7,8,
+ + 1,2,4,5,10,8,
+ + 1,2,3,5,6,9/
+*
+* #] declarations :
+* #[ initialisations:
+*
+* initialize to something ridiculous so that one immediately
+* notices when it is accidentally used...
+*
+ big = 1/(1d20*xclogm)
+ do 8 i=1,4
+ caxi(i) = big
+ 8 continue
+ do 9 i=1,12
+ cbxi(i) = big
+ 9 continue
+ do 10 i=1,28
+ ccxi(i) = big
+ 10 continue
+ do 11 i=1,24
+ cdxi(i) = big
+ 11 continue
+*
+* #] initialisations:
+* #[ get D0:
+* D0-function (ff)
+* futhermore dotpr and determinants are delivered by ff
+ ldot = .TRUE.
+ ier1 = ier
+ call ffxd0(cdxi(1),xpi,ier1)
+ if ( ier1.gt.10 ) then
+ if ( ltest ) then
+ print *,'ffxdx: id = ',id,', nevent = ',nevent
+ print *,'ffxdx: lost ',ier1,' digits in D0 with isgnal '
+ + ,isgnal,', trying other roots, isgnal ',-isgnal
+ print *,' if OK (no further messages) adding this'
+ + ,' to your code will improve speed'
+ endif
+ isgnal = -isgnal
+ ier0 = ier
+ call ffxd0(cd0,xpi,ier0)
+ isgnal = -isgnal
+ if ( ier0.lt.ier1 ) then
+ ier1 = ier0
+ cdxi(1) = cd0
+ endif
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'ffxdx : level 0: id,nevent ',id,nevent
+ print *,'D0 =',cdxi(1),ier1
+ endif
+ if ( ier1 .gt. 10 ) then
+ print *,'ffxdx: id = ',id,', nevent = ',nevent
+ print *,'ffxdx: error: D0 not stable, lost ',ier1,' digits'
+ print *,' please try another permutation or contact',
+ + ' author (t19@nikhef.nl)'
+ print *,'xpi = ',xpi
+ endif
+* note that we may have lost another factor xloss**3 or so
+ mdxi(1) = absc(cdxi(1))*DBLE(10)**mod(ier1,50)
+*
+ if (level .eq. 0) goto 990
+*
+* #] get D0:
+* #[ need C-functions till c-level=(level-1):
+ if ( level.gt.3 ) then
+ print *,'ffxdx: error: higher than third rank ',
+ + 'not yet implemented'
+ stop
+ endif
+ cl = level-1
+* go trough the 4 different cancellation patterns
+ if ( awrite ) then
+ print '(a,i1)','####[ C-function output: to level ',cl
+ endif
+ do 100 i=1,4
+ do 60 j=1,6
+ xpi3(j) = xpi(iinx(j,i))
+ 60 continue
+ ier0 = ier
+ call ffxcx( caxj(3*i-2),maxj(3*i-2),cbxj(12*i-11),
+ + mbxj(12*i-11),ccxj(13*i-12),mcxj(13*i-12),d0,xmm,xpi3,
+ + cl,ier0)
+ ier1 = max(ier1,ier0)
+ fdel2i(i)=fdel2
+ 100 continue
+ if ( awrite ) then
+ print '(a)','####] C-function output:'
+ endif
+* #] need C-functions till c-level=(level-1):
+* #[ break to let ffzdz tie in:
+*
+* convert ??xj to ??xi
+*
+ call ffdji(ccxi,mcxi,cbxi,mbxi,caxi,maxi,
+ + ccxj,mcxj,cbxj,mbxj,caxj,maxj,level)
+*
+* and call the real routine for the rest
+*
+ call ffxdxp(caxj,maxj,cbxj,mbxj,ccxj,mcxj,cdxi,mdxi,xpi,fdel2i,
+ + level,ier1)
+* #] break to let ffzdz tie in:
+ 990 ier = ier1
+ end
+ subroutine ffxdxp(caxj,maxj,cbxj,mbxj,ccxj,mcxj,cdxi,mdxi,xpi,
+ + fdel2i,level,ier)
+* #[ declarations :
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION xpi(13)
+ DOUBLE COMPLEX caxj(12),cbxj(48),ccxj(52),cdxi(24)
+ DOUBLE PRECISION maxj(12),mbxj(48),mcxj(52),mdxi(24),fdel2i(4)
+*
+* local variables
+*
+ integer i,j,ier0,ier1,ier2,iinx(6,4),bij(12)
+ DOUBLE PRECISION xi4(6),f1,f2,f3,absc,xmax,Rm(20:55),
+ + d11max,d22max,d23max,d24max,d0,xmm
+ DOUBLE PRECISION dl2pij(6,6),del3p
+ DOUBLE PRECISION mc0i(4),mxy(3),mc21i(4),mc22i(4),mc23i(4),
+ + mc24i(4),mc11i(4),mc12i(4),md1i(3)
+ DOUBLE COMPLEX R20,R21,R22,R30,R31,R32,R33,R34,R35,R36,R37,R38,
+ + R41,R42,R43,R44,R45,R46,R47,R48,R49,R50,R51,R52,R53,R54,
+ + R55,cd1i(3),cc0i(4),cc11i(4),cc12i(4),
+ + cc21i(4),cc22i(4),cc23i(4),cc24i(4),cc,cxy(3)
+ DOUBLE COMPLEX cd4pppp(3,3,3,3),cd4ppdel(3,3),cd4deldel,
+ + cd3ppp(3,3,3),cd3pdel(3),cd2pp(3,3),cd2del,
+ + cb0ij(4,4),ca0i(4),cd2(7)
+ save iinx,bij
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* data
+*
+ data iinx /2,3,4,6,7,10,
+ + 1,3,4,9,7,8,
+ + 1,2,4,5,10,8,
+ + 1,2,3,5,6,9/
+ data bij /1,2,5,6,9,10,17,18,21,22,33,34/
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations :
+* #[ kinematical quantities for 4pv-red :
+* if ( abs(fdel3) .lt. 1.d-6 ) then
+* print *,'kinematical det = 0, PV-scheme breaks down'
+* print *,fdel3
+* goto 990
+* endif
+ if ( atest ) then
+ del3p =
+ + - xpi(5)*xpi(5)*xpi(7) + xpi(5)*xpi(6)*xpi(7) + xpi(5)*xpi(6)*
+ + xpi(8) - xpi(5)*xpi(6)*xpi(9) - xpi(5)*xpi(7)*xpi(7) + xpi(5)*
+ + xpi(7)*xpi(8) + xpi(5)*xpi(7)*xpi(9) + xpi(5)*xpi(7)*xpi(10) -
+ + xpi(5)*xpi(8)*xpi(10) + xpi(5)*xpi(9)*xpi(10) - xpi(6)*xpi(6)*
+ + xpi(8) + xpi(6)*xpi(7)*xpi(8) - xpi(6)*xpi(7)*xpi(10) - xpi(6)*
+ + xpi(8)*xpi(8) + xpi(6)*xpi(8)*xpi(9) + xpi(6)*xpi(8)*xpi(10) +
+ + xpi(6)*xpi(9)*xpi(10) - xpi(7)*xpi(8)*xpi(9) + xpi(7)*xpi(9)*
+ + xpi(10) + xpi(8)*xpi(9)*xpi(10) - xpi(9)*xpi(9)*xpi(10) -
+ + xpi(9)*xpi(10)*xpi(10)
+ del3p = del3p/4
+ xmax = max(abs(xpi(5)),abs(xpi(6)),abs(xpi(7)),abs(xpi(8)),
+ + abs(xpi(9)),abs(xpi(10)))**3
+ if ( abs(del3p-fdel3).gt.1d-12*xmax ) then
+ print *,'ffxdxp: fdel3 wrong: ',fdel3,del3p,fdel3-del3p,
+ + xmax
+ endif
+ endif
+*
+* inverse kinematical matrix xi4 (3X3)
+*
+ ier2 = ier
+ call aaxi4(xi4,ier2)
+ ier2 = ier2 - ier
+*
+* f-functions:
+ f1 = 2*fpij4(1,5)
+ f2 = 2*fpij4(1,6)
+ f3 = 2*fpij4(1,7)
+*
+* #] kinematical quantities for 4pv-red :
+* #[ level 1 : D11,D12,D13,C0(I)
+* need 4 diff C0(I)-functions,I=1,2,3
+ cc0i(1)=ccxj(1)
+ cc0i(2)=ccxj(14)
+ cc0i(3)=ccxj(27)
+ cc0i(4)=ccxj(40)
+ mc0i(1)=mcxj(1)
+ mc0i(2)=mcxj(14)
+ mc0i(3)=mcxj(27)
+ mc0i(4)=mcxj(40)
+ ier1 = ier
+ call ffxd1a(cdxi(2),mdxi(2),cdxi(1),mdxi(1),cc0i,mc0i,
+ + xpi,fpij4,fdel3,fdel2i,ier1)
+ if ( awrite ) then
+ print *,'GEERT JANs-scheme: id,nevent ',id,nevent
+ print *,'D11=',cdxi(2),mdxi(2),ier1
+ print *,'D12=',cdxi(3),mdxi(3),ier1
+ print *,'D13=',cdxi(4),mdxi(4),ier1
+ endif
+*
+ if ( lwarn .and. atest ) then
+* PV-reduction
+ R20 = ( f1*cdxi(1)+cc0i(2)-cc0i(1) )/2
+ R21 = ( f2*cdxi(1)+cc0i(3)-cc0i(2) )/2
+ R22 = ( f3*cdxi(1)+cc0i(4)-cc0i(3) )/2
+ Rm(20) = ( max(abs(f1)*mdxi(1),mc0i(2),mc0i(1)) )/2
+ Rm(21) = ( max(abs(f2)*mdxi(1),mc0i(3),mc0i(2)) )/2
+ Rm(22) = ( max(abs(f3)*mdxi(1),mc0i(4),mc0i(3)) )/2
+ cd1i(1)=xi4(1)*R20+xi4(4)*R21+xi4(5)*R22
+ cd1i(2)=xi4(4)*R20+xi4(2)*R21+xi4(6)*R22
+ cd1i(3)=xi4(5)*R20+xi4(6)*R21+xi4(3)*R22
+ md1i(1)=abs(xi4(1))*Rm(20)+abs(xi4(4))*Rm(21)+
+ + abs(xi4(5))*Rm(22)
+ md1i(2)=abs(xi4(4))*Rm(20)+abs(xi4(2))*Rm(21)+
+ + abs(xi4(6))*Rm(22)
+ md1i(3)=abs(xi4(5))*Rm(20)+abs(xi4(6))*Rm(21)+
+ + abs(xi4(3))*Rm(22)
+ do 139 i=1,3
+ if ( xloss**2*absc(cdxi(i+1)-cd1i(i)).gt.precc*max(
+ + mdxi(i+1),md1i(i)) ) print *,'ffxdx: error: FF D1',
+ + i,' disagrees with PV:',cdxi(i+1),cd1i(i),
+ + cdxi(i+1)-cd1i(i),max(mdxi(i+1),md1i(i))
+ 139 continue
+ if (awrite) then
+ print *,' '
+ print *,'ffxdx : level 1: id,nevent ',id,nevent
+ print *,'D11=',cd1i(1)
+ print *,'D12=',cd1i(2)
+ print *,'D13=',cd1i(3)
+ endif
+ endif
+*
+ if ( level.eq.1 ) then
+ if ( lwarn ) then
+ xmax = 0
+ do i=1,4
+ if ( absc(cdxi(i)).ne.0 ) then
+ xmax = max(xmax,mdxi(i)/absc(cdxi(i)))
+ elseif ( mdxi(i).ne.0 ) then
+ xmax = max(xmax,1/precc)
+ endif
+ enddo
+ ier1 = int(log10(xmax))
+ if ( awrite ) print *,'ier = ',ier1
+ else
+ ier1 = 0
+ endif
+ goto 990
+ endif
+*
+* #] level 1 :
+* #[ level 2 : D21,D22,D23,D24,D25,D26,D27,C11(I),C12(I)
+* need 4 diff C1-functions
+ ier = ier1
+ do 14 i=1,4
+ j = 2 + (i-1)*13
+ cc11i(i) = ccxj(j)
+ cc12i(i) = ccxj(j+1)
+ mc11i(i) = mcxj(j)
+ mc12i(i) = mcxj(j+1)
+ 14 continue
+* PV-reduction
+ cdxi(11)=-( f1*cdxi(2)+f2*cdxi(3)+f3*cdxi(4)-cc0i(1) )/2
+ + +xpi(1)*cdxi(1)
+ if ( lwarn ) then
+*** d11max = max(absc(f1*cdxi(2)),absc(f2*cdxi(3)),
+*** + absc(f3*cdxi(4)),absc(cc0i(1)),2*absc(xpi(1)*cdxi(1)))/2
+*** if ( absc(cdxi(11)).lt.xloss*d11max ) then
+*** ier0 = ier
+*** call ffwarn(283,ier0,absc(cdxi(11)),d11max)
+*** ier1 = max(ier1,ier0)
+*** endif
+ mdxi(11) = max(abs(f1)*mdxi(2),abs(f2)*mdxi(3),
+ + abs(f3)*mdxi(4),mc0i(1),2*xpi(1)*mdxi(1))/2
+ endif
+ R30=( f1*cdxi(2) + cc11i(2) + cc0i(1) )/2 - cdxi(11)
+ R31=( f2*cdxi(2) + cc11i(3) - cc11i(2) )/2
+ R32=( f3*cdxi(2) + cc11i(4) - cc11i(3) )/2
+ R33=( f1*cdxi(3) + cc11i(2) - cc11i(1) )/2
+ R34=( f2*cdxi(3) + cc12i(3) - cc11i(2) )/2 - cdxi(11)
+ R35=( f3*cdxi(3) + cc12i(4) - cc12i(3) )/2
+ R36=( f1*cdxi(4) + cc12i(2) - cc12i(1) )/2
+ R37=( f2*cdxi(4) + cc12i(3) - cc12i(2) )/2
+ R38=( f3*cdxi(4) - cc12i(3) )/2 - cdxi(11)
+ cdxi(5) = xi4(1)*R30+xi4(4)*R31+xi4(5)*R32
+ cdxi(6) = xi4(4)*R33+xi4(2)*R34+xi4(6)*R35
+ cdxi(7) = xi4(5)*R36+xi4(6)*R37+xi4(3)*R38
+ cdxi(8) = xi4(4)*R30+xi4(2)*R31+xi4(6)*R32
+ cdxi(9) = xi4(5)*R30+xi4(6)*R31+xi4(3)*R32
+ cdxi(10)= xi4(5)*R33+xi4(6)*R34+xi4(3)*R35
+ if ( lwarn ) then
+*** Rm(30)=max(absc(f1*cdxi(2)),absc(cc11i(2)),absc(cc0i(1)),
+*** + 2*d11max)/2
+*** Rm(31)=max(absc(f2*cdxi(2)),absc(cc11i(3)),absc(cc11i(2)))/2
+*** Rm(32)=max(absc(f3*cdxi(2)),absc(cc11i(4)),absc(cc11i(3)))/2
+*** Rm(33)=max(absc(f1*cdxi(3)),absc(cc11i(2)),absc(cc11i(1)))/2
+*** Rm(34)=max(absc(f2*cdxi(3)),absc(cc12i(3)),absc(cc11i(2)),
+*** + 2*d11max)/2
+*** Rm(35)=max(absc(f3*cdxi(3)),absc(cc12i(4)),absc(cc12i(3)))/2
+*** Rm(36)=max(absc(f1*cdxi(4)),absc(cc12i(2)),absc(cc12i(1)))/2
+*** Rm(37)=max(absc(f2*cdxi(4)),absc(cc12i(3)),absc(cc12i(2)))/2
+*** Rm(38)=max(absc(f3*cdxi(4)),absc(cc12i(3)),2*d11max)/2
+*** xmax = max(abs(xi4(1))*Rm(30),abs(xi4(4))*Rm(31),abs(xi4(5))
+*** + *Rm(32))
+*** if ( absc(cdxi(5)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(282,ier0,absc(cdxi(5)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi4(4))*Rm(33),abs(xi4(2))*Rm(34),abs(xi4(6))
+*** + *Rm(35))
+*** if ( absc(cdxi(6)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(281,ier0,absc(cdxi(6)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi4(5))*Rm(36),abs(xi4(6))*Rm(37),abs(xi4(3))
+*** + *Rm(38))
+*** if ( absc(cdxi(7)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(280,ier0,absc(cdxi(7)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi4(4))*Rm(30),abs(xi4(2))*Rm(31),abs(xi4(6))
+*** + *Rm(32))
+*** if ( absc(cdxi(8)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(279,ier0,absc(cdxi(8)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi4(5))*Rm(30),abs(xi4(6))*Rm(31),abs(xi4(3))
+*** + *Rm(32))
+*** if ( absc(cdxi(9)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(278,ier0,absc(cdxi(9)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax = max(abs(xi4(5))*Rm(33),abs(xi4(6))*Rm(34),abs(xi4(3))
+*** + *Rm(35))
+*** if ( absc(cdxi(10)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(277,ier0,absc(cdxi(10)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*
+* the maximum values of the whole value (not only in this step)
+*
+ Rm(30) = max(abs(f1)*mdxi(2),mc11i(2),mc0i(1),2*mdxi(11))/2
+ Rm(31) = max(abs(f2)*mdxi(2),mc11i(3),mc11i(2))/2
+ Rm(32) = max(abs(f3)*mdxi(2),mc11i(4),mc11i(3))/2
+ Rm(33) = max(abs(f1)*mdxi(3),mc11i(2),mc11i(1))/2
+ Rm(34) = max(abs(f2)*mdxi(3),mc12i(3),mc11i(2),2*mdxi(11))/2
+ Rm(35) = max(abs(f3)*mdxi(3),mc12i(4),mc12i(3))/2
+ Rm(36) = max(abs(f1)*mdxi(4),mc12i(2),mc12i(1))/2
+ Rm(37) = max(abs(f2)*mdxi(4),mc12i(3),mc12i(2))/2
+ Rm(38) = max(abs(f3)*mdxi(4),mc12i(3),2*mdxi(11))/2
+ mdxi(5) = max(abs(xi4(1))*Rm(30),abs(xi4(4))*Rm(31),
+ + abs(xi4(5))*Rm(32))
+ mdxi(6) = max(abs(xi4(4))*Rm(33),abs(xi4(2))*Rm(34),
+ + abs(xi4(6))*Rm(35))
+ mdxi(7) = max(abs(xi4(5))*Rm(36),abs(xi4(6))*Rm(37),
+ + abs(xi4(3))*Rm(38))
+ mdxi(8) = max(abs(xi4(4))*Rm(30),abs(xi4(2))*Rm(31),
+ + abs(xi4(6))*Rm(32))
+ mdxi(9) = max(abs(xi4(5))*Rm(30),abs(xi4(6))*Rm(31),
+ + abs(xi4(3))*Rm(32))
+ mdxi(10)= max(abs(xi4(5))*Rm(33),abs(xi4(6))*Rm(34),
+ + abs(xi4(3))*Rm(35))
+ endif
+* redundancy check
+ if ( lwarn .and. atest ) then
+ cxy(1) = xi4(1)*R33+xi4(4)*R34+xi4(5)*R35
+ cxy(2) = xi4(1)*R36+xi4(4)*R37+xi4(5)*R38
+ cxy(3) = xi4(4)*R36+xi4(2)*R37+xi4(6)*R38
+ mxy(1) = abs(xi4(1))*Rm(33)+abs(xi4(4))*Rm(34)+abs(xi4(5))*
+ + Rm(35)
+ mxy(2) = abs(xi4(1))*Rm(36)+abs(xi4(4))*Rm(37)+abs(xi4(5))*
+ + Rm(38)
+ mxy(3) = abs(xi4(4))*Rm(36)+abs(xi4(2))*Rm(37)+abs(xi4(6))*
+ + Rm(38)
+ if ( xloss*absc(cxy(1)-cdxi(8)) .gt.precc*max(mxy(1),
+ + mdxi(8))
+ + .or. xloss*absc(cxy(2)-cdxi(9)) .gt.precc*max(mxy(2),
+ + mdxi(9))
+ + .or. xloss*absc(cxy(3)-cdxi(10)).gt.precc*max(mxy(3),
+ + mdxi(10)) ) then
+ print *,'ffxdx: error: id/nevent ',id,'/',nevent
+ print *,'redundancy check at level 2 failed: '
+ print *,cxy(1),cdxi(8),absc(cxy(1)-cdxi(8)),
+ + max(mxy(1),mdxi(8))
+ print *,cxy(2),cdxi(9),absc(cxy(2)-cdxi(9)),
+ + max(mxy(2),mdxi(9))
+ print *,cxy(3),cdxi(10),absc(cxy(3)-cdxi(20)),
+ + max(mxy(3),mdxi(10))
+ endif
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'ffxdx : level 2: id,nevent ',id,nevent
+ print *,'D21=',cdxi(5),mdxi(5),ier1
+ print *,'D22=',cdxi(6),mdxi(6),ier1
+ print *,'D23=',cdxi(7),mdxi(7),ier1
+ print *,'D24=',cdxi(8),mdxi(8),ier1
+ print *,' ',cxy(1),mxy(1)
+ print *,'D25=',cdxi(9),mdxi(9),ier1
+ print *,' ',cxy(2),mxy(2)
+ print *,'D26=',cdxi(10),mdxi(10),ier1
+ print *,' ',cxy(3),mxy(3)
+ print *,'D27=',cdxi(11),mdxi(11),ier1
+ endif
+* this goes wrong in the case of complex masses - no way out yet...
+ if ( awrite .and. .FALSE. ) then
+ d0 = 0
+ xmm = 0
+ if ( awrite ) print *,'calling ffxdi with ier = ',ier
+* the order of the B0s can be deduced from the C0 -> B0 chain
+ cb0ij(1,2) = cbxj(33)
+ cb0ij(1,3) = cbxj(21)
+ cb0ij(1,4) = cbxj(17)
+ cb0ij(2,1) = cbxj(33)
+ cb0ij(2,3) = cbxj( 9)
+ cb0ij(2,4) = cbxj( 5)
+ cb0ij(3,1) = cbxj(21)
+ cb0ij(3,2) = cbxj( 9)
+ cb0ij(3,4) = cbxj( 1)
+ cb0ij(4,1) = cbxj(17)
+ cb0ij(4,2) = cbxj( 5)
+ cb0ij(4,3) = cbxj( 1)
+* the A0s are not used for the moment
+ call ffxdi(cd4pppp,cd4ppdel,cd4deldel, cd3ppp,cd3pdel,
+ + cd2pp,cd2del, cd1i, dl2pij, cdxi(1),cc0i,cb0ij,ca0i,
+ + fdel4s,fdel3,fdel2i, xpi,fpij4, d0,xmm, 2, ier)
+* #[ convert to PV conventions:
+*
+ ier1 = ier
+ cd2(1) = cd2pp(1,1) - DBLE(fdel2i(1))*cd2del
+ if ( lwarn .and. absc(cd2(1)).lt.xloss*absc(cd2pp(1,1)) ) then
+ call ffwarn(229,ier1,absc(cd2(1)),absc(cd2pp(1,1)))
+ endif
+ cd2(2) = cd2pp(1,2) + DBLE(dl2pij(2,4))*cd2del
+ if ( lwarn .and. absc(cd2(2)).lt.xloss*absc(cd2pp(1,2)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(2)),absc(cd2pp(1,2)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(3) = cd2pp(1,3) - DBLE(dl2pij(1,4))*cd2del
+ if ( lwarn .and. absc(cd2(3)).lt.xloss*absc(cd2pp(1,3)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(3)),absc(cd2pp(1,3)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(4) = cd2pp(2,2) - DBLE(xpi(5)*xpi(7)-fpij4(5,7)**2)*cd2del
+ if ( lwarn .and. absc(cd2(4)).lt.xloss*absc(cd2pp(2,2)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(4)),absc(cd2pp(2,2)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(5) = cd2pp(2,3) + DBLE(dl2pij(1,2))*cd2del
+ if ( lwarn .and. absc(cd2(5)).lt.xloss*absc(cd2pp(2,3)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(5)),absc(cd2pp(2,3)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(6) = cd2pp(3,3) - DBLE(fdel2i(4))*cd2del
+ if ( lwarn .and. absc(cd2(6)).lt.xloss*absc(cd2pp(3,3)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(6)),absc(cd2pp(3,3)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(7) = DBLE(fdel3)*cd2del
+*
+* #] convert to PV conventions:
+ if ( awrite ) then
+ print *,'ffxdi gives'
+ print *,'D11 = ',cd1i(1),ier1
+ print *,'D12 = ',cd1i(2),ier1
+ print *,'D13 = ',cd1i(3),ier1
+ print *,'D21 = ',cd2(1),ier1
+ print *,'D22 = ',cd2(4),ier1
+ print *,'D23 = ',cd2(6),ier1
+ print *,'D24 = ',cd2(2),ier1
+ print *,'D25 = ',cd2(3),ier1
+ print *,'D26 = ',cd2(5),ier1
+ print *,'D27 = ',cd2(7),ier1
+ endif
+ endif
+*
+ if ( level.eq.2 ) then
+ if ( lwarn ) then
+ xmax = 0
+ do i=1,11
+ if ( absc(cdxi(i)).ne.0 ) then
+ xmax = max(xmax,mdxi(i)/absc(cdxi(i)))
+ elseif ( mdxi(i).ne.0 ) then
+ xmax = max(xmax,1/precc)
+ endif
+ enddo
+ ier1 = int(log10(xmax))
+ if ( awrite ) print *,'ier = ',ier1
+ else
+ ier1 = 0
+ endif
+ goto 990
+ endif
+*
+* #] level 2 :
+* #[ level 3 : D31,D32,D33,D34,D35,D36,D37,D38,D39,D310,D311,D312,D313
+* C21(I),C22(I),C23(I),C11(I),C12(I)
+* need 4 diff C2-functions
+ do 15 i=1,4
+ j = 4 +(i-1)*13
+ cc21i(i)=ccxj(j)
+ cc22i(i)=ccxj(j+1)
+ cc23i(i)=ccxj(j+2)
+ cc24i(i)=ccxj(j+3)
+ mc21i(i)=mcxj(j)
+ mc22i(i)=mcxj(j+1)
+ mc23i(i)=mcxj(j+2)
+ mc24i(i)=mcxj(j+3)
+ 15 continue
+* PV-reduction
+ R53=( f1*cdxi(11) + cc24i(2) - cc24i(1) )/2
+ R54=( f2*cdxi(11) + cc24i(3) - cc24i(2) )/2
+ R55=( f3*cdxi(11) + cc24i(4) - cc24i(3) )/2
+ cdxi(22) = xi4(1)*R53+xi4(4)*R54+xi4(5)*R55
+ cdxi(23) = xi4(4)*R53+xi4(2)*R54+xi4(6)*R55
+ cdxi(24) = xi4(5)*R53+xi4(6)*R54+xi4(3)*R55
+ if ( lwarn ) then
+*** Rm(53)=max(abs(f1)*d11max,absc(cc24i(2)),absc(cc24i(1)))/2
+*** Rm(54)=max(abs(f2)*d11max,absc(cc24i(3)),absc(cc24i(2)))/2
+*** Rm(55)=max(abs(f3)*d11max,absc(cc24i(4)),absc(cc24i(3)))/2
+*** d22max = max(abs(xi4(1))*Rm(53),abs(xi4(4))*Rm(54),
+*** + abs(xi4(5))*Rm(55))
+*** if ( absc(cdxi(22)).lt.xloss*d22max ) then
+*** ier0 = ier
+*** call ffwarn(276,ier0,absc(cdxi(22)),d22max)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** d23max = max(abs(xi4(4))*Rm(53),abs(xi4(2))*Rm(54),
+*** + abs(xi4(6))*Rm(55))
+*** if ( absc(cdxi(23)).lt.xloss*d23max ) then
+*** ier0 = ier
+*** call ffwarn(275,ier0,absc(cdxi(23)),d23max)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** d24max = max(abs(xi4(5))*Rm(53),abs(xi4(6))*Rm(54),
+*** + abs(xi4(3))*Rm(55))
+*** if ( absc(cdxi(24)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(274,ier0,absc(cdxi(24)),d24max)
+*** ier1 = max(ier1,ier0)
+*** endif
+*
+* and again for the whole thing
+*
+ Rm(53)=max(abs(f1)*mdxi(11),mc24i(2),mc24i(1))/2
+ Rm(54)=max(abs(f2)*mdxi(11),mc24i(3),mc24i(2))/2
+ Rm(55)=max(abs(f3)*mdxi(11),mc24i(4),mc24i(3))/2
+ mdxi(22) = max(abs(xi4(1))*Rm(53),abs(xi4(4))*Rm(54),
+ + abs(xi4(5))*Rm(55))
+ mdxi(23) = max(abs(xi4(4))*Rm(53),abs(xi4(2))*Rm(54),
+ + abs(xi4(6))*Rm(55))
+ mdxi(24) = max(abs(xi4(5))*Rm(53),abs(xi4(6))*Rm(54),
+ + abs(xi4(3))*Rm(55))
+ endif
+*
+ R41=( f1*cdxi(5) + cc21i(2) - cc0i(1) )/2-2*cdxi(22)
+ R42=( f2*cdxi(5) + cc21i(3) - cc21i(2) )/2
+ R43=( f3*cdxi(5) + cc21i(4) - cc21i(3) )/2
+ R44=( f1*cdxi(6) + cc21i(2) - cc21i(1) )/2
+ R45=( f2*cdxi(6) + cc22i(3) - cc21i(2) )/2-2*cdxi(23)
+ R46=( f3*cdxi(6) + cc22i(4) - cc22i(3) )/2
+ R47=( f1*cdxi(7) + cc22i(2) - cc22i(1) )/2
+ R48=( f2*cdxi(7) + cc22i(3) - cc22i(2) )/2
+ R49=( f3*cdxi(7) - cc22i(3) )/2-2*cdxi(24)
+ R50=( f1*cdxi(8) + cc21i(2) + cc11i(1) )/2-cdxi(23)
+ R51=( f2*cdxi(8) + cc23i(3) - cc21i(2) )/2-cdxi(22)
+ R52=( f3*cdxi(8) + cc23i(4) - cc23i(3) )/2
+ cdxi(12) = xi4(1)*R41+xi4(4)*R42+xi4(5)*R43
+ cdxi(13) = xi4(4)*R44+xi4(2)*R45+xi4(6)*R46
+ cdxi(14) = xi4(5)*R47+xi4(6)*R48+xi4(3)*R49
+ cdxi(15) = xi4(4)*R41+xi4(2)*R42+xi4(6)*R43
+ cdxi(16) = xi4(5)*R41+xi4(6)*R42+xi4(3)*R43
+ cdxi(17) = xi4(1)*R44+xi4(4)*R45+xi4(5)*R46
+ cdxi(18) = xi4(1)*R47+xi4(4)*R48+xi4(5)*R49
+ cdxi(19) = xi4(5)*R44+xi4(6)*R45+xi4(3)*R46
+ cdxi(20) = xi4(4)*R47+xi4(2)*R48+xi4(6)*R49
+ cdxi(21) = xi4(5)*R50+xi4(6)*R51+xi4(3)*R52
+ if ( lwarn ) then
+*** Rm(41)=max(absc(f1*cdxi(5)),absc(cc21i(2)),absc(cc0i(1)),
+*** + 4*d22max)/2
+*** Rm(42)=max(absc(f2*cdxi(5)),absc(cc21i(3)),absc(cc21i(2)))/2
+*** Rm(43)=max(absc(f3*cdxi(5)),absc(cc21i(4)),absc(cc21i(3)))/2
+*** Rm(44)=max(absc(f1*cdxi(6)),absc(cc21i(2)),absc(cc21i(1)))/2
+*** Rm(45)=max(absc(f2*cdxi(6)),absc(cc22i(3)),absc(cc21i(2)),
+*** + 4*d23max)/2
+*** Rm(46)=max(absc(f3*cdxi(6)),absc(cc22i(4)),absc(cc22i(3)))/2
+*** Rm(47)=max(absc(f1*cdxi(7)),absc(cc22i(2)),absc(cc22i(1)))/2
+*** Rm(48)=max(absc(f2*cdxi(7)),absc(cc22i(3)),absc(cc22i(2)))/2
+*** Rm(49)=max(absc(f3*cdxi(7)),absc(cc22i(3)),4*d24max)/2
+*** Rm(50)=max(absc(f1*cdxi(8)),absc(cc21i(2)),absc(cc11i(1)),
+*** + 2*d23max)/2
+*** Rm(51)=max(absc(f2*cdxi(8)),absc(cc23i(3)),absc(cc21i(2)),
+*** + 2*d22max)/2
+*** Rm(52)=max(absc(f3*cdxi(8)),absc(cc23i(4)),absc(cc23i(3)))/2
+*** xmax=max(abs(xi4(1))*Rm(41),abs(xi4(4))*Rm(42),
+*** + abs(xi4(5))*Rm(43))
+*** if ( absc(cdxi(12)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(273,ier0,absc(cdxi(12)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax=max(abs(xi4(4))*Rm(44),abs(xi4(2))*Rm(45),
+*** + abs(xi4(6))*Rm(46))
+*** if ( absc(cdxi(13)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(272,ier0,absc(cdxi(13)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax=max(abs(xi4(5))*Rm(47),abs(xi4(6))*Rm(48),
+*** + abs(xi4(3))*Rm(49))
+*** if ( absc(cdxi(14)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(271,ier0,absc(cdxi(14)),xmax)
+*** if ( awrite ) then
+*** print *,'xi4(5)*R47,xi4(6)*R48,xi4(3)*R49,cdxi(14) = '
+*** print *,xi4(5)*R47,xi4(6)*R48,xi4(3)*R49,cdxi(14)
+*** print *,xi4(5)*Rm(47),xi4(6)*Rm(48),xi4(3)*Rm(49),xmax
+*** endif
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax=max(abs(xi4(4))*Rm(41),abs(xi4(2))*Rm(42),
+*** + abs(xi4(6))*Rm(43))
+*** if ( absc(cdxi(15)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(270,ier0,absc(cdxi(15)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax=max(abs(xi4(5))*Rm(41),abs(xi4(6))*Rm(42),
+*** + abs(xi4(3))*Rm(43))
+*** if ( absc(cdxi(16)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(269,ier0,absc(cdxi(16)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax=max(abs(xi4(1))*Rm(44),abs(xi4(4))*Rm(45),
+*** + abs(xi4(5))*Rm(46))
+*** if ( absc(cdxi(17)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(268,ier0,absc(cdxi(17)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax=max(abs(xi4(1))*Rm(47),abs(xi4(4))*Rm(48),
+*** + abs(xi4(5))*Rm(49))
+*** if ( absc(cdxi(18)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(267,ier0,absc(cdxi(18)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax=max(abs(xi4(5))*Rm(44),abs(xi4(6))*Rm(45),
+*** + abs(xi4(3))*Rm(46))
+*** if ( absc(cdxi(19)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(266,ier0,absc(cdxi(19)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax=max(abs(xi4(4))*Rm(47),abs(xi4(2))*Rm(48),
+*** + abs(xi4(6))*Rm(49))
+*** if ( absc(cdxi(20)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(265,ier0,absc(cdxi(20)),xmax)
+*** if ( awrite ) then
+*** print *,'xi4(4)*R47,xi4(2)*R48,xi4(6)*R49,cdxi(20) = '
+*** print *,xi4(4)*R47,xi4(2)*R48,xi4(6)*R49,cdxi(20)
+*** print *,xi4(4)*Rm(47),xi4(2)*Rm(48),xi4(6)*Rm(49),xmax
+*** endif
+*** ier1 = max(ier1,ier0)
+*** endif
+*** xmax=max(abs(xi4(5))*Rm(50),abs(xi4(6))*Rm(51),
+*** + abs(xi4(3))*Rm(52))
+*** if ( absc(cdxi(21)).lt.xloss*xmax ) then
+*** ier0 = ier
+*** call ffwarn(264,ier0,absc(cdxi(21)),xmax)
+*** ier1 = max(ier1,ier0)
+*** endif
+*
+* again the whole thing, not just this step
+*
+ Rm(41) = max(abs(f1)*mdxi(5),mc21i(2),mc0i(1),4*mdxi(22))/2
+ Rm(42) = max(abs(f2)*mdxi(5),mc21i(3),mc21i(2))/2
+ Rm(43) = max(abs(f3)*mdxi(5),mc21i(4),mc21i(3))/2
+ Rm(44) = max(abs(f1)*mdxi(6),mc21i(2),mc21i(1))/2
+ Rm(45) = max(abs(f2)*mdxi(6),mc22i(3),mc21i(2),4*mdxi(23))/2
+ Rm(46) = max(abs(f3)*mdxi(6),mc22i(4),mc22i(3))/2
+ Rm(47) = max(abs(f1)*mdxi(7),mc22i(2),mc22i(1))/2
+ Rm(48) = max(abs(f2)*mdxi(7),mc22i(3),mc22i(2))/2
+ Rm(49) = max(abs(f3)*mdxi(7),mc22i(3),4*mdxi(24))/2
+ Rm(50) = max(abs(f1)*mdxi(8),mc21i(2),mc11i(1),2*mdxi(23))/2
+ Rm(51) = max(abs(f2)*mdxi(8),mc23i(3),mc21i(2),2*mdxi(22))/2
+ Rm(52) = max(abs(f3)*mdxi(8),mc23i(4),mc23i(3))/2
+ mdxi(12) = max(abs(xi4(1))*Rm(41),abs(xi4(4))*Rm(42),
+ + abs(xi4(5))*Rm(43))
+ mdxi(13) = max(abs(xi4(4))*Rm(44),abs(xi4(2))*Rm(45),
+ + abs(xi4(6))*Rm(46))
+ mdxi(14) = max(abs(xi4(5))*Rm(47),abs(xi4(6))*Rm(48),
+ + abs(xi4(3))*Rm(49))
+ mdxi(15) = max(abs(xi4(4))*Rm(41),abs(xi4(2))*Rm(42),
+ + abs(xi4(6))*Rm(43))
+ mdxi(16) = max(abs(xi4(5))*Rm(41),abs(xi4(6))*Rm(42),
+ + abs(xi4(3))*Rm(43))
+ mdxi(17) = max(abs(xi4(1))*Rm(44),abs(xi4(4))*Rm(45),
+ + abs(xi4(5))*Rm(46))
+ mdxi(18) = max(abs(xi4(1))*Rm(47),abs(xi4(4))*Rm(48),
+ + abs(xi4(5))*Rm(49))
+ mdxi(19) = max(abs(xi4(5))*Rm(44),abs(xi4(6))*Rm(45),
+ + abs(xi4(3))*Rm(46))
+ mdxi(20) = max(abs(xi4(4))*Rm(47),abs(xi4(2))*Rm(48),
+ + abs(xi4(6))*Rm(49))
+ mdxi(21) = max(abs(xi4(5))*Rm(50),abs(xi4(6))*Rm(51),
+ + abs(xi4(3))*Rm(52))
+ endif
+* redundancy check
+ if ( lwarn .and. atest ) then
+ cxy(1) = xi4(1)*R50+xi4(4)*R51+xi4(5)*R52
+ cxy(2) = xi4(4)*R50+xi4(2)*R51+xi4(6)*R52
+ mxy(1) = abs(xi4(1))*Rm(50)+abs(xi4(4))*Rm(51)+ abs(xi4(5))*
+ + Rm(52)
+ mxy(2) = abs(xi4(4))*Rm(50)+abs(xi4(2))*Rm(51)+ abs(xi4(6))*
+ + Rm(52)
+ if ( xloss*absc(cxy(1)-cdxi(15)).gt.precc*max(mxy(1),
+ + mdxi(15))
+ + .or. xloss*absc(cxy(2)-cdxi(17)).gt.precc*max(mxy(2),
+ + mdxi(17)) ) then
+ print *,'ffxdx: error: id/nevent ',id,'/',nevent
+ print *,'redundancy check at level 3 failed: '
+ print *,cxy(1),cdxi(15),absc(cxy(1)-cdxi(15)),
+ + max(mxy(1),mdxi(15))
+ print *,cxy(2),cdxi(17),absc(cxy(2)-cdxi(17)),
+ + max(mxy(2),mdxi(17))
+ endif
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'ffxdx : level 3: id,nevent ',id,nevent
+ print *,'D31 =',cdxi(12),mdxi(12),ier1
+ print *,'D32 =',cdxi(13),mdxi(13),ier1
+ print *,'D33 =',cdxi(14),mdxi(14),ier1
+ print *,'D34 =',cdxi(15),mdxi(15),ier1
+ print *,' ',cxy(1) ,mxy(1)
+ print *,'D35 =',cdxi(16),mdxi(16),ier1
+ print *,'D36 =',cdxi(17),mdxi(17),ier1
+ print *,' ',cxy(2) ,mxy(2)
+ print *,'D37 =',cdxi(18),mdxi(18),ier1
+ print *,'D38 =',cdxi(19),mdxi(19),ier1
+ print *,'D39 =',cdxi(20),mdxi(20),ier1
+ print *,'D310=',cdxi(21),mdxi(21),ier1
+ print *,'D311=',cdxi(22),mdxi(22),ier1
+ print *,'D312=',cdxi(23),mdxi(23),ier1
+ print *,'D313=',cdxi(24),mdxi(24),ier1
+ endif
+*
+ if ( level.eq.3 ) then
+ if ( lwarn ) then
+ xmax = 0
+ do i=1,24
+ if ( absc(cdxi(i)).ne.0 ) then
+ xmax = max(xmax,mdxi(i)/absc(cdxi(i)))
+ elseif ( mdxi(i).ne.0 ) then
+ xmax = max(xmax,1/precc)
+ endif
+ enddo
+ ier1 = int(log10(xmax))
+ if ( awrite ) print *,'ier = ',ier1
+ else
+ ier1 = 0
+ endif
+ goto 990
+ endif
+*
+* #] level 3 :
+* #[ end:
+ print *,'ffxdx: level ',level,' not supported.'
+ stop
+ 990 continue
+ ier = ier1 + ier2
+* #] end:
+*###] ffxdx:
+ end
+*###[ ffdji:
+ subroutine ffdji(ccxi,mcxi,cbxi,mbxi,caxi,maxi,
+ + ccxj,mcxj,cbxj,mbxj,caxj,maxj,level)
+***#[*comment:***********************************************************
+* *
+* Renumber the [mc][abc]xj arrays into the [mc][abc]xi arrays. *
+* Note: the A's are not yet used and not yet renumbered! *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer level
+ DOUBLE PRECISION mcxi(28),mbxi(12),maxi(4),
+ + mcxj(52),mbxj(48),maxj(12)
+ DOUBLE COMPLEX ccxi(28),cbxi(12),caxi(4),
+ + ccxj(52),cbxj(48),caxj(12)
+*
+* local variables
+*
+ integer i,j,k,bij(12),beq(6,2)
+ save bij,beq
+*
+* common
+*
+ include 'aa.h'
+ include 'ff.h'
+*
+* data
+*
+ data bij /1,2,5,6,9,10,17,18,21,22,33,34/
+ data beq / 0, 4, 8,16,20,32,
+ + 12,24,36,28,40,44/
+*
+* #] declarations:
+* #[ renumber:
+* output preparation
+* 1)C-output: reduce the array ccxj(4*13) to ccxi(4*7)
+* c's are calculated only to (level-1)
+ do 130 j=1,4
+ do 131 i=1,7
+ ccxi(i+(j-1)*7) = ccxj(i+(j-1)*13)
+ mcxi(i+(j-1)*7) = mcxj(i+(j-1)*13)
+ 131 continue
+ 130 continue
+* 2)B-output: reduce the array cbxj(12*4) to cbxi(6*2)
+* b's are calculated only to (level-2)
+ do i=1,12
+ cbxi(i) = cbxj(bij(i))
+ mbxi(i) = mbxj(bij(i))
+ enddo
+* check the symmetry in B0(i,j)
+ if ( atest ) then
+ do 13 i=1,4
+ do 12 j=1,6
+ if ( xloss*abs(cbxj(i+beq(j,1))-cbxj(i+beq(j,2)))
+ + .gt. precc*abs(cbxj(i+beq(j,1))) ) then
+ print *,'ffxdji: cbxj(',i+beq(j,1),') != cbxj(',
+ + i+beq(j,2),'): ',cbxj(i+beq(j,1)),
+ + cbxj(i+beq(j,2)),cbxj(i+beq(j,1))-
+ + cbxj(i+beq(j,2))
+ endif
+ 12 continue
+ 13 continue
+ endif
+* #] renumber:
+*###] ffdji:
+ end
diff --git a/ff-2.0/aaxinv.f b/ff-2.0/aaxinv.f
new file mode 100644
index 0000000..f9462b7
--- /dev/null
+++ b/ff-2.0/aaxinv.f
@@ -0,0 +1,273 @@
+
+* file aaxinv 4-oct-1990
+
+*###[ : aaxi3 :
+ subroutine aaxi3(xi3,xpi,ier)
+*###[ : comment:*******************************************************
+*###] : comment:**********************************************************
+*###[ : declarations :
+ implicit none
+* arguments
+ DOUBLE PRECISION xi3(3),xpi(6)
+ integer ier
+* local variables
+ integer i
+ DOUBLE PRECISION e3(3),s1,s2,s3,xnul,xmax
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*###] : declarations :
+*###[ : kinematical matrix x3 and inverse xi3:
+* the dotproducts are imported via ff.h
+* definition see ffxc0.ffdot3:comment
+ s1=fpij3(4,4)
+ s2=fpij3(5,5)
+ s3=fpij3(4,5)
+* inverse kinematical matrix xi3
+* the determinant is also provided by ff
+ if ( fdel2.eq.0 ) then
+ call fferr(89,ier)
+ return
+ endif
+ if ( atest ) then
+* make sure that they are correct.
+ do i=4,5
+ xnul = fpij3(i,i) - xpi(i)
+ if ( xloss*abs(xnul).gt.precx*abs(xpi(i)) ) then
+ print *,'aaxi3: error: saved fpij3(',i,i,
+ + ') does not agree with recomputed: ',
+ + fpij3(4,4),xpi(4),xnul
+ endif
+ enddo
+ xnul = 2*fpij3(4,5) + xpi(4) + xpi(5) - xpi(6)
+ xmax = max(abs(xpi(4)),abs(xpi(5)),abs(xpi(6)))
+ if ( xloss*abs(xnul).gt.precx*xmax ) then
+ print *,'aaxi3: error: saved fpij3(4,5) does not ',
+ + 'agree with recomputed: ',2*fpij3(4,5),
+ + xpi(6)-xpi(4)-xpi(5),xnul,xmax
+ endif
+ xnul = fdel2 - xpi(4)*xpi(5) + fpij3(4,5)**2
+ xmax = max(abs(fdel2),fpij3(4,5)**2)
+ if ( xloss*abs(xnul).gt.precx*xmax ) then
+ print *,'aaxi3: error: saved fdel2 does not ',
+ + 'agree with recomputed: ',fdel2,
+ + xpi(4)*xpi(5) - fpij3(4,5)**2,xnul,xmax
+ endif
+ endif
+ xi3(1)= s2/fdel2
+ xi3(3)=-s3/fdel2
+ xi3(2)= s1/fdel2
+*###] : kinematical matrix x3 and inverse xi3:
+*###[ : check: on accuracy
+ if ( atest ) then
+ e3(1)= s1*xi3(1)+s3*xi3(3)
+ e3(2)= s3*xi3(3)+s2*xi3(2)
+ e3(3)= s1*xi3(3)+s3*xi3(2)
+ if ( abs(e3(1)-1) .gt. .1d-4 ) then
+ print *,'aaxi3: error in xi3(1) or xi3(3): ',e3(1)-1,xi3
+ endif
+ if ( abs(e3(2)-1) .gt. .1d-4 ) then
+ print *,'aaxi3: error in xi3(2) or xi3(3): ',e3(2)-1,xi3
+ endif
+ if ( abs(e3(3)) .gt. .1d-4 ) then
+ print *,'aaxi3: error in xi3(2) or xi3(3): ',e3(3),xi3
+ endif
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'aaxi3:imported dots and inv:'
+ print *,'s..xi3 ',s1,xi3(1)
+ print *,' ',s2,xi3(2)
+ print *,' ',s3,xi3(3)
+ print *,' '
+ endif
+*###] : check:
+*###] : aaxi3 :
+ end
+
+*###[ : aaxi4 :
+ subroutine aaxi4(xi4,ier)
+*###[ : comment:*******************************************************
+*###] : comment:**********************************************************
+*###[ : declarations :
+ implicit none
+* arguments
+ DOUBLE PRECISION xi4(6)
+ integer ier
+* local variables
+ integer i,ier0,ier1
+ DOUBLE PRECISION e4(6),s1,s2,s3,s4,s5,s6,del2
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*###] : declarations :
+*###[ : kinematical matrix x4 and inverse xi4:
+ if ( fdel3.eq.0 ) then
+ call fferr(90,ier)
+ return
+ endif
+* the dotproducts are imported via ff.h
+* definition see ffxd0.ffdot4:comment
+* inverse kinematical matrix xi4
+* the determinant is also provided by ff
+* xi4(1)=( +s2*s3-s6**2 )/fdel3
+* xi4(4)=( -s3*s4+s5*s6 )/fdel3
+* xi4(5)=( -s2*s5+s4*s6 )/fdel3
+* xi4(2)=( +s1*s3-s5**2 )/fdel3
+* xi4(6)=( -s1*s6+s4*s5 )/fdel3
+* xi4(3)=( +s1*s2-s4**2 )/fdel3
+ ier1 = ier
+*
+ ier0 = ier
+ call ffdel2(del2,fpij4,10,6,7,10,1,ier0)
+ ier1 = max(ier0,ier1)
+ xi4(1) = +del2/fdel3
+*
+ del2 = fpij4(5,5)*fpij4(7,7) - fpij4(5,7)**2
+ if ( lwarn .and. abs(del2).lt.xloss*fpij4(5,7)**2 ) then
+ ier0 = ier
+ call ffwarn(263,ier0,del2,fpij4(5,7)**2)
+ ier1 = max(ier0,ier1)
+ endif
+ xi4(2) = +del2/fdel3
+*
+ ier0 = ier
+ call ffdel2(del2,fpij4,10,5,6,9,1,ier0)
+ ier1 = max(ier0,ier1)
+ xi4(3) = +del2/fdel3
+*
+ ier0 = ier
+ call ffdl2t(del2,fpij4,5,7,6,7,10,-1,-1,10,ier0)
+ ier1 = max(ier1,ier0)
+ xi4(4) = -del2/fdel3
+*
+ ier0 = ier
+ call ffdl2i(del2,fpij4,10,5,6,9,-1,6,7,10,+1,ier0)
+ ier1 = max(ier1,ier0)
+ xi4(5) = +del2/fdel3
+*
+ ier0 = ier
+ call ffdl2t(del2,fpij4,5,7,5,6,9,+1,-1,10,ier0)
+ ier1 = max(ier1,ier0)
+ xi4(6) = -del2/fdel3
+*
+*###] : kinematical matrix x4 and inverse xi4:
+*###[ : check:
+ if ( atest ) then
+ s1=fpij4(5,5)
+ s2=fpij4(6,6)
+ s3=fpij4(7,7)
+ s4=fpij4(5,6)
+ s5=fpij4(5,7)
+ s6=fpij4(6,7)
+ e4(1) = ( s1*xi4(1)+s4*xi4(4)+s5*xi4(5) )
+ e4(2) = ( s4*xi4(4)+s2*xi4(2)+s6*xi4(6) )
+ e4(3) = ( s5*xi4(5)+s6*xi4(6)+s3*xi4(3) )
+ e4(4) = ( s1*xi4(4)+s4*xi4(2)+s5*xi4(6) )
+ e4(5) = ( s1*xi4(5)+s4*xi4(6)+s5*xi4(3) )
+ e4(6) = ( s4*xi4(5)+s2*xi4(6)+s6*xi4(3) )
+ do 12 i=1,3
+ if ( abs(e4(i)-1.d0) .gt. .1d-5 .or.
+ + abs(e4(i+3) ) .gt. .1d-5 ) then
+ print *,'aaxi4: error in xi4'
+ return
+ endif
+ 12 continue
+ endif
+*###] : check:
+*###] : aaxi4 :
+ end
+
+*###[ : aaxi5 :
+ subroutine aaxi5(xi5,ier)
+*###[ : comment:*******************************************************
+*###] : comment:**********************************************************
+*###[ : declarations :
+ implicit none
+* arguments
+ DOUBLE PRECISION xi5(10)
+ integer ier
+* local variables
+ DOUBLE PRECISION e5(10),s1,s2,s3,s4,s5,s6,s7,s8,s9,s10
+ integer i,j
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*###] : declarations :
+*###[ : kinematical matrix x5 and inverse xi5:
+ if ( fdel4.eq.0 ) then
+ call fferr(91,ier)
+ return
+ endif
+* the dotproducts are imported via ff.h
+* definition see ffex0.ffdot5:comment
+ s1 = fpij5(6,6)
+ s2 = fpij5(7,7)
+ s3 = fpij5(8,8)
+ s4 = fpij5(9,9)
+ s5 = fpij5(6,7)
+ s6 = fpij5(6,8)
+ s7 = fpij5(6,9)
+ s8 = fpij5(7,8)
+ s9 = fpij5(7,9)
+ s10 = fpij5(8,9)
+*
+* inverse kinematical matrix xi5
+ xi5(1)=
+ + s2*s3*s4-s2*s10**2-s3*s9**2-s4*s8**2+2*s8*s9*s10
+ xi5(5)=
+ + -s3*s4*s5+s3*s7*s9+s4*s6*s8+s5*s10**2-s6*s9*s10-s7*s8*s10
+ xi5(6)=
+ + -s2*s4*s6+s2*s7*s10+s4*s5*s8-s5*s9*s10+s6*s9**2-s7*s8*s9
+ xi5(7)=
+ + -s2*s3*s7+s2*s6*s10+s3*s5*s9-s5*s8*s10-s6*s8*s9+s7*s8**2
+ xi5(2)=
+ + +s1*s3*s4-s1*s10**2-s3*s7**2-s4*s6**2+2*s6*s7*s10
+ xi5(8)=
+ + -s1*s4*s8+s1*s9*s10+s4*s5*s6-s5*s7*s10-s6*s7*s9+s7**2*s8
+ xi5(9)=
+ + -s1*s3*s9+s1*s8*s10+s3*s5*s7-s5*s6*s10-s6*s7*s8+s6**2*s9
+ xi5(3)=
+ + +s1*s2*s4-s1*s9**2-s2*s7**2-s4*s5**2+2*s5*s7*s9
+ xi5(10)=
+ + -s1*s2*s10+s1*s8*s9+s2*s6*s7-s5*s6*s9-s5*s7*s8+s5**2*s10
+ xi5(4)=
+ + +s1*s2*s3-s1*s8**2-s2*s6**2-s3*s5**2+2*s5*s6*s8
+
+* the determinant is also provided by ff
+ do 20 i=1,10
+ 20 xi5(i) = xi5(i) / fdel4
+*###] : kinematical matrix x5 and inverse xi5:
+*###[ : check:
+ if ( atest ) then
+ e5(1)=( s1*xi5(1)+s5*xi5(5)+s6*xi5(6)+s7*xi5(7) )
+ e5(2)=( s5*xi5(5)+s2*xi5(2)+s8*xi5(8)+s9*xi5(9) )
+ e5(3)=( s6*xi5(6)+s8*xi5(8)+s3*xi5(3)+s10*xi5(10) )
+ e5(4)=( s7*xi5(7)+s9*xi5(9)+s10*xi5(10)+s4*xi5(4) )
+ e5(5)=( s1*xi5(5)+s5*xi5(2)+s6*xi5(8)+s7*xi5(9) )
+ e5(6)=( s1*xi5(6)+s5*xi5(8)+s6*xi5(3)+s7*xi5(10) )
+ e5(7)=( s1*xi5(7)+s5*xi5(9)+s6*xi5(10)+s7*xi5(4) )
+ e5(8)=( s5*xi5(6)+s2*xi5(8)+s8*xi5(3)+s9*xi5(10) )
+ e5(9)=( s5*xi5(7)+s2*xi5(9)+s8*xi5(10)+s9*xi5(4) )
+ e5(10)=( s6*xi5(7)+s8*xi5(9)+s3*xi5(10)+s10*xi5(4) )
+ do 12 i=1,4
+ if ( abs(e5(i)-1.d0) .gt. .1d-5 .or.
+ + abs(e5(i+6) ) .gt. .1d-5 ) then
+ print *,'aaxi5: error in xi5'
+ return
+ endif
+ 12 continue
+ endif
+*###] : check:
+*###] : aaxi5 :
+ end
+
+
+
+
diff --git a/ff-2.0/ff.h b/ff-2.0/ff.h
new file mode 100644
index 0000000..828e89f
--- /dev/null
+++ b/ff-2.0/ff.h
@@ -0,0 +1,169 @@
+* $Id: ff.h,v 1.1 1995/12/12 10:03:48 gj Exp $
+* -------------------------------------------------------------
+* INCLUDE FILE FOR THE FF ROUTINES.
+* Geert Jan van Oldenborgh.
+* -------------------------------------------------------------
+* please do not change, and recompile _everything_ when you do.
+* -------------------------------------------------------------
+*
+* this parameter determines how far the scalar npoint functions
+* will look back to find the same parameters (when lmem is true)
+*
+ integer memory
+ parameter(memory=12)
+*
+* if .TRUE. then default (ffinit)
+* lwrite: give debug output .FALSE.
+* ltest: test consistency internally (slow) .TRUE.
+* l4also: in C0 (and higher), also consider the algorithm with 16
+* dilogs .TRUE.
+* ldc3c4: in D0 (and higher), also consider possible cancellations
+* between the C0's .TRUE.
+* lmem: before computing the C0 and higher, first check whether
+* it has already been done recently .FALSE.
+* lwarn: give warning messages (concerning numerical stability)
+* .TRUE.
+* ldot: leave the dotproducts and some determinants in common
+* .FALSE.
+* onshel: (in ffz?0 only): use onshell momenta .TRUE.
+* lsmug: internal use
+* lnasty: internal use
+*
+ logical lwrite,ltest,l4also,ldc3c4,lmem,lwarn,ldot,onshel,lsmug,
+ + lnasty
+*
+* nwidth: number of widths within which the complex mass is used
+* nschem: scheme to handle the complex mass (see ffinit.f)
+* idot: internal flags to signal that some of the dotproducts
+* are input: 0: none; 1: external pi.pj, 2: external +
+* kinematical determinant, 3: all dotproducts + kindet.
+*
+ integer nwidth,nschem,idot
+*
+* xloss: factor that the final result of a subtraction can be
+* smaller than the terms without warning (default 1/8)
+* precx: precision of real numbers, determined at runtime by
+* ffinit (IEEE: 4.e-16)
+* precc: same for complex numbers
+* xalogm: smallest real number of which a log can be taken,
+* determined at runtime by ffinit (IEEE: 2.e-308)
+* xclogm: same for complex.
+* xalog2: xalogm**2
+* xclog2: xclogm**2
+* reqprc: not used
+* x[0124]:0,1,2,4
+* x05: 1/2
+* pi: pi
+* pi6: pi**2/6
+* pi12: pi**2/12
+* xlg2: log(2)
+* bf: factors in the expansion of dilog (~Bernouilli numbers)
+* xninv: 1/n
+* xn2inv: 1/n**2
+* xinfac: 1/n!
+* fpij2: vi.vj for 2point function 1-2: si, 3-3: pi
+* fpij3: vi.vj for 3point function 1-3: si, 4-6: pi
+* fpij4: vi.vj for 4point function 1-4: si, 5-10: pi
+* fpij5: vi.vj for 5point function 1-5: si, 6-15: pi
+* fpij6: vi.vj for 6point function 1-6: si, 7-21: pi
+* fdel2: del2 = delta_(p1,p2)^(p1,p2) = p1^2.p2^2 - p1.p2^2 in C0
+* fdel3: del3 = delta_(p1,p2,p3)^(p1,p2,p3) in D0
+* fdel4s: del4s = delta_(s1,s2,s3,s4)^(s1,s2,s3,s4) in D0
+* fdel4: del4 = delta_(p1,p2,p3,p4)^(p1,p2,p3,p4) in E0
+* fdl3i: del3i = delta_(pj,pk,pl)^(pj,pk,pl) in E0, D0 without si
+* fdl4si: dl4si = del4s in E0, D0 without si
+* fdl3ij: same in F0 without si and sj.
+* fd4sij: dl4si = del4s in E0, D0 without si
+* fdl4i: delta4 in F0 without si.
+* fodel2: same offshell (in case of complex or z-functions)
+* fodel3: -"-
+* cfdl4s: -"-
+* fodel4: -"-
+* fodl3i: -"-
+* fod3ij: -"-
+* fodl4i: -"-
+* fidel3: ier of del3 (is not included in D0)
+* fidel4: ier of del4 (is not included in E0)
+* fidl3i: ier of dl3i (is not included in E0)
+* fid3ij: ier of dl3ij (is not included in F0)
+* fidl4i: ier of dl4i (is not included in F0)
+*
+ DOUBLE PRECISION xloss,precx,precc,xalogm,xclogm,xalog2,xclog2,
+ + reqprc,x0,x05,x1,x2,x4,pi,pi6,pi12,xlg2,bf(20),
+ + xninv(30),xn2inv(30),xinfac(30),
+ + fpij2(3,3),fpij3(6,6),fpij4(10,10),fpij5(15,15),
+ + fpij6(21,21),fdel2,fdel3,fdel4s,fdel4,fdl3i(5),
+ + fdl4si(5),fdl3ij(6,6),fd4sij(6,6),fdl4i(6),fodel2,
+ + fodel3,fodel4,fodl3i(5),fod3ij(6,6),fodl4i(6)
+ integer fidel3,fidel4,fidl3i(5),fid3ij(6,6),fidl4i(6)
+*
+* c[0124]:0,1,2,4 complex
+* c05: 1/2 complex
+* c2ipi: 2*i*pi
+* cipi2: i*pi**2
+* cfp..: complex version of fp..., only defined in ff[cz]*
+* cmipj: (internal only) mi^2 - pj^2 in C0
+* c2sisj: (internal only) 2*si.sj in D0
+* cfdl4s: del4s in complex case (D0)
+* ca1: (internal only) complex A1
+* csdl2p: (internal only) complex transformed sqrt(del2)
+*
+ DOUBLE COMPLEX c0,c05,c1,c2,c4,c2ipi,cipi2,
+ + cfpij2(3,3),cfpij3(6,6),cfpij4(10,10),cfpij5(15,15),
+ + cfpij6(21,21),cmipj(3,3),c2sisj(4,4),cfdl4s,ca1
+*
+* nevent: number in integration loop (to be updated by user)
+* ner: can be used to signal numerical problems (see ffrcvr)
+* id: identifier of scalar function (to be set by user)
+* idsub: internal identifier to pinpoint errors
+* inx: in D0: p(inx(i,j)) = isgn(i,j)*(s(i)-s(j))
+* inx5: in E0: p(inx5(i,j)) = isgn5(i,j)*(s(i)-s(j))
+* inx6: in F0: p(inx6(i,j)) = isgn6(i,j)*(s(i)-s(j))
+* isgn: see inx
+* isgn5: see inx5
+* isgn6: see inx6
+* iold: rotation matrix for 4point function
+* isgrot: signs to iold
+* isgn34: +1 or -1: which root to choose in the transformation (D0)
+* isgnal: +1 or -1: which root to choose in the alpha-trick (C0)
+* irota3: save the number of positions the C0 configuration has been
+* rotated over
+* irota4: same for the D0
+* irota5: same for the E0
+* irota6: same for the F0
+*
+ integer nevent,ner,id,idsub,inx(4,4),isgn(4,4),inx5(5,5),
+ + isgn5(5,5),inx6(6,6),isgn6(6,6),isgn34,isgnal,iold(13,
+ + 12),isgrot(10,12),irota3,irota4,irota5,irota6
+ integer idum93(2)
+*
+* parameters
+*
+ parameter(x0 = 0.d0,x1 = 1.d0,x05 = .5d0,x2 = 2.d0,x4 = 4.d0,
+ + c0 = (0.D0,0.D0),c05 = (.5D0,0.D0),c1 = (1.D0,0.D0),
+ + c2 = (2.D0,0.D0),c4 = (4.D0,0.D0))
+ parameter(
+ + c2ipi = (0.D+0,6.28318530717958647692528676655896D+0),
+ + cipi2 = (0.D+0,9.869604401089358618834490999876D+0),
+ + pi = 3.14159265358979323846264338327948D+0,
+ + pi6 = 1.644934066848226436472415166646D+0,
+ + pi12 = .822467033424113218236207583323D+0,
+ + xlg2 = .6931471805599453094172321214581D+0)
+*
+* common
+*
+ common /ffsign/isgn34,isgnal
+ common /ffprec/ xloss,precx,precc,xalogm,xclogm,xalog2,xclog2,
+ + reqprc
+ common /ffflag/ lwrite,ltest,l4also,ldc3c4,lmem,lwarn,ldot,
+ + nevent,ner,id,idsub,nwidth,nschem,onshel,idot
+ common /ffcnst/ bf,xninv,xn2inv,xinfac,inx,isgn,iold,isgrot,
+ + inx5,isgn5,inx6,isgn6
+ common /ffrota/ irota3,irota4,irota5,irota6
+ common /ffdot/ fpij2,fpij3,fpij4,fpij5,fpij6
+ common /ffdel/ fdel2,fdel3,fdel4s,fdel4,fdl3i,fdl4si,fdl3ij,
+ + fd4sij,fdl4i
+ common /ffidel/ fidel3,fidel4,fidl3i,fid3ij,fidl4i
+ common /ffcdot/ cfpij2,cfpij3,cfpij4,cfpij5,cfpij6
+ common /ffcdel/ fodel2,fodel3,cfdl4s,fodel4,fodl3i,fod3ij,fodl4i
+ common /ffsmug/ lsmug,lnasty,idum93,cmipj,c2sisj,ca1
diff --git a/ff-2.0/ff2dl2.f b/ff-2.0/ff2dl2.f
new file mode 100644
index 0000000..1998d72
--- /dev/null
+++ b/ff-2.0/ff2dl2.f
@@ -0,0 +1,632 @@
+*###[ ff2dl2:
+ subroutine ff2dl2(del2d2,del2n,xpi,dpipj,piDpj, i,
+ + j,k,kj,iskj,l, m,n,nm,isnm, ns, ier)
+***#[*comment:***********************************************************
+* *
+* Calculate *
+* *
+* si mu mu sl *
+* d d = si.sj*sk.sm*sl.sn - si.sk*sj.sm*sl.sn *
+* sj sk sm sn - si.sj*sk.sn*sl.sm + si.sk*sj.sn*sl.sm *
+* *
+* with p(kj) = iskj*(sk-sj) *
+* with p(nm) = isnm*(sn-sm) *
+* *
+* Input: xpi(ns) as usual *
+* dpipj(ns,ns) -"- *
+* piDpj(ns,ns) -"- *
+* i,j,k,kj,iskj see above *
+* l,m,n,nm,isnm -"- *
+* *
+* Output: del2d2 see above *
+* del2n it is needed in fftran anyway *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer i,j,k,kj,iskj,l,m,n,nm,isnm,ns,ier
+ DOUBLE PRECISION del2d2,del2n,xpi(10),dpipj(10,10),piDpj(10,10)
+*
+* local variables:
+*
+ integer isii,ii,ik,ij,im,in,ier0,ier1
+ DOUBLE PRECISION s(5),del2m,del2nm,som,xmax,smax
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( abs(iskj) .ne. 1 ) print *,'ff2dl2: error: abs(iskj) ',
+ + '<> 1 but ',iskj
+ if ( abs(isnm) .ne. 1 ) print *,'ff2dl2: error: abs(isnm) ',
+ + '<> 1 but ',isnm
+ if ( ns .ne. 10 ) print *,'ff2dl2: error: ns <> 10 !!'
+ if ( kj.eq.0 ) then
+ print *,'ff2dl2: error: kj=0:j,k,id,idsub=',j,k,id,idsub
+ endif
+ if ( nm.eq.0 ) then
+ print *,'ff2dl2: error: nm=0:m,n,id,idsub=',m,n,id,idsub
+ endif
+ endif
+* #] check input:
+* #[ get del2n:
+* we need this in any case !
+ ier1 = ier
+ if ( i .eq. n ) then
+ del2n = 0
+ elseif ( i .le. 4 ) then
+ ii = inx(n,i)
+ isii = isgn(n,i)
+ call ffdl2s(del2n,xpi,piDpj,i,n,ii,isii,j,k,kj,iskj,10,ier1)
+ else
+ call ffdl2t(del2n,piDpj,i,n,j,k,kj,iskj,+1,10,ier1)
+ endif
+* #] get del2n:
+* #[ special cases:
+ ier0 = ier
+ if ( i .eq. l .and. j .eq. m .and. k .eq. n ) then
+ call ffdl3m(s,.FALSE.,x0,x0,xpi,dpipj,piDpj,ns,j,k,kj,
+ + i,1,ier0)
+ del2d2 = -s(1)
+* if ( lwrite ) print *,'del2d2 = ',del2d2
+ ier = max(ier0,ier1)
+ return
+ endif
+ if ( k .eq. l .and. j .le. 4 ) then
+ call ffdl2s(del2m,xpi,piDpj, j,l,inx(l,j),isgn(l,j),
+ + m,n,nm,isnm, 10,ier0)
+ del2d2 = -piDpj(i,k)*del2m
+* if ( lwrite ) print *,'del2d2 = ',del2d2
+ ier = max(ier0,ier1)
+ return
+ endif
+* not yet tested:
+* if ( j .eq. l .and. k .le. 4 ) then
+* call ffdl2s(del2m,xpi,piDpj, k,l,inx(k,j),isgn(k,j),
+* + m,n,nm,isnm, 10,ier0)
+* del2d2 = piDpj(i,j)*del2m
+* ier = max(ier0,ier1)
+* return
+* endif
+* #] special cases:
+* #[ calculations:
+ ier0 = ier
+ if ( i .eq. m ) then
+ del2m = 0
+ elseif ( i .le. 4 ) then
+ ii = inx(m,i)
+ isii = isgn(m,i)
+ call ffdl2s(del2m,xpi,piDpj,i,m,ii,isii,j,k,kj,iskj,10,ier1)
+ else
+ call ffdl2t(del2m,piDpj,i,m,j,k,kj,iskj,+1,10,ier1)
+ endif
+ s(1) = del2m*piDpj(n,l)
+ s(2) = del2n*piDpj(m,l)
+ smax = abs(s(1))*DBLE(10)**(ier0-ier)
+ del2d2 = s(1) - s(2)
+ if ( abs(del2d2) .ge. xloss*smax ) goto 60
+
+ som = del2d2
+ xmax = smax
+ if ( lwrite ) print *,' del2d2 = ',del2d2,xmax
+
+ ier0 = ier
+ call ffdl2t(del2nm,piDpj,i,nm,j,k,kj,iskj,+1,10,ier0)
+ s(1) = del2n*piDpj(nm,l)
+ s(2) = del2nm*piDpj(n,l)
+ del2d2 = isnm*(s(1) - s(2))
+ smax = abs(s(2))*DBLE(10)**(ier0-ier)
+ if ( lwrite ) print *,' del2d2+ = ',del2d2,smax
+ if ( abs(del2d2) .ge. xloss*abs(s(1)) ) goto 60
+
+ if ( smax .lt. xmax ) then
+ som = del2d2
+ xmax = smax
+ endif
+
+ s(1) = del2m*piDpj(nm,l)
+ s(2) = del2nm*piDpj(m,l)
+ del2d2 = isnm*(s(1) - s(2))
+ smax = abs(s(2))*DBLE(10)**(ier0-ier)
+ if ( lwrite ) print *,' del2d2+ = ',del2d2,smax
+ if ( abs(del2d2) .ge. xloss*abs(s(1)) ) goto 60
+
+ if ( smax .lt. xmax ) then
+ som = del2d2
+ xmax = smax
+ endif
+
+* One more special case:
+ if ( k .eq. m ) then
+ isii = -1
+ ik = j
+ ij = k
+ im = m
+ in = n
+ elseif ( j .eq. m ) then
+ isii = +1
+ ik = k
+ ij = j
+ im = m
+ in = n
+ elseif ( j .eq. n ) then
+ isii = -1
+ ik = k
+ ij = j
+ im = n
+ in = m
+ elseif ( k .eq. n ) then
+ isii = +1
+ ik = j
+ ij = k
+ im = n
+ in = m
+ else
+ goto 50
+ endif
+ if ( ij .eq. im .and. i .le. 4 .and. ij .le. 4 .and. in .le. 4 )
+ + then
+ if ( inx(ij,i) .gt. 0 .and. inx(im,l) .gt. 0 ) then
+ if ( abs(dpipj(i,inx(ij,i))) .lt. xloss*abs(xpi(ij))
+ + .and. abs(dpipj(l,inx(im,l))) .lt. xloss*abs(xpi(im)) )
+ + then
+ s(1) = piDpj(l,in)*piDpj(ik,ij)*dpipj(i,inx(ij,i))/2
+ s(2) = isgn(ij,i)*piDpj(l,in)*xpi(ij)*piDpj(ik,
+ + inx(ij,i))/2
+ s(3) = -piDpj(i,ij)*piDpj(ik,in)*piDpj(l,im)
+ s(4) = piDpj(i,ik)*piDpj(im,in)*dpipj(l,inx(im,l))/2
+ s(5) = isgn(im,l)*piDpj(i,ik)*xpi(im)*piDpj(in,
+ + inx(im,l))/2
+ del2d2 = s(1) + s(2) + s(3) + s(4) + s(5)
+ if ( isii .lt. 0 ) del2d2 = -del2d2
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)),
+ + abs(s(5)))
+ if ( lwrite ) print *,' del2d2* = ',del2d2,s
+ if ( abs(del2d2) .ge. xloss**2*abs(smax) ) goto 60
+ if ( smax .lt. xmax ) then
+ som = del2d2
+ xmax = smax
+ endif
+ endif
+ endif
+ endif
+ 50 continue
+*
+* give up
+*
+ del2d2 = som
+ if ( lwarn ) call ffwarn(123,ier,del2d2,xmax)
+ if ( lwrite ) then
+ print *,'ff2dl2: giving up on this case'
+ print *,' indices: i=n:',i,j,k,l,m,n
+ print *,' xpi: ',xpi
+ endif
+
+ 60 continue
+* #] calculations:
+* #[ check:
+ if ( ltest ) then
+ s(1) = + piDpj(i,j)*piDpj(k,m)*piDpj(l,n)
+ s(2) = - piDpj(i,k)*piDpj(j,m)*piDpj(l,n)
+ s(3) = - piDpj(i,j)*piDpj(k,n)*piDpj(l,m)
+ s(4) = + piDpj(i,k)*piDpj(j,n)*piDpj(l,m)
+ som = s(1) + s(2) + s(3) + s(4)
+ xmax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)))
+ if ( xloss*abs(som-del2d2) .gt. precx*xmax ) then
+ print *,'ff2dl2: error: del2d2 not correct: ',del2d2,
+ + som,xmax,del2d2-som
+ endif
+ endif
+* #] check:
+*###] ff2dl2:
+ end
+*###[ ff2d22:
+ subroutine ff2d22(dl2d22,xpi,dpipj,piDpj, i, j,k,kj,iskj,
+ + m,n,nm,isnm, ns, ier)
+***#[*comment:***********************************************************
+* *
+* Calculate *
+* *
+* / si mu mu nu \2 *
+* |d d | *
+* \ sj sk sm sn / *
+* *
+* = si.sj^2*sk.sm^2*sn.sn *
+* - 2*si.sj^2*sk.sm*sk.sn*sm.sn *
+* + si.sj^2*sk.sn^2*sm.sm *
+* - 2*si.sj*si.sk*sj.sm*sk.sm*sn.sn *
+* + 2*si.sj*si.sk*sj.sm*sk.sn*sm.sn *
+* + 2*si.sj*si.sk*sj.sn*sk.sm*sm.sn *
+* - 2*si.sj*si.sk*sj.sn*sk.sn*sm.sm *
+* + si.sk^2*sj.sm^2*sn.sn *
+* - 2*si.sk^2*sj.sm*sj.sn*sm.sn *
+* + si.sk^2*sj.sn^2*sm.sm *
+* *
+* Input: xpi(ns) as usual *
+* dpipj(ns,ns) -"- *
+* piDpj(ns,ns) -"- *
+* i,j,k,kj,iskj see above *
+* m,n,nm,isnm -"- *
+* *
+* Output: dl2d22 see above *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer i,j,k,kj,iskj,m,n,nm,isnm,ns,ier
+ DOUBLE PRECISION dl2d22,xpi(10),dpipj(10,10),piDpj(10,10)
+*
+* local variables:
+*
+ integer ii,isii
+ DOUBLE PRECISION s(10),del2s,del23,del24,del27,som,smax,xmax
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( abs(iskj) .ne. 1 ) print *,'ff2d22: error: abs(iskj) ',
+ + '<> 1 but ',iskj
+ if ( abs(isnm) .ne. 1 ) print *,'ff2d22: error: abs(isnm) ',
+ + '<> 1 but ',isnm
+ if ( ns .ne. 10 ) print *,'ff2d22: error: ns <> 10 !!'
+ if ( m .ne. 3 .or. n .ne. 4 ) print *,'ff2d22: error ',
+ + 'only for m=3,n=4 !!'
+ endif
+* #] check input:
+* #[ special cases:
+ if ( i .eq. n .or. i .eq. m ) then
+ call ffdl2s(del2s,xpi,piDpj, j,k,kj,iskj, m,n,nm,isnm,
+ + 10,ier)
+ dl2d22 = xpi(i)*del2s**2
+* if ( lwrite ) print *,' dl2d22 = ',dl2d22
+ return
+ endif
+* #] special cases:
+* #[ calculations:
+* We use the product form
+ if ( i .eq. 3 ) then
+ del23 = 0
+ elseif ( i .le. 4 ) then
+ ii = inx(3,i)
+ isii = isgn(3,i)
+ call ffdl2s(del23,xpi,piDpj,i,3,ii,isii,j,k,kj,iskj,10,ier)
+ else
+ call ffdl2t(del23,piDpj,i,3,j,k,kj,iskj,+1,10,ier)
+ endif
+ if ( i .eq. 4 ) then
+ del24 = 0
+ elseif ( i .le. 4 ) then
+ ii = inx(n,i)
+ isii = isgn(n,i)
+ call ffdl2s(del24,xpi,piDpj,i,4,ii,isii,j,k,kj,iskj,10,ier)
+ else
+ call ffdl2t(del24,piDpj,i,4,j,k,kj,iskj,+1,10,ier)
+ endif
+
+ s(1) = xpi(4)*del23**2
+ s(2) = -2*piDpj(3,4)*del23*del24
+ s(3) = xpi(3)*del24**2
+ dl2d22 = s(1) + s(2) + s(3)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( abs(dl2d22) .ge. xloss*smax ) goto 110
+
+ som = dl2d22
+ xmax = smax
+ if ( lwrite ) print *,' dl2d22 = ',dl2d22,s(1),s(2),s(3)
+
+* try the special case k=4 (for use in ee->mumu among others)
+ if ( i .lt. 4 .and. k .eq. 4 .and. abs(s(3)) .lt. xloss*smax
+ + .and. ( abs(dpipj(i,inx(4,i))) .lt. xloss*xpi(i) .or.
+ + abs(piDpj(j,inx(4,i))) .lt. xloss*abs(piDpj(j,4)) ) )
+ + then
+ s(1) = -del23*piDpj(i,4)*piDpj(j,3)*xpi(4)
+ s(2) = del23*dpipj(i,inx(4,i))*piDpj(j,4)*piDpj(3,4)
+ s(4) = del23*piDpj(3,4)*xpi(4)*piDpj(j,inx(4,i))*isgn(4,i)
+ dl2d22 = s(1) + s(2) + s(3) + s(4)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)))
+ if ( lwrite ) print *,' dl2d22* = ',dl2d22,s(1),s(2),s(3),
+ + s(4)
+ if ( abs(dl2d22) .ge. xloss*smax ) goto 110
+
+ if ( smax .lt. xmax ) then
+ som = dl2d22
+ xmax = smax
+ endif
+ endif
+
+ call ffdl2t(del27,piDpj,i,7,j,k,kj,iskj,+1,10,ier)
+ s(1) = xpi(7)*del24**2
+ s(2) = -2*piDpj(4,7)*del24*del27
+ s(3) = xpi(4)*del27**2
+ dl2d22 = s(1) + s(2) + s(3)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( lwrite ) print *,' dl2d22+ = ',dl2d22,s(1),s(2),s(3)
+ if ( abs(dl2d22) .ge. xloss*smax ) goto 110
+
+ if ( smax .lt. xmax ) then
+ som = dl2d22
+ xmax = smax
+ endif
+
+ s(1) = xpi(7)*del23**2
+ s(2) = -2*piDpj(3,7)*del23*del27
+ s(3) = xpi(3)*del27**2
+ dl2d22 = s(1) + s(2) + s(3)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( lwrite ) print *,' dl2d22+ = ',dl2d22,s(1),s(2),s(3)
+ if ( abs(dl2d22) .ge. xloss*smax ) goto 110
+*
+* We'll have to think of something more intelligent ...
+*
+ if ( smax .lt. xmax ) then
+ som = dl2d22
+ xmax = smax
+ endif
+
+ dl2d22 = som
+ if ( lwarn ) call ffwarn(122,ier,dl2d22,xmax)
+ if ( lwrite ) then
+ print *,'ff2d22: give up on this case ...'
+ print *,' indices: ijkmn:',i,j,k,m,n
+ print *,' xpi:',xpi
+ endif
+
+ 110 continue
+* #] calculations:
+* #[ check:
+ if ( ltest ) then
+ s(1) = + piDpj(i,j)**2*piDpj(k,m)**2*piDpj(n,n)
+ s(2) = - 2*piDpj(i,j)**2*piDpj(k,m)*piDpj(k,n)*piDpj(m,n)
+ s(3) = + piDpj(i,j)**2*piDpj(k,n)**2*piDpj(m,m)
+ s(4) = - 2*piDpj(i,j)*piDpj(i,k)*piDpj(j,m)*piDpj(k,m)*
+ + piDpj(n,n)
+ s(5) = + 2*piDpj(i,j)*piDpj(i,k)*piDpj(j,m)*piDpj(k,n)*
+ + piDpj(m,n)
+ s(6) = + 2*piDpj(i,j)*piDpj(i,k)*piDpj(j,n)*piDpj(k,m)*
+ + piDpj(m,n)
+ s(7) = - 2*piDpj(i,j)*piDpj(i,k)*piDpj(j,n)*piDpj(k,n)*
+ + piDpj(m,m)
+ s(8) = + piDpj(i,k)**2*piDpj(j,m)**2*piDpj(n,n)
+ s(9) = - 2*piDpj(i,k)**2*piDpj(j,m)*piDpj(j,n)*piDpj(m,n)
+ s(10)= + piDpj(i,k)**2*piDpj(j,n)**2*piDpj(m,m)
+ som = 0
+ xmax = 0
+ do 900 ii=1,10
+ som = som + s(ii)
+ xmax = max(xmax,abs(s(ii)))
+ 900 continue
+ if ( xloss*abs(som-dl2d22) .gt. precx*xmax ) then
+ print *,'ff2c22: error: dl2d22 not correct: ',dl2d22,
+ + som,xmax
+ endif
+ endif
+* #] check:
+*###] ff2d22:
+ end
+*###[ ff3dl2:
+ subroutine ff3dl2(del3d2,xpi,dpipj,piDpj, i,
+ + j,k,kj,iskj, l,m,ml,isml, n, o,p,po,ispo, ns, ier)
+***#[*comment:***********************************************************
+* *
+* Calculate *
+* *
+* si mu mu nu mu sn *
+* d d d = ... *
+* sj sk sl sm so sp *
+* *
+* with p(kj) = iskj*(sk-sj) *
+* p(ml) = isml*(sm-sl) *
+* p(po) = ispo*(sp-so) *
+* *
+* Input: xpi(ns) as usual *
+* dpipj(ns,ns) -"- *
+* piDpj(ns,ns) -"- *
+* i,j,k,kj,iskj see above *
+* l,m,ml,isml -"- *
+* n,o,p,po,ispo -"- *
+* *
+* Output: del3d2 see above *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer i,j,k,kj,iskj,l,m,ml,isml,n,o,p,po,ispo,ns,ier
+ DOUBLE PRECISION del3d2,xpi(10),dpipj(10,10),piDpj(10,10)
+*
+* local variables:
+*
+ integer isii,ii
+ DOUBLE PRECISION s(2),dl2il,dl2im,dl2ln,dl2mn,dl2iml,dl2mln
+ DOUBLE PRECISION d2d2j,d2d2k,d2d2kj,dum,d2d2o,d2d2p,d2d2po
+ DOUBLE PRECISION som,xmax
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( abs(iskj) .ne. 1 ) print *,'ff3dl2: error: abs(iskj) ',
+ + '<> 1 but ',iskj
+ if ( abs(isml) .ne. 1 ) print *,'ff3dl2: error: abs(isml) ',
+ + '<> 1 but ',isml
+ if ( abs(ispo) .ne. 1 ) print *,'ff3dl2: error: abs(ispo) ',
+ + '<> 1 but ',ispo
+ if ( ns .ne. 10 ) print *,'ff3dl2: error: ns <> 10 !!'
+ endif
+* #] check input:
+* #[ split up l,m:
+ if ( i .eq. l ) then
+ dl2il = 0
+ elseif ( i .le. 4 ) then
+ ii = inx(l,i)
+ isii = isgn(l,i)
+ call ffdl2s(dl2il,xpi,piDpj,i,l,ii,isii,j,k,kj,iskj,10,ier)
+ else
+ call ffdl2t(dl2il,piDpj,i,l,j,k,kj,iskj,+1,10,ier)
+ endif
+ if ( m .eq. n ) then
+ dl2mn = 0
+ elseif ( i .le. 4 ) then
+ ii = inx(n,m)
+ isii = isgn(n,m)
+ call ffdl2s(dl2mn,xpi,piDpj,m,n,ii,isii,o,p,po,ispo,10,ier)
+ else
+ call ffdl2t(dl2mn,piDpj,m,n,o,p,po,ispo,+1,10,ier)
+ endif
+ s(1) = dl2il*dl2mn
+ if ( i .eq. m ) then
+ dl2im = 0
+ elseif ( i .le. 4 ) then
+ ii = inx(m,i)
+ isii = isgn(m,i)
+ call ffdl2s(dl2im,xpi,piDpj,i,m,ii,isii,j,k,kj,iskj,10,ier)
+ else
+ call ffdl2t(dl2im,piDpj,i,m,j,k,kj,iskj,+1,10,ier)
+ endif
+ if ( l .eq. n ) then
+ dl2ln = 0
+ elseif ( i .le. 4 ) then
+ ii = inx(n,l)
+ isii = isgn(n,l)
+ call ffdl2s(dl2ln,xpi,piDpj,l,n,ii,isii,o,p,po,ispo,10,ier)
+ else
+ call ffdl2t(dl2ln,piDpj,l,n,o,p,po,ispo,+1,10,ier)
+ endif
+ s(2) = dl2im*dl2ln
+ del3d2 = s(1) - s(2)
+ if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
+
+ if ( lwrite ) print *,' del3d2 = ',del3d2,s(1),-s(2)
+ som = del3d2
+ xmax = abs(s(1))
+*
+* rotate l,m
+*
+ call ffdl2t(dl2mln,piDpj,ml,n,o,p,po,ispo,+1,10,ier)
+ call ffdl2t(dl2iml,piDpj,i,ml,j,k,kj,iskj,+1,10,ier)
+ s(1) = dl2im*dl2mln
+ s(2) = dl2iml*dl2mn
+ del3d2 = isml*(s(1) - s(2))
+ if ( lwrite ) print *,' del3d2+ = ',del3d2,s(1),-s(2)
+ if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
+
+ if ( abs(s(1)) .lt. xmax ) then
+ som = del3d2
+ xmax = abs(s(1))
+ endif
+
+ s(1) = dl2il*dl2mln
+ s(2) = dl2iml*dl2ln
+ del3d2 = isml*(s(1) - s(2))
+ if ( lwrite ) print *,' del3d2+ = ',del3d2,s(1),-s(2)
+ if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
+
+ if ( abs(s(1)) .lt. xmax ) then
+ som = del3d2
+ xmax = abs(s(1))
+ endif
+
+* #] split up l,m:
+* #[ split up j,k:
+ call ff2dl2(d2d2k,dum,xpi,dpipj,piDpj, k, l,m,ml,isml, n,
+ + o,p,po,ispo, 10, ier)
+ call ff2dl2(d2d2j,dum,xpi,dpipj,piDpj, j, l,m,ml,isml, n,
+ + o,p,po,ispo, 10, ier)
+ s(1) = piDpj(i,j)*d2d2k
+ s(2) = piDpj(i,k)*d2d2j
+ del3d2 = s(1) - s(2)
+ if ( lwrite ) print *,' del3d2+ = ',del3d2,s(1),-s(2)
+ if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
+
+ if ( abs(s(1)) .lt. xmax ) then
+ som = del3d2
+ xmax = abs(s(1))
+ endif
+
+ call ff2dl2(d2d2kj,dum,xpi,dpipj,piDpj, kj, l,m,ml,isml, n,
+ + o,p,po,ispo, 10, ier)
+ s(1) = piDpj(i,k)*d2d2kj
+ s(2) = piDpj(i,kj)*d2d2k
+ del3d2 = iskj*(s(1) - s(2))
+ if ( lwrite ) print *,' del3d2+ = ',del3d2,s(1),-s(2)
+ if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
+
+ if ( abs(s(1)) .lt. xmax ) then
+ som = del3d2
+ xmax = abs(s(1))
+ endif
+
+ s(1) = piDpj(i,j)*d2d2kj
+ s(2) = piDpj(i,kj)*d2d2j
+ del3d2 = iskj*(s(1) - s(2))
+ if ( lwrite ) print *,' del3d2+ = ',del3d2,s(1),-s(2)
+ if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
+
+ if ( abs(s(1)) .lt. xmax ) then
+ som = del3d2
+ xmax = abs(s(1))
+ endif
+
+* #] split up j,k:
+* #[ split up o,p:
+ call ff2dl2(d2d2o,dum,xpi,dpipj,piDpj, i, j,k,kj,iskj, o,
+ + l,m,ml,isml, 10, ier)
+ call ff2dl2(d2d2p,dum,xpi,dpipj,piDpj, i, j,k,kj,iskj, p,
+ + l,m,ml,isml, 10, ier)
+ s(1) = piDpj(p,n)*d2d2o
+ s(2) = piDpj(o,n)*d2d2p
+ del3d2 = s(1) - s(2)
+ if ( lwrite ) print *,' del3d2+ = ',del3d2,s(1),-s(2)
+ if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
+
+ if ( abs(s(1)) .lt. xmax ) then
+ som = del3d2
+ xmax = abs(s(1))
+ endif
+
+ call ff2dl2(d2d2po,dum,xpi,dpipj,piDpj, i, j,k,kj,iskj, po,
+ + l,m,ml,isml, 10, ier)
+ s(1) = piDpj(po,n)*d2d2p
+ s(2) = piDpj(p,n)*d2d2po
+ del3d2 = ispo*(s(1) - s(2))
+ if ( lwrite ) print *,' del3d2+ = ',del3d2,s(1),-s(2)
+ if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
+
+ if ( abs(s(1)) .lt. xmax ) then
+ som = del3d2
+ xmax = abs(s(1))
+ endif
+
+ s(1) = piDpj(po,n)*d2d2o
+ s(2) = piDpj(o,n)*d2d2po
+ del3d2 = ispo*(s(1) - s(2))
+ if ( lwrite ) print *,' del3d2+ = ',del3d2,s(1),-s(2)
+ if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
+
+ if ( abs(s(1)) .lt. xmax ) then
+ som = del3d2
+ xmax = abs(s(1))
+ endif
+
+* #] split up o,p:
+* #[ give up:
+ del3d2 = som
+ if ( lwarn ) call ffwarn(124,ier,del3d2,xmax)
+* #] give up:
+*###] ff3dl2:
+ end
diff --git a/ff-2.0/ffabcd.f b/ff-2.0/ffabcd.f
new file mode 100644
index 0000000..a8e74ea
--- /dev/null
+++ b/ff-2.0/ffabcd.f
@@ -0,0 +1,501 @@
+*###[ ffabcd:
+ subroutine ffabcd(aijkl,xpi,dpipj,piDpj,del2s,sdel2s,
+ + in,jn,jin,isji, kn,ln,lkn,islk, ns, ifirst, ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the a,b,c,d of the equation for qij.qkl *
+* *
+* a = s4.s4^2 *
+* *
+* si sj sk sl / sm sn sm sn sm sn mu ro\ *
+* -b/2 = d d |d d - d s4 s4 | *
+* mu nu nu ro \ mu s4 ro s4 sm sn / *
+* *
+* _ si sj sk sl / mu s4 ro mu s4 ro\ *
+* vD/2 = d d |d s4 + d s4 | *
+* mu nu nu ro \ s3 s4 s3 s4 / *
+* *
+* with sm = s3, sn = s4 *
+* p(jin) = isji*(sj-si) *
+* p(lkn) = islk*(sl-sk) *
+* *
+* Input: xpi(ns) as usual *
+* dpipj(ns,ns) -"- *
+* piDpj(ns,ns) -"- *
+* in,jn,jin,isjn see above *
+* kn,ln,lkn,islk see above *
+* *
+* Output: del4d2 see above *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer in,jn,jin,isji,kn,ln,lkn,islk,ns,ifirst,
+ + ier
+ DOUBLE PRECISION aijkl,xpi(10),dpipj(10,10),piDpj(10,10),del2s
+ DOUBLE PRECISION sdel2s
+*
+* local variables:
+*
+ integer i,j,ji,k,l,lk,isii
+ integer ii,ll
+ integer iii(6,2)
+ save iii
+ logical ldet(4)
+ DOUBLE PRECISION xa,xb,xc,xd,s(24),del3(4),som,somb,somd,xbp,
+ + xdp,smaxp,smax,save,xmax,rloss,del2d2,dum,del2i,del2j,
+ + del2ji,del2k,del2l,del2lk,d2d2i,d2d2j,d2d2ji,d2d2k,
+ + d2d2l,d2d2lk,d3d2m,d3d2n,d3d2nm
+ save del3,ldet
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* data
+*
+ data iii / 0,3,4,0,7,0,
+ + 0,3,4,0,7,0/
+* data isign/1,1,1,0,1,0,
+* + 1,1,1,0,1,0/
+* #] declarations:
+* #[ initialisaties:
+ if ( ifirst .eq. 0 ) then
+ ifirst = ifirst + 1
+ ldet(2) = .FALSE.
+ ldet(3) = .FALSE.
+ ldet(4) = .FALSE.
+ endif
+ xa = xpi(4)**2
+* #] initialisaties:
+* #[ check input:
+ if ( ltest ) then
+ if ( abs(isji) .ne. 1 ) print *,'ff2d22: error: abs(isji)',
+ + ' /= 1',isji
+ if ( abs(islk) .ne. 1 ) print *,'ff2d22: error: abs(islk)',
+ + ' /= 1',islk
+ if ( ns .ne. 10 ) print *,'ffabcd: only valid for ns=10!!'
+ endif
+* #] check input:
+* #[ prepare input:
+ i = in
+ j = jn
+ ji = jin
+ k = kn
+ l = ln
+ lk = lkn
+* sort it so that i<j, k<l, i<=k, and if i=k, j<=l
+* (I think this is superfluous as the indices are sorted when
+* called)
+* if ( i .gt. j ) then
+* ii = i
+* i = j
+* j = ii
+* isji = -isji
+* endif
+* if ( k .gt. l ) then
+* ii = k
+* k = l
+* l = ii
+* islk = -islk
+* endif
+* if ( 16*i + j .gt. 16*k + l ) then
+* ii = i
+* i = k
+* k = ii
+* ii = j
+* j = l
+* l = ii
+* ii = ji
+* ji = lk
+* lk = ii
+* ii = isji
+* isji = islk
+* islk = ii
+* endif
+* #] prepare input:
+* #[ special cases:
+ if ( k .eq. 3 ) then
+ xb = 0
+ xc = 0
+ xd = 0
+* print *,' b,c,d = 0 (kl=34)'
+ goto 990
+ elseif ( j .ge. 3 .and. l .ge. 3 ) then
+* the whole thing collapses to factor*det3
+* we have a good memory of things already calculated ...
+ if ( .not.ldet(i+k) ) then
+ ldet(i+k) = .TRUE.
+ iii(1,1) = i
+ iii(4,1) = isgn(3,i)*inx(3,i)
+ iii(6,1) = isgn(i,4)*inx(i,4)
+ iii(1,2) = k
+ iii(4,2) = isgn(3,k)*inx(3,k)
+ iii(6,2) = isgn(k,4)*inx(k,4)
+ call ffdl3s(del3(i+k),xpi,piDpj,iii,10,ier)
+ endif
+ if ( l .eq. 4 .and. j .eq. 4 ) then
+ xb = xpi(4)**2*del3(i+k)/del2s
+ xd = 0
+ xc = xb**2/xa
+ elseif ( l .eq. 4 .or. j .eq. 4 ) then
+ xb = piDpj(3,4)*xpi(4)*del3(i+k)/del2s
+ xd = -xpi(4)*del3(i+k)/sdel2s
+ xc = xpi(4)*xpi(3)*del3(i+k)**2/del2s**2
+ else
+* l .eq. 3 .and. j .eq. 3
+ xd = -2*piDpj(3,4)*del3(i+k)/sdel2s
+ s(1) = xpi(3)*xpi(4)
+ s(2) = 2*piDpj(3,4)**2
+ som = s(2) - s(1)
+ if ( abs(som) .ge. xloss*abs(s(1)) ) goto 20
+ call ffwarn(88,ier,som,s(1))
+ 20 continue
+ xb = som*del3(i+k)/del2s
+ xc = xpi(3)**2*del3(i+k)**2/del2s**2
+ endif
+ goto 900
+ endif
+ if ( j .eq. 2 .and. l .eq. 4 ) then
+ call ff3dl2(s(1),xpi,dpipj,piDpj, 4, 1,2,5,+1,
+ + k,3,inx(3,k),isgn(3,k), 4, 3,4,7,+1, 10,ier)
+ xb = -xpi(4)*s(1)/del2s
+ iii(1,1) = 1
+ iii(2,1) = 2
+ iii(4,1) = 5
+ iii(5,1) = 10
+ iii(6,1) = 8
+ iii(1,2) = k
+ iii(4,2) = isgn(3,k)*inx(3,k)
+ iii(6,2) = isgn(k,4)*inx(k,4)
+ call ffdl3s(s(1),xpi,piDpj,iii,10,ier)
+* restore values for other users
+ iii(2,1) = 3
+ iii(5,1) = 7
+ xd = -xpi(4)*s(1)/sdel2s
+ goto 800
+ endif
+* #] special cases:
+* #[ normal case b:
+*
+* First term:
+*
+ call ff2dl2(del2d2,dum,xpi,dpipj,piDpj, 4,
+ + i,j,ji,isji, 4, k,l,lk,islk, 10, ier)
+ s(1) = -del2d2*del2s
+*
+* Second and third term, split i,j
+*
+ if ( i .eq. 4 ) then
+ del2i = 0
+ else
+ ii = inx(4,i)
+ isii = isgn(4,i)
+ call ffdl2s(del2i,xpi,piDpj,i,4,ii,isii,3,4,7,+1,10,ier)
+ endif
+ if ( j .eq. 4 ) then
+ del2j = 0
+ else
+ ii = inx(4,j)
+ isii = isgn(4,j)
+ call ffdl2s(del2j,xpi,piDpj,j,4,ii,isii,3,4,7,+1,10,ier)
+ endif
+ call ff2dl2(d2d2i,dum,xpi,dpipj,piDpj, i, k,l,lk,islk, 4,
+ + 3,4,7,+1, 10, ier)
+ call ff2dl2(d2d2j,dum,xpi,dpipj,piDpj, j, k,l,lk,islk, 4,
+ + 3,4,7,+1, 10, ier)
+ s(2) = +del2i*d2d2j
+ s(3) = -del2j*d2d2i
+ somb = s(1) + s(2) + s(3)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( abs(somb) .ge. xloss*smax ) goto 90
+ xmax = smax
+ save = somb
+
+* if the first term is wrong ... forget about it
+ if ( abs(somb) .lt. xloss*abs(s(1)) ) then
+ if ( lwrite ) print *,'somb: s = ',s(1),s(2),s(3)
+ goto 80
+ endif
+ if ( lwrite ) print *,' somb = ',somb,s(1),s(2),s(3)
+
+ call ffdl2t(del2ji,piDpj, ji,4, 3,4,7,+1,+1, 10,ier)
+ call ff2dl2(d2d2ji,dum,xpi,dpipj,piDpj, ji, k,l,lk,islk, 4,
+ + 3,4,7,+1, 10, ier)
+ s(2) = +del2j*d2d2ji
+ s(3) = -del2ji*d2d2j
+ somb = s(1) + isji*(s(2) + s(3))
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( lwrite ) print *,' somb+1= ',somb,s(1),s(2),s(3),isji
+ if ( abs(somb) .ge. xloss*smax ) goto 90
+ if ( smax .lt. xmax ) then
+ save = somb
+ xmax = smax
+ endif
+
+ s(2) = +del2i*d2d2ji
+ s(3) = -del2ji*d2d2i
+ somb = s(1) + isji*(s(2) + s(3))
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( lwrite ) print *,' somb+2= ',somb,s(1),s(2),s(3),isji
+ if ( abs(somb) .ge. xloss*max(abs(s(1)),abs(s(2)),abs(s(3))) )
+ + goto 90
+ if ( smax .lt. xmax ) then
+ save = somb
+ xmax = smax
+ endif
+*
+* Second and third term, split k,l
+*
+* more of the same ...
+* if ( k .eq. 4 ) then
+* del2k = 0
+* else
+* ii = inx(4,k)
+* isii = isgn(4,k)
+* call ffdl2s(del2k,xpi,piDpj,k,4,ii,isii,3,4,7,+1,10,ier)
+* endif
+* if ( l .eq. 4 ) then
+* del2l = 0
+* else
+* ii = inx(4,l)
+* isii = isgn(4,l)
+* call ffdl2s(del2l,xpi,piDpj,l,4,ii,isii,3,4,7,+1,10,ier)
+* endif
+* call ff2dl2(d2d2k,dum,xpi,dpipj,piDpj, k, i,j,ji,isji, 4,
+* + 3,4,7,+1, 10, ier)
+* call ff2dl2(d2d2l,dum,xpi,dpipj,piDpj, l, i,j,ji,isji, 4,
+* + 3,4,7,+1, 10, ier)
+* s(2) = +del2k*d2d2l
+* s(3) = -del2l*d2d2k
+* somb = s(1) + s(2) + s(3)
+* smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+* if ( abs(somb) .ge. xloss*smax ) goto 90
+* if ( lwrite ) print *,' somb+3= ',somb,s(1),s(2),s(3)
+* if ( smax .lt. xmax ) then
+* save = somb
+* xmax = smax
+* endif
+*
+* call ffdl2t(del2lk,piDpj, lk,4, 3,4,7,+1,+1, 10,ier)
+* call ff2dl2(d2d2lk,dum,xpi,dpipj,piDpj, lk, i,j,ji,isji, 4,
+* + 3,4,7,+1, 10, ier)
+* s(2) = +del2l*d2d2lk
+* s(3) = -del2lk*d2d2l
+* somb = s(1) + islk*(s(2) + s(3))
+* smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+* if ( lwrite ) print *,' somb+4= ',somb,s(1),s(2),s(3),islk
+* if ( abs(somb) .ge. xloss*smax ) goto 90
+* if ( smax .lt. xmax ) then
+* save = somb
+* xmax = smax
+* endif
+*
+* s(2) = +del2k*d2d2lk
+* s(3) = -del2lk*d2d2k
+* somb = s(1) + islk*(s(2) + s(3))
+* smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+* if ( lwrite ) print *,' somb+5= ',somb,s(1),s(2),s(3),isji
+* if ( abs(somb) .ge. xloss*smax ) goto 90
+* if ( smax .lt. xmax ) then
+* save = somb
+* xmax = smax
+* endif
+**
+* Second and third term, split m,n
+**
+* call ff3dl2(d3d2m,xpi,dpipj,piDpj, 3, i,j,ji,isji,
+* + k,l,lk,islk, 4, 3,4,7,+1, 10,ier)
+* call ff3dl2(d3d2n,xpi,dpipj,piDpj, 4, i,j,ji,isji,
+* + k,l,lk,islk, 4, 3,4,7,+1, 10,ier)
+* s(2) = +d3d2m*piDpj(4,4)
+* s(3) = -d3d2n*piDpj(3,4)
+* somb = s(1) + s(2) + s(3)
+* smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+* if ( lwrite ) print *,' somb+6= ',somb,s(1),s(2),s(3)
+* if ( abs(somb) .ge. xloss*smax ) goto 90
+* if ( smax .lt. xmax ) then
+* save = somb
+* xmax = smax
+* endif
+*
+* call ff3dl2(d3d2nm,xpi,dpipj,piDpj, 7, i,j,ji,isji,
+* + k,l,lk,islk, 4, 3,4,7,+1, 10,ier)
+* s(2) = +d3d2n*piDpj(7,4)
+* s(3) = -d3d2nm*piDpj(4,4)
+* somb = s(1) + s(2) + s(3)
+* smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+* if ( lwrite ) print *,' somb+7= ',somb,s(1),s(2),s(3)
+* if ( abs(somb) .ge. xloss*smax ) goto 90
+* if ( smax .lt. xmax ) then
+* save = somb
+* xmax = smax
+* endif
+*
+* s(2) = +d3d2m*piDpj(7,4)
+* s(3) = -d3d2nm*piDpj(3,4)
+* somb = s(1) + s(2) + s(3)
+* smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+* if ( lwrite ) print *,' somb+8= ',somb,s(1),s(2),s(3)
+* if ( abs(somb) .ge. xloss*smax ) goto 90
+* if ( smax .lt. xmax ) then
+* save = somb
+* xmax = smax
+* endif
+*
+ 80 continue
+*
+* give up:
+*
+ somb = save
+ call ffwarn(89,ier,somb,xmax)
+ if ( lwrite ) then
+ print *,'ffabcd: giving up on somb'
+ print *,' i,j,k,l = ',i,j,k,l
+ print *,' xpi = ',xpi
+ endif
+ 90 continue
+ xb = somb/del2s
+* #] normal case b:
+* #[ normal case d:
+ call ff3dl2(s(1),xpi,dpipj,piDpj, 4, i,j,ji,isji, k,l,lk,islk,
+ + 4, 3,4,7,+1, 10, ier)
+ if ( i .eq. k .and. j .eq. l ) then
+ somd = -2*s(1)
+ if ( lwrite ) s(2) = s(1)
+ else
+ call ff3dl2(s(2),xpi,dpipj,piDpj, 4, k,l,lk,islk,
+ + i,j,ji,isji, 4, 3,4,7,+1, 10, ier)
+ somd = - s(1) - s(2)
+ if ( abs(somd) .lt. xloss*abs(s(1)) ) then
+ call ffwarn(90,ier,somd,s(1))
+ endif
+ endif
+* if ( lwrite ) print *,' somd = ',somd,s(1),s(2)
+ xd = -somd/sdel2s
+* #] normal case d:
+* #[ normal case c:
+ 800 continue
+ s(1) = xb - xd
+ s(2) = xb + xd
+ som = s(1)*s(2)
+ if ( min(abs(s(1)),abs(s(2))) .ge. xloss*abs(xb) ) goto 220
+* take into account that we know that we only need x+
+ if ( xb*xd .ge. 0 ) goto 220
+ call ffwarn(91,ier,min(abs(s(1)),abs(s(2))),xb)
+ if ( lwrite ) print *,'b-d,b+d,b,d: ',s(1),s(2),xb,xd
+ 220 continue
+ xc = som/xa
+* #] normal case c:
+* #[ check output:
+ 900 continue
+ if ( ltest ) then
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ s(1) = -piDpj(in,kn)*piDpj(jn,3)*piDpj(ln,3)*piDpj(4,4)
+ + **2
+ s(2) = +piDpj(in,kn)*piDpj(jn,3)*piDpj(ln,4)*piDpj(3,4)
+ + *piDpj(4,4)
+ s(3) = +piDpj(in,kn)*piDpj(jn,4)*piDpj(ln,3)*piDpj(3,4)
+ + *piDpj(4,4)
+ s(4) = -piDpj(in,kn)*piDpj(jn,4)*piDpj(ln,4)*piDpj(3,4)
+ + **2
+ s(5) = +piDpj(in,kn)*piDpj(jn,4)*piDpj(ln,4)*piDpj(3,3)
+ + *piDpj(4,4)
+ s(6) = -piDpj(in,kn)*piDpj(jn,4)*piDpj(ln,4)*piDpj(3,4)
+ + **2
+ s(7) = +piDpj(in,ln)*piDpj(jn,3)*piDpj(kn,3)*piDpj(4,4)
+ + **2
+ s(8) = -piDpj(in,ln)*piDpj(jn,3)*piDpj(kn,4)*piDpj(3,4)
+ + *piDpj(4,4)
+ s(9) = -piDpj(in,ln)*piDpj(jn,4)*piDpj(kn,3)*piDpj(3,4)
+ + *piDpj(4,4)
+ s(10) = +piDpj(in,ln)*piDpj(jn,4)*piDpj(kn,4)*piDpj(3,4)
+ + **2
+ s(11) = -piDpj(in,ln)*piDpj(jn,4)*piDpj(kn,4)*piDpj(3,3)
+ + *piDpj(4,4)
+ s(12) = +piDpj(in,ln)*piDpj(jn,4)*piDpj(kn,4)*piDpj(3,4)
+ + **2
+ s(13) = +piDpj(in,3)*piDpj(jn,kn)*piDpj(ln,3)*piDpj(4,4)
+ + **2
+ s(14) = -piDpj(in,3)*piDpj(jn,kn)*piDpj(ln,4)*piDpj(3,4)
+ + *piDpj(4,4)
+ s(15) = -piDpj(in,3)*piDpj(jn,ln)*piDpj(kn,3)*piDpj(4,4)
+ + **2
+ s(16) = +piDpj(in,3)*piDpj(jn,ln)*piDpj(kn,4)*piDpj(3,4)
+ + *piDpj(4,4)
+ s(17) = -piDpj(in,4)*piDpj(jn,kn)*piDpj(ln,3)*piDpj(3,4)
+ + *piDpj(4,4)
+ s(18) = +piDpj(in,4)*piDpj(jn,kn)*piDpj(ln,4)*piDpj(3,4)
+ + **2
+ s(19) = +piDpj(in,4)*piDpj(jn,ln)*piDpj(kn,3)*piDpj(3,4)
+ + *piDpj(4,4)
+ s(20) = -piDpj(in,4)*piDpj(jn,ln)*piDpj(kn,4)*piDpj(3,4)
+ + **2
+ s(21) = -piDpj(in,4)*piDpj(jn,kn)*piDpj(ln,4)*piDpj(3,3)
+ + *piDpj(4,4)
+ s(22) = +piDpj(in,4)*piDpj(jn,kn)*piDpj(ln,4)*piDpj(3,4)
+ + **2
+ s(23) = +piDpj(in,4)*piDpj(jn,ln)*piDpj(kn,4)*piDpj(3,3)
+ + *piDpj(4,4)
+ s(24) = -piDpj(in,4)*piDpj(jn,ln)*piDpj(kn,4)*piDpj(3,4)
+ + **2
+ xbp = s(1)
+ smaxp = abs(s(1))
+ do 910 ll = 2,24
+ xbp = xbp + s(ll)
+ smaxp = max(smaxp,abs(xbp))
+ 910 continue
+ xbp = xbp/del2s
+ smaxp = abs(smaxp/del2s)
+ if ( rloss*abs(xb-xbp) .gt. precx*smaxp ) then
+ print *,'ffabcd: error: xb does not agree with ',
+ + 'normal case:'
+ print *,' xb: ',xb
+ print *,' xbp: ',xbp,smaxp
+ print *,' diff:',xb-xbp
+ xb = xbp
+ endif
+ s(1) = + piDpj(in,kn)*piDpj(jn,3)*piDpj(ln,4)*piDpj(4,4)
+ s(2) = - piDpj(in,kn)*piDpj(jn,4)*piDpj(ln,4)*piDpj(3,4)
+ s(3) = + piDpj(in,kn)*piDpj(jn,4)*piDpj(ln,3)*piDpj(4,4)
+ s(4) = - piDpj(in,kn)*piDpj(jn,4)*piDpj(ln,4)*piDpj(3,4)
+ s(5) = - piDpj(in,ln)*piDpj(jn,3)*piDpj(kn,4)*piDpj(4,4)
+ s(6) = + piDpj(in,ln)*piDpj(jn,4)*piDpj(kn,4)*piDpj(3,4)
+ s(7) = - piDpj(in,ln)*piDpj(jn,4)*piDpj(kn,3)*piDpj(4,4)
+ s(8) = + piDpj(in,ln)*piDpj(jn,4)*piDpj(kn,4)*piDpj(3,4)
+ s(9) = - piDpj(in,3)*piDpj(jn,kn)*piDpj(ln,4)*piDpj(4,4)
+ s(10) = + piDpj(in,3)*piDpj(jn,ln)*piDpj(kn,4)*piDpj(4,4)
+ s(11) = + piDpj(in,4)*piDpj(jn,kn)*piDpj(ln,4)*piDpj(3,4)
+ s(12) = - piDpj(in,4)*piDpj(jn,ln)*piDpj(kn,4)*piDpj(3,4)
+ s(13) = - piDpj(in,4)*piDpj(jn,kn)*piDpj(ln,3)*piDpj(4,4)
+ s(14) = + piDpj(in,4)*piDpj(jn,kn)*piDpj(ln,4)*piDpj(3,4)
+ s(15) = + piDpj(in,4)*piDpj(jn,ln)*piDpj(kn,3)*piDpj(4,4)
+ s(16) = - piDpj(in,4)*piDpj(jn,ln)*piDpj(kn,4)*piDpj(3,4)
+ xdp = s(1)
+ smaxp = abs(s(1))
+ do 920 ll = 2,16
+ xdp = xdp + s(ll)
+ smaxp = max(smaxp,abs(xdp))
+ 920 continue
+ xdp = -xdp/sdel2s
+ smaxp = abs(smaxp/sdel2s)
+ if ( rloss*abs(xd-xdp) .gt. precx*smaxp ) then
+ print *,'ffabcd: error: xd does not agree with ',
+ + 'normal case:'
+ print *,' xd: ',xd
+ print *,' xdp: ',xdp,smaxp
+ print *,' diff:',xd-xdp
+ xd = xdp
+ endif
+ endif
+* #] check output:
+* #[ and tne final answer:
+ 990 continue
+ call ffroot(dum,aijkl,xa,xb,xc,xd,ier)
+* #] and tne final answer:
+*###] ffabcd:
+ end
+
diff --git a/ff-2.0/ffca0.f b/ff-2.0/ffca0.f
new file mode 100644
index 0000000..20c1da0
--- /dev/null
+++ b/ff-2.0/ffca0.f
@@ -0,0 +1,194 @@
+*###[ ffca0:
+ subroutine ffca0(ca0,d0,xmm,cm,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the one-point function (see 't Hooft and *
+* Veltman) for complex mass *
+* *
+* Input: d0 (real) infinity, result of the *
+* renormalization procedure, the final *
+* answer should not depend on it. *
+* xmm (real) arbitrary mass2, the final answer *
+* should not depend on this either. *
+* cm (complex) mass2, re>0, im<0. *
+* *
+* Output: ca0 (complex) A0, the one-point function, *
+* ier 0 (OK) *
+* *
+* Calls: log. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX ca0,cm
+ DOUBLE PRECISION d0,xmm
+*
+* local variables
+*
+ DOUBLE COMPLEX cmu,clogm,c
+ DOUBLE PRECISION absc,xm
+*
+* common blocks etc
+*
+ include 'ff.h'
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ the real case:
+*
+* adapted to log-and-pole scheme 25-mar-1992
+*
+ if ( DIMAG(cm) .eq. 0 .or. nschem .lt. 7 ) then
+ xm = DBLE(cm)
+ call ffxa0(ca0,d0,xmm,xm,ier)
+ return
+ endif
+* #] the real case:
+* #[ "calculations":
+ if ( xmm .ne. 0 ) then
+ cmu = cm/DBLE(xmm)
+ else
+ cmu = cm
+ endif
+ if ( absc(cmu) .gt. xclogm ) then
+ clogm = log(cmu)
+ else
+ clogm = 0
+ if ( cmu .ne. c0 ) call fferr(1,ier)
+ endif
+ ca0 = - cm * ( clogm - 1 - DBLE(d0) )
+* #] "calculations":
+* #[ debug:
+ if (lwrite) then
+ print *,'d0 = ',d0
+ print *,'xmm = ',xmm
+ print *,'cm = ',cm
+ print *,'ca0 = ',ca0
+ endif
+* #] debug:
+*###] ffca0:
+ end
+*###[ ffxa0:
+ subroutine ffxa0(ca0,d0,xmm,xm,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the one-point function (see 't Hooft and *
+* Veltman) for real mass *
+* *
+* Input: d0 (real) infinity, result of the *
+* renormalization procedure, the final *
+* answer should not depend on it. *
+* xmm (real) arbitrary mass2, the final answer *
+* should not depend on this either. *
+* xm (real) mass2, *
+* *
+* Output: ca0 (complex) A0, the one-point function, *
+* ier 0 (ok) *
+* *
+* Calls: log. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX ca0
+ DOUBLE PRECISION d0,xmm,xm
+*
+* local variables
+*
+ DOUBLE PRECISION xmu,xlogm
+*
+* common blocks etc
+*
+
+ include 'ff.h'
+* #] declarations:
+* #[ "calculations":
+ if ( xmm .ne. 0 ) then
+ xmu = xm/xmm
+ else
+ xmu = xm
+ endif
+ if ( xmu .gt. xalogm ) then
+ xlogm = log(xmu)
+ else
+ xlogm = 0
+ if ( xmu .ne. 0 ) call fferr(2,ier)
+ endif
+ ca0 = -(xm*(xlogm - 1 - d0))
+* #] "calculations":
+* #[ debug:
+ if (lwrite) then
+ print *,'d0 = ',d0
+ print *,'xmm = ',xmm
+ print *,'xm = ',xm
+ print *,'ca0 = ',ca0
+ endif
+* #] debug:
+*###] ffxa0:
+ end
+*###[ ffza0:
+ subroutine ffza0(za0,d0,xmm,cm,xm,ndiv,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the one-point function (see 't Hooft and *
+* Veltman) for complex mass in some on-shell scheme *
+* *
+* Input: d0 (real) infinity, result of the *
+* renormalization procedure, the final *
+* answer should not depend on it. *
+* xmm (real) arbitrary mass2, the final answer *
+* should not depend on this either. *
+* cm (complex) mass2, re>0, im<0. *
+* xm (real) mass2, used instead of cm if onshel=true *
+* ndiv (integer) if >0 return 0 (the number of *
+* divergences the A0 should contain) *
+* *
+* Output: za0 (complex) A0, the one-point function, *
+* ier 0 (OK) *
+* *
+* Calls: log. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ndiv,ier
+ DOUBLE COMPLEX za0,cm
+ DOUBLE PRECISION d0,xmm,xm
+*
+* common blocks etc
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ preliminaries:
+*
+* as the A0 cannot contain any on-shell singularities, return
+* zero when one asks for one.
+*
+ if ( onshel .and. ndiv .gt. 0 ) then
+ za0 = 0
+ return
+ endif
+*
+* #] preliminaries:
+* #[ "work":
+ if ( nschem.lt.7 ) then
+ call ffxa0(za0,d0,xmm,xm,ier)
+ else
+ call ffca0(za0,d0,xmm,cm,ier)
+ endif
+* #] "work":
+*###] ffza0:
+ end
+
diff --git a/ff-2.0/ffcb0.f b/ff-2.0/ffcb0.f
new file mode 100644
index 0000000..094f35b
--- /dev/null
+++ b/ff-2.0/ffcb0.f
@@ -0,0 +1,1022 @@
+* $Id: ffcb0.f,v 1.11 1996/07/18 10:49:04 gj Exp $
+*###[ ffcb0:
+ subroutine ffcb0(cb0,d0,xmu,cp,cma,cmb,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the the two-point function (cf 't Hooft and Veltman) *
+* we include an overall factor 1/(i*pi^2) relative to FormF *
+* *
+* Input: d0 (real) infinity arising from renormalization *
+* xmu (real) renormalization mass *
+* cp (complex) k2, in B&D metric *
+* cma (complex) mass2, re>0, im<0. *
+* cmb (complex) mass2, re>0, im<0. *
+* *
+* Output: cb0 (complex) B0, the two-point function, *
+* ier (integer) number of digits lost in calculation *
+* *
+* Calls: ffcb0p,ffxb0p *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cb0,cp,cma,cmb
+ DOUBLE PRECISION xmu,d0
+*
+* local variables
+*
+ integer ier0,init,initc,ithres,i,j,nschsa
+ logical lreal
+ DOUBLE COMPLEX cmamb,cmap,cmbp,cm,c,cb0p,cqi(3),cqiqj(3,3)
+ DOUBLE PRECISION absc,xp,xma,xmb,sprec,smax
+ save init,initc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data init,initc /2*0/
+*
+* #] declarations:
+* #[ check input:
+*
+ if ( lwrite ) then
+ print *,'ffcb0: input:'
+ print *,'cma,cmb,cp,ier = ',cma,cmb,cp,ier
+ endif
+ if ( ltest ) then
+ if ( DIMAG(cma) .gt. 0 .or. DIMAG(cmb) .gt. 0 ) then
+ print *,'ffcb0: error: Im(masses) > 0: ',cma,cmb
+ stop
+ endif
+ if ( DBLE(cma) .lt. 0 .or. DBLE(cmb) .lt. 0 ) then
+ print *,'ffcb0: error: Re(masses) < 0: ',cma,cmb
+ stop
+ endif
+ if ( DIMAG(cp) .gt. 0 ) then
+ print *,'ffcb0: error: Im(p^2) > 0: ',cp
+ ier = ier + 100
+ endif
+ if ( DIMAG(cp) .ne. 0 .and. DBLE(cp) .le. 0 ) then
+ print *,'ffcb0: error: cannot handle Re(p^2)<0, '//
+ + 'Im(p^2)<0: ',cp
+ ier = ier + 100
+ endif
+ endif
+*
+* #] check input:
+* #[ the real cases:
+*
+ if ( DIMAG(cma) .eq. 0 .and. DIMAG(cmb) .eq. 0 .and.
+ + DIMAG(cp).eq.0 ) then
+ lreal = .TRUE.
+ if ( lwrite ) print *,'ffcb0: real masses'
+ elseif ( nschem.le.4 ) then
+ lreal = .TRUE.
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb0: nschem <= 4, ignoring complex masses: ',
+ + nschem
+ endif
+ elseif ( nschem.le.6 ) then
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb0: nschem = 5,6 complex masses near ',
+ + 'threshold: ',nschem
+ endif
+ cqi(1) = cma
+ cqi(2) = cmb
+ cqi(3) = cp
+ cqiqj(1,2) = cma - cmb
+ cqiqj(2,1) = -cqiqj(1,2)
+ cqiqj(1,3) = cma - cp
+ cqiqj(3,1) = -cqiqj(1,3)
+ cqiqj(2,3) = cmb - cp
+ cqiqj(3,2) = -cqiqj(2,3)
+ cqiqj(1,1) = 0
+ cqiqj(2,2) = 0
+ cqiqj(3,3) = 0
+ call ffthre(ithres,cqi,cqiqj,3,1,2,3)
+ if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
+ lreal = .TRUE.
+ if ( lwrite ) print *,'ffcb0: no threshold'
+ else
+ lreal = .FALSE.
+ if ( lwrite ) print *,'ffcb0: found threshold'
+ endif
+ else
+ lreal = .FALSE.
+ endif
+ if ( lreal ) then
+ xp = DBLE(cp)
+ xma = DBLE(cma)
+ xmb = DBLE(cmb)
+ sprec = precx
+ precx = precc
+ if ( lwrite ) print *,'ffcb0: to real case'
+ call ffxb0(cb0,d0,xmu,xp,xma,xmb,ier)
+ precx = sprec
+ if ( ldot ) then
+ do 120 j=1,3
+ do 110 i=1,3
+ cfpij2(i,j) = fpij2(i,j)
+ 110 continue
+ 120 continue
+ endif
+ return
+ endif
+*
+* #] the real cases:
+* #[ get differences:
+*
+ cmamb = cma - cmb
+ cmap = cma - cp
+ cmbp = cmb - cp
+ if ( lwarn ) then
+ ier0 = 0
+ if ( absc(cmamb) .lt. xloss*absc(cma) .and. cma .ne. cmb )
+ + call ffwarn(94,ier0,absc(cmamb),absc(cmb))
+ if ( absc(cmap) .lt. xloss*absc(cp) .and. cma .ne. cp )
+ + call ffwarn(95,ier0,absc(cmap),absc(cp))
+ if ( absc(cmbp) .lt. xloss*absc(cp) .and. cmb .ne. cp )
+ + call ffwarn(96,ier0,absc(cmbp),absc(cp))
+ endif
+*
+* #] get differences:
+* #[ calculations:
+*
+* no more schem-checking, please...
+*
+ nschsa = nschem
+ nschem = 7
+ call ffcb0p(cb0p,cp,cma,cmb,cmap,cmbp,cmamb,ier)
+ nschem = nschsa
+ if ( cma .eq. 0 ) then
+ if ( cmb .eq. 0 ) then
+ cm = 1
+ else
+ cm = cmb**2
+ endif
+ elseif ( cmb .eq. 0 ) then
+ cm = cma**2
+ else
+ cm = cma*cmb
+ endif
+ if ( xmu .ne. 0 ) cm = cm/DBLE(xmu)**2
+ if ( absc(cm) .gt. xclogm ) then
+ cb0 = DBLE(d0) - cb0p - log(cm)/2
+ smax = max(abs(d0),absc(cb0p),absc(log(cm))/2)
+ if (lwarn .and. absc(cb0).lt.xloss*smax )
+ + call ffwarn(149,ier,absc(cb0),smax)
+ else
+ call fferr(3,ier)
+ cb0 = -cb0p + DBLE(d0)
+ endif
+* #] calculations:
+* #[ check output:
+ if ( ltest ) then
+ if ( DIMAG(cb0).lt.0 .and. abs(cp).gt.1.1*(sqrt(abs(cma)) +
+ + sqrt(abs(cmb)))**2 ) then
+ print *,'ffcb0: warning: sign imaginary part looks '//
+ + 'suspicious: ',cb0
+ print *,' id, nevent = ',id,'/',idsub,nevent
+ print *,' p,m1,m2 = ',cp,cma,cmb
+ endif
+ endif
+* #] check output:
+*###] ffcb0:
+ end
+*###[ ffcb0p:
+ subroutine ffcb0p(cb0p,cp,cma,cmb,cmap,cmbp,cmamb,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the main part of the two-point function (cf 't *
+* Hooft and Veltman) for all possible cases: masses equal, *
+* unequal, equal to zero, real or complex (with a negative *
+* imaginary part). I think it works. *
+* Has been checked against FormF for all parameter space. *
+* Only problems with underflow for extreme cases. VERY OLD CODE. *
+* *
+* Input: cp (complex) k2, in B&D metric *
+* cma (complex) mass2, re>0, im<0. *
+* cmb (complex) mass2, re>0, im<0. *
+* cmap/b (complex) cma/b - cp *
+* cmamb (complex) cma - cmb *
+* *
+* Output: cb0p (complex) B0, the two-point function, *
+* minus log(cm/mu), delta and the *
+* factor -ipi^2. *
+* ier (integer) 0=ok, 1=numerical problems, 2=error *
+* *
+* Calls: (z/a)log, atan. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cb0p,cp,cma,cmb,cmap,cmbp,cmamb
+*
+* local variables
+*
+ integer i,j,initeq,initn1,n1,n2,nffeta,nffet1,ier0,init,
+ + ithres,is1
+ logical lwsave,lreal
+ DOUBLE PRECISION xp,ax,ay,ffbnd,
+ + xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ + xprcn1,bdn101,bdn105,bdn110,bdn115,
+ + xprnn2,bdn201,bdn205,bdn210,bdn215,
+ + xpneq(30),xpnn1(30),
+ + absc,sprec,xma,xmb,dmap,dmbp,dmamb,rloss,smax
+ DOUBLE COMPLEX check,cm,cmp,cm1,cm2,cm1m2,
+ + cm1p,cm2p,cs,cs1,cs2,cx,cy,csom,clam,cslam,clogmm,
+ + zfflo1,c,zm,zp,zm1,zp1,zfflog,cb0r,cqi(3),
+ + cqiqj(3,3),cpiDpj(3,3),ck,clamr,cslamr,zmr,zpr,zm1r,zp1r
+ save initeq,initn1,xpneq,xpnn1,init,
+ + xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ + xprcn1,bdn101,bdn105,bdn110,bdn115,
+ + xprnn2,bdn201,bdn205,bdn210,bdn215
+*FOR ABSOFT ONLY
+* DOUBLE COMPLEX csqrt
+* external csqrt
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data xprceq /-1./
+ data xprcn1 /-1./
+ data xprnn2 /-1./
+ data initeq /0/
+ data initn1 /0/
+ data init /0/
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ check input:
+*
+ if (ltest) then
+ check = cma - cmb - cmamb
+ if ( absc(check) .gt. precc*max(absc(cma),absc(cmb),absc(
+ + cmamb))/xloss ) then
+ print *,'ffcb0p: input not OK, cmamb /= cma - cmb',check
+ endif
+ check = cp - cma + cmap
+ if ( absc(check) .gt. precc*max(absc(cp),absc(cma),absc(
+ + cmap))/xloss ) then
+ print *,'ffcb0p: input not OK, cmap /= cma - cp',check
+ endif
+ check = cp - cmb + cmbp
+ if ( absc(check) .gt. precc*max(absc(cp),absc(cmb),absc(
+ + cmbp))/xloss ) then
+ print *,'ffcb0p: input not OK, cmbp /= cmb - cp',check
+ endif
+ endif
+*
+* #] check input:
+* #[ fill some dotproducts:
+*
+ call ffcot2(cpiDpj,cp,cma,cmb,cmap,cmbp,cmamb,ier)
+ if ( ldot ) then
+ do 20 i=1,3
+ do 10 j=1,3
+ cfpij2(j,i) = cpiDpj(j,i)
+ fpij2(j,i) = DBLE(cpiDpj(j,i))
+ 10 continue
+ 20 continue
+ endif
+*
+* #] fill some dotproducts:
+* #[ the real cases:
+*
+ if ( DIMAG(cma) .eq. 0 .and. DIMAG(cmb) .eq. 0 .and.
+ + DIMAG(cp).eq.0 ) then
+ lreal = .TRUE.
+ if ( lwrite ) print *,'ffcb0p: real masses'
+ elseif ( nschem.le.4 ) then
+ lreal = .TRUE.
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb0p: nschem <= 4, ignoring complex masses:',
+ + nschem
+ endif
+ elseif ( nschem.le.6 ) then
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb0p: nschem = 4,6 complex masses near ',
+ + 'threshold: ',nschem
+ endif
+ cqi(1) = cma
+ cqi(2) = cmb
+ cqi(3) = cp
+ cqiqj(1,2) = cmamb
+ cqiqj(2,1) = -cqiqj(1,2)
+ cqiqj(1,3) = cmap
+ cqiqj(3,1) = -cqiqj(1,3)
+ cqiqj(2,3) = cmbp
+ cqiqj(3,2) = -cqiqj(2,3)
+ cqiqj(1,1) = 0
+ cqiqj(2,2) = 0
+ cqiqj(3,3) = 0
+ call ffthre(ithres,cqi,cqiqj,3,1,2,3)
+ if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
+ lreal = .TRUE.
+ if ( lwrite ) print *,'ffcb0p: no threshold'
+ else
+ if ( lwrite ) print *,'ffcb0p: found threshold'
+ lreal = .FALSE.
+ endif
+ else
+ lreal = .FALSE.
+ endif
+ if ( lreal ) then
+ xp = DBLE(cp)
+ xma = DBLE(cma)
+ xmb = DBLE(cmb)
+ dmap = DBLE(cmap)
+ dmbp = DBLE(cmbp)
+ dmamb = DBLE(cmamb)
+ sprec = precx
+ precx = precc
+ if ( lwrite ) print *,'ffcb0: to real case'
+ call ffxb0p(cb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
+ precx = sprec
+ if ( ldot ) then
+ do 120 j=1,3
+ do 110 i=1,3
+ cfpij2(i,j) = fpij2(i,j)
+ 110 continue
+ 120 continue
+ endif
+ return
+ endif
+*
+* #] the real cases:
+* #[ which case:
+*
+* sort according to the type of mass combination encountered:
+* 200: one equal to zero, 300: both equal, 400: rest.
+*
+ if ( cma .eq. 0 ) then
+ if ( cmb .eq. 0 ) then
+ goto 100
+ endif
+ cm = cmb
+ cmp = cmbp
+ goto 200
+ endif
+ if ( cmb .eq. 0 ) then
+ cm = cma
+ cmp = cmap
+ goto 200
+ endif
+ if ( cma .eq. cmb ) then
+ cm = cma
+ cmp = cmap
+ goto 300
+ endif
+ if ( DBLE(cma) .lt. DBLE(cmb) ) then
+ cm2 = cma
+ cm1 = cmb
+ cm1m2 = -cmamb
+ cm1p = cmbp
+ cm2p = cmap
+ is1 = 2
+ else
+ cm1 = cma
+ cm2 = cmb
+ cm1m2 = cmamb
+ cm1p = cmap
+ cm2p = cmbp
+ is1 = 1
+ endif
+ goto 400
+* #] which case:
+* #[ both masses equal to zero:
+ 100 continue
+ if ( absc(cp) .gt. xclogm ) then
+ if ( DBLE(cp).gt.0 ) then
+ cb0p = log(cp) - c2ipi/2 - 2
+ else
+ cb0p = log(-cp) - 2
+ endif
+ else
+ cb0p = 0
+ call fferr(7,ier)
+ endif
+ return
+* #] both masses equal to zero:
+* #[ one mass zero:
+ 200 continue
+*
+* special case cp = 0, checked 25-oct-1991
+*
+ if ( cp .eq. 0 ) then
+ cb0p = -1
+ goto 990
+ endif
+*
+* Normal case:
+*
+ cs1 = cp/cm
+ cs2 = cmp/cm
+* make sure we get the right Riemann sheet!
+ if ( absc(cs1) .lt. xloss ) then
+ cs = zfflo1(cs1,ier)
+ elseif ( DBLE(cs2).gt.0 ) then
+ cs = zfflog(cs2,0,c0,ier)
+ else
+ cs = zfflog(-cs2,0,c0,ier)
+ cs = cs - c2ipi/2
+ endif
+ cs = -cs*cmp/cp
+ cb0p = cs - 2
+ if ( lwarn .and. absc(cb0p) .lt. xloss*2 ) call
+ + ffwarn(1,ier,absc(cb0p),x2)
+ goto 990
+* #] one mass zero:
+* #[ both masses equal:
+ 300 continue
+*
+* Both masses are equal. Not only this speeds up things, some
+* cancellations have to be avoided as well. Checked 25-oct-1991.
+* -#[ taylor expansion:
+*
+* first this special case
+*
+ if ( absc(cp) .lt. 8*xloss*absc(cm) ) then
+*
+* a Taylor expansion seems appropriate as the result will go
+* as k^2 but seems to go as 1/k !!
+*
+ if ( lwrite ) print*,'ffcb0: equal masses, Taylor expansion'
+* #[ data and bounds:
+ if ( initeq .eq. 0 ) then
+ initeq = 1
+ xpneq(1) = x1/6
+ do 1 i=2,30
+ xpneq(i) = xpneq(i-1)*DBLE(i-1)/DBLE(2*(2*i+1))
+ 1 continue
+ endif
+ if (xprceq .ne. precc ) then
+*
+* calculate the boundaries for the number of terms to be
+* included in the taylorexpansion
+*
+ xprceq = precc
+ sprec = precx
+ precx = precc
+ bdeq01 = ffbnd(1,1,xpneq)
+ bdeq05 = ffbnd(1,5,xpneq)
+ bdeq11 = ffbnd(1,11,xpneq)
+ bdeq17 = ffbnd(1,17,xpneq)
+ bdeq25 = ffbnd(1,25,xpneq)
+ precx = sprec
+ endif
+* #] data and bounds:
+ cx = cp/cm
+ ax = absc(cx)
+ if ( lwarn .and. ax .gt. bdeq25 ) then
+ call ffwarn(2,ier,precc,xpneq(25)*ax**25)
+ endif
+ if ( ax .gt. bdeq17 ) then
+ csom = cx*(DBLE(xpneq(18)) + cx*(DBLE(xpneq(19)) +
+ + cx*(DBLE(xpneq(20)) + cx*(DBLE(xpneq(21)) +
+ + cx*(DBLE(xpneq(22)) + cx*(DBLE(xpneq(23)) +
+ + cx*(DBLE(xpneq(24)) + cx*(DBLE(xpneq(25)) ))))))))
+ else
+ csom = 0
+ endif
+ if ( ax .gt. bdeq11 ) then
+ csom = cx*(DBLE(xpneq(12)) + cx*(DBLE(xpneq(13)) +
+ + cx*(DBLE(xpneq(14)) + cx*(DBLE(xpneq(15)) +
+ + cx*(DBLE(xpneq(16)) + cx*(DBLE(xpneq(17)) + csom ))))
+ + ))
+ endif
+ if ( ax .gt. bdeq05 ) then
+ csom = cx*(DBLE(xpneq(6)) + cx*(DBLE(xpneq(7)) +
+ + cx*(DBLE(xpneq(8)) + cx*(DBLE(xpneq(9)) +
+ + cx*(DBLE(xpneq(10)) + cx*(DBLE(xpneq(11)) + csom ))))))
+ endif
+ if ( ax .gt. bdeq01 ) then
+ csom = cx*(DBLE(xpneq(2)) + cx*(DBLE(xpneq(3)) +
+ + cx*(DBLE(xpneq(4)) + cx*(DBLE(xpneq(5)) + csom ))))
+ endif
+ cb0p = -cx*(DBLE(xpneq(1))+csom)
+ if (lwrite) then
+ print *,'ffcx0p: m1 = m2, Taylor expansion in ',cx
+ endif
+ goto 990
+ endif
+* -#] taylor expansion:
+* -#[ normal case:
+*
+* normal case. first determine if the arguments of the logarithm
+* has positive real part: (we assume Re(cm) > Im(cm) )
+*
+ if ( lwrite ) print*,'ffcb0: equal masses, normal case'
+ call ffclmb(clam,-cp,-cm,-cm,cmp,cmp,c0,ier)
+ cslam = sqrt(clam)
+ call ffcoot(zm,zp,c1,c05,cm/cp,cslam/(2*cp),ier)
+ if ( lwrite ) print *,' zm,zp = ',zm,zp
+ cs1 = zp/zm
+ if ( absc(cs1-1) .lt. xloss ) then
+* In this case a quicker and more accurate way is to
+* calculate log(1-cx).
+ if ( lwrite ) print *,' arg log1 = ',1-cs1
+ cs2 = cp - cslam
+ if ( lwrite ) print *,' arg log1+= ',-2*cslam/cs2
+ if ( absc(cs2) .lt. xloss*absc(cp) ) then
+ cs2 = -cslam*(cp+cslam)/(4*cp*cm)
+ if ( lwrite ) print *,' arg log1*= ',cs2
+ else
+ cs2 = -2*cslam/cs2
+ endif
+ cs = zfflo1(cs2/(2*cm),ier)
+ else
+* finally the normal case
+ cs = zfflog(cs1,0,c0,ier)
+ endif
+ cs = cslam*cs/cp
+ if (lwrite) print *,'cs = ',cs
+ cb0p = cs - 2
+*
+* eta terms
+*
+ n1 = nffet1(zp,1/zm,cs1,ier)
+ if ( ltest .and. n1.ne.0 ) print *,'ffcb0: surprise! n1= ',n1
+ if ( DIMAG(cp).eq.0 ) then
+ n2 = nffet1(-zp,-1/zm,cs1,ier)
+ else
+* use the onshell expression to get the correct continuation
+ ck = DBLE(cp)
+ call ffclmb(clamr,-ck,-cm,-cm,cm-ck,cm-ck,c0,ier)
+ cslamr = sqrt(clamr)
+ call ffcoot(zmr,zpr,c1,c05,cm/ck,cslamr/(2*ck),ier)
+ if ( absc(zm-zmr)+absc(zp-zpr).gt.absc(zm-zpr)+absc(zp-zmr)
+ + ) then
+ cs1 = zmr
+ zmr = zpr
+ zpr = cs1
+ endif
+ if ( lwrite ) print *,' zmr,zpr = ',zmr,zpr
+ if ( DIMAG(zmr).eq.0 .or. DIMAG(zpr).eq.0 ) then
+ if ( DBLE(zpr).gt.DBLE(zmr) ) then
+ n2 = +1
+ else
+ n2 = -1
+ endif
+ else
+ n2 = nffeta(-zpr,-1/zmr,ier)
+ endif
+ endif
+ if ( ltest .and. DBLE(cp).gt.0 .and. n2.eq.0 ) print *,
+ + 'ffcb0: surprise! n2= ',n2
+ if ( lwrite .and. (n1.ne.0 .or. n2.ne.0) ) then
+ print *,'ffcb0: eta terms: n1,n2 = ',n1,n2
+ endif
+ if ( n1+n2 .ne. 0 )
+ + cb0p = cb0p - cslam*c2ipi*(n1+n2)/(2*cp)
+ if (lwrite) print *,'cs = ',cb0p+2
+* also superfluous - just to make sure
+ if ( lwarn .and. absc(cb0p) .lt. xloss*max(x2,absc(cs)) )
+ + call ffwarn(4,ier,absc(cb0p),x2)
+ goto 990
+* -#] normal case:
+*
+* #] both masses equal:
+* #[ unequal nonzero masses:
+ 400 continue
+* -#[ get log(xm2/xm1):
+ cx = cm2/cm1
+ c = cx-1
+ if ( 1/absc(cx) .lt. xclogm ) then
+ call fferr(6,ier)
+ clogmm = 0
+ elseif ( absc(c) .lt. xloss ) then
+ clogmm = zfflo1(cm1m2/cm1,ier)
+ else
+ clogmm = log(cx)
+ endif
+* -#] get log(xm2/xm1):
+* -#[ cp = 0:
+*
+* first a special case
+*
+ if ( cp .eq. 0 ) then
+ cs2 = ((cm2+cm1) / cm1m2)*clogmm
+* save the factor 1/2 for the end
+ cs = - cs2 - 2
+ if (lwrite) print *,'cs = ',cs/2
+ if ( absc(cs) .lt. xloss*2 ) then
+* Taylor expansions: choose which one
+ cx = cm1m2/cm1
+ ax = absc(cx)
+ if ( ax .lt. .15 .or. precc .gt. 1.E-8 .and. ax
+ + .lt. .3 ) then
+* #[ taylor 1:
+*
+* This is the simple Taylor expansion 'n1'
+*
+*--#[ data and bounds:
+* get the coefficients of the taylor expansion
+ if ( initn1 .eq. 0 ) then
+ initn1 = 1
+ do 410 i = 1,30
+ 410 xpnn1(i)=DBLE(i)/DBLE((i+1)*(i+2))
+ endif
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn1 .ne. precc ) then
+ xprcn1 = precc
+ sprec = precx
+ precx = precc
+ bdn101 = ffbnd(1,1,xpnn1)
+ bdn105 = ffbnd(1,5,xpnn1)
+ bdn110 = ffbnd(1,10,xpnn1)
+ bdn115 = ffbnd(1,15,xpnn1)
+ precx = sprec
+ endif
+*--#] data and bounds:
+* calculate:
+ if ( lwarn .and. ax .gt. bdn115 )
+ + call ffwarn(5,ier,precc,abs(xpnn1(15))*ax**15)
+ if ( ax .gt. bdn110 ) then
+ cs = cx*(DBLE(xpnn1(11)) + cx*(DBLE(xpnn1(12))
+ + + cx*(DBLE(xpnn1(13)) + cx*(DBLE(xpnn1(14))
+ + + cx*(DBLE(xpnn1(15))) ))))
+ else
+ cs = 0
+ endif
+ if ( ax .gt. bdn105 ) then
+ cs = cx*(DBLE(xpnn1(6)) + cx*(DBLE(xpnn1(7)) +
+ + cx*(DBLE(xpnn1(8)) + cx*(DBLE(xpnn1(9)) +
+ + cx*(DBLE(xpnn1(10)) + cs)))))
+ endif
+ if ( ax .gt. bdn101 ) then
+ cs = cx*(DBLE(xpnn1(2)) + cx*(DBLE(xpnn1(3)) +
+ + cx*(DBLE(xpnn1(4)) + cx*(DBLE(xpnn1(5)) +
+ + cs))))
+ endif
+ cs = cx*cx*(DBLE(xpnn1(1)) + cs)
+ if (lwrite) then
+ print *,'ffcx0p: cp = 0, simple Taylor exp'
+ print *,' in ',cx
+ print *,' gives cs ',cs/2
+ endif
+* #] taylor 1:
+ else
+* #[ taylor 2:
+*
+* This is the more complicated exponential Taylor
+* expansion 'n2'
+*
+* #[ bounds:
+* determine the boundaries for 1,5,10,15 terms for this
+* Taylor expansion (starting at i=4)
+*
+ if ( xprnn2 .ne. precc ) then
+ xprnn2 = precc
+ sprec = precx
+ precx = precc
+ bdn201 = ffbnd(4,1,xinfac)
+ bdn205 = ffbnd(4,5,xinfac)
+ bdn210 = ffbnd(4,10,xinfac)
+ bdn215 = ffbnd(4,15,xinfac)
+ precx = sprec
+ endif
+* #] bounds:
+* calculate:
+ cy = 2*cx/(2-cx)
+ ay = absc(cy)
+ if ( lwarn .and. ay .gt. bdn215 )
+ + call ffwarn(6,ier,precc,xinfac(18)*ax**15)
+ if ( ay .gt. bdn210 ) then
+ cs = cy*(DBLE(xinfac(14)) + cy*(DBLE(xinfac(15))
+ + + cy*(DBLE(xinfac(16)) + cy*(DBLE(xinfac(17))
+ + + cy*(DBLE(xinfac(18)))))))
+ else
+ cs = 0
+ endif
+ if ( ay .gt. bdn205 ) then
+ cs = cy*(DBLE(xinfac(9)) + cy*(DBLE(xinfac(10))
+ + + cy*(DBLE(xinfac(11)) + cy*(DBLE(xinfac(12))
+ + + cy*(DBLE(xinfac(13)) + cs)))))
+ endif
+ if ( ay .gt. bdn201 ) then
+ cs = cy*(DBLE(xinfac(5)) + cy*(DBLE(xinfac(6))
+ + + cy*(DBLE(xinfac(7)) + cy*(DBLE(xinfac(8))
+ + + cs))))
+ endif
+ cs = (1-cx)*cy**4 * (DBLE(xinfac(4)) + cs)
+ cs = cx*cy**2*(1+cy)/12 - cs
+ cs = - 2*zfflo1(cs,ier)/cy
+ if (lwrite) then
+ print *,'ffcx0p: cp = 0, other Taylor expansion'
+ print *,' in ',cy
+ print *,' cs = ',cs/2
+ endif
+* #] taylor 2:
+ endif
+ endif
+ cb0p = cs/2
+ goto 990
+ endif
+* -#] cp = 0:
+* -#[ normal case:
+*
+* (programmed anew 28-oct-1991)
+*
+ if ( lwrite ) print *,'ffcb0: general case, cp,cm1,cm2 = ',cp,
+ + cm1,cm2
+ call ffclmb(clam,cm1,cm2,cp,cm1m2,cm1p,cm2p,ier)
+ cslam = sqrt(clam)
+ if ( is1.eq.1 ) then
+ cs = +cpiDpj(2,3)
+ else
+ cs = -cpiDpj(1,3)
+ endif
+ call ffcoot(zm,zp,cp,cs,cm2,cslam/2,ier)
+ zm1 = 1-zm
+ zp1 = 1-zp
+ if ( absc(zm1) .lt. xloss .or. absc(zp1) .lt. xloss ) then
+ if ( lwrite ) print *,'zm1,zp1 was ',zm1,zp1
+ if ( is1.eq.1 ) then
+ cs = -cpiDpj(1,3)
+ else
+ cs = +cpiDpj(2,3)
+ endif
+ call ffcoot(zp1,zm1,cp,cs,cm1,cslam/2,ier)
+ if ( lwrite ) print *,'zm1,zp1 is ',zm1,zp1
+ if ( abs(DIMAG(zm)) .lt. abs(DIMAG(zm1)) ) then
+ zm = DCMPLX(DBLE(zm),-DIMAG(zm1))
+ else
+ zm1 = DCMPLX(DBLE(zm1),-DIMAG(zm))
+ endif
+ if ( abs(DIMAG(zp)) .lt. abs(DIMAG(zp1)) ) then
+ zp = DCMPLX(DBLE(zp),-DIMAG(zp1))
+ else
+ zp1 = DCMPLX(DBLE(zp1),-DIMAG(zp))
+ endif
+ endif
+ if ( lwrite ) then
+ print *,'ffcb0: zm = ',zm,zm1
+ print *,'ffcb0: zp = ',zp,zp1
+ endif
+ if ( DIMAG(cp).ne.0 ) then
+* compute roots for Im(cp).eq.0 for continuation terms.
+ ck = DBLE(cp)
+ call ffclmb(clamr,cm1,cm2,ck,cm1m2,cm1-ck,cm2-ck,ier)
+ cslamr = sqrt(clamr)
+ if ( absc(cslamr-cslam).gt.absc(cslamr+cslam) )
+ + cslamr = -cslamr
+ cs = (cm2-cm1+ck)/2
+ call ffcoot(zmr,zpr,ck,cs,cm2,cslamr/2,ier)
+ zm1r = 1-zmr
+ zp1r = 1-zpr
+ if ( absc(zm1r) .lt. xloss .or. absc(zp1r) .lt. xloss ) then
+ if ( lwrite ) print *,'zm1r,zp1r was ',zm1r,zp1r
+ cs = -(cm2-cm1-ck)/2
+ call ffcoot(zp1r,zm1r,ck,cs,cm1,cslamr/2,ier)
+ if ( lwrite ) print *,'zm1r,zp1r is ',zm1r,zp1r
+ if ( abs(DIMAG(zmr)) .lt. abs(DIMAG(zm1r)) ) then
+ zmr = DCMPLX(DBLE(zmr),-DIMAG(zm1r))
+ else
+ zm1r = DCMPLX(DBLE(zm1r),-DIMAG(zmr))
+ endif
+ if ( abs(DIMAG(zpr)) .lt. abs(DIMAG(zp1r)) ) then
+ zpr = DCMPLX(DBLE(zpr),-DIMAG(zp1r))
+ else
+ zp1r = DCMPLX(DBLE(zp1r),-DIMAG(zpr))
+ endif
+ endif
+ if ( lwrite ) then
+ print *,'ffcb0: zmr = ',zmr,zm1r
+ print *,'ffcb0: zpr = ',zpr,zp1r
+ endif
+ else
+ zmr = zm
+ zm1r = zm1
+ zpr = zp
+ zp1r = zp1
+ endif
+ call ffc1lg(cs1,zm,zm1,zmr,zm1r,-1,ier)
+ call ffc1lg(cs2,zp,zp1,zpr,zp1r,+1,ier)
+ cb0p = -clogmm/2 + cs1 + cs2
+ smax = max(absc(clogmm)/2,absc(cs1),absc(cs2))
+ if ( absc(cb0p) .lt. xloss*smax ) then
+ call ffwarn(7,ier,absc(cb0p),smax)
+ endif
+ if ( lwrite ) then
+ print *,'log(m1/m2) term ',-clogmm/2
+ print *,'-1-zm*log(1-1/zm) ',cs1
+ print *,'-1-zp*log(1-1/zp) ',cs2
+ print *,'cb0p ',cb0p
+ endif
+ goto 990
+* -#] normal case:
+* #] unequal nonzero masses:
+* #[ debug:
+ 990 continue
+ if (lwrite) then
+ print *,'cb0p = ',cb0p
+ endif
+* #] debug:
+* #[ check output:
+ if ( .FALSE. .and. ltest ) then
+ ier0 = 0
+ xp = DBLE(cp)
+ xma = DBLE(cma)
+ xmb = DBLE(cmb)
+ dmap = DBLE(cmap)
+ dmbp = DBLE(cmbp)
+ dmamb = DBLE(cmamb)
+ sprec = precx
+ precx = precc
+ lwsave = lwrite
+ lwrite = .FALSE.
+ call ffxb0p(cb0r,xp,xma,xmb,dmap,dmbp,dmamb,ier0)
+ lwrite = lwsave
+ precx = sprec
+ rloss = xloss**2*DBLE(10)**(-mod(ier0,50))
+ smax = 0
+ if ( xma .ne. 0 ) smax = smax + absc(cma)/xma-1
+ if ( xmb .ne. 0 ) smax = smax + absc(cmb)/xmb-1
+ if ( absc(cb0p/cb0r-1) .gt. 2*smax .and. absc(cb0p/cb0r-1)
+ + .gt. 2*precc/rloss ) then
+ print *,'ffcb0p: warning: complex result differs very ',
+ + 'much from real one :',cb0p,cb0r
+ print *,' (input = ',xp,cma,cmb,')'
+ endif
+ endif
+* #] check output:
+*###] ffcb0p:
+ end
+*###[ ffc1lg:
+ subroutine ffc1lg(cs,z,z1,zr,z1r,is,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the potentially unstable combination -1-z*log(1-1/z) *
+* =\sum_{n=1} 1/(n+1) z^{-n}. *
+* *
+* Input z,z1 complex root, z1=1-z *
+* zr,z1r complex root for Im(p^2)=0, z1r=1-zr *
+* is integer -1: roots are z-, +1: z+ *
+* *
+* Output cs complex see above *
+* ier integer usual error flag *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer is,ier
+ DOUBLE COMPLEX cs,z,z1,zr,z1r
+*
+* local variables
+*
+ DOUBLE PRECISION absc
+ DOUBLE COMPLEX c,zfflog
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ work:
+ if ( 1 .lt. xclogm*absc(z) ) then
+ cs = 0
+ elseif ( 1 .lt. precc*absc(z) ) then
+ cs = 1/(2*z)
+ elseif ( 1 .gt. 2*xloss*absc(z) ) then
+*
+* normal case
+*
+ if ( lwrite ) print *,'ffc1lg: normal case',z,z1
+ cs = -1 - z*zfflog(-z1/z,0,c0,ier)
+*
+* check analytical continuation for Im(p^2) -> 0
+*
+ if ( z.ne.zr .or. z1.ne.z1r ) then
+ c = -z1r/zr
+ if ( DBLE(c).lt.0 ) then
+* check whetehr we chose the correct continuation
+ if ( (DIMAG(c).gt.0 .or. DIMAG(c).eq.0 .and.
+ + is.eq.+1) .and. DIMAG(-z1/z).lt.0 ) then
+ cs = cs - c2ipi*z
+ if ( lwrite ) print*,'ffc1lg: added 2ipi to log'
+ elseif ( (DIMAG(c).lt.0 .or. DIMAG(c).eq.0 .and.
+ + is.eq.-1) .and. DIMAG(-z1/z).gt.0 ) then
+ cs = cs + c2ipi*z
+ if ( lwrite ) print*,'ffc1lg: subtracted 2ipi'//
+ + ' from log'
+ endif
+ endif
+ endif
+ if ( absc(cs) .lt. xloss ) call ffwarn(8,ier,absc(cs),x1)
+ else
+*
+* Taylor expansion
+*
+ if ( lwrite ) print *,'ffc1lg: Taylor',z,z1
+ call ffcayl(cs,1/z,xninv(2),29,ier)
+ endif
+* #] work:
+*###] ffc1lg:
+ end
+*###[ ffcot2:
+ subroutine ffcot2(cpiDpj,cp,cma,cmb,cmap,cmbp,cmamb,ier)
+***#[*comment:***********************************************************
+* *
+* Store the 3 dotproducts in the common block ffdot. *
+* *
+* Input: see ffxc0p *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cpiDpj(3,3),cp,cma,cmb,cmap,cmbp,cmamb
+*
+* local variables
+*
+ integer ier0,ier1
+ DOUBLE PRECISION absc,xmax
+ DOUBLE COMPLEX c
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ work:
+ ier1 = ier
+ cpiDpj(1,1) = cma
+ cpiDpj(2,2) = cmb
+ cpiDpj(3,3) = cp
+ if ( absc(cmap) .lt. absc(cmbp) ) then
+ cpiDpj(1,2) = (cmap + cmb)/2
+ else
+ cpiDpj(1,2) = (cmbp + cma)/2
+ endif
+ cpiDpj(2,1) = cpiDpj(1,2)
+ xmax = min(absc(cma),absc(cmb))/2
+ if ( lwarn .and. absc(cpiDpj(1,2)) .lt. xloss*xmax ) then
+ call ffwarn(10,ier1,absc(cpiDpj(1,2)),xmax)
+ endif
+ if ( absc(cmamb) .lt. absc(cmbp) ) then
+ cpiDpj(1,3) = (-cmamb - cp)/2
+ else
+ cpiDpj(1,3) = (cmbp - cma)/2
+ endif
+ cpiDpj(3,1) = cpiDpj(1,3)
+ xmax = min(absc(cma),absc(cp))/2
+ if ( lwarn .and. abs(cpiDpj(1,3)) .lt. xloss*xmax ) then
+ ier0 = ier
+ call ffwarn(11,ier0,absc(cpiDpj(1,3)),xmax)
+ ier1 = max(ier0,ier1)
+ endif
+ if ( absc(cmamb) .lt. absc(cmap) ) then
+ cpiDpj(2,3) = (-cmamb + cp)/2
+ else
+ cpiDpj(2,3) = (-cmap + cmb)/2
+ endif
+ cpiDpj(3,2) = cpiDpj(2,3)
+ xmax = min(absc(cmb),absc(cp))/2
+ if ( lwarn .and. absc(cpiDpj(2,3)) .lt. xloss*xmax ) then
+ ier0 = ier
+ call ffwarn(11,ier,absc(cpiDpj(2,3)),xmax)
+ ier1 = max(ier0,ier1)
+ endif
+ ier = ier1
+* #] work:
+*###] ffcot2:
+ end
diff --git a/ff-2.0/ffcb1.f b/ff-2.0/ffcb1.f
new file mode 100644
index 0000000..2366d8c
--- /dev/null
+++ b/ff-2.0/ffcb1.f
@@ -0,0 +1,447 @@
+*###[ ffcb1:
+ subroutine ffcb1(cb1,cb0,ca0i,xp,xm1,xm2,piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate 1 / d^n Q Q(mu) *
+* ------ | ------------------------ = B1*p(mu) *
+* i pi^2 / (Q^2-m1^2)((Q+p)^2-m2^2) *
+* *
+* Input: cb0 complex scalar twopoint function *
+* ca0i(2) complex scalar onepoint function with *
+* m1,m2 *
+* xp complex p.p in B&D metric *
+* xm1,2 complex m_1^2,m_2^2 *
+* piDpj(3,3) complex dotproducts between s1,s2,p *
+* ier integer digits lost so far *
+* Output: cb1 complex B1 *
+* ier integer digits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX xp,xm1,xm2,piDpj(3,3)
+ DOUBLE COMPLEX cb1,cb0,ca0i(2)
+*
+* local variables
+*
+ integer ier0,i,j
+ DOUBLE COMPLEX dm1p,dm2p,dm1m2,cc
+ DOUBLE PRECISION rm1,rm2,rp,rpiDpj(3,3),sprec,absc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ real case:
+ if ( DIMAG(xm1).eq.0 .and. DIMAG(xm2).eq.0 ) then
+ rm1 = DBLE(xm1)
+ rm2 = DBLE(xm2)
+ rp = DBLE(xp)
+ do 20 j=1,3
+ do 10 i=1,3
+ rpiDpj(i,j) = DBLE(piDpj(i,j))
+ 10 continue
+ 20 continue
+ sprec = precx
+ precx = precc
+ call ffxb1(cb1,cb0,ca0i,rp,rm1,rm2,rpiDpj,ier)
+ precx = sprec
+ return
+ endif
+* #] real case:
+* #[ get differences:
+ ier0 = 0
+ dm1m2 = xm1 - xm2
+ dm1p = xm1 - xp
+ dm2p = xm2 - xp
+ if ( lwarn ) then
+ if ( abs(dm1m2) .lt. xloss*abs(xm1) .and. xm1 .ne. xm2 )
+ + call ffwarn(97,ier0,absc(dm1m2),absc(xm1))
+ if ( abs(dm1p) .lt. xloss*abs(xp) .and. xp .ne. xm1 )
+ + call ffwarn(98,ier0,absc(dm1p),absc(xp))
+ if ( abs(dm2p) .lt. xloss*abs(xp) .and. xp .ne. xm2 )
+ + call ffwarn(99,ier0,absc(dm2p),absc(xp))
+ endif
+* #] get differences:
+* #[ call ffcb1a:
+ call ffcb1a(cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj,ier)
+* #] call ffcb1a:
+*###] ffcb1:
+ end
+*###[ ffcb1a:
+ subroutine ffcb1a(cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj,
+ + ier)
+***#[*comment:***********************************************************
+* *
+* Calculate 1 / d^n Q Q(mu) *
+* ------ | ------------------------ = B1*p(mu) *
+* i pi^2 / (Q^2-m1^2)((Q+p)^2-m2^2) *
+* *
+* Input: cb0 complex scalar twopoint function *
+* ca0i(2) complex scalar onepoint function with *
+* m1,m2 *
+* xp complex p.p in B&D metric *
+* xm1,2 complex m_1^2,m_2^2 *
+* piDpj(3,3) complex dotproducts between s1,s2,p *
+* ier integer digits lost so far *
+* Output: cb1 complex B1 *
+* ier integer digits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj(3,3)
+ DOUBLE COMPLEX cb1,cb0,ca0i(2)
+*
+* local variables
+*
+ integer i,j,ithres,init
+ logical lneg,lreal
+ DOUBLE PRECISION xmax,absc,bnd101,bnd105,bnd110,bnd115,ax,cprec,
+ + xprec,xmxp,rloss
+ DOUBLE COMPLEX s,s1,h,slam,xma,xmb,x,small,dmbma,clam,clogm,
+ + ts2Dp,xlo3,xlogm,cqiqj(3,3),cqi(3),xnul
+ DOUBLE COMPLEX cs(5),cc,csom
+ DOUBLE PRECISION ffbnd
+ DOUBLE COMPLEX zfflo1,zfflo3
+ DOUBLE PRECISION rm1,rm2,rp,rm1m2,rm1p,rm2p,rpiDpj(3,3),sprec
+ save cprec,bnd101,bnd105,bnd110,bnd115,init
+*FOR ABSOFT ONLY
+* DOUBLE COMPLEX csqrt
+* external csqrt
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* data
+*
+ data cprec /0./
+*
+* #] declarations:
+* #[ the real cases:
+*
+ if ( DIMAG(xm1) .eq. 0 .and. DIMAG(xm2) .eq. 0 ) then
+ lreal = .TRUE.
+ if ( lwrite ) print *,'ffcb1a: real masses'
+ elseif ( nschem.le.4 ) then
+ lreal = .TRUE.
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb1a: nschem <= 4, ignoring complex masses:',
+ + nschem
+ endif
+ elseif ( nschem.le.6 ) then
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb1a: nschem = 5,6 complex masses near ',
+ + 'threshold: ',nschem
+ endif
+ cqi(1) = xm1
+ cqi(2) = xm2
+ cqi(3) = xp
+ cqiqj(1,2) = dm1m2
+ cqiqj(2,1) = -cqiqj(1,2)
+ cqiqj(1,3) = dm1p
+ cqiqj(3,1) = -cqiqj(1,3)
+ cqiqj(2,3) = dm2p
+ cqiqj(3,2) = -cqiqj(2,3)
+ cqiqj(1,1) = 0
+ cqiqj(2,2) = 0
+ cqiqj(3,3) = 0
+ call ffthre(ithres,cqi,cqiqj,3,1,2,3)
+ if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
+ lreal = .TRUE.
+ if ( lwrite ) print *,'ffcb1a: no threshold'
+ else
+ if ( lwrite ) print *,'ffcb1a: found threshold'
+ lreal = .FALSE.
+ endif
+ else
+ lreal = .FALSE.
+ endif
+ if ( lreal ) then
+ rm1 = DBLE(xm1)
+ rm2 = DBLE(xm2)
+ rp = DBLE(xp)
+ rm1p = DBLE(dm1p)
+ rm2p = DBLE(dm2p)
+ rm1m2 = DBLE(dm1m2)
+ do 20 j=1,3
+ do 10 i=1,3
+ rpiDpj(i,j) = DBLE(piDpj(i,j))
+ 10 continue
+ 20 continue
+ sprec = precx
+ precx = precc
+ call ffxb1a(cb1,cb0,ca0i,rp,rm1,rm2,rm1p,rm2p,rm1m2,rpiDpj,
+ + ier)
+ precx = sprec
+ return
+ endif
+* #] the real cases:
+* #[ check input:
+ if ( ltest ) then
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ xmax = max(absc(xm1),absc(xm2),abs(DBLE(xp)))
+ xnul = 2*piDpj(1,2) - xm1 - xm2 + xp
+ if ( rloss*absc(xnul) .gt. precc*xmax ) print *,
+ + 'ffcb1a: error: s1.s2 wrong: ',2*piDpj(1,2),xm1+xm2-xp,
+ + xnul,ier
+ xnul = 2*piDpj(1,3) + xm1 - xm2 + xp
+ if ( rloss*absc(xnul) .gt. precc*xmax ) print *,
+ + 'ffcb1a: error: s1.p wrong: ',2*piDpj(1,3),-xm1+xm2-xp,
+ + xnul,ier
+ xnul = 2*piDpj(2,3) + xm1 - xm2 - xp
+ if ( rloss*absc(xnul) .gt. precc*xmax ) print *,
+ + 'ffcb1a: error: s2.p wrong: ',2*piDpj(2,3),-xm1+xm2+xp,
+ + xnul,ier
+ endif
+* #] check input:
+* #[ p^2 != 0:
+ if ( DBLE(xp) .ne. 0 ) then
+* #[ normal case:
+ if ( dm1m2 .ne. 0 ) then
+ cs(1) = -ca0i(2)
+ cs(2) = +ca0i(1)
+ else
+ cs(1) = 0
+ cs(2) = 0
+ endif
+ cs(3) = +2*piDpj(1,3)*cb0
+ cb1 = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( absc(cb1) .ge. xloss*xmax ) goto 110
+* #] normal case:
+* #[ almost equal masses:
+ if ( absc(dm1m2) .le. xloss*absc(xm1) ) then
+ if ( lwrite ) print *,'Using algorithms for dm1m2 small'
+ cs(2) = dm1m2/xm1*cs(2)
+ cs(1) = -xm2*zfflo1(-dm1m2/xm2,ier)
+ if ( lwrite ) print *,'cb1 was',cb1,xmax
+ cb1 = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( lwrite ) print *,'cb1 is ',cb1,xmax
+ if ( absc(cb1) .ge. xloss*xmax ) goto 110
+* for the perfectionist (not me (today)):
+* if d0=0 and mu~m1(~m2), then the terms of order
+* (m1^2-m2^2) also cancel. To patch this I need d0 and mu
+ endif
+* #] almost equal masses:
+* #[ p2 -> 0:
+ if ( xloss**2*max(absc(xm1),absc(xm2)) .gt. absc(xp) ) then
+ if ( DBLE(xm2).gt.DBLE(xm1) ) then
+ xma = xm1
+ xmb = xm2
+ dmbma = -dm1m2
+ ts2Dp = +2*piDpj(2,3)
+ lneg = .FALSE.
+ else
+ xma = xm2
+ xmb = xm1
+ dmbma = +dm1m2
+ ts2Dp = -2*piDpj(1,3)
+ lneg = .TRUE.
+ endif
+ else
+ goto 100
+ endif
+*
+* We found a situation in which p2 is much smaller than
+* the masses.
+*
+ if ( lwrite ) print *,'Using algorithms for p2 small'
+ if ( xma.eq.0 ) then
+ clogm = 1
+ elseif ( absc(dmbma) .gt. xloss*absc(xmb) ) then
+ clogm = log(xmb/xma)
+ else
+ clogm = zfflo1(-dmbma/xma,ier)
+ endif
+ clam = (dmbma-xp)**2 - 4*xma*xp
+ slam = sqrt(clam)
+ small = xp*(-2*(xma+xmb) + xp)/(slam+dmbma)
+ if ( lwrite ) then
+ print *,'small = ',small
+ print *,'vgl ',slam-dmbma,slam
+ endif
+ cs(1) = clogm*xma*(4*xmb*(small-xp) + (small-xp)**2)/(2*
+ + (slam+dmbma)*(slam+2*piDpj(1,2)))
+ if ( lwrite ) then
+ print *,'cs(1) = ',cs(1)
+ print *,'vgl ',
+ + +xma*clogm*(DBLE(x05)+(xma+xmb-xp/2)/(slam-xma+xmb))
+ + +xmb*clogm*(DBLE(x05)-(xma+xmb-xp/2)/(slam-xma+xmb))
+ endif
+ if ( cprec.ne.precc ) then
+ cprec = precc
+ xprec = precx
+ precx = precc
+ bnd101 = ffbnd(2,1,xinfac)
+ bnd105 = ffbnd(2,5,xinfac)
+ bnd110 = ffbnd(2,10,xinfac)
+ bnd115 = ffbnd(2,15,xinfac)
+ precx = xprec
+ endif
+ x = xp/slam
+ if ( lwrite ) print *,'Taylor expansion in ',x
+ ax = absc(x)
+ if ( lwarn .and. ax.gt.bnd115 )
+ + call ffwarn(220,ier,precc,xinfac(16)*ax**14)
+ if ( ax.gt.bnd110 ) then
+ s = x*(DBLE(xinfac(12)) + x*(DBLE(xinfac(13)) +
+ + x*(DBLE(xinfac(14)) + x*(DBLE(xinfac(15)) +
+ + x*(DBLE(xinfac(16)) )))))
+ else
+ s = 0
+ endif
+ if ( ax.gt.bnd105 ) then
+ s = x*(DBLE(xinfac(7)) + x*(DBLE(xinfac(8)) +
+ + x*(DBLE(xinfac(9)) + x*(DBLE(xinfac(10)) +
+ + x*(DBLE(xinfac(11) + s) )))))
+ endif
+ if ( ax.gt.bnd101) then
+ s = x*(DBLE(xinfac(3)) + x*(DBLE(xinfac(4)) +
+ + x*(DBLE(xinfac(5)) + x*(DBLE(xinfac(6)) + s))))
+ endif
+ s = x**2*(DBLE(x05) + s)
+ s1 = 2*xp/(ts2Dp + slam)*(s + x)
+ h = -4*xp**2*xmb/(slam*(slam+ts2Dp)**2) - s + s1
+ if ( lwarn .and. absc(h) .lt. xloss*max(absc(s),absc(s1)) )
+ + then
+ call ffwarn(221,ier,absc(h),max(absc(s),absc(s1)))
+ endif
+ if ( lwrite ) then
+ print *,'arg ',h
+ print *,'vgl ',1-(1-2*xp/(xp+dmbma+slam))*exp(xp/
+ + slam)
+ endif
+ if ( absc(h) .lt. .1 ) then
+ cs(2) = dmbma*slam/xp*zfflo1(h,ier)
+ else
+ print *,'ffcb1: warning: I thought this was small: ',h
+ print *,' cp,cma,cmb = ',xp,xma,xmb
+ cs(2) = dmbma*slam/xp*log(1-h)
+*** goto 100
+ endif
+ if ( lneg ) then
+ cs(1) = -cs(1)
+ cs(2) = -cs(2)
+ endif
+ cs(3) = -xp*cb0
+ if ( lwrite ) print *,'cb1 was',cb1,xmax
+ cb1 = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( lwrite ) then
+ print *,'cb1 is ',cb1,xmax
+ print *,'cs = ',(cs(i),i=1,3)
+ endif
+ if ( absc(cb1) .gt. xloss*xmax) goto 110
+* #] p2 -> 0:
+* #[ give up:
+*
+* give up...
+*
+ 100 continue
+ if ( lwarn ) then
+ call ffwarn(167,ier,absc(cb1),xmax)
+ if ( lwrite ) then
+ print *,'cs(i) = ',(cs(i),i=1,3)
+ print *,'xp,xm1,xm2 = ',xp,xm1,xm2
+ endif
+ endif
+ 110 continue
+* #] give up:
+ cb1 = cb1/(2*xp)
+* #] p^2 != 0:
+* #[ p^2=0, m1 != m2:
+ elseif ( dm1m2 .ne. 0 ) then
+ cs(1) = +xm2/(2*dm1m2**2)*(ca0i(2)+xm2/2)
+ cs(2) = -xm1/(2*dm1m2**2)*(ca0i(1)+xm1/2)
+ cs(3) = +ca0i(2)/dm1m2
+ cb1 = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)))
+ if ( absc(cb1).ge.xloss**2*xmax ) goto 120
+ if ( lwrite ) then
+ print *,'cb1 = ',cb1,xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,3)
+ endif
+*
+* m1 ~ m2, see b21.frm
+*
+ if ( absc(dm1m2).lt.xloss*absc(xm1) ) then
+ xlogm = zfflo1(dm1m2/xm1,ier)
+ else
+ xlogm = log(xm2/xm1)
+ endif
+ cs(1) = -(xm1/dm1m2)/2
+ cs(2) = -xlogm/2*(xm1/dm1m2)**2
+ cs(3) = +1/DBLE(4) - ca0i(1)/(2*xm1)
+ cs(4) = xlogm/2
+ csom = cs(1) + cs(2) + cs(3) + cs(4)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)))
+ if ( lwrite ) then
+ print *,'cb1+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,4)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb1 = csom
+ if ( absc(cb1).gt.xloss**2*xmax ) goto 120
+ endif
+*
+* better
+*
+ xlo3 = zfflo3(dm1m2/xm1,ier)
+ cs(1) = -(dm1m2/xm1)**2/4
+ cs(2) = -(dm1m2/xm1)/2
+ cs(3) = -xlo3/(dm1m2/xm1)**2/2
+ cs(4) = xlo3/2
+ cs(5) = 1/DBLE(2) - ca0i(1)/(2*xm1)
+ csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
+ if ( lwrite ) then
+ print *,'cb1+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,5)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb1 = csom
+ if ( absc(cb1).gt.xloss**2*xmax ) goto 120
+ endif
+*
+* give up
+*
+ if ( lwarn ) then
+ if ( absc(cb1) .lt. xloss*xmax )
+ + call ffwarn(167,ier,absc(cb1),xmax)
+ endif
+ 120 continue
+* #] p^2=0, m1 != m2:
+* #[ p^2=0, m1 == m2:
+ else
+ cb1 = -cb0/2
+ endif
+* #] p^2=0, m1 == m2:
+*###] ffcb1a:
+ end
diff --git a/ff-2.0/ffcb2p.f b/ff-2.0/ffcb2p.f
new file mode 100644
index 0000000..0e5431b
--- /dev/null
+++ b/ff-2.0/ffcb2p.f
@@ -0,0 +1,526 @@
+*###[ ffcb2p:
+ subroutine ffcb2p(cb2i,cb1,cb0,ca0i,cp,xm1,xm2,piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu) *
+* of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2) *
+* originally based on aaxbx by Andre Aeppli. *
+* *
+* Input: cb1 complex vector two point function *
+* cb0 complex scalar two point function *
+* ca0i(2) complex scalar onepoint function with *
+* m1,m2 *
+* cp complex p.p in B&D metric *
+* xm1,2 complex m_1^2,m_2^2 *
+* piDpj(3,3) complex dotproducts between s1,s2,p *
+* ier integer digits lost so far *
+* *
+* Output: cb2i(2) complex B21,B22: coeffs of p*p, g in B2 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cp,xm1,xm2,piDpj(3,3)
+ DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
+ DOUBLE PRECISION rm1,rm2,rp,rpiDpj(3,3),sprec
+*
+* local variables
+*
+ integer i,j
+ DOUBLE COMPLEX dm1p,dm2p,dm1m2
+*
+* common blocks
+*
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ real case:
+ if ( DIMAG(xm1).eq.0 .and. DIMAG(xm2).eq.0 ) then
+ rm1 = DBLE(xm1)
+ rm2 = DBLE(xm2)
+ rp = DBLE(cp)
+ do 20 j=1,3
+ do 10 i=1,3
+ rpiDpj(i,j) = DBLE(piDpj(i,j))
+ 10 continue
+ 20 continue
+ sprec = precx
+ precx = precc
+ call ffxb2p(cb2i,cb1,cb0,ca0i,rp,rm1,rm2,rpiDpj,ier)
+ precx = sprec
+ return
+ endif
+* #] real case:
+* #[ work:
+*
+ dm1p = xm1 - cp
+ dm2p = xm2 - cp
+ dm1m2= xm1 - xm2
+ call ffcb2q(cb2i,cb1,cb0,ca0i,cp,xm1,xm2,dm1p,dm2p,dm1m2,
+ + piDpj,ier)
+*
+* #] work:
+*###] ffcb2p:
+ end
+*###[ ffcb2q:
+ subroutine ffcb2q(cb2i,cb1,cb0,ca0i,cp,xm1,xm2,dm1p,dm2p,dm1m2,
+ + piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu) *
+* of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2) *
+* originally based on aaxbx by Andre Aeppli. *
+* *
+* Input: cb1 complex vector two point function *
+* cb0 complex scalar two point function *
+* ca0i(2) complex scalar onepoint function with *
+* m1,m2 *
+* cp complex p.p in B&D metric *
+* xm1,2 complex m_1^2,m_2^2 *
+* piDpj(3,3) complex dotproducts between s1,s2,p *
+* ier integer digits lost so far *
+* *
+* Output: cb2i(2) complex B21,B22: coeffs of p*p, g in B2 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj(3,3)
+ DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
+*
+* local variables
+*
+ integer i,j,ier0,ier1,ithres,init
+ logical lreal,llogmm
+ DOUBLE PRECISION xmax,xmxsav,absc,rloss,xmxp
+ DOUBLE PRECISION rm1,rm2,rp,rm1p,rm2p,rm1m2,rpiDpj(3,3),sprec
+ DOUBLE COMPLEX cs(14),cc,slam,xlo3,csom,clam,xlogmm,zfflo1,alp,
+ + bet,xnoe,xnoe2,zfflo3
+ DOUBLE COMPLEX cqi(3),cqiqj(3,3),qiDqj(3,3)
+ save init
+* for Absoft only
+* external csqrt
+* DOUBLE COMPLEX csqrt
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ real cases:
+ if ( DIMAG(xm1).eq.0 .and. DIMAG(xm2).eq.0 ) then
+ lreal = .TRUE.
+ if ( lwrite ) print *,'ffcb2q: real masses'
+ elseif ( nschem.le.4 ) then
+ lreal = .TRUE.
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb2q: nschem <= 4, ignoring complex masses:',
+ + nschem
+ endif
+ elseif ( nschem.le.6 ) then
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb2q: nschem = 5,6 complex masses near ',
+ + 'threshold: ',nschem
+ endif
+ cqi(1) = xm1
+ cqi(2) = xm2
+ cqi(3) = cp
+ cqiqj(1,2) = dm1m2
+ cqiqj(2,1) = -cqiqj(1,2)
+ cqiqj(1,3) = dm1p
+ cqiqj(3,1) = -cqiqj(1,3)
+ cqiqj(2,3) = dm2p
+ cqiqj(3,2) = -cqiqj(2,3)
+ cqiqj(1,1) = 0
+ cqiqj(2,2) = 0
+ cqiqj(3,3) = 0
+ call ffthre(ithres,cqi,cqiqj,3,1,2,3)
+ if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
+ lreal = .TRUE.
+ if ( lwrite ) print *,'ffcb2q: no threshold'
+ else
+ if ( lwrite ) print *,'ffcb2q: found threshold'
+ lreal = .FALSE.
+ endif
+ else
+ lreal = .FALSE.
+ endif
+ if ( lreal ) then
+ rm1 = DBLE(xm1)
+ rm2 = DBLE(xm2)
+ rp = DBLE(cp)
+ rm1p = DBLE(dm1p)
+ rm2p = DBLE(dm2p)
+ rm1m2 = DBLE(dm1m2)
+ do 20 j=1,3
+ do 10 i=1,3
+ rpiDpj(i,j) = DBLE(piDpj(i,j))
+ 10 continue
+ 20 continue
+ sprec = precx
+ precx = precc
+ call ffxb2q(cb2i,cb1,cb0,ca0i,rp,rm1,rm2,rm1p,rm2p,
+ + rm1m2,rpiDpj,ier)
+ precx = sprec
+ return
+ endif
+* #] real cases:
+* #[ test input:
+ if ( ltest ) then
+ ier0 = ier
+ call ffcot2(qiDqj,cp,xm1,xm2,dm1p,dm2p,dm1m2,ier0)
+ rloss = xloss*DBLE(10)**(-mod(ier0,50))
+ do 40 j=1,3
+ do 30 i=1,3
+ if ( rloss*absc(piDpj(i,j)-qiDqj(i,j)).gt.precc*
+ + absc(qiDqj(i,j)) ) print *,'ffcb2q: ',
+ + 'error: piDpj(',i,j,') wrong: ',piDpj(i,j),
+ + qiDqj(i,j),piDpj(i,j)-qiDqj(i,j),ier0
+ 30 continue
+ 40 continue
+ endif
+* #] test input:
+* #[ normal case:
+ ier0 = ier
+ ier1 = ier
+*
+* with thanks to Andre Aeppli, off whom I stole the original
+*
+ if ( DBLE(cp) .ne. 0) then
+ cs(1) = ca0i(2)
+ cs(2) = xm1*cb0
+ cs(3) = 2*piDpj(1,3)*cb1
+ cs(4) = (xm1+xm2)/2
+ cs(5) = -cp/6
+ cb2i(1) = cs(1) - cs(2) + 2*cs(3) - cs(4) - cs(5)
+ cb2i(2) = cs(1) + 2*cs(2) - cs(3) + 2*cs(4) + 2*cs(5)
+ xmax = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
+ xmxsav = xmax
+ if ( absc(cb2i(1)) .ge. xloss*xmax ) goto 100
+ if ( lwrite ) then
+ print *,'cb2i(1) = ',cb2i(1),xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',1,cs(1),2,-cs(2),3,2*cs(3),4,
+ + -cs(4),5,-cs(5)
+ endif
+* #] normal case:
+* #[ improve: m1=m2:
+*
+* a relatively simple case: dm1m2 = 0 (bi0.frm)
+*
+ if ( dm1m2.eq.0 ) then
+ slam = sqrt(cp**2-4*xm1*cp)
+ xlo3 = zfflo3((cp-slam)/(2*xm1),ier)
+ cs(1) = cp*(-1/DBLE(3) + slam/(4*xm1))
+ cs(2) = cp**2*(-slam/(4*xm1**2) - 3/(4*xm1))
+ cs(3) = cp**3/(4*xm1**2)
+ cs(4) = cp/xm1*ca0i(1)
+ cs(5) = xlo3/cp*(-xm1*slam)
+ cs(6) = xlo3*slam
+ csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5) + cs(6)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ + absc(cs(5)),absc(cs(6)))
+ if ( lwrite ) then
+ print *,'cb2i(1)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,6)
+ endif
+ if ( xmxp.lt.xmax ) then
+ cb2i(1) = csom
+ xmax = xmxp
+ endif
+ if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
+ endif
+* #] improve: m1=m2:
+* #[ improve: |cp| < xm1 < xm2:
+*
+* try again (see bi.frm)
+*
+ clam = 4*(piDpj(1,3)**2 - xm1*cp)
+ if ( xm1.eq.0 .or. xm2.eq.0 ) then
+ xlogmm = 0
+ elseif ( absc(dm1m2).lt.xloss*absc(xm1) ) then
+ xlogmm = zfflo1(dm1m2/xm1,ier)
+ else
+ xlogmm = log(xm2/xm1)
+ endif
+ if ( abs(DBLE(cp)).lt.xloss*absc(xm2) .and.
+ + DBLE(xm1).lt.DBLE(xm2) ) then
+ slam = sqrt(clam)
+ alp = (2*xm1*xm2/(2*piDpj(1,2)+slam) + xm1)/(slam-dm1m2)
+* bet = [xm2-xm1-cp-slam]
+ bet = 4*xm1*cp/(2*piDpj(1,3)+slam)
+ cs(1) = cp/xm2*ca0i(2)
+ cs(2) = xlogmm*bet*(-2*xm1**2*xm2 - 2*xm1**3)
+ + /((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
+ cs(3) = xlogmm*(-4*cp*xm1**3)
+ + /((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
+ xnoe = 1/(2*piDpj(2,3)+slam)
+ xnoe2 = xnoe**2
+ cs(4) = xnoe2*xm1*bet*(cp-4*xm2)
+ cs(5) = xnoe2*xm1*2*cp*xm2
+ cs(6) = xnoe2*xm1**2*bet
+ cs(7) = xnoe2*xm1**2*4*cp
+ cs(8) = xnoe2*bet*(cp*xm2+3*xm2**2)
+ cs(9) = xnoe2*(-6*cp*xm2**2)
+ cs(10)= cp*(7/6.d0 - 2*xm1*slam*xnoe2 +
+ + 4*xm2*slam*xnoe2 - 2*slam*xnoe)
+ cs(11)= cp**2*( -2*slam*xnoe2 )
+ xlo3 = zfflo3(2*cp*xnoe,ier)
+ cs(12) = xlo3*dm1m2**2*slam/cp**2
+ cs(13) = xlo3*(xm1 - 2*xm2)*slam/cp
+ cs(14) = xlo3*slam
+ csom = 0
+ xmxp = 0
+ do 50 i=1,14
+ csom = csom + cs(i)
+ xmxp = max(xmxp,absc(cs(i)))
+ 50 continue
+ if ( lwrite ) then
+ print *,'cb2i(1)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,14)
+ endif
+ if ( xmxp.lt.xmax ) then
+ cb2i(1) = csom
+ xmax = xmxp
+ endif
+ if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
+ endif
+* #] improve: |cp| < xm1 < xm2:
+* #[ improve: |cp| < xm2 < xm1:
+ if ( abs(DBLE(cp)).lt.xloss*absc(xm1) .and.
+ + DBLE(xm2).lt.DBLE(xm1) ) then
+ slam = sqrt(clam)
+ alp = (2*xm2*xm1/(2*piDpj(1,2)+slam) + xm2)/(slam+dm1m2)
+* bet = [xm1-xm2-cp-slam]
+ bet = 4*xm2*cp/(-2*piDpj(2,3)+slam)
+ xnoe = 1/(-2*piDpj(1,3)+slam)
+ xnoe2 = xnoe**2
+ cs(1) = cp/xm1*ca0i(1)
+ cs(2) = -xlogmm*bet*(12*cp*xm1*xm2+6*cp*xm2**2-
+ + 6*cp**2*xm2-2*xm1*xm2**2-2*xm2**3)
+ + /((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
+ cs(3) = -xlogmm*(-24*cp*xm1**2*xm2-4*cp*xm2**3+36*
+ + cp**2*xm1*xm2+12*cp**2*xm2**2-12*cp**3*xm2)
+ + /((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
+ cs(4) = xnoe2*xm2*bet*(cp-4*xm1)
+ cs(5) = xnoe2*xm2*(-10*cp*xm1)
+ cs(6) = xnoe2*xm2**2*bet
+ cs(7) = xnoe2*xm2**2*4*cp
+ cs(8) = xnoe2*bet*(cp*xm1+3*xm1**2)
+ cs(9) = xnoe2*6*cp*xm1**2
+ cs(10)= cp*(7/6.d0 - 2*xm1*slam*xnoe2 +
+ + 4*xm2*slam*xnoe2 - 2*slam*xnoe)
+ cs(11)= cp**2*( -2*slam*xnoe2 )
+ xlo3 = zfflo3(2*cp*xnoe,ier)
+ cs(12) = xlo3*dm1m2**2*slam/cp**2
+ cs(13) = xlo3*(xm1 - 2*xm2)*slam/cp
+ cs(14) = xlo3*slam
+ csom = 0
+ xmxp = 0
+ do 60 i=1,14
+ csom = csom + cs(i)
+ xmxp = max(xmxp,absc(cs(i)))
+ 60 continue
+ if ( lwrite ) then
+ print *,'cb2i(1)-= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,14)
+ endif
+ if ( xmxp.lt.xmax ) then
+ cb2i(1) = csom
+ xmax = xmxp
+ endif
+ if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
+ endif
+* #] improve: |cp| < xm2 < xm1:
+* #[ wrap up:
+ if ( lwarn ) then
+ call ffwarn(225,ier0,absc(cb2i(1)),xmax)
+ if ( lwrite ) then
+ print *,'cp,xm1,xm2 = ',cp,xm1,xm2
+ endif
+ endif
+ 100 continue
+ xmax = xmxsav
+ if ( absc(cb2i(2)) .lt. xloss**2*xmax ) then
+ if ( lwrite ) then
+ print *,'cb2i(2) = ',cb2i(2),xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',1,cs(1),2,2*cs(2),3,-cs(3),
+ + 4,2*cs(4)
+ endif
+*
+ if ( lwarn ) then
+ call ffwarn(226,ier1,absc(cb2i(2)),xmax)
+ endif
+ 110 continue
+ if ( lwrite ) print *,'cb2i(2)+= ',cb2i(2)
+ endif
+ cb2i(1) = DBLE(1/(3*cp)) * cb2i(1)
+ cb2i(2) = DBLE(1/6.d0) * cb2i(2)
+* #] wrap up:
+* #[ cp=0, m1!=m2:
+ elseif (dm1m2 .ne. 0) then
+* #[ B21:
+ llogmm = .FALSE.
+*
+* B21 (see thesis, b21.frm)
+*
+ cs(1) = xm1**2/3/dm1m2**3*ca0i(1)
+ cs(2) = (-xm1**2 + xm1*xm2 - xm2**2/3)/dm1m2**3*ca0i(2)
+ cs(3) = (5*xm1**3/18 - xm1*xm2**2/2 + 2*xm2**3/9)
+ + /dm1m2**3
+ cb2i(1) = cs(1)+cs(2)+cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
+ if ( lwrite ) then
+ print *,'cb2i(1) = ',cb2i(1),xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,3)
+ endif
+*
+* ma ~ mb
+*
+ if ( absc(dm1m2).lt.xloss*absc(xm1) ) then
+ xlogmm = zfflo1(dm1m2/xm1,ier)
+ else
+ xlogmm = log(xm2/xm1)
+ endif
+ llogmm = .TRUE.
+ cs(1) = (xm1/dm1m2)/6
+ cs(2) = (xm1/dm1m2)**2/3
+ cs(3) = (xm1/dm1m2)**3*xlogmm/3
+ cs(4) = -2/DBLE(9) + ca0i(1)/(3*xm1)
+ cs(5) = -xlogmm/3
+ csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ + absc(cs(5)))
+ if ( lwrite ) then
+ print *,'cb2i(1)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,5)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb2i(1) = csom
+ if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
+ endif
+*
+* and last try
+*
+ xlo3 = zfflo3(dm1m2/xm1,ier)
+ cs(1) = (dm1m2/xm1)**2/6
+ cs(2) = (dm1m2/xm1)/3
+ cs(3) = xlo3/(3*(dm1m2/xm1)**3)
+*same cs(4) = -2/DBLE(9) + ca0i(1)/(3*xm1)
+ cs(5) = -xlo3/3
+ csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ + absc(cs(5)))
+ if ( lwrite ) then
+ print *,'cb2i(1)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,5)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb2i(1) = csom
+ if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
+ endif
+*
+* give up
+*
+ if ( lwarn ) then
+ call ffwarn(225,ier,absc(cb2i(1)),xmax)
+ if ( lwrite ) then
+ print *,'cp,xm1,xm2 = ',cp,xm1,xm2
+ endif
+ endif
+ 160 continue
+* #] B21:
+* #[ B22:
+*
+* B22
+*
+ cs(1) = +xm1/(4*dm1m2)*ca0i(1)
+ cs(2) = -xm2/(4*dm1m2)*ca0i(2)
+ cs(3) = (xm1+xm2)/8
+ cb2i(2) = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
+ if ( lwrite ) then
+ print *,'cb2i(2) = ',cb2i(2),xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,3)
+ endif
+*
+* second try, close together
+*
+ if ( .not.llogmm ) then
+ if ( abs(dm1m2).lt.xloss*absc(xm1) ) then
+ xlogmm = zfflo1(dm1m2/xm1,ier)
+ else
+ xlogmm = log(xm2/xm1)
+ endif
+ endif
+ cs(1) = dm1m2*( -1/DBLE(8) - ca0i(1)/(4*xm1) )
+ cs(2) = dm1m2*xlogmm/4
+ cs(3) = xm1*(xm1/dm1m2)/4*xlogmm
+ cs(4) = xm1*( 1/DBLE(4) + ca0i(1)/(2*xm1) )
+ cs(5) = -xm1*xlogmm/2
+ csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ + absc(cs(5)))
+ if ( lwrite ) then
+ print *,'cb2i(2)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,2)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb2i(2) = csom
+ endif
+ if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
+*
+* give up
+*
+ if ( lwarn ) then
+ call ffwarn(226,ier,absc(cb2i(2)),xmax)
+ if ( lwrite ) then
+ print *,'cp,xm1,xm2 = ',cp,xm1,xm2
+ endif
+ endif
+ 210 continue
+* #] B22:
+* #] cp=0, m1!=m2:
+* #[ cp=0, m1==m2:
+ else
+*
+* taken over from ffxb2a, which in turns stem from my thesis GJ
+*
+ cb2i(1) = cb0/3
+ cb2i(2) = xm1/2*(cb0 + 1)
+ endif
+* #] cp=0, m1==m2:
+* #[ finish up:
+ ier = max(ier0,ier1)
+* #] finish up:
+*###] ffcb2q:
+ end
diff --git a/ff-2.0/ffcc0.f b/ff-2.0/ffcc0.f
new file mode 100644
index 0000000..17bdae7
--- /dev/null
+++ b/ff-2.0/ffcc0.f
@@ -0,0 +1,1250 @@
+* $Id: ffcc0.f,v 1.2 1996/06/30 19:03:55 gj Exp $
+*###[ ffcc0:
+ subroutine ffcc0(cc0,cpi,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the threepoint function closely following *
+* recipe in 't Hooft & Veltman, NP B(183) 1979. *
+* B&D metric is used throughout! *
+* *
+* p2 | | *
+* v | *
+* / \ *
+* m2/ \m3 *
+* p1 / \ p3 *
+* -> / m1 \ <- *
+* ------------------------ *
+* *
+* 1 / 1 *
+* = ----- \d^4Q---------------------------------------- *
+* ipi^2 / [Q^2-m1^2][(Q+p1)^2-m2^2][(Q-p3)^2-m3^2] *
+* *
+* If the function is infra-red divergent (p1=m2,p3=m3,m1=0 or *
+* cyclic) the function is calculated with a user-supplied cutoff *
+* delta in the common block /ffcut/. *
+* *
+* the parameter nschem in the common block /fflags/ determines *
+* which recipe is followed, see ffinit.f *
+* *
+* Input: cpi(6) (complex) m1^2,m2^3,p1^2,p2^2,p3^2 *
+* of divergences, but C0 has none) *
+* /ffcut/ delta (real) IR cutoff *
+* /fflags/..nschem(integer) 6: full complex, 0: real, else: *
+* some or all logs *
+* /fflags/..nwidth(integer) when |p^2-Re(m^2)| < nwidth|Im(m^2) *
+* use complex mass *
+* ier (integer) number of digits lost so far *
+* Output: cc0 (complex) C0, the threepoint function *
+* ier (integer) number of digits lost more than (at *
+* most) xloss^5 *
+* Calls: ffcc0p,ffcb0p *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cc0,cpi(6)
+*
+* local variables:
+*
+ integer i,j,ier0,init
+ logical lwsave
+ DOUBLE COMPLEX c,cc0r,cc0p,cc00
+ DOUBLE COMPLEX cdpipj(6,6)
+ DOUBLE PRECISION xmax,absc,xpi(6),sprecx,dm
+ save init
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data init/0/
+*
+* #] declarations:
+* #[ the real case:
+*
+* take a faster route if all masses are real or nschem < 3
+*
+ if ( nschem .ge. 3 ) then
+ do 10 i = 1,6
+ if ( DIMAG(cpi(i)) .ne. 0 ) goto 30
+ 10 continue
+ elseif ( init .eq. 0 ) then
+ init = 1
+ print *,'ffcc0: disregarding complex masses, nschem= ',
+ + nschem
+ endif
+ do 20 i = 1,6
+ xpi(i) = DBLE(cpi(i))
+ 20 continue
+ sprecx = precx
+ precx = precc
+ call ffxc0(cc0,xpi,ier)
+ precx = sprecx
+ if ( ldot ) call ffcod3(cpi)
+ return
+ 30 continue
+*
+* #] the real case:
+* #[ check input:
+*
+ idsub = 0
+ if ( ltest ) then
+ do 34 i=1,3
+ if ( DIMAG(cpi(i)) .gt. 0 ) call fferr(49,ier)
+ 34 continue
+ do 35 i=4,6
+ if ( DIMAG(cpi(i)) .ne. 0 ) call fferr(49,ier)
+ 35 continue
+ endif
+ if ( lwrite ) then
+ print *,'ffcc0: input = ',cpi
+ endif
+*
+* #] check input:
+* #[ convert input:
+ if ( lwarn ) then
+ do 50 i=1,6
+ cdpipj(i,i) = 0
+ do 40 j = i+1,6
+ cdpipj(i,j) = cpi(i) - cpi(j)
+ if ( absc(cdpipj(i,j)) .lt. xloss*absc(cpi(i)) .and.
+ + cpi(i) .ne. cpi(j) ) then
+ ier0 = 0
+ call ffwarn(86,ier0,absc(cdpipj(i,j)),
+ + absc(cpi(i)))
+ endif
+ cdpipj(j,i) = - cdpipj(i,j)
+ 40 continue
+ 50 continue
+ else
+ do 70 i=1,6
+ cdpipj(i,i) = 0
+ do 60 j = 1,6
+ cdpipj(j,i) = cpi(j) - cpi(i)
+ 60 continue
+ 70 continue
+ endif
+* #] convert input:
+* #[ call ffcc0a:
+ call ffcc0a(cc0,cpi,cdpipj,ier)
+* #] call ffcc0a:
+* #[ check output:
+ if ( .FALSE. .and. ltest .and. nschem .ge. 3 ) then
+ do 920 i = 1,6
+ xpi(i) = DBLE(cpi(i))
+ 920 continue
+ lwsave = lwrite
+ lwrite = .FALSE.
+ ier0 = 0
+ call ffxc0(cc0r,xpi,ier0)
+ cc00 = cc0r
+ if ( lwsave ) print *,'compare with real case: cc0 = ',
+ + cc0r,ier0
+ dm = sqrt(precc)/xloss**2
+ if ( lwsave ) print *,'using dm^2/m^2 = ',dm
+ do 930 i=1,3
+ if ( DIMAG(cpi(i)) .eq. 0 ) goto 930
+ do 924 j=1,i-1
+ if ( cdpipj(j,i) .eq. 0 ) goto 930
+ 924 continue
+ do 925 j=i,3
+ if ( cdpipj(j,i) .eq. 0 ) xpi(j) = xpi(j)*(1 + dm)
+ 925 continue
+ ier0 = 0
+ call ffxc0(cc0p,xpi,ier0)
+ do 926 j=i,3
+ if ( cdpipj(j,i) .eq. 0 ) xpi(j) = xpi(j)/(1 + dm)
+ 926 continue
+ if ( lwsave ) print *,'cc0p = ',cc0p
+ cc0p = (cc0p - cc00)/DBLE(dm*xpi(i))
+ if ( lwsave ) print *,'cc0'' = ',cc0p
+ cc0r = cc0r + DCMPLX(DBLE(0),DIMAG(cpi(i)))*cc0p
+ if ( lwsave ) print *,'with first term Taylor in ',i,
+ + ' = ',cc0r,ier0
+ 930 continue
+ lwrite = lwsave
+ xmax = 0
+ if ( xpi(1).ne.0 )
+ + xmax = xmax + absc((cpi(1)/DBLE(xpi(1))-1)**2)
+ if ( xpi(2).ne.0 )
+ + xmax = xmax + absc((cpi(2)/DBLE(xpi(2))-1)**2)
+ if ( xpi(3).ne.0 )
+ + xmax = xmax + absc((cpi(3)/DBLE(xpi(3))-1)**2)
+ if ( absc(cc0/cc0r-1) .gt. 2*xmax ) then
+ print *,'ffcc0: result is very different from the real',
+ + ' case: ',cc0,cc0r,cc0-cc0r
+ print *,' (input = ',cpi,')'
+ endif
+ endif
+* #] check output:
+*###] ffcc0:
+ end
+*###[ ffcc0r:
+ subroutine ffcc0r(cc0,cpi,ier)
+***#[*comment:***********************************************************
+* *
+* Tries all 2 permutations of the 3pointfunction *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ier
+ DOUBLE COMPLEX cc0,cc0p,cpi(6),cqi(6)
+ integer inew(6,2),irota,ier1,i,j,icon,ialsav,init
+ logical lcon
+ parameter (icon=3)
+ save inew,init,lcon
+ include 'ff.h'
+ data inew /1,2,3,4,5,6,
+ + 1,3,2,6,5,4/
+ data init /0/
+* #] declarations:
+* #[ open console for some activity on screen:
+ if ( init .eq. 0 ) then
+ init = 1
+ if ( lwrite ) then
+ open(icon,file='CON:',status='old',err=11)
+ lcon = .TRUE.
+ goto 13
+ endif
+ 11 continue
+ lcon = .FALSE.
+ 13 continue
+ endif
+* #] open console for some activity on screen:
+* #[ calculations:
+ cc0 = 0
+ ier = 999
+ ialsav = isgnal
+ do 30 j = -1,1,2
+ do 20 irota=1,2
+ do 10 i=1,6
+ cqi(inew(i,irota)) = cpi(i)
+ 10 continue
+ print '(a,i1,a,i2)','---#[ rotation ',irota,': isgnal ',
+ + isgnal
+ if (lcon) write(icon,'(a,i1,a,i2)')'rotation ',irota,',
+ + isgnal ',isgnal
+ ier1 = 0
+ ner = 0
+ id = id + 1
+ isgnal = ialsav
+ call ffcc0(cc0p,cqi,ier1)
+ ier1 = ier1 + ner
+ print '(a,i1,a,i2)','---#] rotation ',irota,': isgnal ',
+ + isgnal
+ print '(a,2g28.16,i3)','c0 = ',cc0p,ier1
+ if (lcon) write(icon,'(a,2g28.16,i3)')'d0 = ',cc0p,ier1
+ if ( ier1 .lt. ier ) then
+ cc0 = cc0p
+ ier = ier1
+ endif
+ 20 continue
+ ialsav = -ialsav
+ 30 continue
+* #] calculations:
+*###] ffcc0r:
+ end
+*###[ ffcc0a:
+ subroutine ffcc0a(cc0,cpi,cdpipj,ier)
+***#[*comment:***********************************************************
+* *
+* see ffcc0 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cc0,cpi(6),cdpipj(6,6)
+*
+* local variables:
+*
+ integer i,j,irota,inew(6,6),i1,i2,i3,initlo,ithres(3),ifound
+ logical ljust
+* DOUBLE COMPLEX cs,cs1,cs2
+ DOUBLE COMPLEX c,cqi(6),cqiqj(6,6),cqiDqj(6,6)
+ DOUBLE PRECISION absc,xqi(6),dqiqj(6,6),qiDqj(6,6),sprec
+ save initlo
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* memory
+*
+ integer iermem(memory),ialmem(memory),nscmem(memory),memind,
+ + ierini
+ DOUBLE COMPLEX cpimem(6,memory)
+ DOUBLE COMPLEX cc0mem(memory)
+ DOUBLE PRECISION dl2mem(memory)
+ save memind,iermem,ialmem,cpimem,cc0mem
+ data memind /0/
+*
+* statement function:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data inew /1,2,3,4,5,6,
+ + 2,3,1,5,6,4,
+ + 3,1,2,6,4,5,
+ + 1,3,2,6,5,4,
+ + 3,2,1,5,4,6,
+ + 2,1,3,4,6,5/
+ data initlo /0/
+*
+* #] declarations:
+* #[ initialisations:
+ if ( lmem .and. memind .eq. 0 ) then
+ do 2 i=1,memory
+ do 1 j=1,6
+ cpimem(j,i) = 0
+ 1 continue
+ ialmem(i) = 0
+ nscmem(i) = -1
+ 2 continue
+ endif
+ idsub = 0
+ ljust = .FALSE.
+* #] initialisations:
+* #[ handel special cases:
+ if ( DIMAG(cpi(1)).eq.0 .and. DIMAG(cpi(2)).eq.0 .and.
+ + DIMAG(cpi(3)).eq.0 ) then
+ do 4 i=1,6
+ xqi(i) = DBLE(cpi(i))
+ do 3 j=1,6
+ dqiqj(j,i) = DBLE(cdpipj(j,i))
+ 3 continue
+ 4 continue
+ sprec = precx
+ precx = precc
+ if ( lwrite ) print *,'ffcc0a: real masses, calling ffxc0a'
+ call ffxc0a(cc0,xqi,dqiqj,ier)
+ precx = sprec
+ if ( ldot ) call ffcod3(cpi)
+ return
+ endif
+* goto 5
+* No special cases for the moment...
+**
+* The infrared divergent diagrams cannot be complex
+**
+* The general case cannot handle cpi=0, pj=pk. These are simple
+* though.
+**
+* if ( cpi(4) .eq. 0 .and. cdpipj(5,6) .eq. 0 .and. cdpipj(1,2)
+* + .ne. 0 ) then
+* call ffcb0p(cs1,-cpi(5),cpi(1),cpi(3),cdpipj(1,6),
+* + cdpipj(3,5),cdpipj(1,3),ier)
+* call ffcb0p(cs2,-cpi(5),cpi(2),cpi(3),cdpipj(2,5),
+* + cdpipj(3,5),cdpipj(2,3),ier)
+* cs = cs1 - cs2
+* cc0 = cs/cdpipj(1,2)
+* elseif ( cpi(6) .eq. 0 .and. cdpipj(4,5) .eq. 0 .and.
+* + cdpipj(3,1) .ne. 0 ) then
+* call ffcb0p(cs1,-cpi(4),cpi(3),cpi(2),cdpipj(3,5),
+* + cdpipj(2,4),cdpipj(3,2),ier)
+* call ffcb0p(cs2,-cpi(4),cpi(1),cpi(2),cdpipj(1,4),
+* + cdpipj(2,4),cdpipj(1,2),ier)
+* cs = cs1 - cs2
+* cc0 = cs/cdpipj(3,1)
+* elseif ( cpi(5) .eq. 0 .and. cdpipj(6,4) .eq. 0 .and.
+* + cdpipj(2,3) .ne. 0 ) then
+* call ffcb0p(cs1,-cpi(6),cpi(2),cpi(1),cdpipj(2,4),
+* + cdpipj(1,6),cdpipj(2,1),ier)
+* call ffcb0p(cs2,-cpi(6),cpi(3),cpi(1),cdpipj(3,6),
+* + cdpipj(1,6),cdpipj(3,1),ier)
+* cs = cs1 - cs2
+* cc0 = cs/cdpipj(2,3)
+* else
+* goto 5
+* endif
+**
+* common piece - excuse my style
+**
+* print *,'ffcc0: WARNING: this algorithm has not yet been tested'
+* if ( absc(cs) .lt. xloss*absc(cs1) )
+* + call ffwarn(26,ier,absc(cs),absc(cs1))
+**
+* debug output
+**
+* if (lwrite) then
+* print *,'simple case cpi=0,cpj=cpk, two twopoint functions:'
+* print *,cs1,cs2
+* print *,'result: cc0=',cc0,ier
+* endif
+* return
+* 5 continue
+* #] handel special cases:
+* #[ rotate to alpha in (0,1):
+ call ffcrt3(irota,cqi,cqiqj,cpi,cdpipj,6,2,ier)
+* #] rotate to alpha in (0,1):
+* #[ look in memory:
+ ierini = ier+ner
+ if ( lmem ) then
+ do 70 i=1,memory
+ do 60 j=1,6
+ if ( cqi(j) .ne. cpimem(j,i) ) goto 70
+ 60 continue
+ if ( ialmem(i) .ne. isgnal .or.
+ + nscmem(i) .ne. nschem ) goto 70
+* we found an already calculated masscombination ..
+* (maybe check differences as well)
+ if ( lwrite ) print *,'ffcc0: using previous result'
+ cc0 = cc0mem(i)
+ ier = ier+iermem(i)
+ if ( ldot ) then
+ fodel2 = dl2mem(i)
+ fdel2 = fodel2
+* we forgot to recalculate the stored quantities
+ ljust = .TRUE.
+ goto 71
+ endif
+ return
+ 70 continue
+* if ( lwrite ) print *,'ffcc0: not found in memory'
+ endif
+ 71 continue
+* #] look in memory:
+* #[ dot products:
+ call ffcot3(cqiDqj,cqi,cqiqj,6,ier)
+*
+* save dotproducts for tensor functions if requested
+*
+ if ( ldot ) then
+ do 75 i=1,6
+ do 74 j=1,6
+ cfpij3(j,i) = cqiDqj(inew(i,irota),inew(j,irota))
+ 74 continue
+ 75 continue
+ if ( irota .gt. 3 ) then
+*
+* the signs of the s's have been changed
+*
+ do 77 i=1,3
+ do 76 j=4,6
+ cfpij3(j,i) = -cfpij3(j,i)
+ cfpij3(i,j) = -cfpij3(i,j)
+ 76 continue
+ 77 continue
+ endif
+*
+* also give the real dotproducts as reals
+*
+ do 79 i=4,6
+ do 78 j=4,6
+ fpij3(j,i) = DBLE(cfpij3(j,i))
+ 78 continue
+ 79 continue
+ endif
+ if ( ljust ) return
+* #] dot products:
+* #[ handle poles-only approach:
+ sprec = precx
+ precx = precc
+ if ( nschem.le.6 ) then
+ if ( initlo.eq.0 ) then
+ initlo = 1
+ if ( nschem.eq.1 .or. nschem.eq.2 ) then
+ print *,'ffcc0a: disregarding all complex masses'
+ elseif ( nschem.eq.3 ) then
+ print *,'ffcc0a: undefined nschem=3'
+ elseif ( nschem.eq.4 ) then
+ print *,'ffcc0a: using the scheme in which ',
+ + 'complex masses are used everywhere when ',
+ + 'there is a divergent log'
+ elseif ( nschem.eq.5 ) then
+ print *,'ffcc0a: using the scheme in which ',
+ + 'complex masses are used everywhere when ',
+ + 'there is a divergent or almost divergent log'
+ elseif ( nschem.eq.6 ) then
+ print *,'ffcc0a: using the scheme in which ',
+ + 'complex masses are used everywhere when ',
+ + 'there is a singular log'
+ elseif ( nschem.eq.7 ) then
+ print *,'ffcc0a: using complex masses'
+ endif
+ if ( nschem.ge.3 ) then
+ print *,'ffcc0a: switching to complex when ',
+ + '|p^2-Re(m^2)| < ',nwidth,'*|Im(m^2)|'
+ endif
+ endif
+ do 9 i=1,6
+ xqi(i) = DBLE(cqi(i))
+ do 8 j=1,6
+ dqiqj(j,i) = DBLE(cqiqj(j,i))
+ qiDqj(j,i) = DBLE(cqiDqj(j,i))
+ 8 continue
+ 9 continue
+ i1 = 0
+ ithres(1) = 0
+ ithres(2) = 0
+ ithres(3) = 0
+ if ( nschem.le.2 ) goto 21
+*
+ do 10 i1=1,3
+*
+* search for a combination of 2 almost on-shell particles
+* and a light one
+*
+ i2 = mod(i1,3)+1
+ i3 = mod(i2,3)+1
+ call ffbglg(ifound,cqi,cqiqj,cqiDqj,6,i1,i2,i3,i1+3,
+ + i3+3)
+ if ( ifound .ne. 0 ) goto 11
+ 10 continue
+ if ( lwrite ) print *,'ffcc0a: no large logs'
+ i1 = 0
+ 11 continue
+ if ( nschem.ge.4 .and. i1.ne.0 ) goto 30
+ if ( nschem.le.3 ) goto 21
+*
+ do 20 i=1,3
+ i2 = mod(i,3)+1
+ call ffthre(ithres(i),cqi,cqiqj,6,i,i2,i+3)
+ 20 continue
+*
+ if ( nschem.eq.5 .and. (ithres(1).eq.2 .or.
+ + ithres(2).eq.2 .or. ithres(3).eq.2) ) goto 30
+ if ( nschem.eq.6 .and. (ithres(1).eq.1 .or.
+ + ithres(2).eq.1 .or. ithres(3).eq.1) ) goto 30
+*
+ 21 continue
+*
+* The infrared divergent diagrams are calculated in ffxc0i:
+*
+ if ( dqiqj(2,4).eq.0 .and. dqiqj(3,6).eq.0 .and. xqi(1).eq.0
+ + .or. dqiqj(3,5).eq.0 .and. dqiqj(1,4).eq.0 .and. xqi(2).eq.0
+ + .or. dqiqj(1,6).eq.0 .and. dqiqj(2,5).eq.0 .and. xqi(3).eq.0
+ + ) then
+ call ffxc0i(cc0,xqi,dqiqj,ier)
+ else
+ call ffxc0b(cc0,xqi,dqiqj,qiDqj,ier)
+ endif
+* the dotproducts are already set, but I forgot this
+ if ( ldot ) fodel2 = fdel2
+ goto 31
+*
+* the complex case
+*
+ 30 continue
+ precx = sprec
+ call ffcc0b(cc0,cqi,cqiqj,cqiDqj,ier)
+ 31 continue
+*
+* #] handle poles-only approach:
+* #[ call ffcc0b:
+ else
+ precx = sprec
+ call ffcc0b(cc0,cqi,cqiqj,cqiDqj,ier)
+ endif
+* #] call ffcc0b:
+* #[ add to memory:
+ if ( lmem ) then
+ memind = memind + 1
+ if ( memind .gt. memory ) memind = 1
+ do 200 j=1,6
+ cpimem(j,memind) = cqi(j)
+ 200 continue
+ cc0mem(memind) = cc0
+ iermem(memind) = ier+ner-ierini
+ ialmem(memind) = isgnal
+ nscmem(memind) = nschem
+ dl2mem(memind) = fodel2
+ endif
+* #] add to memory:
+*###] ffcc0a:
+ end
+*###[ ffcc0b:
+ subroutine ffcc0b(cc0,cqi,cqiqj,cqiDqj,ier)
+***#[*comment:***********************************************************
+* *
+* see ffcc0 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer nerr
+ parameter (nerr=6)
+*
+* arguments
+*
+ DOUBLE COMPLEX cc0,cqi(6),cqiqj(6,6),cqiDqj(6,6)
+ integer ier
+*
+* local variables:
+*
+ integer isoort(8),ipi12(8),i,j,k,ipi12t,ilogi(3),ier0,ieri(nerr)
+ DOUBLE COMPLEX cs3(80),cs,cs1,cs2,cslam,c,cel2,cel3,cel2s(3),
+ + cel3mi(3),clogi(3),calph(3),cblph(3),cetalm,cetami(6),
+ + clamp,ceta,csdel2,celpsi(3)
+ DOUBLE PRECISION xmax,absc,del2,qiDqj(6,6)
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ calculations:
+*
+* some determinants
+*
+ if ( lwrite ) print '(a)',' ##[ determinants:'
+ do 98 i = 1,nerr
+ ieri(i) = 0
+ 98 continue
+ do 104 i=4,6
+ do 103 j=4,6
+ qiDqj(j,i) = DBLE(cqiDqj(j,i))
+ 103 continue
+ 104 continue
+ call ffdel2(del2,qiDqj,6,4,5,6,1,ier)
+ if ( lwrite ) print *,'ffcc0: del2 = ',del2
+ fodel2 = del2
+ fdel2 = fodel2
+ cel2 = DCMPLX(DBLE(del2))
+* if ( lwrite ) print *,'ffcc0: calling ffcel3'
+ call ffcel3(cel3,cqi,cqiDqj,6,ier)
+ if ( DIMAG(cel3).ne.0 .and.
+ + abs(DIMAG(cel3)).lt.precc*abs(DBLE(cel3)) ) then
+ if ( lwrite ) print *,'ffcc0b: rounded cel3 from ',cel3
+ cel3 = DBLE(cel3)
+ if ( lwrite ) print *,'to ',cel3
+ endif
+* if ( lwrite ) print *,'ffcc0: calling ffcl3m'
+ call ffcl3m(cel3mi,.TRUE.,cel3,cel2,cqi,cqiqj,cqiDqj,6, 4,5,6,
+ + 1,3,ier)
+ do 105 i=1,3
+ j = i+1
+ if ( j .eq. 4 ) j = 1
+* if ( lwrite ) print *,'ffcc0: calling ffcel2'
+ call ffcel2(cel2s(i),cqiDqj,6,i+3,i,j,1,ieri(i))
+ k = i-1
+ if ( k .eq. 0 ) k = 3
+* if ( lwrite ) print *,'ffcc0: calling ffcl2p'
+ call ffcl2p(celpsi(i),cqi,cqiqj,cqiDqj,i+3,j+3,k+3,i,j,k,6,
+ + ieri(i+3))
+ 105 continue
+ cetalm = cel3*DBLE(1/del2)
+ do 108 i=1,3
+ cetami(i) = cel3mi(i)*DBLE(1/del2)
+ 108 continue
+ csdel2 = isgnal*DBLE(sqrt(-del2))
+ ier0 = 0
+ do 99 i=1,nerr
+ ier0 = max(ier0,ieri(i))
+ 99 continue
+ ier = ier + ier0
+*
+* initialize cs3:
+*
+ do 80 i=1,80
+ cs3(i) = 0
+ 80 continue
+ do 90 i=1,8
+ ipi12(i) = 0
+ 90 continue
+*
+* get alpha,1-alpha
+*
+ call ffcoot(cblph(1),calph(1),cqi(5),-cqiDqj(5,6),cqi(6),csdel2,
+ + ier)
+ call ffcoot(calph(3),cblph(3),cqi(5),-cqiDqj(5,4),cqi(4),csdel2,
+ + ier)
+ cs1 = cblph(1) - c05
+ cs2 = calph(1) - c05
+ if ( l4also .and. ( DBLE(calph(1)) .gt. 1 .or. DBLE(calph(1))
+ + .lt. 0 ) .and. absc(cs1) .lt. absc(cs2) ) then
+ calph(1) = cblph(1)
+ calph(3) = cblph(3)
+ csdel2 = -csdel2
+ isgnal = -isgnal
+ endif
+ cslam = 2*csdel2
+ if (lwrite) then
+ print *,'cslam =',2*csdel2
+* call ffclmb(clamp,cqi(4),cqi(5),cqi(6),cqiqj(4,5),
+* + cqiqj(4,6),cqiqj(5,6),ier)
+* print *,'cslamp =',sqrt(clamp)
+ print *,'ceta =',-4*cel3
+* ier0 = 0
+* call ffceta(ceta,cpi,cdpipj,6,ier0)
+* print *,'cetap =',ceta
+ print *,'cetalm =',cetalm
+ print *,'calpha =',calph(1),calph(3)
+ endif
+ if ( lwrite ) print '(a)',' ##] determinants:'
+*
+* and the calculations
+*
+ call ffcc0p(cs3,ipi12,isoort,clogi,ilogi,cqi,cqiqj,cqiDqj,
+ + csdel2,cel2s,cetalm,cetami,celpsi,calph,3,ier)
+*
+* sum'em up:
+*
+ cs = 0
+ xmax = 0
+ do 110 i=1,80
+ cs = cs + cs3(i)
+ xmax = max(xmax,absc(cs))
+ 110 continue
+ ipi12t = ipi12(1)
+ do 120 i=2,8
+ ipi12t = ipi12t + ipi12(i)
+ 120 continue
+ cs = cs + ipi12t*DBLE(pi12)
+*
+* check for cancellations
+*
+ if ( lwarn .and. 2*absc(cs) .lt. xloss*xmax )
+ + call ffwarn(27,ier,absc(cs),xmax)
+*
+* check for imaginary part zero (this may have to be dropped)
+*
+ if ( abs(DIMAG(cs)) .lt. precc*abs(DBLE(cs)) )
+ + cs = DCMPLX(DBLE(cs))
+ cc0 = - cs/cslam
+* #] calculations:
+* #[ debug:
+ if(lwrite)then
+* print *,'s3''s :'
+* print '(a)',' ##[ all terms: '
+* 1000 format(g12.6,1x,g12.6,1x,g12.6,1x,g12.6,1x,g12.6,1x,
+* + g12.6,1x,g12.6,1x,g12.6)
+* print 1000,(cs3(i),cs3(i+20),cs3(i+40),cs3(i+60),i=1,20)
+ print *,'ipi12: ',ipi12
+ print *,'isoort:' ,isoort
+* print '(a)',' ##] all terms: '
+ print *,'som :'
+ print *,cs,ipi12t,ier
+ endif
+* #] debug:
+*###] ffcc0b:
+ end
+*###[ ffcrt3:
+ subroutine ffcrt3(irota,cqi,cdqiqj,cpi,cdpipj,ns,iflag,ier)
+***#[*comment:***********************************************************
+* *
+* rotates the arrays cpi, cdpipj into cqi,cdqiqj so that *
+* cpi(6),cpi(4) suffer the strongest outside cancellations and *
+* cpi(6) > cpi(4) if iflag = 1, so that cpi(5) largest and cpi(5) *
+* and cpi(6) suffer cancellations if iflag = 2. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer irota,ns,iflag,ier
+ DOUBLE COMPLEX cpi(ns),cdpipj(ns,ns),cqi(ns),cdqiqj(ns,ns)
+*
+* local variables
+*
+ DOUBLE PRECISION a1,a2,a3,xpimax,absc
+ DOUBLE COMPLEX c
+ integer i,j,inew(6,6),ier0
+ save inew
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data inew /1,2,3,4,5,6,
+ + 2,3,1,5,6,4,
+ + 3,1,2,6,4,5,
+ + 1,3,2,6,5,4,
+ + 3,2,1,5,4,6,
+ + 2,1,3,4,6,5/
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ get largest cancellation:
+ if ( iflag .eq. 1 ) then
+ a1 = absc(cdpipj(6,4))/max(absc(cpi(6)+cpi(4)),xclogm)
+ a2 = absc(cdpipj(5,4))/max(absc(cpi(5)+cpi(4)),xclogm)
+ a3 = absc(cdpipj(5,6))/max(absc(cpi(6)+cpi(5)),xclogm)
+ if ( a1 .le. a2 .and. a1 .le. a3 ) then
+ if ( absc(cpi(6)) .lt. absc(cpi(4)) ) then
+ irota = 4
+ else
+ irota = 1
+ endif
+ elseif ( a2 .le. a3 ) then
+ if ( absc(cpi(4)) .lt. absc(cpi(5)) ) then
+ irota = 6
+ else
+ irota = 3
+ endif
+ else
+ if ( absc(cpi(5)) .lt. absc(cpi(6)) ) then
+ irota = 5
+ else
+ irota = 2
+ endif
+ endif
+ elseif ( iflag .eq. 2 ) then
+ xpimax = max(DBLE(cpi(4)),DBLE(cpi(5)),DBLE(cpi(6)))
+ if ( xpimax .eq. 0 ) then
+ if ( DBLE(cpi(5)) .ne. 0 ) then
+ irota = 1
+ elseif ( DBLE(cpi(4)) .ne. 0 ) then
+ irota = 2
+ elseif ( DBLE(cpi(6)) .ne. 0 ) then
+ irota = 3
+ else
+ call fferr(40,ier)
+ return
+ endif
+ elseif ( DBLE(cpi(5)) .eq. xpimax ) then
+ if ( DBLE(cpi(4)) .le. DBLE(cpi(6)) ) then
+ irota = 1
+ else
+ irota = 4
+ endif
+ elseif ( DBLE(cpi(4)) .eq. xpimax ) then
+ if ( DBLE(cpi(5)) .ge. DBLE(cpi(6)) ) then
+ irota = 2
+ else
+ irota = 5
+ endif
+ else
+ if ( DBLE(cpi(4)) .ge. DBLE(cpi(6)) ) then
+ irota = 3
+ else
+ irota = 6
+ endif
+ endif
+ else
+ call fferr(35,ier)
+ endif
+* #] get largest cancellation:
+* #[ rotate:
+ do 20 i=1,6
+ cqi(inew(i,irota)) = cpi(i)
+ do 10 j=1,6
+ cdqiqj(inew(i,irota),inew(j,irota)) = cdpipj(i,j)
+ 10 continue
+ 20 continue
+* #] rotate:
+* #[ test output:
+ if ( ltest ) then
+ ier0 = 0
+ call ffchck(cqi,cdqiqj,6,ier0)
+ if ( ier0 .ne. 0 ) print *,'ffcrt3: error: momenta wrong'
+ endif
+* #] test output:
+*###] ffcrt3:
+ end
+*###[ ffcot3:
+ subroutine ffcot3(cpiDpj,cpi,cdpipj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the dotproducts pi.pj with *
+* *
+* pi = si i1=1,3 *
+* pi = p(i-3) i1=4,6 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ns,ier
+ DOUBLE COMPLEX cpi(ns),cdpipj(ns,ns),cpiDpj(ns,ns)
+*
+* locals
+*
+ integer is1,is2,is3,ip1,ip2,ip3,i,ier0,ier1
+ DOUBLE COMPLEX check,c
+ DOUBLE PRECISION absc
+*
+* rest
+*
+ include 'ff.h'
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ calculations:
+*
+ ier1 = 0
+ do 10 is1=1,3
+ is2 = is1 + 1
+ if ( is2 .eq. 4 ) is2 = 1
+ is3 = is2 + 1
+ if ( is3 .eq. 4 ) is3 = 1
+ ip1 = is1 + 3
+ ip2 = is2 + 3
+ ip3 = is3 + 3
+*
+* pi.pj, si.sj
+*
+ cpiDpj(is1,is1) = cpi(is1)
+ cpiDpj(ip1,ip1) = cpi(ip1)
+*
+* si.s(i+1)
+*
+ if ( absc(cdpipj(is1,ip1)) .le. absc(cdpipj(is2,ip1)) ) then
+ cpiDpj(is1,is2) = (cdpipj(is1,ip1) + cpi(is2))/2
+ else
+ cpiDpj(is1,is2) = (cdpipj(is2,ip1) + cpi(is1))/2
+ endif
+ if ( lwarn ) then
+ ier0 = 0
+ if ( absc(cpiDpj(is1,is2)) .lt.
+ + xloss*min(absc(cpi(is1)),absc(cpi(is2)))/2 )
+ + call ffwarn(100,ier0,absc(cpiDpj(is1,is2)),
+ + min(absc(cpi(is1)),absc(cpi(is2)))/2)
+ ier1 = max(ier1,ier0)
+ endif
+ cpiDpj(is2,is1) = cpiDpj(is1,is2)
+*
+* pi.si
+*
+ if ( absc(cdpipj(is2,is1)) .le. absc(cdpipj(is2,ip1)) ) then
+ cpiDpj(ip1,is1) = (cdpipj(is2,is1) - cpi(ip1))/2
+ else
+ cpiDpj(ip1,is1) = (cdpipj(is2,ip1) - cpi(is1))/2
+ endif
+ if ( lwarn ) then
+ ier0 = 0
+ if ( absc(cpiDpj(ip1,is1)) .lt.
+ + xloss*min(absc(cpi(ip1)),absc(cpi(is1)))/2)
+ + call ffwarn(101,ier,absc(cpiDpj(ip1,is1)),
+ + min(absc(cpi(ip1)),absc(cpi(is1)))/2)
+ ier1 = max(ier1,ier0)
+ endif
+ cpiDpj(is1,ip1) = cpiDpj(ip1,is1)
+*
+* pi.s(i+1)
+*
+ if ( absc(cdpipj(is2,is1)) .le. absc(cdpipj(ip1,is1)) ) then
+ cpiDpj(ip1,is2) = (cdpipj(is2,is1) + cpi(ip1))/2
+ else
+ cpiDpj(ip1,is2) = (cdpipj(ip1,is1) + cpi(is2))/2
+ endif
+ if ( lwarn ) then
+ ier0 = 0
+ if ( absc(cpiDpj(ip1,is2)) .lt.
+ + xloss*min(absc(cpi(ip1)),absc(cpi(is2)))/2)
+ + call ffwarn(102,ier,absc(cpiDpj(ip1,is2)),
+ + min(absc(cpi(ip1)),absc(cpi(is2)))/2)
+ ier1 = max(ier1,ier0)
+ endif
+ cpiDpj(is2,ip1) = cpiDpj(ip1,is2)
+*
+* pi.s(i+2)
+*
+ if ( (absc(cdpipj(is2,is1)) .le. absc(cdpipj(ip3,is1)) .and.
+ + absc(cdpipj(is2,is1)) .le. absc(cdpipj(is2,ip2))) .or.
+ + (absc(cdpipj(ip3,ip2)) .le. absc(cdpipj(ip3,is1)) .and.
+ + absc(cdpipj(ip3,ip2)).le.absc(cdpipj(is2,ip2))))then
+ cpiDpj(ip1,is3) = (cdpipj(ip3,ip2)+cdpipj(is2,is1))/2
+ else
+ cpiDpj(ip1,is3) = (cdpipj(ip3,is1)+cdpipj(is2,ip2))/2
+ endif
+ if ( lwarn ) then
+ ier0 = 0
+ if ( absc(cpiDpj(ip1,is3)) .lt. xloss*min(absc(cdpipj(
+ + ip3,ip2)),absc(cdpipj(ip3,is1)))/2 ) call
+ + ffwarn(103,ier,absc(cpiDpj(ip1,is3)),min(absc(
+ + cdpipj(ip3,ip2)),absc(cdpipj(ip3,is1)))/2)
+ ier1 = max(ier1,ier0)
+ endif
+ cpiDpj(is3,ip1) = cpiDpj(ip1,is3)
+*
+* pi.p(i+1)
+*
+ if ( absc(cdpipj(ip3,ip1)) .le. absc(cdpipj(ip3,ip2)) ) then
+ cpiDpj(ip1,ip2) = (cdpipj(ip3,ip1) - cpi(ip2))/2
+ else
+ cpiDpj(ip1,ip2) = (cdpipj(ip3,ip2) - cpi(ip1))/2
+ endif
+ if ( lwarn ) then
+ ier0 = 0
+ if ( absc(cpiDpj(ip1,ip2)) .lt.
+ + xloss*min(absc(cpi(ip1)),absc(cpi(ip2)))/2 )
+ + call ffwarn(104,ier,absc(cpiDpj(ip1,ip2)),
+ + min(absc(cpi(ip1)),absc(cpi(ip2)))/2)
+ ier1 = max(ier1,ier0)
+ endif
+ cpiDpj(ip2,ip1) = cpiDpj(ip1,ip2)
+ 10 continue
+ ier = ier + ier1
+* #] calculations:
+* #[ check:
+ if ( ltest ) then
+ do 20 i = 1,6
+ check = cpiDpj(i,4) + cpiDpj(i,5) + cpiDpj(i,6)
+ if ( xloss*absc(check) .gt. precc*max(absc(cpiDpj(i,4)),
+ + absc(cpiDpj(i,5)),absc(cpiDpj(i,6))) ) print *,
+ + 'ffcot3: error: dotproducts with p(',i,
+ + ') wrong: ',check
+ 20 continue
+ endif
+* #] check:
+*###] ffcot3:
+ end
+*###[ ffbglg:
+ subroutine ffbglg(ifound,cqi,cqiqj,cqiDqj,ns,i1,i2,i3,ip1,ip3)
+***#[*comment:***********************************************************
+* *
+* Find a configuration which contains big logs, i.e. terms which *
+* would be IR divergent but for the finite width effects. *
+* We also use the criterium that delta^{s1 s2 s[34]}_{s1 s2 s[34]}*
+* should not be 0 when m^2 is shifted over nwidth*Im(m^2) *
+* *
+* Input: cqi(ns) (complex) masses, p^2 *
+* cqiqj(ns,ns) (complex) diff cqi(i)-cqi(j) * *
+* cqiDqj(ns,ns) (complex) cqi(i).cqi(j) * *
+* ns (integer) size of cqi,cqiqj *
+* i1,i2,i3 (integer) combo to be tested *
+* small,~onshell,~onshell *
+* ip1,ip3 (integer) (i1,i2) and (i1,i3) inx *
+* Output: ifound (integer) 0: no divergence, 1: IR *
+* -1: del(s,s,s)~0 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ifound,ns,i1,i2,i3,ip1,ip3
+ DOUBLE COMPLEX cqi(ns),cqiqj(ns,ns),cqiDqj(ns,ns)
+*
+* locals vars
+*
+ integer i123
+ DOUBLE PRECISION absc
+ DOUBLE COMPLEX cel3,cdm2,cdm3,c
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ work:
+ ifound = 0
+ if ( abs(DBLE(cqi(i1))) .lt. -xloss*(DIMAG(cqi(i2)) +
+ + DIMAG(cqi(i3)))
+ + .and. abs(DBLE(cqiqj(ip1,i2))) .le. -nwidth*DIMAG(cqi(i2))
+ + .and. abs(DBLE(cqiqj(ip3,i3))) .le. -nwidth*DIMAG(cqi(i3))
+ + ) then
+ if ( lwrite ) then
+ print *,'ffbglg: found large logs in ',i1,i2,i3
+ print *,' small mass = ',cqi(i1)
+ print *,' onshell mass = ',cqi(i2),cqi(ip1),
+ + cqiqj(ip1,i2)
+ print *,' onshell mass = ',cqi(i3),cqi(ip3),
+ + cqiqj(ip3,i3)
+ endif
+ ifound = 1
+ return
+ endif
+ if ( nschem.ge.5 .and. cqi(i1).eq.0 ) then
+ i123 = 2**i1 + 2**i2 + 2**i3
+ if ( i123.eq.2**1+2**2+2**3 .or. i123.eq.2**1+2**2+2**4 )
+ + then
+ cel3 = - cqiDqj(i1,i2)**2*cqi(i3)
+ + - cqiDqj(i1,i3)**2*cqi(i2)
+ + + 2*cqiDqj(i1,i2)*cqiDqj(i1,i3)*cqiDqj(i2,i3)
+ cdm2 = cqiDqj(i1,i2)*cqiDqj(ip3,i3) +
+ + cqiDqj(i1,i3)*cqiDqj(ip1,i3)
+ cdm3 = -cqiDqj(i1,i2)*cqiDqj(ip3,i2) -
+ + cqiDqj(i1,i3)*cqiDqj(ip1,i2)
+ if ( lwrite ) then
+ print *,'ffbglg: examining ',i1,i2,i3
+ print *,' cel3 = ',cel3
+ print *,' dcel3/dm2*Im(m2) = ',cdm2*DIMAG(cqi(i2))
+ print *,' dcel3/dm3*Im(m3) = ',cdm3*DIMAG(cqi(i3))
+ endif
+ if ( 2*absc(cel3) .lt.-nwidth*(absc(cdm2)*DIMAG(cqi(i2))
+ + + absc(cdm3)*DIMAG(cqi(i3))) ) then
+ ifound = -1
+ if ( lwrite ) print *,' found near-IR divergence.'
+ endif
+ endif
+ endif
+* #] work:
+*###] ffbglg:
+ end
+*###[ ffthre:
+ subroutine ffthre(ithres,cqi,cqiqj,ns,i1,i2,ip)
+***#[*comment:***********************************************************
+* *
+* look for threshold effects. *
+* ithres = 1: 3 heavy masses *
+* ithres = 2: 2 masses almost equal and 1 zero *
+* *
+* Input: cqi(ns) (complex) usual masses,p^2 *
+* cqiqj(ns,ns) (complex) cqi(i)-cqi(j) *
+* ns (integer) size *
+* i1,i2 (integer) position to be tested *
+* ip (integer) (i1,i2) index *
+* *
+* Output: ithres (integer) see above, 0 if nothing *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ithres,ns,i1,i2,ip
+ DOUBLE COMPLEX cqi(ns),cqiqj(ns,ns)
+*
+* local variables
+*
+ integer ier0
+ DOUBLE COMPLEX c
+ DOUBLE PRECISION absc,xq1,xq2,xq3,dq1q2,dq1q3,dq2q3,xlam,d1,d2,
+ + sprecx
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ work:
+ ithres = 0
+ if ( DIMAG(cqi(i1)).eq.0 .and. DIMAG(cqi(i2)).eq.0 .or.
+ + nschem.le.4 ) return
+ if ( DBLE(cqi(i1)).lt.-DIMAG(cqi(i2)) .and.
+ + abs(DBLE(cqiqj(ip,i2))).lt.-nwidth*DIMAG(cqi(i2))
+ + .or. DBLE(cqi(i2)).lt.-DIMAG(cqi(i1)) .and.
+ + abs(DBLE(cqiqj(ip,i1))).lt.-nwidth*DIMAG(cqi(i1)) ) then
+ if ( lwrite ) then
+ xlam = min(abs(DBLE(cqiqj(ip,i1))),
+ + abs(DBLE(cqiqj(ip,i2))))
+ endif
+ ithres = 2
+ elseif ( nschem.ge.6 .and. DBLE(cqi(i1)).ne.0 .and.
+ + DBLE(cqi(i2)).ne.0 ) then
+ ier0 = 0
+ xq1 = DBLE(cqi(i1))
+ xq2 = DBLE(cqi(i2))
+ xq3 = DBLE(cqi(ip))
+ dq1q2 = DBLE(cqiqj(i1,i2))
+ dq1q3 = DBLE(cqiqj(i1,ip))
+ dq2q3 = DBLE(cqiqj(i2,ip))
+ sprecx = precx
+ precx = precc
+ call ffxlmb(xlam,xq1,xq2,xq3, dq1q2,dq1q3,dq2q3, ier0)
+ precx = sprecx
+ d1 = absc(cqiqj(i1,ip) - cqi(i2))
+ d2 = absc(cqiqj(i2,ip) - cqi(i1))
+* if ( d1 .lt. -nwidth*DIMAG(cqi(i1)) .or.
+** + d2 .lt. -nwidth*DIMAG(cqi(i2)) )
+** + call ffwarn(182,ier0,x1,x1)
+ if ( abs(xlam) .lt. -nwidth*(DBLE(d1)*
+ + DIMAG(cqi(i1)) + d2*DIMAG(cqi(i2))) ) then
+ ithres = 1
+ if ( lwrite ) xlam = sqrt(abs(xlam))
+ endif
+ endif
+ if ( lwrite .and. ithres .ne. 0 )
+ + print *,'ffthre: threshold in vertex ',i1,i2,ip,': ',
+ + ithres,xlam,cqi(i1),cqi(i2),cqi(ip)
+* #] work:
+*###] ffthre:
+ end
+*###[ ffcod3:
+ subroutine ffcod3(cpi)
+***#[*comment:***********************************************************
+* *
+* Convert real dorproducts into complex ones, adding the *
+* imaginary parts where appropriate. *
+* *
+* Input: cpi(6) complex m^2, p^2 *
+* /ffdots/fpij3(6,6) real p.p real *
+* *
+* Output: /ffcots/cfpij3(6,6) complex p.p complex *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cpi(6)
+*
+* local variables
+*
+ integer i,i1,i2,ip
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ print info:
+*
+ if ( lwrite ) then
+ print *,'ffcod3: converting real to complex dotproducts'
+ endif
+*
+* #] print info:
+* #[ add widths:
+*
+ do 25 i=1,3
+ ip = i+3
+ i1 = 1 + mod(i,3)
+ i2 = 1 + mod(i1,3)
+* s.s
+ cfpij3(i,i) = cpi(i)
+ cfpij3(i1,i) = DCMPLX(DBLE(fpij3(i1,i)),
+ + (DIMAG(cpi(i1))+DIMAG(cpi(i)))/2)
+ cfpij3(i,i1) = cfpij3(i1,i)
+* s.p
+ cfpij3(i,ip) = DCMPLX(DBLE(fpij3(i,ip)),
+ + (DIMAG(cpi(i1))-DIMAG(cpi(i)))/2)
+ cfpij3(ip,i) = cfpij3(i,ip)
+ cfpij3(i1,ip) = DCMPLX(DBLE(fpij3(i1,ip)),
+ + (DIMAG(cpi(i1))-DIMAG(cpi(i)))/2)
+ cfpij3(ip,i1) = cfpij3(i1,ip)
+ cfpij3(i2,ip) = DCMPLX(DBLE(fpij3(i2,ip)),
+ + (DIMAG(cpi(i1))-DIMAG(cpi(i)))/2)
+ cfpij3(ip,i2) = cfpij3(i2,ip)
+* p.p
+ cfpij3(ip,ip) = cpi(ip)
+ cfpij3(ip,i1+3) = fpij3(ip,i1+3)
+ cfpij3(i1+3,ip) = cfpij3(ip,i1+3)
+ 25 continue
+ fodel2 = fdel2
+*
+* #] add widths:
+*###] ffcod3:
+ end
diff --git a/ff-2.0/ffcc0p.f b/ff-2.0/ffcc0p.f
new file mode 100644
index 0000000..e29205b
--- /dev/null
+++ b/ff-2.0/ffcc0p.f
@@ -0,0 +1,638 @@
+*###[ ffcc0p:
+ subroutine ffcc0p(cs3,ipi12,isoort,clogi,ilogi,cpi,cpipj,
+ + cpiDpj,sdel2,cel2si,etalam,etami,delpsi,alpha,npoin,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the threepoint function closely following *
+* recipe in 't Hooft & Veltman, NP B(183) 1979. *
+* Bjorken and Drell metric is used nowadays! *
+* *
+* p2 ^ | *
+* | | *
+* / \ *
+* m2/ \m3 *
+* p1 / \ p3 *
+* <- / m1 \ -> *
+* ------------------------ *
+* *
+* Input: cpi(1-3) (complex) pi squared (,2=untransformed *
+* when npoin=4) *
+* cpi(4-6) (complex) internal mass squared *
+* cpipj(6,6) (complex) cpi(i)-cpi(j) *
+* cpiDpj(6,6) (complex) pi(i).pi(j) *
+* *
+* Output: cs3 (complex)(48) C0, not yet summed. *
+* ipi12 (integer)(3) factors pi^2/12, not yet summed *
+* cslam (complex) lambda(p1,p2,p3). *
+* isoort (integer)(3) indication of he method used *
+* ier (integer) 0=ok, 1=inaccurate, 2=error *
+* *
+* Calls: ffcel2,ffcoot,ffccyz,ffcdwz,ffcs3,ffcs4 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(8),isoort(8),ilogi(3),npoin,ier
+ DOUBLE COMPLEX cs3(80),clogi(3),cpi(6),cpipj(6,6),
+ + cpiDpj(6,6),sdel2,cel2si(3),etalam,etami(6),
+ + delpsi(3),alpha(3)
+*
+* local variables:
+*
+ integer i,j,k,ip,ierw,jsoort(8),iw,ismall(3),ier0
+ logical l4,l4pos
+ DOUBLE COMPLEX c,cs,zfflog,cs1,cs2,cs4,ci
+ DOUBLE COMPLEX cy(4,3),cz(4,3),cw(4,3),cdyz(2,2,3),
+ + cdwy(2,2,3),cdwz(2,2,3),cd2yzz(3),cd2yww(3)
+ DOUBLE COMPLEX csdl2i(3)
+* DOUBLE COMPLEX cyp,cym,ca,cb,cc,cd
+ DOUBLE COMPLEX zfflo1
+ DOUBLE PRECISION absc
+*FOR ABSOFT ONLY
+* DOUBLE COMPLEX csqrt
+* external csqrt
+*
+* common blocks:
+*
+ include 'ff.h'
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ ier0 = 0
+ call ffchck(cpi,cpipj,6,ier0)
+ if ( ier0 .ne. 0 ) print *,'ffcc0p: error: ',
+ + 'transformed momenta wrong'
+ endif
+* #] check input:
+* #[ get roots etc:
+* #[ get z-roots:
+ if ( npoin .ne. 3 ) then
+ l4pos = .FALSE.
+ else
+ l4pos = l4also
+ endif
+ if ( lwrite ) print '(a)',' ##[ get roots: (ffcc0p)'
+ do 10 i=1,3
+*
+* get roots (y,z)
+*
+ ip = i+3
+* first get the roots
+ j = i+1
+ if ( j .eq. 4 ) j = 1
+ csdl2i(i) = sqrt(-cel2si(i))
+ if ( cpi(ip) .eq. 0 ) then
+ if ( i .eq. 1 .and. alpha(3) .eq. 0 .or.
+ + i .eq. 3 .and. alpha(1) .eq. 0 ) then
+ isoort(2*i-1) = 0
+ isoort(2*i) = 0
+ l4pos = .FALSE.
+ goto 10
+ endif
+ endif
+ call ffccyz(cy(1,i),cz(1,i),cdyz(1,1,i),cd2yzz(i),i,
+ + sdel2,csdl2i(i),etalam,etami,delpsi(i),
+ + cpi,cpiDpj,isoort(2*i-1),6,ier)
+ 10 continue
+* if ( lwrite ) then
+* print *,'cy(1) = ',cy(2,1)
+* print *,'vgl = ',cy(4,2)/alpha(3)
+* print *,'cy(3)1 = ',cy(4,3)
+* print *,'vgl = ',cy(2,2)/alpha(1)
+* endif
+* #] get z-roots:
+* #[ get w-roots:
+*
+* get w's:
+*
+ ierw = 0
+ l4 = .FALSE.
+ if ( isoort(4) .eq. 0 ) then
+ call fferr(10,ierw)
+ goto 90
+ endif
+ do 70 iw = 1,3,2
+ if ( .not. l4pos .or. alpha(4-iw) .eq. 0 ) then
+ jsoort(2*iw-1) = 0
+ jsoort(2*iw) = 0
+ l4pos = .FALSE.
+ else
+ jsoort(2*iw-1) = -1
+ jsoort(2*iw) = -1
+ cd2yww(iw) = -cd2yzz(2)/alpha(4-iw)
+ do 20 j=1,2
+ cw(j+iw-1,iw) = cz(j+3-iw,2)/alpha(4-iw)
+ cw(j+3-iw,iw) = 1 - cw(j+iw-1,iw)
+ if ( absc(cw(j+3-iw,iw)) .lt. xloss ) then
+ if (lwrite) print *,' cw(',j+3-iw,iw,') = ',
+ + cw(j+3-iw,iw),x1
+ cs = cz(j+iw-1,2) - alpha(iw)
+ if ( absc(cs) .lt. xloss*absc(alpha(iw)) ) then
+ ierw = 1
+ goto 70
+ endif
+ cw(j+3-iw,iw) = cs/alpha(4-iw)
+ if (lwrite) print *,' cw(',j+3-iw,iw,')+ = ',
+ + cw(j+3-iw,iw),absc(alpha(iw))/absc(alpha(4-iw))
+ endif
+ cdwy(j,2,iw) = cdyz(2,j,2)/alpha(4-iw)
+ do 15 i=1,2
+ cdwz(j,i,iw) = cw(j,iw) - cz(i,iw)
+ if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cw(j,iw)) )
+ + goto 14
+ if ( lwrite ) print *,' cdwz(',j,i,iw,') = ',
+ + cdwz(j,i,iw),absc(cw(j,iw))
+ cdwz(j,i,iw) = cz(i+2,iw) - cw(j+2,iw)
+ if ( lwrite ) print *,' cdwz(',j,i,iw,')+ = ',
+ + cdwz(j,i,iw),absc(cw(j+2,iw))
+ if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cw(j+2,iw)) )
+ + goto 14
+ cdwz(j,i,iw) = cdwy(j,2,iw) + cdyz(2,i,iw)
+ if ( lwrite ) print *,' cdwz(',j,i,iw,')++= ',
+ + cdwz(j,i,iw),absc(cdwy(j,2,iw))
+ if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cdwy(j,2,iw)) )
+ + goto 14
+ l4 = .TRUE.
+ call ffcdwz(cdwz(1,1,iw),cw(1,iw),cz(1,iw),j,i,iw,
+ + alpha(1),alpha(3),cpi,cpipj,cpiDpj,csdl2i,
+ + sdel2,6,ierw)
+ 14 continue
+ 15 continue
+ 20 continue
+ endif
+ 70 continue
+* #] get w-roots:
+* #[ write output:
+ if ( lwrite ) then
+ print *,'ffcc0p: found roots:'
+ do 85 i=1,3
+ print *,' k = ',i
+ if ( isoort(2*i) .ne. 0 ) then
+ print *,' cym,cym1 = ',cy(1,i),cy(3,i),
+ + '(not used)'
+ print *,' cyp,cyp1 = ',cy(2,i),cy(4,i)
+ print *,' czm,czm1 = ',cz(1,i),cz(3,i)
+ print *,' czp,czp1 = ',cz(2,i),cz(4,i)
+ if ( i .ne. 2 .and. l4pos ) then
+ print *,' cwm,cwm1 = ',cw(1,i),cw(3,i)
+ print *,' cwp,cwp1 = ',cw(2,i),cw(4,i)
+ endif
+ else
+ if ( isoort(2*i-1) .eq. 0 ) then
+ print *,' no roots, all is zero'
+ else
+ print *,' cyp,cyp1 = ',cy(2,i),
+ + cy(4,i)
+ print *,' czp,czp1 = ',cz(2,i),
+ + cz(4,i)
+ if ( i .ne. 2 .and. jsoort(2*i-1) .ne. 0 ) then
+ print *,' cwm,cwm1 = ',cw(1,i),cw(3,i)
+ print *,' cwp,cwp1 = ',cw(2,i),cw(4,i)
+ endif
+ endif
+ endif
+ 85 continue
+ 86 continue
+ print '(a)',' ##] get roots:'
+ endif
+* #] write output:
+* #[ which case:
+ 90 if ( l4 ) then
+ if ( DIMAG(alpha(1)) .ne. 0 ) then
+ if ( lwrite ) print *,'ffcc0p: cannot handle unphysical'
+ + ,' momenta in 16 dilogs (yet)'
+ l4pos = .FALSE.
+ elseif ( ierw .ge. 1 ) then
+ l4pos = .FALSE.
+ else
+ ier = max(ier,ierw)
+ endif
+ endif
+* #] which case:
+* #] get roots etc:
+* #[ logarithms for 4point function:
+ if ( npoin .eq. 4 ) then
+ if ( lwrite ) print '(a)',' ##[ logarithms for Ai<0:'
+ do 95 i = 1,3
+ ismall(i) = 0
+ if ( ilogi(i) .ne. -999 ) goto 95
+ if ( isoort(2*i) .ne. 0 ) then
+* maybe add sophisticated factors i*pi later
+ c = -cdyz(2,1,i)/cdyz(2,2,i)
+ if ( lwrite ) then
+* fantasize imag part, but suppress error message
+ print *,'c = ',c
+ clogi(i) = zfflog(c,1,c1,ier0)
+ print *,'clogi = ',clogi(i)
+ endif
+ if ( absc(c-1) .lt. xloss ) then
+ cs = cd2yzz(i)/cdyz(2,2,i)
+ clogi(i) = zfflo1(cs,ier)
+ ilogi(i) = 0
+ ismall(i) = 1
+ if ( lwrite ) then
+ print *,'c = ',c
+ print *,'c+= ',1-cs
+ endif
+ elseif ( DBLE(c) .gt. 0 ) then
+ clogi(i) = zfflog(c,0,c0,ier)
+ ilogi(i) = 0
+ else
+ if ( absc(c+1) .lt. xloss ) then
+ cs = -2*csdl2i(i)/cdyz(2,2,i)/
+ + DBLE(cpi(i+3))
+ clogi(i) = zfflo1(cs,ier)
+ ismall(i) = -1
+ if ( lwrite ) then
+ print *,'c = ',c
+ print *,'c+= ',-1+cs
+ endif
+ else
+ cs = 0
+ clogi(i) = zfflog(-c,0,c0,ier)
+ endif
+ if ( DIMAG(c).lt.0 .or. DIMAG(cs).lt.0 ) then
+ ilogi(i) = -1
+ elseif ( DIMAG(c).gt.0 .or. DIMAG(cs).gt.0 ) then
+ ilogi(i) = +1
+ elseif ( DBLE(cdyz(2,2,i)) .eq. 0 ) then
+ ilogi(i)=-nint(sign(DBLE(x1),DBLE(cpi(i+3))))
+ ier = ier + 50
+ print *,'doubtful imaginary part ',ilogi(i)
+ endif
+ if ( abs(DIMAG(c)).lt.precc*absc(c) .and.
+ + abs(DIMAG(cs)).lt.precc*absc(cs) ) then
+ print *,'ffcc0p: error: imaginary part doubtful'
+ ier = ier + 50
+ endif
+ endif
+ if ( lwrite ) then
+ print *,'clogi+ = ',i,clogi(i),ilogi(i)
+ if ( ilogi(i).ne.0 ) then
+ print *,' = ',i,clogi(i)+DCMPLX(x0,pi)*
+ + ilogi(i)
+ endif
+ endif
+ endif
+ 95 continue
+ do 96 i=1,3
+ j = i + 1
+ if ( j .eq. 4 ) j = 1
+ if ( abs(ismall(i)+ismall(j)) .eq. 2 .and. absc(clogi(i)+
+ + clogi(j)) .lt. xloss*absc(clogi(i)) ) then
+ print *,'eerst: ',clogi(i)+clogi(j)
+* assume that we got here because of complex sqrt(-delta)
+ ci = DCMPLX(DBLE(0),DBLE(1))
+ cs1=-2*ci*DIMAG(cy(2,i))*csdl2i(j)/DBLE(cpi(j+3))/
+ + (cdyz(2,2,i)*cdyz(2,2,j))
+ cs2=-2*ci*DIMAG(cy(2,j))*csdl2i(i)/DBLE(cpi(i+3))/
+ + (cdyz(2,2,i)*cdyz(2,2,j))
+ cs = cs1 + cs2
+ if ( absc(cs) .lt. xloss*absc(cs1) ) then
+ if ( lwrite ) print *,'Eerste poging:',cs,cs1,cs2
+ k = j+1
+ if ( k .eq. 4 ) k = 1
+ cs1 = cpipj(j+3,i+3)*cpi(j)
+ cs2 = cpiDpj(k+3,j)*cpiDpj(j+3,j)
+ cs4 = -cpiDpj(k+3,j)*cpiDpj(i+3,j)
+ cs = cs1 + cs2 + cs4
+ if ( lwrite ) then
+ print *,'csdl2i(i)-csdl2i(j) = ',
+ + csdl2i(i)-csdl2i(j),absc(csdl2i(i))
+ print *,'csdl2i(i)-csdl2i(j)+= ',cs/
+ + (csdl2i(i)+csdl2i(j))
+ endif
+ if ( absc(cs) .lt. xloss*max(absc(cs1),absc(cs2),
+ + absc(cs4)) ) then
+ print *,'ffcc0p: cancellations in delj-deli'
+ goto 96
+ endif
+ cs1=ci*DIMAG(cy(2,j))*cs/(csdl2i(i)+csdl2i(j))
+ call ffcl2t(cs2,cpiDpj,k+3,j,4,5,6,+1,-1,6,ier)
+ cs2 = -cs2*csdl2i(j)/sdel2/DBLE(cpi(j+3))
+ cs = cs1 + cs2
+ if ( lwrite ) print *,'Tweede poging:',cs,cs1,cs2
+ if ( absc(cs) .lt. xloss*absc(cs1) ) then
+ print *,'ffcc0p: cancellations in extra terms'
+ goto 96
+ endif
+ cs = -2*cs/DBLE(cpi(i+3))/(cdyz(2,2,i)*
+ + cdyz(2,2,j))
+ endif
+ clogi(i) = zfflo1(cs,ier)
+ clogi(j) = 0
+ print *,'nu: ',clogi(i)+clogi(j)
+ endif
+ 96 continue
+ if ( lwrite ) print '(a)',' ##] logarithms for Ai<0:'
+ endif
+* #] logarithms for 4point function:
+* #[ integrals:
+ if ( .not. l4 .or. .not. l4pos ) then
+* normal case
+ do 200 i=1,3
+ if ( lwrite ) print '(a,i1,a)',' ##[ s3 nr ',i,':'
+ j = 2*i-1
+ if ( isoort(2*i-1) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffcc0p: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j),isoort(j+1)
+ endif
+ else
+ call ffcs3(cs3(20*i-19),ipi12(2*i-1),cy(1,i),
+ + cz(1,i),cdyz(1,1,i),cd2yzz(i),cpi,cpiDpj,
+ + i,6,isoort(j),ier)
+ endif
+ if ( lwrite ) print '(a,i1,a)',' ##] s3 nr ',i,':'
+ 200 continue
+ isoort(7) = 0
+ isoort(8) = 0
+ else
+ if ( lwrite ) print '(a)',' ##[ s4 nr 1:'
+ isoort(3) = jsoort(1)
+ isoort(4) = jsoort(2)
+ call ffcs4(cs3(1),ipi12(1),cw(1,1),cy(1,1),
+ + cz(1,1),cdwy(1,1,1),cdwz(1,1,1),cdyz(1,1,1),
+ + cd2yww(1),cd2yzz(1),cpi,cpiDpj,
+ + cpi(5)*alpha(3)**2,etami,1,6,isoort(1),ier)
+ if ( lwrite ) print '(a)',' ##] s4 nr 1:'
+ if ( lwrite ) print '(a)',' ##[ s4 nr 2:'
+ isoort(7) = jsoort(5)
+ isoort(8) = jsoort(6)
+ call ffcs4(cs3(41),ipi12(1),cw(1,3),cy(1,3),
+ + cz(1,3),cdwy(1,1,3),cdwz(1,1,3),cdyz(1,1,3),
+ + cd2yww(3),cd2yzz(3),cpi,cpiDpj,
+ + cpi(5)*alpha(1)**2,etami,3,6,isoort(5),ier)
+ if ( lwrite ) print '(a)',' ##] s4 nr 2:'
+ endif
+* #] integrals:
+*###] ffcc0p:
+ end
+*###[ ffccyz:
+ subroutine ffccyz(cy,cz,cdyz,cd2yzz,ivert,csdelp,csdels,etalam,
+ + etami,delps,xpi,piDpj,isoort,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* *
+* cz(1,2) = (-p(ip1).p(is2) +/- csdelp)/xpi(ip1) *
+* cy(1,2) = (-p(ip1).p(is2) +/- sdisc)/xpi(ip1) *
+* cdisc = csdels + etaslam*xpi(ip1) *
+* *
+* cy(3,4) = 1-cy(1,2) *
+* cz(3,4) = 1-cz(1,2) *
+* cdyz(i,j) = cy(i) - cz(j) *
+* *
+* Input: ivert (integer) defines the vertex *
+* csdelp (complex) sqrt(lam(p1,p2,p3))/2 *
+* csdels (complex) sqrt(lam(p,ma,mb))/2 *
+* etalam (complex) det(si.sj)/det(pi.pj) *
+* etami(6) (complex) si.si - etalam *
+* xpi(ns) (complex) standard *
+* piDpj(ns,ns) (complex) standard *
+* ns (integer) dim of xpi,piDpj *
+* *
+* Output: cy(4),cz(4),cdyz(4,4) (complex) see above *
+* ier (integer) usual error flag *
+* *
+* Calls: fferr,ffroot *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ivert,ns,ier,isoort(2)
+ DOUBLE COMPLEX cy(4),cz(4),cdyz(2,2),cd2yzz,csdelp,csdels
+ DOUBLE COMPLEX etalam,etami(6),delps,xpi(6),piDpj(6,6)
+*
+* local variables:
+*
+ integer i,j,ip1,ip2,ip3,is1,is2,is3,ier0
+ DOUBLE COMPLEX cverg,cdisc,c,check,dpipj(6,6)
+ DOUBLE PRECISION absc,rloss
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ set up pointers:
+ if ( lwrite ) print *,'ffccyz: ivert = ',ivert
+ if ( ltest .and. ns .ne. 6 ) then
+ print *,'ffccyz: error: ns != 6 !!',ns
+ stop
+ endif
+ is1 = ivert
+ is2 = ivert+1
+ if ( is2 .eq. 4 ) is2 = 1
+ is3 = ivert-1
+ if ( is3 .eq. 0 ) is3 = 3
+ ip1 = is1 + 3
+ ip2 = is2 + 3
+ ip3 = is3 + 3
+* #] set up pointers:
+* #[ check input:
+ if ( ltest ) then
+ ier0 = ier
+ dpipj(1,1) = 1
+ call ffcl2p(cverg,xpi,dpipj,piDpj,ip1,ip2,ip3,is1,is2,is3,6,
+ + ier0)
+ rloss = xloss*DBLE(10)**(-mod(ier0,50))
+ if ( rloss*absc(cverg-delps).gt.precc*absc(cverg) ) print *,
+ + 'ffccyz: error: delps <> cverg',delps,cverg,delps-cverg
+ ier0 = ier
+ call ffcel2(cverg,piDpj,6,ip1,ip2,ip3,1,ier0)
+ rloss = xloss*DBLE(10)**(-mod(ier0,50))
+ if ( rloss*absc(cverg+csdelp**2) .gt. precc*absc(cverg) )
+ + print *,'ffccyz: error: csdelp**2 incorrect ',
+ + csdelp**2,-cverg,csdelp**2+cverg
+ ier0 = ier
+ call ffcel3(cverg,xpi,piDpj,6,ier0)
+ check = etami(is2)-xpi(is2)-cverg/csdelp**2
+ rloss = xloss**2*DBLE(10)**(-mod(ier0,50))
+ if ( rloss*absc(check) .gt. precc*max(absc(etami(is2)),
+ + absc(xpi(is2)),absc(cverg/csdelp**2)) ) print *,
+ + 'ffccyz: error: etami(',is2,') incorrect ',
+ + etami(is2),xpi(is2)+cverg/csdelp**2,check,ier0
+ endif
+* #] check input:
+* #[ xk = 0:
+ if ( xpi(ip1) .eq. 0 ) then
+ isoort(2) = 0
+ if ( piDpj(is1,ip1) .eq. 0 ) then
+ isoort(1) = 0
+ if (lwrite) print *,' ck = 0, cm1 = cm2, so cs3 = 0'
+ return
+ endif
+ if ( DIMAG(etalam).ne.0 ) then
+ isoort(1) = -1
+ else
+ isoort(1) = -3
+ endif
+ cy(1) = etami(is2) / piDpj(is1,ip1) /2
+ cy(2) = cy(1)
+ cy(3) = - etami(is1) / piDpj(is1,ip1) /2
+ cy(4) = cy(3)
+ cz(1) = xpi(is2) / piDpj(is1,ip1) /2
+ cz(2) = cz(1)
+ cz(3) = - xpi(is1) / piDpj(is1,ip1) /2
+ cz(4) = cz(3)
+ cdyz(1,1) = - etalam / piDpj(is1,ip1) /2
+ cdyz(1,2) = cdyz(1,1)
+ cdyz(2,1) = cdyz(1,1)
+ cdyz(2,2) = cdyz(1,1)
+ if ( ltest ) then
+* check whether we have the correct root ...
+ call ffcl2p(cverg,xpi,dpipj,piDpj,ip1,ip2,ip3,
+ + is1,is2,is3,6,ier)
+ cdisc = cverg/csdelp
+ check = piDpj(ip1,is2) + cdisc
+ if ( xloss*absc(check) .gt. precc*max(absc(piDpj(
+ + ip1,is2)),absc(cdisc)) ) then
+ call fferr(36,ier)
+ if ( lwrite ) then
+ print *,'piDpj(',ip1,is2,') = ',piDpj(ip1,is2)
+ print *,'cdisc = ',cdisc
+ print *,'diff = ',check
+ endif
+ endif
+ endif
+ return
+ endif
+* #] xk = 0:
+* #[ get cy(1,2),cz(1,2):
+ if ( DIMAG(etalam).ne.0 ) then
+ isoort(1) = -1
+ isoort(2) = -1
+ else
+ isoort(1) = -3
+ isoort(2) = -3
+ endif
+ call ffcoot(cz(1),cz(2),xpi(ip1),piDpj(ip1,is2),xpi(is2),
+ + csdels,ier)
+ cdisc = delps/csdelp
+ call ffcoot(cy(1),cy(2),xpi(ip1),piDpj(ip1,is2),etami(is2),
+ + cdisc,ier)
+* #] get cy(1,2),cz(1,2):
+* #[ get cy(3,4),cz(3,4):
+ cz(4) = 1-cz(2)
+ cz(3) = 1-cz(1)
+ if ( absc(cz(3)) .lt. xloss .or. absc(cz(4)) .lt. xloss ) then
+ call ffcoot(cz(4),cz(3),xpi(ip1),-piDpj(ip1,is1),
+ + xpi(is1),csdels,ier)
+ endif
+* the imaginary part may not be accurate in these cases, take
+* some precautions:
+ if ( cz(3) .eq. 0 ) cz(1) = 1
+ if ( cz(4) .eq. 0 ) cz(2) = 1
+ if ( DIMAG(cz(1)).eq.0 )
+ + cz(1) = DCMPLX(DBLE(cz(1)),-DIMAG(cz(3)))
+ if ( DIMAG(cz(2)).eq.0 )
+ + cz(2) = DCMPLX(DBLE(cz(2)),-DIMAG(cz(4)))
+ if ( DIMAG(cz(1)) .gt. 0 .neqv. DIMAG(cz(3)) .lt. 0 ) then
+ if ( abs(DBLE(cz(1))) .ge. abs(DBLE(cz(3))) ) then
+ cz(1) = DCMPLX(DBLE(cz(1)),-DIMAG(cz(3)))
+ if ( lwrite ) print *,'ffccyz: comment: imaginary ',
+ + 'part z1 changed to -z3'
+ else
+ cz(3) = DCMPLX(DBLE(cz(3)),-DIMAG(cz(1)))
+ if ( lwrite ) print *,'ffccyz: comment: imaginary ',
+ + 'part z3 changed to -z1'
+ endif
+ endif
+ if ( DIMAG(cz(2)) .gt. 0 .neqv. DIMAG(cz(4)) .lt. 0 ) then
+ if ( abs(DBLE(cz(2))) .ge. abs(DBLE(cz(4))) ) then
+ cz(2) = DCMPLX(DBLE(cz(2)),-DIMAG(cz(4)))
+ if ( lwrite ) print *,'ffccyz: comment: imaginary ',
+ + 'part z2 changed to -z4'
+ else
+ cz(4) = DCMPLX(DBLE(cz(4)),-DIMAG(cz(2)))
+ if ( lwrite ) print *,'ffccyz: comment: imaginary ',
+ + 'part z4 changed to -z2'
+ endif
+ endif
+ cy(4) = 1-cy(2)
+ cy(3) = 1-cy(1)
+ if ( absc(cy(3)) .lt. xloss .or. absc(cy(4)) .lt. xloss ) then
+ call ffcoot(cy(4),cy(3),xpi(ip1),-piDpj(ip1,is1),
+ + etami(is1),cdisc,ier)
+ endif
+ if ( cy(3) .eq. 0 ) cy(1) = 1
+ if ( cy(4) .eq. 0 ) cy(2) = 1
+ if ( DIMAG(cy(1)).eq.0 )
+ + cy(1) = DCMPLX(DBLE(cy(1)),-DIMAG(cy(3)))
+ if ( DIMAG(cy(2)).eq.0 )
+ + cy(2) = DCMPLX(DBLE(cy(2)),-DIMAG(cy(4)))
+ if ( DIMAG(cy(1)) .gt. 0 .neqv. DIMAG(cy(3)) .lt. 0 ) then
+ if ( abs(DBLE(cy(1))) .ge. abs(DBLE(cy(3))) ) then
+ cy(1) = DCMPLX(DBLE(cy(1)),-DIMAG(cy(3)))
+ if ( lwrite ) print *,'ffccyz: comment: imaginary ',
+ + 'part y1 changed to -y3'
+ else
+ cy(3) = DCMPLX(DBLE(cy(3)),-DIMAG(cy(1)))
+ if ( lwrite ) print *,'ffccyz: comment: imaginary ',
+ + 'part y3 changed to -y1'
+ endif
+ endif
+ if ( DIMAG(cy(2)) .gt. 0 .neqv. DIMAG(cy(4)) .lt. 0 ) then
+ if ( abs(DBLE(cy(2))) .ge. abs(DBLE(cy(4))) ) then
+ cy(2) = DCMPLX(DBLE(cy(2)),-DIMAG(cy(4)))
+ if ( lwrite ) print *,'ffccyz: comment: imaginary ',
+ + 'part y2 changed to -y4'
+ else
+ cy(4) = DCMPLX(DBLE(cy(4)),-DIMAG(cy(2)))
+ if ( lwrite ) print *,'ffccyz: comment: imaginary ',
+ + 'part y4 changed to -y2'
+ endif
+ endif
+* #] get cy(3,4),cz(3,4):
+* #[ get cdyz:
+* Note that cdyz(i,j) only exists for i,j=1,2!
+ if ( absc(cdisc+csdels) .gt. xloss*absc(cdisc) ) then
+ cdyz(2,1) = ( cdisc + csdels )/xpi(ip1)
+ cdyz(2,2) = etalam/(xpi(ip1)*cdyz(2,1))
+ else
+ cdyz(2,2) = ( cdisc - csdels )/xpi(ip1)
+ cdyz(2,1) = etalam/(xpi(ip1)*cdyz(2,2))
+ endif
+ cdyz(1,1) = -cdyz(2,2)
+ cdyz(1,2) = -cdyz(2,1)
+ cd2yzz = 2*cdisc/xpi(ip1)
+* #] get cdyz:
+* #[ test output:
+ if ( ltest ) then
+ rloss = xloss*DBLE(10)**(-1-mod(ier,50))
+ do 99 i=1,2
+ if ( rloss*absc(cy(i)+cy(i+2)-1) .gt. precc*max(absc(
+ + cy(i)),absc(cy(i+2)),x1)) print *,'ffccyz: error: ',
+ + 'cy(',i+2,')<>1-cy(',i,'):',cy(i+2),cy(i),cy(i+2)+
+ + cy(i)-1
+ if ( rloss*absc(cz(i)+cz(i+2)-1) .gt. precc*max(absc(
+ + cz(i)),absc(cz(i+2)),x1)) print *,'ffccyz: error: ',
+ + 'cz(',i+2,')<>1-cz(',i,'):',cz(i+2),cz(i),cz(i+2)+
+ + cz(i)-1
+ do 98 j=1,2
+ if ( rloss*absc(cdyz(i,j)-cy(i)+cz(j)) .gt. precc*
+ + max(absc(cdyz(i,j)),absc(cy(i)),absc(cz(j))) )
+ + print *,'ffccyz: error: cdyz(',i,j,') <> cy(',
+ + i,')-','cz(',j,'):',cdyz(i,j),cy(i),cz(j),
+ + cdyz(i,j)-cy(i)+cz(j)
+ 98 continue
+ 99 continue
+ if ( rloss*absc(cd2yzz-2*cy(2)+cz(1)+cz(2)) .gt. precc*max(
+ + absc(cd2yzz),x2*absc(cy(2)),absc(cz(1)),absc(cz(2))) )
+ + print *,'ffccyz: error: cd2yzz <> 2*cy(2)+cz(1)+cz(2):',
+ + cd2yzz,2*cy(2),cz(1),cz(2),cd2yzz-2*cy(2)+cz(1)+cz(2)
+ endif
+* #] test output:
+*###] ffccyz:
+ end
diff --git a/ff-2.0/ffcc1.f b/ff-2.0/ffcc1.f
new file mode 100644
index 0000000..09d5bdf
--- /dev/null
+++ b/ff-2.0/ffcc1.f
@@ -0,0 +1,218 @@
+*###[ ffcc1:
+ subroutine ffcc1(cc1i,cc0,cb0i,xpi,piDpj,del2,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the C1(mu) = C11*p1(mu) + C12*p2(mu) numerically *
+* *
+* Input: cc0 complex scalar threepoint function *
+* cb0i(3) complex scalar twopoint functions *
+* without m1,m2,m3 *
+* (=with p2,p3,p1) *
+* xpi(6) complex masses (1-3), momenta^2 (4-6) *
+* piDpj(6,6) complex dotproducts as in C0 *
+* del2 real overall determinant *
+* ier integer digits lost so far *
+* Output: cc1i(2) complex C11,C12 * *
+* ier integer number of dgits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION del2
+ DOUBLE COMPLEX xpi(6),piDpj(6,6)
+ DOUBLE COMPLEX cc1i(2),cc0,cb0i(3)
+*
+* local variables
+*
+ integer i,j
+ DOUBLE PRECISION xmax,absc,xlosn,mc0,mb0i(3),mc1i(2)
+ DOUBLE COMPLEX xnul,dpipj(6,6),piDpjp(6,6)
+ DOUBLE COMPLEX cc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffcc1: input:'
+ print *,'xpi = ',xpi
+ print *,'del2 = ',del2
+ endif
+ if ( ltest ) then
+ xlosn = xloss*DBLE(10)**(-1-mod(ier,50))
+ do 1 i=1,6
+ if ( xpi(i) .ne. piDpj(i,i) ) then
+ print *,'ffcc1: error: xpi and piDpj do not agree'
+ endif
+ 1 continue
+ do 4 i=1,6
+ do 3 j=1,6
+ dpipj(j,i) = xpi(j) - xpi(i)
+ 3 continue
+ 4 continue
+ call ffcot3(piDpjp,xpi,dpipj,6,ier)
+ do 7 i=1,6
+ do 6 j=1,6
+ xnul = piDpj(j,i) - piDpjp(j,i)
+ if ( xlosn*absc(xnul) .gt. precc*absc(piDpjp(j,i)) )
+ + print *,'piDpj(',j,i,') not correct, cmp:',
+ + piDpj(j,i),piDpjp(j,i),xnul
+ 6 continue
+ 7 continue
+ xnul = DBLE(del2) - xpi(4)*xpi(5) + piDpj(4,5)**2
+ xmax =max(abs(del2),absc(xpi(4)*xpi(5)),absc(piDpj(4,5)**2))
+ if ( xlosn*absc(xnul) .gt. precc*xmax ) then
+ print *,'ffcc1: error: del2 != pi(4)*pi(5)-pi.pj(4,5)^2'
+ + ,del2,xpi(4)*xpi(5),piDpj(4,5)**2,xnul
+ endif
+ i = 0
+ call ffcb0(cc,x0,x1,xpi(4),xpi(1),xpi(2),i)
+ if ( xlosn*absc(cc-cb0i(3)) .gt. precc*absc(cc) ) print *,
+ + 'cb0i(3) not right: ',cb0i(3),cc,cb0i(3)-cc
+ call ffcb0(cc,x0,x1,xpi(5),xpi(2),xpi(3),i)
+ if ( xlosn*absc(cc-cb0i(1)) .gt. precc*absc(cc) ) print *,
+ + 'cb0i(1) not right: ',cb0i(1),cc,cb0i(1)-cc
+ call ffcb0(cc,x0,x1,xpi(6),xpi(3),xpi(1),i)
+ if ( xlosn*absc(cc-cb0i(2)) .gt. precc*absc(cc) ) print *,
+ + 'cb0i(2) not right: ',cb0i(2),cc,cb0i(2)-cc
+ call ffcc0(cc,xpi,ier)
+ if ( xlosn*absc(cc-cc0) .gt. precc*absc(cc) ) print *,
+ + 'cc0 not right: ',cc0,cc,cc0-cc
+ endif
+* #] check input:
+* #[ call ffcc1a:
+*
+ mc0 = absc(cc0)*DBLE(10)**mod(ier,50)
+ mb0i(1) = absc(cb0i(1))*DBLE(10)**mod(ier,50)
+ mb0i(2) = absc(cb0i(2))*DBLE(10)**mod(ier,50)
+ mb0i(3) = absc(cb0i(3))*DBLE(10)**mod(ier,50)
+ call ffcc1a(cc1i,mc1i,cc0,mc0,cb0i,mb0i,xpi,piDpj,del2,ier)
+*
+* #] call ffcc1a:
+*###] ffxc1:
+ end
+*###[ ffcc1a:
+ subroutine ffcc1a(cc1i,mc1i,cc0,mc0,cb0i,mb0i,xpi,piDpj,del2,
+ + ier)
+***#[*comment:***********************************************************
+* *
+* calculate the C1(mu) = C11*p1(mu) + C12*p2(mu) numerically *
+* *
+* Input: cc0 complex scalar threepoint function *
+* mc0 real maximal partial sum in C0 *
+* cb0i(3) complex scalar twopoint functions *
+* without m1,m2,m3 *
+* (=with p2,p3,p1) *
+* mb0i(3) real maxoimal partial sum in B0i *
+* xpi(6) complex masses (1-3), momenta^2 (4-6) *
+* piDpj(6,6) complex dotproducts as in C0 *
+* del2 real overall determinant *
+* ier integer digits lost so far *
+* Output: cc1i(2) complex C11,C12 *
+* mc1i(2) real maximal partial sum in C11,C12 *
+* ier integer number of dgits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION mc1i(2),mc0,mb0i(3),del2
+ DOUBLE COMPLEX cc1i(2),cc0,cb0i(3),xpi(6),piDpj(6,6)
+*
+* local variables
+*
+ integer i,ier0,ier1
+ DOUBLE PRECISION xmax,absc,ms(5)
+ DOUBLE COMPLEX cs(5),cc,del2s2,dpipj(6,6)
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ calculations:
+* C1 =
+* + p1(mu)*Del2^-1 * ( - 1/2*B(p1)*p1.p2 - 1/2*B(p2)*p2.p2 - 1/2*B(p3)*
+* p2.p3 - C*p1.p2*p2.s1 + C*p1.s1*p2.p2 )
+*
+* + p2(mu)*Del2^-1 * ( 1/2*B(p1)*p1.p1 + 1/2*B(p2)*p1.p2 + 1/2*B(p3)*
+* p1.p3 + C*p1.p1*p2.s1 - C*p1.p2*p1.s1 );
+*
+ cs(1) = - cb0i(1)*piDpj(5,5)
+ cs(2) = - cb0i(2)*piDpj(6,5)
+ cs(3) = - cb0i(3)*piDpj(4,5)
+ cs(4) = - 2*cc0*piDpj(1,5)*piDpj(4,5)
+ cs(5) = + 2*cc0*piDpj(1,4)*piDpj(5,5)
+ ms(1) = mb0i(1)*absc(piDpj(5,5))
+ ms(2) = mb0i(2)*absc(piDpj(6,5))
+ ms(3) = mb0i(3)*absc(piDpj(4,5))
+ ms(4) = 2*mc0*absc(piDpj(1,5)*piDpj(4,5))
+ ms(5) = 2*mc0*absc(piDpj(1,4)*piDpj(5,5))
+*
+ cc1i(1) = 0
+ mc1i(1) = 0
+ xmax = 0
+ do 10 i=1,5
+ cc1i(1) = cc1i(1) + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ mc1i(1) = max(mc1i(1),ms(i))
+ 10 continue
+ ier0 = ier
+ if ( lwarn .and. absc(cc1i(1)) .lt. xloss*xmax )
+ + call ffwarn(163,ier,absc(cc1i(1)),xmax)
+ cc1i(1) = cc1i(1)*DBLE(1/(2*del2))
+ mc1i(1) = mc1i(1)*abs(1/(2*del2))
+
+ cs(1) = + cb0i(1)*piDpj(5,4)
+ cs(2) = + cb0i(2)*piDpj(6,4)
+ cs(3) = + cb0i(3)*piDpj(4,4)
+* invalidate dpipj
+ dpipj(1,1) = 1
+ ier1 = ier
+ call ffcl2p(del2s2,xpi,dpipj,piDpj, 4,5,6, 1,2,3, 6,ier)
+ cs(4) = + 2*cc0*del2s2
+ ms(1) = mb0i(1)*abs(piDpj(5,4))
+ ms(2) = mb0i(2)*abs(piDpj(6,4))
+ ms(3) = mb0i(3)*abs(piDpj(4,4))
+ ms(4) = 2*mc0*abs(del2s2)*DBLE(10)**mod(ier1-ier,50)
+*
+ cc1i(2) = 0
+ mc1i(2) = 0
+ xmax = 0
+ do 20 i=1,4
+ cc1i(2) = cc1i(2) + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ mc1i(2) = max(mc1i(2),ms(i))
+ 20 continue
+ if ( lwarn .and. absc(cc1i(2)) .lt. xloss*xmax )
+ + call ffwarn(163,ier1,absc(cc1i(2)),xmax)
+ cc1i(2) = cc1i(2)*(1/DBLE(2*del2))
+ mc1i(2) = mc1i(2)*abs(1/DBLE(2*del2))
+ ier = max(ier0,ier1)
+*
+* #] calculations:
+* #[ print output:
+ if ( lwrite ) then
+ print *,'ffcc1: results:'
+ print *,'cc1i = ',cc1i
+ endif
+* #] print output:
+*###] ffcc1:
+ end
diff --git a/ff-2.0/ffcdb0.f b/ff-2.0/ffcdb0.f
new file mode 100644
index 0000000..e09a7f6
--- /dev/null
+++ b/ff-2.0/ffcdb0.f
@@ -0,0 +1,880 @@
+*###[ ffcdb0:
+ subroutine ffcdb0(cdb0,cdb0p,cp,cma,cmb,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the derivative of the two-point function with *
+* respect to p2, plus the same times p2. *
+* *
+* Input: cp (complex) k2, in B&D metric *
+* cma (complex) mass2 *
+* cmb (complex) mass2 *
+* *
+* Output: cdb0 (complex) dB0/dxp *
+* cdb0p (complex) cp*dB0/dxp *
+* ier (integer) # of digits lost, if >=100: error *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cdb0,cdb0p
+ DOUBLE COMPLEX cp,cma,cmb
+*
+* local variables
+*
+ integer ier0
+ DOUBLE COMPLEX cmamb,cmap,cmbp,cc
+ DOUBLE PRECISION xp,xma,xmb,absc
+*
+* common
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffcdb0: input:'
+ print *,'cma,cmb,cp,ier = ',cma,cmb,cp,ier
+ endif
+ if ( ltest ) then
+ if ( DBLE(cma) .lt. 0 .or. DBLE(cmb) .lt. 0 ) then
+ print *,'ffcdb0: error: Re(cma,b) < 0: ',cma,cmb
+ stop
+ endif
+ if ( DIMAG(cma) .gt. 0 .or. DIMAG(cmb) .gt. 0 ) then
+ print *,'ffcdb0: error: Im(cma,b) > 0: ',cma,cmb
+ stop
+ endif
+ if ( DIMAG(cp) .ne. 0 ) then
+ print *,'ffcdb0: error: Im(cp) != 0: ',cp
+ stop
+ endif
+ endif
+ if ( DIMAG(cma).eq.0 .and. DIMAG(cmb).eq.0 ) then
+ xma = DBLE(cma)
+ xmb = DBLE(cmb)
+ xp = DBLE(cp)
+ if ( lwrite ) print *,'ffcdb0: calling real case'
+ call ffxdb0(cdb0,cdb0p,xp,xma,xmb,ier)
+ return
+ endif
+* #] check input:
+* #[ get differences:
+ ier0 = 0
+ cmamb = cma - cmb
+ cmap = cma - cp
+ cmbp = cmb - cp
+ if ( lwarn ) then
+ if ( absc(cmamb) .lt. xloss*absc(cma) .and. cma .ne. cmb )
+ + call ffwarn(94,ier0,absc(cmamb),absc(cma))
+ if ( absc(cmap) .lt. xloss*absc(cp) .and. cp .ne. cma )
+ + call ffwarn(95,ier0,absc(cmap),absc(cp))
+ if ( absc(cmbp) .lt. xloss*absc(cp) .and. cp .ne. cmb )
+ + call ffwarn(96,ier0,absc(cmbp),absc(cp))
+ endif
+* #] get differences:
+* #[ calculations:
+ call ffcdbp(cdb0,cdb0p,cp,cma,cmb,cmap,cmbp,cmamb,ier)
+ if ( lwrite ) then
+ print *,' B0'' = ',cdb0,ier
+ print *,'cp*B0'' = ',cdb0p,ier
+ endif
+* #] calculations:
+*###] ffcdb0:
+ end
+*###[ ffcdbp:
+ subroutine ffcdbp(cdb0,cdb0p,cp,cma,cmb,cmap,cmbp,cmamb,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the derivatives of the two-point function *
+* *
+* Input: cp (complex) p.p, in B&D metric *
+* cma (complex) mass2, *
+* cmb (complex) mass2, *
+* dm[ab]p (complex) cm[ab] - cp *
+* cmamb (complex) cma - cmb *
+* *
+* Output: cdb0 (complex) B0' = dB0/dxp *
+* cdb0p (complex) cp*B0' *
+* ier (integer) 0=ok,>0=numerical problems,>100=error *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cdb0,cdb0p
+ DOUBLE COMPLEX cp,cma,cmb,cmap,cmbp,cmamb
+*
+* local variables
+*
+ integer i,initeq,jsign,init,ithres,initir,n1,n2,nffet1
+ logical lreal
+ DOUBLE PRECISION ax,ffbnd,ffbndc,
+ + xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ + xprcn3,bdn301,bdn305,bdn310,bdn315,
+ + xprcn5,bdn501,bdn505,bdn510,bdn515,
+ + xprec0,bdn001,bdn005,bdn010,bdn015,bdn020,
+ + absc,xmax,prcsav
+ DOUBLE COMPLEX xcheck,cm,cdmp,cm1,cm2,cm1m2,cdm1p,
+ + cdm2p,s,s1,s1a,s1b,s1p,s2,s2a,s2b,s2p,s3,cx,som,
+ + clam,slam,xlogmm,alpha,alph1,xnoe,xpneq(30),
+ + zfflo1,zfflo3,d1,d2,diff,h,a,b,c,d,beta,
+ + betm2n,s1c,s1d,s1e,s1f,cqi(3),cqiqj(3,3),zm,zp
+ DOUBLE COMPLEX cc
+ DOUBLE PRECISION xp,xma,xmb,dmamb,dmap,dmbp,sprec
+ save initeq,xpneq,init,initir,
+ + xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ + xprcn3,bdn301,bdn305,bdn310,bdn315,
+ + xprcn5,bdn501,bdn505,bdn510,bdn515,
+ + xprec0,bdn001,bdn005,bdn010,bdn015,bdn020
+*for ABSOFT only
+* DOUBLE COMPLEX csqrt
+* external csqrt
+*
+* common blocks
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* data
+*
+ data xprceq /-1./
+ data xprec0 /-1./
+ data xprcn3 /-1./
+ data xprcn5 /-1./
+ data initeq /0/
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+* #] declarations:
+* #[ check input:
+ if (ltest) then
+ xcheck = cma - cmb - cmamb
+ if ( absc(xcheck) .gt. precc*max(absc(cma),absc(cmb),absc(
+ + cmamb))/xloss ) then
+ print *,'ffcdbp: input not OK, cmamb <> cma-cmb',xcheck
+ endif
+ xcheck = -cp + cma - cmap
+ if ( absc(xcheck) .gt. precc*max(absc(cp),absc(cma),absc(
+ + cmap))/xloss ) then
+ print *,'ffcdbp: input not OK, cmap <> cma - cp',xcheck
+ endif
+ xcheck = -cp + cmb - cmbp
+ if ( absc(xcheck) .gt. precc*max(absc(cp),absc(cmb),absc(
+ + cmbp))/xloss ) then
+ print *,'ffcdbp: input not OK, cmbp <> cmb - cp',xcheck
+ endif
+ endif
+* #] check input:
+* #[ the real cases:
+*
+ if ( DIMAG(cma) .eq. 0 .and. DIMAG(cmb) .eq. 0 ) then
+ lreal = .TRUE.
+ elseif ( nschem.le.2 ) then
+ lreal = .TRUE.
+ if ( init.eq.0 ) then
+ init = 1
+ print *,'ffcb0: nschem <= 2, ignoring complex masses: ',
+ + nschem
+ endif
+ elseif ( nschem.le.4 ) then
+ if ( init.eq.0 ) then
+ init = 1
+ print *,'ffcdbp: nschem = 3,4 complex masses near ',
+ + 'singularity: ',nschem
+ endif
+ if ( abs(DBLE(cma)) .lt. -xloss*DIMAG(cmb)
+ + .and. abs(DBLE(cmbp)) .le. -nwidth*DIMAG(cmb)
+ + .or. abs(DBLE(cmb)) .lt. -xloss*DIMAG(cma)
+ + .and. abs(DBLE(cmap)) .le. -nwidth*DIMAG(cma) ) then
+ lreal = .FALSE.
+ else
+ lreal = .TRUE.
+ endif
+ elseif ( nschem.le.6 ) then
+ if ( init.eq.0 ) then
+ init = 1
+ print *,'ffcdbp: nschem = 5,6 complex masses near ',
+ + 'threshold: ',nschem
+ endif
+ cqi(1) = cma
+ cqi(2) = cmb
+ cqi(3) = cp
+ cqiqj(1,2) = cmamb
+ cqiqj(2,1) = -cqiqj(1,2)
+ cqiqj(1,3) = cmap
+ cqiqj(3,1) = -cqiqj(1,3)
+ cqiqj(2,3) = cmbp
+ cqiqj(3,2) = -cqiqj(2,3)
+ cqiqj(1,1) = 0
+ cqiqj(2,2) = 0
+ cqiqj(3,3) = 0
+ call ffthre(ithres,cqi,cqiqj,3,1,2,3)
+ if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
+ lreal = .TRUE.
+ else
+ lreal = .FALSE.
+ endif
+ else
+ lreal = .FALSE.
+ endif
+ if ( lreal ) then
+ xp = DBLE(cp)
+ xma = DBLE(cma)
+ xmb = DBLE(cmb)
+ dmap = DBLE(cmap)
+ dmbp = DBLE(cmbp)
+ dmamb = DBLE(cmamb)
+ sprec = precx
+ precx = precc
+ if ( lwrite ) print *,'ffcdbp: to real case'
+ call ffxdbp(cdb0,cdb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
+ precx = sprec
+ return
+ endif
+*
+* #] the real cases:
+* #[ which case:
+*
+* sort according to the type of masscombination encountered:
+* 100: both masses zero, 200: one equal to zero, 300: both equal
+* 400: rest.
+*
+ if ( cma .eq. 0 ) then
+ if ( cmb .eq. 0 ) then
+ goto 100
+ endif
+ cm = cmb
+ cdmp = cmbp
+ goto 200
+ endif
+ if ( cmb .eq. 0 ) then
+ cm = cma
+ cdmp = cmap
+ goto 200
+ elseif ( cmamb .eq. 0 ) then
+ cm = cma
+ cdmp = cmap
+ goto 300
+ elseif ( DBLE(cma) .gt. DBLE(cmb) ) then
+ cm2 = cma
+ cm1 = cmb
+ cm1m2 = -cmamb
+ cdm1p = cmbp
+ cdm2p = cmap
+ else
+ cm1 = cma
+ cm2 = cmb
+ cm1m2 = cmamb
+ cdm1p = cmap
+ cdm2p = cmbp
+ endif
+ goto 400
+* #] which case:
+* #[ both masses equal to zero:
+ 100 continue
+ if ( cp.ne.0 ) cdb0 = -1/cp
+ cdb0p = -1
+ return
+* #] both masses equal to zero:
+* #[ one mass equal to zero:
+ 200 continue
+*
+* special case cp = 0
+*
+ if ( cp .eq. 0 ) then
+ cdb0p = 0
+ cdb0 = 1/(2*cm)
+ goto 990
+*
+* special case cp = cm
+*
+ elseif ( cdmp.eq.0 ) then
+ if ( initir.eq.0 ) then
+ initir = 1
+ print *,'ffcdbd: IR divergent B0'', using cutoff ',delta
+ endif
+ if ( delta.eq.0 ) then
+ call fferr(74,ier)
+ cdb0p = 0
+ else
+ cdb0p = -1 + log(cm/DBLE(delta))/2
+ endif
+ cdb0 = cdb0p/cp
+ goto 990
+ endif
+*
+* Normal case:
+*
+ cx = cp/cm
+ ax = absc(cx)
+ if ( ax .lt. xloss ) then
+* #[ Taylor expansion:
+ if ( xprec0 .ne. precx ) then
+ xprec0 = precc
+ prcsav = precx
+ precx = precc
+ bdn001 = ffbnd(2,1,xninv)
+ bdn005 = ffbnd(2,5,xninv)
+ bdn010 = ffbnd(2,10,xninv)
+ bdn015 = ffbnd(2,15,xninv)
+ bdn020 = ffbnd(2,20,xninv)
+ precx = prcsav
+ endif
+ if ( lwarn .and. ax .gt. bdn020 ) then
+ call ffwarn(15,ier,precc,xninv(21)*ax**20)
+ endif
+ if ( ax .gt. bdn015 ) then
+ som = cx*(DBLE(xninv(17)) + cx*(DBLE(xninv(18))
+ + + cx*(DBLE(xninv(19)) + cx*(DBLE(xninv(20))
+ + + cx*(DBLE(xninv(21)) )))))
+ else
+ som = 0
+ endif
+ if ( ax .gt. bdn010 ) then
+ som = cx*(DBLE(xninv(12)) + cx*(DBLE(xninv(13))
+ + + cx*(DBLE(xninv(14)) + cx*(DBLE(xninv(15))
+ + + cx*(DBLE(xninv(16)) + som )))))
+ endif
+ if ( ax .gt. bdn005 ) then
+ som = cx*(DBLE(xninv(7)) + cx*(DBLE(xninv(8))
+ + + cx*(DBLE(xninv(9)) + cx*(DBLE(xninv(10))
+ + + cx*(DBLE(xninv(11)) + som )))))
+ endif
+ if ( ax .gt. bdn001 ) then
+ som = cx*(DBLE(xninv(3)) + cx*(DBLE(xninv(4))
+ + + cx*(DBLE(xninv(5)) + cx*(DBLE(xninv(6)) + som ))))
+ endif
+ cdb0p = cx*(DBLE(xninv(2)) + som)
+ if ( lwrite ) then
+ print *,'cdb0p = ',cdb0p
+ print *,'verg ',-1 - cm/cp*zfflo1(cx,ier),1
+ endif
+* #] Taylor expansion:
+ else
+* #[ short formula:
+ s = log(cdmp/cm)
+ cdb0p = -(1 + s*cm/cp)
+ if ( lwarn .and. absc(cdb0p).lt.xloss ) then
+ call ffwarn(13,ier,absc(cdb0p),x1)
+ endif
+* #] short formula:
+ endif
+ cdb0 = cdb0p/cp
+ goto 990
+* #] one mass equal to zero:
+* #[ both masses equal:
+ 300 continue
+*
+* Both masses are equal. Not only this speeds up things, some
+* cancellations have to be avoided as well.
+*
+* first a special case
+*
+ if ( absc(cp) .lt. 8*xloss*absc(cm) ) then
+* -#[ taylor expansion:
+*
+* a Taylor expansion seems appropriate as the result will go
+* as k^2 but seems to go as 1/k !!
+*
+*--#[ data and bounds:
+ if ( initeq .eq. 0 ) then
+ initeq = 1
+ xpneq(1) = x1/6
+ do 1 i=2,30
+ xpneq(i) = - xpneq(i-1)*DBLE(i)/DBLE(2*(2*i+1))
+ 1 continue
+ endif
+ if (xprceq .ne. precx ) then
+*
+* calculate the boundaries for the number of terms to be
+* included in the taylorexpansion
+*
+ xprceq = precx
+ bdeq01 = ffbndc(1,1,xpneq)
+ bdeq05 = ffbndc(1,5,xpneq)
+ bdeq11 = ffbndc(1,11,xpneq)
+ bdeq17 = ffbndc(1,17,xpneq)
+ bdeq25 = ffbndc(1,25,xpneq)
+ endif
+*--#] data and bounds:
+ cx = -cp/cm
+ ax = absc(cx)
+ if ( lwarn .and. ax .gt. bdeq25 ) then
+ call ffwarn(13,ier,precc,abs(xpneq(25))*ax**25)
+ endif
+ if ( ax .gt. bdeq17 ) then
+ som = cx*(xpneq(18) + cx*(xpneq(19) + cx*(xpneq(20) +
+ + cx*(xpneq(21) + cx*(xpneq(22) + cx*(xpneq(23) +
+ + cx*(xpneq(24) + cx*(xpneq(25) ))))))))
+ else
+ som = 0
+ endif
+ if ( ax .gt. bdeq11 ) then
+ som = cx*(xpneq(12) + cx*(xpneq(13) + cx*(xpneq(14) +
+ + cx*(xpneq(15) + cx*(xpneq(16) + cx*(xpneq(17) + som ))))
+ + ))
+ endif
+ if ( ax .gt. bdeq05 ) then
+ som = cx*(xpneq(6) + cx*(xpneq(7) + cx*(xpneq(8) + cx*(
+ + xpneq(9) + cx*(xpneq(10) + cx*(xpneq(11) + som ))))))
+ endif
+ if ( ax .gt. bdeq01 ) then
+ som = cx*(xpneq(2) + cx*(xpneq(3) + cx*(xpneq(4) + cx*(
+ + xpneq(5) + som ))))
+ endif
+ cdb0p = -cx*(xpneq(1)+som)
+ if (lwrite) then
+ print *,'ffcdbp: m1 = m2, Taylor expansion in ',cx
+ print *,'cdb0p = ',cdb0p
+ endif
+ if ( cp.ne.0 ) then
+ cdb0 = cdb0p*(1/DBLE(cp))
+ else
+ cdb0 = xpneq(1)/cm
+ endif
+ goto 990
+* -#] taylor expansion:
+ endif
+* -#[ normal case:
+*
+* normal case
+*
+ if ( lwrite ) print*,'ffcdb0: equal masses, normal case'
+ call ffclmb(clam,-cp,-cm,-cm,cdmp,cdmp,c0,ier)
+ slam = sqrt(clam)
+ call ffcoot(zm,zp,c1,c05,cm/cp,slam/(2*cp),ier)
+ if ( lwrite ) print *,' zm,zp = ',zm,zp
+ s1 = zp/zm
+ if( abs(s1-1) .lt. xloss ) then
+* In this case a quicker and more accurate way is to
+* calculate log(1-cx).
+ print *,'Not tested, probably wrong'
+ ier = ier + 50
+ if ( lwrite ) print *,' arg log1 = ',1-s1
+ s2 = (cp - slam)
+ if ( lwrite ) print *,' arg log1+= ',-2*slam/s2
+ if ( absc(s2) .lt. xloss*absc(cp) ) then
+ s2 = -slam*(cp+slam)/(4*cp*cm)
+ if ( lwrite ) print *,' arg log1*= ',s2
+ else
+ s2 = -2*slam/s2
+ endif
+ s = -2*cm/slam*zfflo1(s2/(2*cm),ier)
+ else
+* finally the normal case
+ s = -2*cm/slam*log(s1)
+ endif
+*
+* eta terms
+*
+ n1 = nffet1(zp,1/zm,s1,ier)
+ n2 = nffet1(-zp,-1/zm,s1,ier)
+ if ( lwrite .and. (n1.ne.0 .or. n2.ne.0) ) then
+ print *,'ffcb0: eta terms: n1,n2 = ',n1,n2
+ endif
+ if (lwrite) print *,'s = ',s
+ if ( n1+n2 .ne. 0 ) then
+ s1 = cm/slam*c2ipi*(n1+n2)
+ s = s + s1
+ if ( lwrite ) then
+ print *,'eta''s: ',s1
+ print *,'sum : ',s
+ endif
+ endif
+ cdb0p = s - 1
+ cdb0 = cdb0p/cp
+ if ( lwarn .and. absc(cdb0p).lt.xloss )
+ + call ffwarn(233,ier,absc(cdb0),x1)
+ goto 990
+* -#] normal case:
+*
+* #] both masses equal:
+* #[ unequal nonzero masses:
+ 400 continue
+* -#[ get log(cm2/cm1):
+ cx = cm2/cm1
+ c = cx-1
+ if ( 1 .lt. xclogm*absc(cx) ) then
+ call fferr(8,ier)
+ xlogmm = 0
+ elseif ( absc(c) .lt. xloss ) then
+ xlogmm = zfflo1(cm1m2/cm1,ier)
+ else
+ xlogmm = log(cx)
+ endif
+* -#] get log(cm2/cm1):
+* -#[ cp = 0:
+*
+* first a special case
+*
+ if ( cp .eq. 0 ) then
+*
+* repaired 19-nov-1993, see b2.frm
+*
+ s1 = cm1*cm2*xlogmm/cm1m2**3
+ s2 = (cm1+cm2)/(2*cm1m2**2)
+ s = s1 + s2
+ if ( absc(s) .lt. xloss**2*absc(s2) ) then
+*
+* second try
+*
+ h = zfflo3(cm1m2/cm1,ier)
+ s1 = -cm1*h/cm1m2**2
+ s2 = 1/(2*cm1)
+ s3 = cm1**2*h/cm1m2**3
+ s = s1 + s2 + s3
+ if ( absc(s) .lt. xloss*max(absc(s2),absc(s3)) ) then
+ call ffwarn(234,ier,absc(s),absc(s2))
+ endif
+ endif
+ cdb0 = s
+ cdb0p = 0
+ goto 990
+ endif
+* -#] cp = 0:
+* -#[ normal case:
+*
+* proceeding with the normal case
+*
+ call ffclmb(clam,-cp,-cm2,-cm1,cdm2p,cdm1p,cm1m2,ier)
+ diff = clam + cp*(cdm2p+cm1)
+ if ( absc(diff) .lt. xloss*absc(clam) ) then
+ if ( lwrite ) print *,'diff = ',diff
+ h = cm1m2**2 - cp*(cm1+cm2)
+ if ( lwrite ) print *,'diff+= ',h
+ if ( absc(h) .lt. xloss*absc(cm1m2)**2 ) then
+ if ( absc(cm1m2)**2 .lt. absc(clam) ) diff = h
+ call ffwarn(235,ier,absc(diff),min(absc(cm1m2)**2,
+ + absc(clam)))
+ endif
+ endif
+*--#[ first try:
+* first try the normal way
+ slam = sqrt(clam)
+ if ( lwrite ) then
+ print *,'clam = ',clam
+ print *,'slam = ',slam
+ endif
+ if ( abs(DBLE(cm1)) .lt. abs(DBLE(cm2)) ) then
+ s2a = cm1 + cdm2p
+ else
+ s2a = cm2 + cdm1p
+ endif
+ s2 = s2a + slam
+ if ( absc(s2) .gt. xloss*absc(slam) ) then
+* looks fine
+ jsign = 1
+ else
+ s2 = s2a - slam
+ jsign = -1
+ endif
+ s2 = s2/sqrt(4*cm1*cm2)
+ if ( lwrite ) print *,' arg log s2 = ',s2
+ if ( absc(s2) .lt. xclogm ) then
+ call fferr(9,ier)
+ s2 = 0
+ elseif ( absc(s2-1) .lt. xloss ) then
+ ier = ier + 50
+ print *,'ffcdb0: untested: s2 better in first try'
+ if ( jsign.eq.1 ) then
+ if ( lwrite ) print *,'s2 ',-diff/(2*slam*cp)*2*log(s2)
+ s2 = -slam*(s2a+slam)/(2*cm1*cm2)
+ s2 = -diff/(2*slam*cp)*zfflo1(s2,ier)
+ else
+ if ( lwrite ) print *,'s2 ',+diff/(2*slam*cp)*2*log(s2)
+ s2 = +slam*(s2a-slam)/(2*cm1*cm2)
+ s2 = +diff/(2*slam*cp)*zfflo1(s2,ier)
+ endif
+ if ( lwrite ) print *,'s2+ ',s2,jsign
+ else
+ s2 = -diff/(2*slam*cp)*2*log(s2)
+ if ( jsign .eq. -1 ) s2 = -s2
+ endif
+ s1 = -cm1m2*xlogmm/(2*cp)
+ cdb0p = s1+s2-1
+ if (lwrite) then
+ print *,'ffcdbp: first try, cdb0p = ',cdb0p,s1,s2,-1
+ endif
+*--#] first try:
+ if ( absc(cdb0p) .lt. xloss**2*max(absc(s1),absc(s2)) ) then
+*--#[ second try:
+* this is unacceptable, try a better solution
+ s1a = diff + slam*cm1m2
+ if (lwrite) print *,'s1 = ',-s1a/(2*cp*slam),diff/
+ + (2*cp*slam)
+ if ( absc(s1a) .gt. xloss*absc(diff) ) then
+* this works
+ s1 = -s1a/(2*cp*slam)
+ else
+* by division a more accurate form can be found
+ s1 = -2*cm1*cm2*cp/(slam*(diff - slam*cm1m2))
+ if (lwrite) print *,'s1+= ',s1
+ endif
+ s = s1
+ s1 = s1*xlogmm
+ if ( abs(DBLE(cp)).lt.abs(DBLE(cm2)) ) then
+ s2a = cp - cm1m2
+ else
+ s2a = cm2 - cdm1p
+ endif
+ s2 = s2a - slam
+ if (lwrite) print *,'s2 = ',s2/(2*cm2),slam/(2*cm2)
+ if ( absc(s2) .gt. xloss*absc(slam) ) then
+* at least reasonable
+ s2 = s2 / (2*cm2)
+ else
+* division again
+ s2 = (2*cp) / (s2a+slam)
+ if (lwrite) print *,'s2+= ',s2
+ endif
+ if ( absc(s2) .lt. .1 ) then
+* choose a quick way to get the logarithm
+ s2 = zfflo1(s2,ier)
+ else
+ s2 = log(1-s2)
+ endif
+ s2 = -diff/(slam*cp)*s2
+ cdb0p = s1 + s2 - 1
+ if (lwrite) then
+ print *,'ffcdbp: 2nd try, cdb0p = ',cdb0p,s1,s2,-1
+ endif
+*--#] second try:
+ if ( absc(cdb0p) .lt. xloss**2*max(absc(s1),absc(s2)) )
+ + then
+*--#[ third try:
+* (we accept two times xloss because that's the same
+* as in this try)
+* A Taylor expansion might work. We expand
+* inside the logs. Only do the necessary work.
+*
+* #[ split up 1:
+ xnoe = s2a+slam
+ a = 1
+ b = 2/xnoe-1/cp
+ c = -4/(cp*xnoe)
+ d = sqrt(cp**(-2) + (2/xnoe)**2)
+ call ffcoot(d1,d2,a,b,c,d,ier)
+ if ( DBLE(cp).gt.0 ) then
+ beta = d2
+ else
+ beta = d1
+ endif
+ alpha = beta*diff/slam
+ alph1 = 1-alpha
+ if ( absc(alph1) .lt. xloss ) then
+ s1a = 4*cp**2*cm1*cm2/(slam*cm1m2*(diff-slam*
+ + cm1m2))
+ s1b = -diff/slam*4*cm1*cp/(cm1m2*xnoe*(2*cp-
+ + xnoe))
+ b = -1/cp
+ c = -(2/xnoe)**2
+ call ffcoot(d1,d2,a,b,c,d,ier)
+ if ( DBLE(cp).gt.0 ) then
+ betm2n = d2
+ else
+ betm2n = d1
+ endif
+ d1 = s1a + s1b - diff/slam*betm2n
+ if ( lwrite ) then
+ print *,'alph1 = ',d1,s1a,s1b,-diff/slam*
+ + betm2n
+ print *,'verg ',1-alpha
+ endif
+ xmax = max(absc(s1a),absc(s1b))
+ if ( xmax .lt. 1 ) then
+ alph1 = d1
+ else
+ xmax = 1
+ endif
+ if ( absc(alph1) .lt. xloss*xmax )
+ + call ffwarn(236,ier,absc(alph1),xmax)
+ else
+ betm2n = beta - 2/xnoe
+ endif
+ if ( lwrite ) then
+ print *,' s1 - alph1 = ',s1-alph1
+ print *,' s2 - alpha = ',s2-alpha
+ endif
+* #] split up 1:
+* #[ s2:
+*
+* first s2:
+*
+ 490 s2p = s2 - alpha
+ if ( absc(s2p) .lt. xloss*absc(s2) ) then
+* -#[ bounds:
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn5 .ne. precx ) then
+ xprcn5 = precc
+ prcsav = precx
+ precx = precc
+ bdn501 = ffbnd(3,1,xinfac)
+ bdn505 = ffbnd(3,5,xinfac)
+ bdn510 = ffbnd(3,10,xinfac)
+ bdn515 = ffbnd(3,15,xinfac)
+ precx = prcsav
+ endif
+* -#] bounds:
+ cx = beta*cp
+ ax = absc(cx)
+ if ( lwarn .and. ax .gt. bdn515 ) then
+ call ffwarn(13,ier,absc(s2p),absc(s2))
+ goto 495
+ endif
+ if ( ax .gt. bdn510 ) then
+ s2a = cx*(DBLE(xinfac(13)) + cx*(DBLE(xinfac(
+ + 14))+ cx*(DBLE(xinfac(15)) + cx*(DBLE(xinfac(
+ + 16))+ cx*(DBLE(xinfac(17)))))))
+ else
+ s2a = 0
+ endif
+ if ( ax .gt. bdn505 ) then
+ s2a = cx*(DBLE(xinfac( 8)) + cx*(DBLE(xinfac(
+ + 9))+ cx*(DBLE(xinfac(10)) + cx*(DBLE(xinfac(
+ + 11))+ cx*(DBLE(xinfac(12)) + s2a)))))
+ endif
+ if ( ax .gt. bdn501 ) then
+ s2a =cx*(DBLE(xinfac(4))+cx*(DBLE(xinfac(5))
+ + +cx*(DBLE(xinfac(6))+cx*(DBLE(xinfac(7))
+ + + s2a))))
+ endif
+ s2a = cx**3*(DBLE(xinfac(3))+s2a)
+ s2b = 2*cp/xnoe*(s2a + cx**2/2)
+ s2p = s2b - s2a
+ if ( lwarn .and. absc(s2p).lt.xloss*absc(s2a) )
+ + call ffwarn(237,ier,absc(s2p),absc(s2a))
+ s2p = -diff/(cp*slam)*zfflo1(s2p,ier)
+ if (lwrite) then
+ print *,'ffcdbp: Taylor expansion of s2-a'
+ print *,' in cx = ',cx
+ print *,' gives s2p = ',s2p
+ endif
+ endif
+* #] s2:
+* #[ s1:
+*
+* next s1:
+*
+ 495 s1p = s1 - alph1
+ if ( absc(s1p) .lt. xloss*absc(s1) ) then
+* -#[ bounds:
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn3 .ne. precx ) then
+ xprcn3 = precc
+ prcsav = precx
+ precx = precc
+ bdn301 = ffbnd(3,1,xinfac)
+ bdn305 = ffbnd(3,5,xinfac)
+ bdn310 = ffbnd(3,10,xinfac)
+ bdn315 = ffbnd(3,15,xinfac)
+ precx = prcsav
+ endif
+* -#] bounds:
+*
+ cx = slam*(diff-slam*cm1m2)*alph1/(2*cp*cm1*cm2)
+ ax = absc(cx)
+ if ( lwarn .and. ax .gt. bdn315 ) then
+ call ffwarn(238,ier,absc(s1p),absc(s1))
+ goto 496
+ endif
+ h = (2*cp*(cm1+cm2) - cp**2)/(slam-cm1m2)
+*
+* see form job gets1.frm
+*
+ s1b = diff*(diff-slam*cm1m2)*betm2n/(2*cp*cm1*
+ + cm2)
+ s1c = 1/(cm1*xnoe*(2*cp-xnoe))*(
+ + cp*( 4*cp*cm2 + 2*cm1m2**2/cm2*(cp-h) +
+ + 2*cm1m2*(3*cp-h) - 8*cm1m2**2 )
+ + - 2*cm1m2**3/cm2*(3*cp-h)
+ + + 4*cm1m2**4/cm2
+ + )
+ if ( lwrite ) then
+ print *,'s1c was ',-2*cp/cm1m2 + 2*diff*
+ + (diff-slam*cm1m2)/(cm2*cm1m2*xnoe*(2*cp-
+ + xnoe)) + cm1m2/cm1
+ print *,' en is ',s1c
+ print *,'s1b+s1c was ',cm1m2/cm1-cx
+ print *,' en is ',s1b+s1c
+ endif
+ s1d = cx*cm1m2/cm1
+ s1e = -cx**2/2
+ if ( ax .gt. bdn310 ) then
+ s1a = cx*(DBLE(xinfac(13)) + cx*(DBLE(xinfac(
+ + 14))+ cx*(DBLE(xinfac(15)) + cx*(DBLE(xinfac(
+ + 16))+ cx*(DBLE(xinfac(17)))))))
+ else
+ s1a = 0
+ endif
+ if ( ax .gt. bdn305 ) then
+ s1a = cx*(DBLE(xinfac( 8)) + cx*(DBLE(xinfac(
+ + 9))+ cx*(DBLE(xinfac(10)) + cx*(DBLE(xinfac(
+ + 11))+ cx*(DBLE(xinfac(12)) + s1a)))))
+ endif
+ if ( ax .gt. bdn301 ) then
+ s1a =cx*(DBLE(xinfac(4))+cx*(DBLE(xinfac(5))
+ + +cx*(DBLE(xinfac(6))+cx*(DBLE(xinfac(7))
+ + +s1a))))
+ endif
+ s1a = -cx**3 *(DBLE(xinfac(3)) + s1a)
+ s1f = cm1m2/cm1*(cx**2/2 - s1a)
+ s1p = s1e + s1d + s1c + s1b + s1a + s1f
+ xmax = max(absc(s1a),absc(s1b),absc(s1c),
+ + absc(s1d),absc(s1e))
+ if ( lwarn .and. absc(s1p).lt.xloss*xmax ) then
+ call ffwarn(239,ier,absc(s1p),xmax)
+ endif
+ s1p = s*zfflo1(s1p,ier)
+ if (lwrite) then
+ print *,'s1a = ',s1a
+ print *,'s1b = ',s1b
+ print *,'s1c = ',s1c
+ print *,'s1d = ',s1d
+ print *,'s1e = ',s1e
+ print *,'s1f = ',s1f
+ print *,'s = ',s
+ print *,'ffcdbp: Taylor exp. of s1-(1-a)'
+ print *,' in cx = ',cx
+ print *,' gives s1p = ',s1p
+ print *,' verg ',s*log(cm2/cm1
+ + *exp(cx))
+ endif
+ endif
+* #] s1:
+*
+* finally ...
+*
+ 496 cdb0p = s1p + s2p
+ if ( lwarn .and. absc(cdb0p) .lt. xloss*absc(s1p) )
+ + then
+ call ffwarn(240,ier,absc(cdb0p),absc(s1p))
+ endif
+*--#] third try:
+ endif
+ endif
+ cdb0 = cdb0p*(1/DBLE(cp))
+ goto 990
+* -#] normal case:
+* #] unequal nonzero masses:
+* #[ debug:
+ 990 continue
+ if (lwrite) then
+ print *,'cdb0 = ',cdb0
+ print *,'cdb0p = ',cdb0p
+ endif
+* #] debug:
+*###] ffcdbp:
+ end
diff --git a/ff-2.0/ffcel2.f b/ff-2.0/ffcel2.f
new file mode 100644
index 0000000..bb2c05f
--- /dev/null
+++ b/ff-2.0/ffcel2.f
@@ -0,0 +1,782 @@
+*###[ ffcel2:
+ subroutine ffcel2(del2,piDpj,ns,i1,i2,i3,lerr,ier)
+*************************************************************************
+* calculate in a numerically stable way *
+* del2(piDpj(i1,i1),piDpj(i2,i2),piDpj(i3,i3)) = *
+* = piDpj(i1,i1)*piDpj(i2,i2) - piDpj(i1,i2)^2 *
+* = piDpj(i1,i1)*piDpj(i3,i3) - piDpj(i1,i3)^2 *
+* = piDpj(i2,i2)*piDpj(i3,i3) - piDpj(i2,i3)^2 *
+* ier is the usual error flag. *
+*************************************************************************
+ implicit none
+*
+* arguments:
+*
+ integer ns,i1,i2,i3,lerr,ier
+ DOUBLE COMPLEX del2,piDpj(ns,ns)
+*
+* local variables
+*
+ DOUBLE COMPLEX s1,s2,cc
+ DOUBLE PRECISION absc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* calculations
+*
+ if ( absc(piDpj(i1,i2)) .lt. absc(piDpj(i1,i3)) .and.
+ + absc(piDpj(i1,i2)) .lt. absc(piDpj(i2,i3)) ) then
+ s1 = piDpj(i1,i1)*piDpj(i2,i2)
+ s2 = piDpj(i1,i2)**2
+ elseif ( absc(piDpj(i1,i3)) .lt. absc(piDpj(i2,i3)) ) then
+ s1 = piDpj(i1,i1)*piDpj(i3,i3)
+ s2 = piDpj(i1,i3)**2
+ else
+ s1 = piDpj(i2,i2)*piDpj(i3,i3)
+ s2 = piDpj(i2,i3)**2
+ endif
+ del2 = s1 - s2
+ if ( absc(del2) .lt. xloss*absc(s2) ) then
+ if ( lerr .eq. 0 ) then
+* we know we have another chance
+ if ( del2.ne.0 ) then
+ ier = ier + int(log10(xloss*absc(s2)/absc(del2)))
+ else
+ ier = ier + int(log10(xloss*absc(s2)/xclogm))
+ endif
+ else
+ if ( lwarn ) call ffwarn(71,ier,absc(del2),absc(s2))
+ endif
+ endif
+*###] ffcel2:
+ end
+*###[ ffcl2p:
+ subroutine ffcl2p(delps1,xpi,dpipj,piDpj,
+ + ip1,ip2,ip3,is1,is2,is3,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* delta_{ip1,is2}^{ip1,ip2} *
+* ier is the usual error flag. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ip1,ip2,ip3,is1,is2,is3,ier
+ DOUBLE COMPLEX delps1,xpi(ns),dpipj(ns,ns),piDpj(ns,ns)
+*
+* local variables
+*
+ DOUBLE COMPLEX s1,s2,s3,som,c
+ DOUBLE PRECISION xmax,absc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ stupid tree:
+* 1
+ s1 = xpi(ip1)*piDpj(ip2,is2)
+ s2 = piDpj(ip1,ip2)*piDpj(ip1,is2)
+ delps1 = s1 - s2
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
+ if ( lwrite ) print *,' delps1 = ',delps1,absc(s1)
+ som = delps1
+ xmax = absc(s1)
+* 2
+ s1 = piDpj(ip1,ip2)*piDpj(ip3,is2)
+ s2 = piDpj(ip1,ip3)*piDpj(ip2,is2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+1 = ',delps1,absc(s1)
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
+ if ( absc(s1) .lt. xmax ) then
+ som = delps1
+ xmax = absc(s1)
+ endif
+* 3
+ s1 = piDpj(ip1,ip3)*piDpj(ip1,is2)
+ s2 = xpi(ip1)*piDpj(ip3,is2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+2 = ',delps1,absc(s1)
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
+ if ( absc(s1) .lt. xmax ) then
+ som = delps1
+ xmax = absc(s1)
+ endif
+* 4
+ s1 = xpi(ip1)*piDpj(ip2,is1)
+ s2 = piDpj(ip1,is1)*piDpj(ip1,ip2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+3 = ',delps1,absc(s1)
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
+ if ( absc(s1) .lt. xmax ) then
+ som = delps1
+ xmax = absc(s1)
+ endif
+* 5
+ s1 = piDpj(ip1,is2)*piDpj(ip2,is1)
+ s2 = piDpj(ip1,is1)*piDpj(ip2,is2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+4 = ',delps1,absc(s1)
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
+ if ( absc(s1) .lt. xmax ) then
+ som = delps1
+ xmax = absc(s1)
+ endif
+* 6
+ s1 = piDpj(ip1,ip2)*piDpj(ip3,is1)
+ s2 = piDpj(ip1,ip3)*piDpj(ip2,is1)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+5 = ',delps1,absc(s1)
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
+ if ( absc(s1) .lt. xmax ) then
+ som = delps1
+ xmax = absc(s1)
+ endif
+* 7
+ s1 = piDpj(ip2,is2)*piDpj(ip3,is1)
+ s2 = piDpj(ip2,is1)*piDpj(ip3,is2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+6 = ',delps1,absc(s1)
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
+ if ( absc(s1) .lt. xmax ) then
+ som = delps1
+ xmax = absc(s1)
+ endif
+* 8
+ s1 = piDpj(ip1,ip3)*piDpj(ip1,is1)
+ s2 = xpi(ip1)*piDpj(ip3,is1)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+7 = ',delps1,absc(s1)
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
+ if ( absc(s1) .lt. xmax ) then
+ som = delps1
+ xmax = absc(s1)
+ endif
+* 9
+ s1 = piDpj(ip1,is1)*piDpj(ip3,is2)
+ s2 = piDpj(ip1,is2)*piDpj(ip3,is1)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+8 = ',delps1,absc(s1)
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
+ if ( absc(s1) .lt. xmax ) then
+ som = delps1
+ xmax = absc(s1)
+ endif
+*10 22-nov-1993 yet another one
+ if ( dpipj(1,1).eq.0 ) then
+ s1 = +xpi(ip1)*dpipj(is3,is2)/2
+ s2 = -piDpj(ip1,ip2)*dpipj(is2,is1)/2
+ s3 = +xpi(ip1)*piDpj(ip2,ip3)/2
+ delps1 = s1+s2+s3
+ if ( lwrite ) print *,' delps1+9 = ',delps1,s1,s2,s3
+ if ( absc(delps1) .ge. xloss*max(absc(s1),absc(s2)) )
+ + goto 100
+ if ( max(absc(s1),absc(s2)) .lt. xmax ) then
+ som = delps1
+ xmax = absc(s1)
+ endif
+ endif
+* NO possibility
+ delps1 = som
+ if ( lwarn ) call ffwarn(92,ier,absc(delps1),xmax)
+ 100 continue
+* #] stupid tree:
+*###] ffcl2p:
+ end
+*###[ ffcl2s:
+ subroutine ffcl2s(delps1,xpi,piDpj,in,jn,jin,isji,
+ + kn,ln,lkn,islk,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* *
+* \delta_{si,sj}^{sk,sl} *
+* *
+* with p(ji) = isji*(sj-si) *
+* p(lk) = islk*(sl-sk) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer in,jn,jin,isji,kn,ln,lkn,islk,ns,ier
+ DOUBLE COMPLEX delps1,xpi(ns),piDpj(ns,ns)
+*
+* local variables
+*
+ integer ii,jj,i,j,ji,k,l,lk,ihlp
+ DOUBLE COMPLEX s1,s2,som,c
+ DOUBLE PRECISION smax,absc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( abs(isji) .ne. 1 ) print *,'ffcl2s: error: abs(isji) ',
+ + ' <> 1 but ',isji
+ if ( abs(islk) .ne. 1 ) print *,'ffcl2s: error: abs(islk) ',
+ + ' <> 1 but ',islk
+ endif
+* #] check input:
+* #[ stupid tree:
+ som = 0
+ smax = 0
+ i = in
+ j = jn
+ ji = jin
+ k = kn
+ l = ln
+ lk = lkn
+ do 20 ii=1,3
+ do 10 jj=1,3
+ s1 = piDpj(i,k)*piDpj(j,l)
+ s2 = piDpj(i,l)*piDpj(j,k)
+ delps1 = s1 - s2
+ if ( ii .gt. 1 ) delps1 = isji*delps1
+ if ( jj .gt. 1 ) delps1 = islk*delps1
+ if ( ii .eq. 3 .neqv. jj .eq. 3 ) delps1 = -delps1
+ if ( absc(delps1) .ge. xloss*absc(s1) ) goto 30
+
+ if ( lwrite ) print *,' delps1+',3*ii+jj-3,'=',delps1,
+ + absc(s1)
+*
+* Save the most accurate estimate so far:
+ if ( ii .eq. 1 .and. jj .eq. 1 .or. absc(s1) .lt. smax
+ + ) then
+ som = delps1
+ smax = absc(s1)
+ endif
+*
+* rotate the jj's
+ ihlp = k
+ k = l
+ l = lk
+ lk = ihlp
+ 10 continue
+*
+* and the ii's
+ ihlp = i
+ i = j
+ j = ji
+ ji = ihlp
+ 20 continue
+ delps1 = som
+ if ( lwarn ) call ffwarn(83,ier,absc(delps1),smax)
+ 30 continue
+ if ( lwrite .and. 3*ii+jj.ne.4 ) print *,' delps1+',3*ii+jj-3,
+ + '=', delps1,s1,s2
+* #] stupid tree:
+*###] ffcl2s:
+ end
+*###[ ffcl2t:
+ subroutine ffcl2t(delps,piDpj,in,jn,kn,ln,lkn,islk,iss,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* *
+* \delta_{si,sj}^{sk,sl} *
+* *
+* with p(lk) = islk*(iss*sl - sk) (islk,iss = +/-1) *
+* and NO relationship between s1,s2 assumed (so 1/2 the *
+* possibilities of ffdl2s). *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer in,jn,ip1,kn,ln,lkn,islk,iss,ns,ier
+ DOUBLE COMPLEX delps,piDpj(ns,ns)
+*
+* local variables
+*
+ DOUBLE COMPLEX s1,s2,c
+ DOUBLE PRECISION absc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if ( ltest .and. abs(islk) .ne. 1 )
+ + print *,'ffcl2t: error: abs(islk) <> 1'
+* #] check input:
+* #[ calculations:
+ if ( in .eq. jn ) then
+ delps = 0.
+ return
+ endif
+ s1 = piDpj(kn,in)*piDpj(ln,jn)
+ s2 = piDpj(ln,in)*piDpj(kn,jn)
+ delps = s1 - s2
+ if ( absc(delps) .ge. xloss*absc(s1) ) goto 10
+ if ( lwrite ) print *,' delps = ',delps,s1,-s2
+ s1 = piDpj(kn,in)*piDpj(lkn,jn)
+ s2 = piDpj(lkn,in)*piDpj(kn,jn)
+ delps = iss*islk*(s1 - s2)
+ if ( lwrite ) print *,' delps+ = ',delps,islk,s1,-s2
+ if ( absc(delps) .ge. xloss*absc(s1) ) goto 10
+ s1 = piDpj(lkn,in)*piDpj(ln,jn)
+ s2 = piDpj(ln,in)*piDpj(lkn,jn)
+ delps = islk*(- s1 + s2)
+ if ( lwrite ) print *,' delps++= ',delps,islk,-s1,s2
+ if ( absc(delps) .ge. xloss*absc(s1) ) goto 10
+ if ( lwarn ) call ffwarn(93,ier,absc(delps),absc(s1))
+ 10 continue
+* #] calculations:
+*###] ffcl2t:
+ end
+*###[ ffcl3m:
+ subroutine ffcl3m(del3mi,ldel,del3,del2,xpi,dpipj,piDpj,ns,ip1n,
+ + ip2n,ip3n,is,itime,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate xpi(i)*del2 - del3(piDpj) *
+* *
+* / si mu \2 (This appears to be one of the harder *
+* = | d | determinants to calculate accurately. *
+* \ p1 p2 / Note that we allow a loss of xloss^2) *
+* *
+* Input: ldel iff .true. del2 and del3 exist *
+* del3 \delta^{s(1),p1,p2}_{s(1),p1,p2} *
+* del2 \delta^{p1,p2}_{p1,p2} *
+* xpi(ns) standard *
+* dpipj(ns,ns) standard *
+* piDpj(ns,ns) standard *
+* ipi pi = xpi(abs(ipi)) [p3=-p1 +/-p2] *
+* is si = xpi(is,is+1,..,is+itime-1) *
+* itime number of functions to calculate *
+* *
+* Output: del3mi(3) (\delta^{s_i \mu}_{p_1 p_2})^2 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ip1n,ip2n,ip3n,is,itime,ier
+ logical ldel
+ DOUBLE COMPLEX del3mi(itime),del3,del2,xpi(ns),dpipj(ns,ns),
+ + piDpj(ns,ns)
+*
+* local variables:
+*
+ DOUBLE PRECISION smax,xmax,absc
+ DOUBLE COMPLEX s(7),som,xsom,del2s,delps,c
+ integer i,j,k,ip1,ip2,ip3,ipn,is1,is2,isi,is3,ihlp,iqn,jsgnq,
+ + jsgn1,jsgn2,jsgn3,jsgnn,iadj(10,10,3:4),init,nm
+ save iadj,init
+ logical lsign,lmax,ltwist
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data iadj /200*0/
+ data init /0/
+* #] declarations:
+* #[ initialisations:
+ if ( init .eq. 0 ) then
+ init = 1
+*
+* Fill the array with adjacent values: if
+* x = iadj(i,j)
+* k = abs(mod(k,100))
+* jsgnk = sign(x)
+* jsgnj = 1-2*theta(x-100) (ie -1 iff |x|>100)
+* then
+* pi(k) = jsgnk*( p(i) - jsgnj*pi(j) )
+*
+ do 5 nm=3,4
+ do 4 i=1,nm
+ is1 = i
+ is2 = i+1
+ if ( is2 .gt. nm ) is2 = 1
+ is3 = i-1
+ if ( is3 .eq. 0 ) is3 = nm
+ ip1 = is1 + nm
+ iadj(is1,is2,nm) = -ip1
+ iadj(is2,is1,nm) = ip1
+ iadj(ip1,is2,nm) = -is1
+ iadj(is2,ip1,nm) = is1
+ iadj(is1,ip1,nm) = 100+is2
+ iadj(ip1,is1,nm) = 100+is2
+ if ( nm .eq. 3 ) then
+ iadj(ip1,is2+3,3) = -100-is3-3
+ iadj(is2+3,ip1,3) = -100-is3-3
+ endif
+ 4 continue
+ 5 continue
+
+ iadj(3,1,4) = -9
+ iadj(1,3,4) = 9
+ iadj(9,1,4) = -3
+ iadj(1,9,4) = 3
+ iadj(3,9,4) = 100+1
+ iadj(9,3,4) = 100+1
+
+ iadj(2,4,4) = -10
+ iadj(4,2,4) = 10
+ iadj(10,4,4) = -2
+ iadj(4,10,4) = 2
+ iadj(2,10,4) = 100+4
+ iadj(10,2,4) = 100+4
+
+ endif
+ if ( ns .eq. 6 ) then
+ nm = 3
+ else
+ nm = 4
+ endif
+* #] initialisations:
+* #[ superfluous code:
+* if ( ns .ne. 6 ) print *,'ffcl3m: called with ns <> 6 !!'
+* if ( ip1n .lt. 4 ) then
+* lsign = .TRUE.
+* else
+* lsign = .FALSE.
+* endif
+* if ( ltest .and. lsign ) then
+* if ( ip3n .eq. 4 ) then
+* if ( ip1n .ne. 1 .or. ip2n .ne. 2 ) goto 2
+* elseif ( ip3n .eq. 5 ) then
+* if ( ip1n .ne. 2 .or. ip2n .ne. 3 ) goto 2
+* elseif ( ip3n .eq. 6 ) then
+* if ( ip1n .ne. 3 .or. ip2n .ne. 1 ) goto 2
+* else
+* goto 2
+* endif
+* goto 3
+* 2 continue
+* print *,'ffcl3m: unexpected combination of indices',ip1,ip2,
+* + ip3
+* 3 continue
+* endif
+* this went at he end:
+* #[ special case 4,5,6:
+* Next try - I don't give up easily
+* if ( nm .eq. 6 .and. ip1n .eq. 4 .and. ip2n .eq. 5 .and.
+* + ip3n .eq. 6 .and. is .eq. 1 ) then
+* is3 = isi + 1
+* if ( is3 .eq. 4 ) is3 = 1
+* is1 = is3 + 1
+* if ( is1 .eq. 4 ) is1 = 1
+* ip1 = is1 + 3
+* ip2 = isi + 3
+* ip3 = is3 + 3
+* This is an algorithm of last resort. Add special
+* cases at will.
+* s(1) = xpi(ip1)*xpi(ip2)*xpi(ip3)
+* s(2) = dpipj(is1,isi)*dpipj(ip1,ip2)**2
+* s(3) = -dpipj(is1,isi)*xpi(ip3)*(xpi(ip1)+xpi(ip2))
+* s(4) = 2*dpipj(is1,isi)*dpipj(is1,is3)*
+* + piDpj(ip1,ip3)
+* s(5) = -2*dpipj(is1,is3)*xpi(ip1)*piDpj(ip2,ip3)
+* s(6) = dpipj(is1,isi)**2*xpi(ip3)
+* s(7) = dpipj(is1,is3)**2*xpi(ip1)
+* som = s(1)
+* smax = abs(s(1))
+* do 31 j=2,7
+* som = som + s(j)
+* smax = max(smax,abs(som))
+* 31 continue
+* som = som/4
+* smax = smax/4
+* if (lwrite) print *,' del3mi(',isi,')++= ',som,smax
+* if ( abs(som) .ge. xloss*smax ) goto 35
+* if ( smax .lt. xmax ) then
+* xsom = som
+* xmax = smax
+* endif
+* endif
+* #] special case 4,5,6:
+* #] superfluous code:
+* #[ easy tries:
+ do 40 i=1,itime
+ isi = i+is-1
+ lmax = .FALSE.
+*
+* get xpi(isi)*del2 - del3 ... if del3 and del2 are defined
+*
+ if ( ldel ) then
+ s(1) = xpi(isi)*del2
+ som = s(1) - del3
+ smax = absc(s(1))
+ if ( absc(som) .ge. xloss**2*smax ) goto 35
+ if ( lwrite ) print *,' del3mi(',isi,') =',som,s(1),
+ + del3
+ xsom = som
+ xmax = smax
+ lmax = .TRUE.
+ endif
+ ip1 = ip1n
+ ip2 = ip2n
+ ip3 = ip3n
+ do 20 j=1,3
+*
+* otherwise use the simple threeterm formula
+*
+ s(1) = xpi(ip2)*piDpj(ip1,isi)**2
+ s(2) = xpi(ip1)*piDpj(ip2,isi)*piDpj(ip2,isi)
+ s(3) = -2*piDpj(ip2,isi)*piDpj(ip2,ip1)*piDpj(ip1,isi)
+ som = s(1) + s(2) + s(3)
+ smax = max(absc(s(1)),absc(s(2)),absc(s(3)))
+ if ( lwrite .and. (ldel.or.j.ne.1) ) print *,
+ + ' del3mi(',isi,')+ =',som,(s(k),k=1,3)
+ if ( absc(som) .ge. xloss**2*smax ) goto 35
+ if ( lwrite .and. .not.(ldel.or.j.ne.1) ) print *,
+ + ' del3mi(',isi,') =',som,(s(k),k=1,3)
+ if ( .not. lmax .or. smax .lt. xmax ) then
+ xsom = som
+ xmax = smax
+ lmax = .TRUE.
+ endif
+*
+* if there are cancellations between two of the terms:
+* we try mixing with isi.
+*
+* First map cancellation to s(2)+s(3) (do not mess up
+* rotations...)
+*
+ if ( absc(s(1)+s(3)) .lt. absc(s(3))/2 ) then
+ ihlp = ip1
+ ip1 = ip2
+ ip2 = ihlp
+ som = s(1)
+ s(1) = s(2)
+ s(2) = som
+ ltwist = .TRUE.
+ else
+ ltwist = .FALSE.
+ endif
+ if ( absc(s(2)+s(3)) .lt. absc(s(3))/2 ) then
+*
+* switch to the vector pn so that si = jsgn1*p1 + jsgnn*pn
+*
+ k = iadj(isi,ip1,nm)
+ if ( k .ne. 0 ) then
+ ipn = abs(k)
+ jsgnn = isign(1,k)
+ if ( ipn .gt. 100 ) then
+ ipn = ipn - 100
+ jsgn1 = -1
+ else
+ jsgn1 = +1
+ endif
+ if ( absc(dpipj(ipn,isi)) .lt.
+ + xloss*absc(piDpj(ip1,isi)) .and.
+ + absc(piDpj(ipn,ip2)) .lt.
+ + xloss*absc(piDpj(ip2,isi)) ) then
+* same: s(1) = xpi(ip2)*piDpj(ip1,isi)**2
+ s(2) = jsgnn*piDpj(isi,ip2)*piDpj(ipn,ip2)*
+ + xpi(ip1)
+ s(3) = jsgn1*piDpj(isi,ip2)*piDpj(ip1,ip2)*
+ + dpipj(ipn,isi)
+ som = s(1) + s(2) + s(3)
+ smax = max(absc(s(1)),absc(s(2)),absc(s(3)))
+ if ( lwrite ) print *,
+ + ' del3mi(',isi,')++=',som,(s(k),k=1,3)
+* print *,' (isi+ip1) with isi,ip1,ip2,ipn: ',
+* + isi,ip1,ip2,ipn
+* print *,'xpi(ip2),piDpj(ip1,isi)',xpi(ip2),
+* + piDpj(ip1,isi)
+* print *,'piDpj(isi,ip2),piDpj(ipn,ip2),xpi(ip1)'
+* + ,piDpj(isi,ip2),piDpj(ipn,ip2),xpi(ip1)
+ if ( absc(som) .ge. xloss**2*smax ) goto 35
+ if ( smax .lt. xmax ) then
+ xsom = som
+ xmax = smax
+ endif
+*
+* there may be a cancellation between s(1) and
+* s(2) left. Introduce a vector q such that
+* pn = jsgnq*q + jsgn2*p2. We also need the sign
+* jsgn3 in p3 = -p1 - jsgn3*p2
+*
+ k = iadj(ipn,ip2,nm)
+ if ( k .ne. 0 ) then
+ iqn = abs(k)
+*not used jsgnq = isign(1,k)
+ if ( iqn .gt. 100 ) then
+ iqn = iqn - 100
+ jsgn2 = -1
+ else
+ jsgn2 = +1
+ endif
+ k = iadj(ip1,ip2,nm)
+ if ( k .eq. 0 .or. k .lt. 100 ) then
+* we have p1,p2,p3 all p's
+ jsgn3 = +1
+ elseif ( k .lt. 0 ) then
+* ip1,ip2 are 2*s,1*p such that p2-p1=ip3
+ jsgn3 = -1
+ else
+ jsgn3 = 0
+ endif
+* we need one condition on the signs for this
+* to work
+ if ( ip3.ne.0 .and. jsgn1*jsgn2.eq.jsgnn*
+ + jsgn3 .and. absc(s(3)).lt.xloss*smax ) then
+ s(1) = piDpj(ip1,isi)**2*dpipj(iqn,ipn)
+ s(2) = -jsgn2*jsgn1*piDpj(ipn,ip2)*
+ + piDpj(ip1,isi)*dpipj(ipn,isi)
+* s(3) stays the same
+ s(4) = -jsgn2*jsgn1*piDpj(ipn,ip2)*
+ + xpi(ip1)*piDpj(isi,ip3)
+ som = s(1) + s(2) + s(3) + s(4)
+ smax = max(absc(s(1)),absc(s(2)),
+ + absc(s(3)),absc(s(4)))
+ if ( lwrite ) print *,
+ + ' del3mi(',isi,')+2=',som,(s(k),k=1,4)
+ if (absc(som).ge.xloss**2*smax) goto 35
+ if ( smax .lt. xmax ) then
+ xsom = som
+ xmax = smax
+ endif
+ endif
+ endif
+ endif
+ endif
+ k = iadj(isi,ip2,nm)
+ if ( k .ne. 0 ) then
+ ipn = abs(k)
+ jsgnn = isign(1,k)
+ if ( ipn .gt. 100 ) then
+ jsgn1 = -1
+ ipn = ipn - 100
+ else
+ jsgn1 = +1
+ endif
+ if ( absc(dpipj(ipn,isi)) .lt.
+ + xloss*absc(piDpj(ip2,isi)) .and.
+ + absc(piDpj(ipn,ip1)) .lt.
+ + xloss*absc(piDpj(ip1,isi)) ) then
+ s(1) = jsgnn*piDpj(isi,ip1)*piDpj(ipn,ip1)*
+ + xpi(ip2)
+ s(2) = xpi(ip1)*piDpj(ip2,isi)**2
+ s(3) = jsgn1*piDpj(isi,ip1)*piDpj(ip2,ip1)*
+ + dpipj(ipn,isi)
+ som = s(1) + s(2) + s(3)
+ smax = max(absc(s(1)),absc(s(2)),absc(s(3)))
+ if ( lwrite ) print *,
+ + ' del3mi(',isi,')++=',som,(s(k),k=1,3)
+ print *,' (isi+ip2) with isi,ip1,ip2,ipn: ',
+ + isi,ip1,ip2,ipn
+ if ( absc(som) .ge. xloss**2*smax ) goto 35
+ if ( smax .lt. xmax ) then
+ xsom = som
+ xmax = smax
+ endif
+ endif
+ endif
+ endif
+*this does not suffice
+* if ( lsign ) then
+* if ( absc(s(1)) .lt. absc(s(2)) ) then
+* s(2) = piDpj(isi,ip2)*piDpj(isi,ip3)*xpi(ip1)
+* if ( j .eq. 2 ) s(2) = -s(2)
+* s(3) = piDpj(isi,ip1)*piDpj(isi,ip2)*
+* + dpipj(ip3,ip2)
+* else
+* s(1) = piDpj(isi,ip1)*piDpj(isi,ip3)*xpi(ip2)
+* if ( j .eq. 1 ) s(1) = -s(1)
+* s(3) = piDpj(isi,ip1)*piDpj(isi,ip2)*
+* + dpipj(ip3,ip1)
+* endif
+* if ( j .eq. 3 ) s(3) = -s(3)
+**
+* som = s(1) + s(2) + s(3)
+* smax = max(absc(s(1)),absc(s(2)),absc(s(3)))
+* if ( lwrite ) print *,
+* + ' del3mi(',isi,')++=',som,(s(k),k=1,3)
+* if ( absc(som) .ge. xloss**2*smax ) goto 35
+* if ( smax .lt. xmax ) then
+* xmax = smax
+* xsom = som
+* endif
+* endif
+*nor does this
+* if ( j .eq. 1 )
+* + call ffcel2(del2s,piDpj,6,ip1,ip2,ip3,1,ier)
+* call ffcl2t(delps,piDpj,isi,ip2,ip1,ip2,ip3,+1,+1,6,ier)
+* s(1) = piDpj(isi,ip2)**2*del2s/xpi(ip2)
+* s(2) = delps**2/xpi(ip2)
+* som = s(1) + s(2)
+* smax = absc(s(1))
+* if ( lwrite ) print *,
+* + ' del3mi(',isi,')++=',del3mi(i),(s(k),k=1,2)
+* if ( absc(som) .ge. xloss*smax ) goto 35
+* if ( smax .lt. xmax ) then
+* xmax = smax
+* xsom = som
+* endif
+*
+* rotate the ipi
+*
+ if ( ip3 .eq. 0 ) goto 30
+ if ( j .ne. 3 ) then
+ if ( .not. ltwist ) then
+ ihlp = ip1
+ ip1 = ip2
+ ip2 = ip3
+ ip3 = ihlp
+ else
+ ihlp = ip2
+ ip2 = ip3
+ ip3 = ihlp
+ endif
+ endif
+ 20 continue
+ 30 continue
+* #] easy tries:
+* #[ choose the best value:
+*
+* These values are the best found:
+*
+ som = xsom
+ smax = xmax
+ if ( lwarn ) call ffwarn(75,ier,absc(som),smax)
+ if ( lwrite ) then
+ print *,'ffcl3m: giving up:'
+ print *,'ip1,ip2,ip3,is,itime =',ip1,ip2,ip3,is,itime
+ print *,'xpi = ',xpi
+ endif
+
+ 35 continue
+ del3mi(i) = som
+ 40 continue
+* #] choose the best value:
+*###] ffcl3m:
+ end
diff --git a/ff-2.0/ffcel3.f b/ff-2.0/ffcel3.f
new file mode 100644
index 0000000..d921ddd
--- /dev/null
+++ b/ff-2.0/ffcel3.f
@@ -0,0 +1,402 @@
+*###[ ffcel3:
+ subroutine ffcel3(del3,xpi,piDpj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate del3(piDpj) = det(si.sj) with *
+* the momenta as follows: *
+* p(1-3) = s(i) *
+* p(4-6) = p(i) *
+* *
+* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
+* piDpj(ns,ns) (real) *
+* ns (integer) *
+* ier (integer) *
+* *
+* Output: del3 (real) det(si.sj) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ier
+ DOUBLE COMPLEX del3,xpi(6),piDpj(6,6)
+*
+* local variables:
+*
+ integer mem,nperm
+ parameter(mem=10,nperm=16)
+ integer i,jj(6),iperm(3,nperm),imem,memarr(mem,3),memind,inow
+ DOUBLE COMPLEX s(6),del3p,cc
+ DOUBLE PRECISION xmax,xmaxp,absc,rloss
+ save iperm,memind,memarr,inow
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+* #] declarations:
+* #[ data:
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1/
+ data inow /1/
+*
+* these are all permutations that give a non-zero result with the
+* correct sign. This list was generated with getperm3.
+*
+ data iperm/
+ + 1,2,3, 1,2,5, 1,6,2, 1,4,3,
+ + 1,3,5, 1,4,5, 1,6,4, 1,5,6,
+ + 2,4,3, 2,3,6, 2,4,5, 2,6,4,
+ + 2,5,6, 3,4,5, 3,6,4, 3,5,6/
+* #] data:
+* #[ check input:
+ if ( ltest .and. ns .ne. 6 ) then
+ print *,'ffcel3: error: only for ns = 6, not ',ns
+ stop
+ endif
+* #] check input:
+* #[ starting point in memory?:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
+ inow = memarr(i,3)
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] starting point in memory?:
+* #[ calculations:
+ imem = inow
+ del3 = 0
+ xmax = 0
+
+ 10 continue
+
+ jj(1) = iperm(1,inow)
+ jj(3) = iperm(2,inow)
+ jj(5) = iperm(3,inow)
+
+ jj(2) = iperm(1,inow)
+ jj(4) = iperm(2,inow)
+ jj(6) = iperm(3,inow)
+
+ s(1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(6))
+ s(2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(2))
+ s(3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(4))
+ s(4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(4))
+ s(5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(2))
+ s(6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(6))
+
+ del3p = 0
+ xmaxp = 0
+ do 20 i=1,6
+ del3p = del3p + s(i)
+ xmaxp = max(xmaxp,absc(s(i)))
+ 20 continue
+ if ( absc(del3p) .lt. xloss*xmaxp ) then
+ if ( lwrite ) print *,'del3+',inow,' = ',del3p,xmaxp
+ if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
+ del3 = del3p
+ xmax = xmaxp
+ endif
+ inow = inow + 1
+ if ( inow .gt. nperm ) inow = 1
+ if ( inow .eq. imem ) then
+ if ( lwarn ) call ffwarn(72,ier,absc(del3),xmax)
+ goto 800
+ endif
+ goto 10
+ endif
+ if ( inow .ne. imem ) then
+ if ( lwrite ) print *,'del3+',inow,' = ',del3p,xmaxp
+ endif
+ del3 = del3p
+ xmax = xmaxp
+* #] calculations:
+* #[ into memory:
+ 800 continue
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+* #] into memory:
+* #[ check output:
+ if ( ltest ) then
+
+ s(1) = +piDpj(1,1)*piDpj(2,2)*piDpj(3,3)
+ s(2) = +piDpj(1,2)*piDpj(2,3)*piDpj(3,1)
+ s(3) = +piDpj(1,3)*piDpj(2,1)*piDpj(3,2)
+ s(4) = -piDpj(1,1)*piDpj(2,3)*piDpj(3,2)
+ s(5) = -piDpj(1,3)*piDpj(2,2)*piDpj(3,1)
+ s(6) = -piDpj(1,2)*piDpj(2,1)*piDpj(3,3)
+
+ del3p = 0
+ xmaxp = 0
+ do 820 i=1,6
+ del3p = del3p + s(i)
+ xmaxp = max(xmaxp,absc(s(i)))
+ 820 continue
+ cc = del3p-del3
+ rloss = xloss*DBLE(10)**(-mod(ier,50))
+ if ( rloss*absc(cc) .gt. precc*xmaxp ) then
+ print *,'ffcel3: error: result does not agree with',
+ + ' normal case'
+ print *,'result: ',del3,xmax
+ print *,'normal: ',del3p,xmaxp
+ print *,'diff.: ',del3-del3p
+ endif
+ endif
+* #] check output:
+*###] ffcel3:
+ end
+*(##[ ffcl3s:
+ subroutine ffcl3s(dl3s,xpi,piDpj,ii,ns,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate dl3s(piDpj) = det(si.sj) with *
+* the momenta indicated by the indices ii(1-6,1), ii(1-6,2) *
+* as follows: *
+* p(|ii(1,)|-|ii(3,)|) = s(i) *
+* p(|ii(4,)|-|ii(6,)|) = p(i) = sgn(ii())*(s(i+1) - s(i)) *
+* *
+* At this moment (26-apr-1990) only the diagonal is tried *
+* *
+* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
+* piDpj(ns,ns) (real) *
+* ii(6,2) (integer) see above *
+* ns (integer) *
+* ier (integer) *
+* *
+* Output: dl3s (real) det(si.sj) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ii(6,2),ns,ier
+ DOUBLE COMPLEX dl3s,xpi(ns),piDpj(ns,ns)
+*
+* local variables:
+*
+ integer mem,nperm
+ parameter(mem=10,nperm=16)
+ integer i,j,jj(6),jsgn,iperm(3,nperm),imem,memarr(mem,3),
+ + memind,inow
+ DOUBLE PRECISION xmax,xmaxp,xlosn,absc,rloss
+ DOUBLE COMPLEX s(6),dl3sp,xhck,cc
+ save iperm,memind,memarr,inow
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ data:
+*
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1/
+ data inow /1/
+*
+* these are all permutations that give a non-zero result with the
+* correct sign. This list was generated with getperm3.
+*
+ data iperm/
+ + 1,2,3, 1,2,5, 1,6,2, 1,4,3,
+ + 1,3,5, 1,4,5, 1,6,4, 1,5,6,
+ + 2,4,3, 2,3,6, 2,4,5, 2,6,4,
+ + 2,5,6, 3,4,5, 3,6,4, 3,5,6/
+* #] data:
+* #[ test input:
+ if ( ltest ) then
+ if ( lwrite ) then
+ print *,'ffcl3s: input: ii(,1) = ',(ii(i,1),i=1,6)
+ print *,' ii(,2) = ',(ii(i,2),i=1,6)
+ endif
+ xlosn = xloss*DBLE(10)**(-mod(ier,50)-1)
+ do 3 j=1,2
+ do 1 i=1,6
+ if ( abs(ii(i,j)) .gt. ns ) print *,'ffcl3s: error: ',
+ + '|ii(i,j)| > ns: ',ii(i,j),ns
+ if ( abs(ii(i,j)) .eq. 0 ) print *,'ffcl3s: error: ',
+ + '|ii(i,j)| = 0: ',ii(i,j)
+ 1 continue
+ do 2 i=1,6
+
+ xhck = piDpj(abs(ii(i,j)),ii(1,j))
+ + - piDpj(abs(ii(i,j)),ii(2,j))
+ + + sign(1,ii(4,j))*piDpj(abs(ii(i,j)),abs(ii(4,j)))
+ xmax = max(absc(piDpj(abs(ii(i,j)),ii(1,j))),
+ + absc(piDpj(abs(ii(i,j)),ii(2,j))))
+ if ( xlosn*absc(xhck).gt.precc*xmax ) print *,'ffcl3s:'
+ + ,' error: dotproducts 124 with ',i,' do not add to 0:'
+ + ,piDpj(abs(ii(i,j)),ii(1,j)),
+ + piDpj(abs(ii(i,j)),ii(2,j)),
+ + piDpj(abs(ii(i,j)),abs(ii(4,j))),xhck
+
+ xhck = piDpj(abs(ii(i,j)),ii(2,j))
+ + - piDpj(abs(ii(i,j)),ii(3,j))
+ + +sign(1,ii(5,j))*piDpj(abs(ii(i,j)),abs(ii(5,j)))
+ xmax = max(absc(piDpj(abs(ii(i,j)),ii(2,j))),
+ + absc(piDpj(abs(ii(i,j)),ii(3,j))))
+ if ( xlosn*absc(xhck).gt.precc*xmax ) print *,'ffcl3s:'
+ + ,' error: dotproducts 235 with ',i,' do not add to 0:'
+ + ,piDpj(abs(ii(i,j)),ii(2,j)),
+ + piDpj(abs(ii(i,j)),ii(3,j)),
+ + piDpj(abs(ii(i,j)),abs(ii(5,j))),xhck
+
+ xhck = piDpj(abs(ii(i,j)),ii(3,j))
+ + - piDpj(abs(ii(i,j)),ii(1,j))
+ + + sign(1,ii(6,j))*piDpj(abs(ii(i,j)),abs(ii(6,j)))
+ xmax = max(absc(piDpj(abs(ii(i,j)),ii(3,j))),
+ + absc(piDpj(abs(ii(i,j)),ii(1,j))))
+ if ( xlosn*absc(xhck).gt.precc*xmax ) print *,'ffcl3s:'
+ + ,' error: dotproducts 316 with ',i,' do not add to 0:'
+ + ,piDpj(abs(ii(i,j)),ii(3,j)),
+ + piDpj(abs(ii(i,j)),ii(1,j)),
+ + piDpj(abs(ii(i,j)),abs(ii(6,j))),xhck
+
+ xhck = sign(1,ii(4,j))*piDpj(abs(ii(i,j)),abs(ii(4,j)))
+ + + sign(1,ii(5,j))*piDpj(abs(ii(i,j)),abs(ii(5,j)))
+ + + sign(1,ii(6,j))*piDpj(abs(ii(i,j)),abs(ii(6,j)))
+ xmax = max(absc(piDpj(abs(ii(i,j)),abs(ii(4,j)))),
+ + absc(piDpj(abs(ii(i,j)),abs(ii(5,j)))))
+ if ( xlosn*absc(xhck).gt.precc*xmax ) print *,'ffcl3s:'
+ + ,' error: dotproducts 456 with ',i,' do not add to 0:'
+ + ,piDpj(abs(ii(i,j)),abs(ii(4,j))),
+ + piDpj(abs(ii(i,j)),abs(ii(5,j))),
+ + piDpj(abs(ii(i,j)),abs(ii(6,j))),xhck
+
+ 2 continue
+ 3 continue
+ do 4 i=1,ns
+ xhck = piDpj(i,i) - xpi(i)
+ xmax = abs(xpi(i))
+ if ( xlosn*absc(xhck).gt.precc*xmax ) print *,'ffcl3s:'
+ + ,' error: xpi(',i,') != piDpj(',i,i,') :',xpi(i),
+ + piDpj(i,i),xhck
+ 4 continue
+ endif
+* #] test input:
+* #[ starting point in memory?:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
+ inow = memarr(i,3)
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] starting point in memory?:
+* #[ calculations:
+ imem = inow
+ dl3s = 0
+ xmax = 0
+
+ 10 continue
+
+ jj(1) = abs(ii(iperm(1,inow),1))
+ jj(3) = abs(ii(iperm(2,inow),1))
+ jj(5) = abs(ii(iperm(3,inow),1))
+
+ jj(2) = abs(ii(iperm(1,inow),2))
+ jj(4) = abs(ii(iperm(2,inow),2))
+ jj(6) = abs(ii(iperm(3,inow),2))
+
+ jsgn = sign(1,ii(iperm(1,inow),1))
+ + *sign(1,ii(iperm(2,inow),1))
+ + *sign(1,ii(iperm(3,inow),1))
+ + *sign(1,ii(iperm(1,inow),2))
+ + *sign(1,ii(iperm(2,inow),2))
+ + *sign(1,ii(iperm(3,inow),2))
+
+ s(1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(6))
+ s(2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(2))
+ s(3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(4))
+ s(4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(4))
+ s(5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(2))
+ s(6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(6))
+
+ dl3sp = 0
+ xmaxp = 0
+ do 20 i=1,6
+ dl3sp = dl3sp + s(i)
+ xmaxp = max(xmaxp,absc(s(i)))
+ 20 continue
+ if ( absc(dl3sp) .lt. xloss*xmaxp ) then
+ if ( lwrite ) print *,'dl3s+',inow,' = ',dl3sp,xmaxp
+ if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
+ dl3s = jsgn*dl3sp
+ xmax = xmaxp
+ endif
+ inow = inow + 1
+ if ( inow .gt. nperm ) inow = 1
+ if ( inow .eq. imem ) then
+ if ( lwarn ) call ffwarn(85,ier,absc(dl3s),xmax)
+ goto 800
+ endif
+ goto 10
+ endif
+ if ( inow .ne. imem ) then
+ if ( lwrite ) print *,'dl3s+',inow,' = ',dl3sp,xmaxp
+ endif
+ dl3s = jsgn*dl3sp
+ xmax = xmaxp
+* #] calculations:
+* #[ into memory:
+ 800 continue
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+* #] into memory:
+* #[ check output:
+ if ( ltest ) then
+
+ s(1) = +piDpj(ii(1,1),ii(1,2))*piDpj(ii(2,1),ii(2,2))*
+ + piDpj(ii(3,1),ii(3,2))
+ s(2) = +piDpj(ii(1,1),ii(2,2))*piDpj(ii(2,1),ii(3,2))*
+ + piDpj(ii(3,1),ii(1,2))
+ s(3) = +piDpj(ii(1,1),ii(3,2))*piDpj(ii(3,1),ii(2,2))*
+ + piDpj(ii(2,1),ii(1,2))
+ s(4) = -piDpj(ii(1,1),ii(1,2))*piDpj(ii(2,1),ii(3,2))*
+ + piDpj(ii(3,1),ii(2,2))
+ s(5) = -piDpj(ii(1,1),ii(3,2))*piDpj(ii(2,1),ii(2,2))*
+ + piDpj(ii(3,1),ii(1,2))
+ s(6) = -piDpj(ii(1,1),ii(2,2))*piDpj(ii(2,1),ii(1,2))*
+ + piDpj(ii(3,1),ii(3,2))
+
+ dl3sp = 0
+ xmaxp = 0
+ do 820 i=1,6
+ dl3sp = dl3sp + s(i)
+ xmaxp = max(xmaxp,absc(s(i)))
+ 820 continue
+ rloss = xloss*DBLE(10)**(-mod(ier,50))
+ if ( rloss*absc(dl3sp-dl3s) .gt. precc*xmaxp ) then
+ print *,'ffcl3s: error: result does not agree with',
+ + ' normal case'
+ print *,'result: ',dl3s,xmax
+ print *,'normal: ',dl3sp,xmaxp
+ print *,'diff.: ',dl3s-dl3sp
+ endif
+ endif
+* #] check output:
+*)##] ffcl3s:
+ end
diff --git a/ff-2.0/ffcel4.f b/ff-2.0/ffcel4.f
new file mode 100644
index 0000000..c3ed94e
--- /dev/null
+++ b/ff-2.0/ffcel4.f
@@ -0,0 +1,419 @@
+*###[ ffcel4:
+ subroutine ffcel4(del4,xpi,piDpj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate del4(piDpj) = det(si.sj) with *
+* the momenta as follows: *
+* p(1-4) = s(i) *
+* p(4-10) = p(i) *
+* *
+* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
+* piDpj(ns,ns) (real) *
+* ns (integer) *
+* ier (integer) *
+* *
+* Output: del4 (real) det(si.sj) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ier
+ DOUBLE COMPLEX del4,xpi(10),piDpj(10,10)
+*
+* local variables:
+*
+ integer mem,nperm
+ parameter(mem=10,nperm=125)
+ integer i,jj(8),iperm(4,nperm),imem,jmem,memarr(mem,4),memind,
+ + inow,jnow,icount
+ DOUBLE PRECISION xmax,xmaxp,absc,rloss
+ DOUBLE COMPLEX s(24),del4p,c
+ save iperm,memind,memarr,inow,jnow
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement functions:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ data:
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1,mem*1/
+ data inow /1/
+ data jnow /1/
+*
+* these are all permutations that give a non-zero result with the
+* correct sign. This list was generated with getperm4.
+* (note: this used to be well-ordened, but then it had more than
+* 19 continuation lines)
+*
+ data iperm/
+ + 1,2,3,4,1,2,3,7,1,2,8,3,1,2,3,10,1,2,6,4,1,2,4,7,1,2,4,9,1,2,6,7
+ + ,1,2,8,6,1,2,6,10,1,2,7,8,1,2,7,9,1,2,10,7,1,2,9,8,1,2,10,9,1,3,
+ + 4,5,1,3,6,4,1,3,10,4,1,3,7,5,1,3,5,8,1,3,10,5,1,3,6,7,1,3,8,6,1,
+ + 3,6,10,1,3,10,7,1,3,8,10,1,4,5,6,1,4,7,5,1,4,9,5,1,4,6,7,1,4,6,9
+ + ,1,4,6,10,1,4,10,7,1,4,10,9,1,5,6,7,1,5,8,6,1,5,6,10,1,5,7,8,1,5
+ + ,7,9,1,5,10,7,1,5,9,8,1,5,10,9,1,6,8,7,1,6,9,7,1,6,8,9,1,6,8,10,
+ + 1,6,9,10,1,7,10,8,1,7,10,9,1,8,9,10,2,3,4,5,2,3,8,4,2,3,9,4,2,3,
+ + 7,5,2,3,5,8,2,3,10,5,2,3,8,7,2,3,9,7,2,3,8,9,2,3,8,10,2,3,9,10,2
+ + ,4,5,6,2,4,7,5,2,4,9,5,2,4,6,8,2,4,6,9,2,4,8,7,2,4,9,7,2,4,8,9,2
+ + ,5,6,7,2,5,8,6,2,5,6,10,2,5,7,8,2,5,7,9,2,5,10,7,2,5,9,8,2,5,10,
+ + 9,2,6,8,7,2,6,9,7,2,6,8,9,2,6,8,10,2,6,9,10,2,7,10,8,2,7,10,9,2,
+ + 8,9,10,3,4,5,6,3,4,8,5,3,4,9,5,3,4,5,10,3,4,6,8,3,4,6,9,3,4,10,8
+ + ,3,4,10,9,3,5,6,7,3,5,8,6,3,5,6,10,3,5,7,8,3,5,7,9,3,5,10,7,3,5,
+ + 9,8,3,5,10,9,3,6,8,7,3,6,9,7,3,6,8,9,3,6,8,10,3,6,9,10,3,7,10,8,
+ + 3,7,10,9,3,8,9,10,4,5,6,7,4,5,8,6,4,5,6,10,4,5,7,8,4,5,7,9,4,5,1
+ + 0,7,4,5,9,8,4,5,10,9,4,6,8,7,4,6,9,7,4,6,8,9,4,6,8,10,4,6,9,10,4
+ + ,7,10,8,4,7,10,9,4,8,9,10/
+* #] data:
+* #[ get starting point from memory:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
+ inow = memarr(i,3)
+ jnow = memarr(i,4)
+ if ( lwrite ) print *,'ffcel4: from memory: ',id,idsub,
+ + inow,jnow
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] get starting point from memory:
+* #[ calculations:
+ imem = inow
+ jmem = jnow
+ del4 = 0
+ xmax = 0
+ icount = 0
+*
+ 10 continue
+
+ jj(1) = iperm(1,inow)
+ jj(3) = iperm(2,inow)
+ jj(5) = iperm(3,inow)
+ jj(7) = iperm(4,inow)
+
+ jj(2) = iperm(1,jnow)
+ jj(4) = iperm(2,jnow)
+ jj(6) = iperm(3,jnow)
+ jj(8) = iperm(4,jnow)
+
+ s( 1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(7),jj(8))
+ s( 2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(7),jj(8))
+ s( 3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(7),jj(8))
+ s( 4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(7),jj(8))
+ s( 5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(7),jj(8))
+ s( 6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(7),jj(8))
+
+ s( 7) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(7),jj(6))*piDpj(jj(5),jj(8))
+ s( 8) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(7),jj(2))*piDpj(jj(5),jj(8))
+ s( 9) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(7),jj(4))*piDpj(jj(5),jj(8))
+ s(10) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(7),jj(4))*piDpj(jj(5),jj(8))
+ s(11) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(7),jj(2))*piDpj(jj(5),jj(8))
+ s(12) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(7),jj(6))*piDpj(jj(5),jj(8))
+
+ s(13) = -piDpj(jj(1),jj(2))*piDpj(jj(7),jj(4))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(3),jj(8))
+ s(14) = -piDpj(jj(1),jj(4))*piDpj(jj(7),jj(6))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(3),jj(8))
+ s(15) = -piDpj(jj(1),jj(6))*piDpj(jj(7),jj(2))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(3),jj(8))
+ s(16) = +piDpj(jj(1),jj(2))*piDpj(jj(7),jj(6))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(3),jj(8))
+ s(17) = +piDpj(jj(1),jj(6))*piDpj(jj(7),jj(4))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(3),jj(8))
+ s(18) = +piDpj(jj(1),jj(4))*piDpj(jj(7),jj(2))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(3),jj(8))
+
+ s(19) = -piDpj(jj(7),jj(2))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(1),jj(8))
+ s(20) = -piDpj(jj(7),jj(4))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(1),jj(8))
+ s(21) = -piDpj(jj(7),jj(6))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(1),jj(8))
+ s(22) = +piDpj(jj(7),jj(2))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(1),jj(8))
+ s(23) = +piDpj(jj(7),jj(6))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(1),jj(8))
+ s(24) = +piDpj(jj(7),jj(4))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(1),jj(8))
+
+ del4p = 0
+ xmaxp = 0
+ do 20 i=1,24
+ del4p = del4p + s(i)
+ xmaxp = max(xmaxp,absc(s(i)))
+ 20 continue
+ if ( absc(del4p) .lt. xloss*xmaxp ) then
+ if ( lwrite ) print *,'del4+',icount,' = ',del4p,xmaxp,inow,
+ + jnow
+ if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
+ del4 = del4p
+ xmax = xmaxp
+ endif
+* as the list is ordered we may have more luck stepping
+* through with large steps
+ inow = inow + 43
+ jnow = jnow + 49
+ if ( inow .gt. nperm ) inow = inow - nperm
+ if ( jnow .gt. nperm ) jnow = jnow - nperm
+ icount = icount + 1
+ if ( icount.gt.15 .or. inow.eq.imem .or. jnow.eq.jmem
+ + ) then
+ if ( lwarn ) call ffwarn(143,ier,absc(del4),xmax)
+ goto 800
+ endif
+ goto 10
+ endif
+ if ( inow.ne.imem) then
+ if ( lwrite ) print *,'del4+',icount,' = ',del4p,xmaxp,inow,
+ + jnow
+ endif
+ del4 = del4p
+ xmax = xmaxp
+* #] calculations:
+* #[ into memory:
+ if ( lwrite ) print *,'ffcel4: into memory: ',id,idsub,inow,jnow
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+ memarr(memind,4) = jnow
+ 800 continue
+* #] into memory:
+* #[ check output:
+ if ( ltest ) then
+
+ s( 1) = +piDpj(1,1)*piDpj(2,2)*piDpj(3,3)*piDpj(4,4)
+ s( 2) = +piDpj(1,2)*piDpj(2,3)*piDpj(3,1)*piDpj(4,4)
+ s( 3) = +piDpj(1,3)*piDpj(2,1)*piDpj(3,2)*piDpj(4,4)
+ s( 4) = -piDpj(1,1)*piDpj(2,3)*piDpj(3,2)*piDpj(4,4)
+ s( 5) = -piDpj(1,3)*piDpj(2,2)*piDpj(3,1)*piDpj(4,4)
+ s( 6) = -piDpj(1,2)*piDpj(2,1)*piDpj(3,3)*piDpj(4,4)
+
+ s( 7) = -piDpj(1,1)*piDpj(2,2)*piDpj(4,3)*piDpj(3,4)
+ s( 8) = -piDpj(1,2)*piDpj(2,3)*piDpj(4,1)*piDpj(3,4)
+ s( 9) = -piDpj(1,3)*piDpj(2,1)*piDpj(4,2)*piDpj(3,4)
+ s(10) = +piDpj(1,1)*piDpj(2,3)*piDpj(4,2)*piDpj(3,4)
+ s(11) = +piDpj(1,3)*piDpj(2,2)*piDpj(4,1)*piDpj(3,4)
+ s(12) = +piDpj(1,2)*piDpj(2,1)*piDpj(4,3)*piDpj(3,4)
+
+ s(13) = -piDpj(1,1)*piDpj(4,2)*piDpj(3,3)*piDpj(2,4)
+ s(14) = -piDpj(1,2)*piDpj(4,3)*piDpj(3,1)*piDpj(2,4)
+ s(15) = -piDpj(1,3)*piDpj(4,1)*piDpj(3,2)*piDpj(2,4)
+ s(16) = +piDpj(1,1)*piDpj(4,3)*piDpj(3,2)*piDpj(2,4)
+ s(17) = +piDpj(1,3)*piDpj(4,2)*piDpj(3,1)*piDpj(2,4)
+ s(18) = +piDpj(1,2)*piDpj(4,1)*piDpj(3,3)*piDpj(2,4)
+
+ s(19) = -piDpj(4,1)*piDpj(2,2)*piDpj(3,3)*piDpj(1,4)
+ s(20) = -piDpj(4,2)*piDpj(2,3)*piDpj(3,1)*piDpj(1,4)
+ s(21) = -piDpj(4,3)*piDpj(2,1)*piDpj(3,2)*piDpj(1,4)
+ s(22) = +piDpj(4,1)*piDpj(2,3)*piDpj(3,2)*piDpj(1,4)
+ s(23) = +piDpj(4,3)*piDpj(2,2)*piDpj(3,1)*piDpj(1,4)
+ s(24) = +piDpj(4,2)*piDpj(2,1)*piDpj(3,3)*piDpj(1,4)
+
+ del4p = 0
+ xmaxp = 0
+ do 820 i=1,24
+ del4p = del4p + s(i)
+ xmaxp = max(xmaxp,absc(s(i)))
+ 820 continue
+ rloss = xloss*DBLE(10)**(-mod(ier,50)-1)
+ if ( rloss*absc(del4p-del4) .gt. precc*xmaxp ) then
+ print *,'ffcel4: error: result does not agree with',
+ + ' normal case'
+ print *,'result: ',del4,xmax
+ print *,'normal: ',del4p,xmaxp
+ print *,'diff.: ',del4-del4p,ier
+ endif
+ endif
+* #] check output:
+*###] ffcel4:
+ end
+*###[ ffcl3p:
+ subroutine ffcl3p(dl3p,piDpj,ns,ii,jj,ier)
+***#[*comment:***********************************************************
+* calculate in a numerically stable way *
+* *
+* p1 p2 p3 *
+* delta *
+* p1' p2' p3' *
+* *
+* with pn = xpi(ii(n)), p4 = -p1-p2-p3, p5 = -p1-p2, p6 = p2+p3 *
+* with pn'= xpi(jj(n)), p4'= etc. (when ns=15 p5=p1+p2) *
+* *
+* Input: piDpj complex(ns,ns) dotpruducts *
+* ns integer either 10 or 15 *
+* ii,jj integer(6) location of pi in piDpj *
+* ier integer number of digits lost so far *
+* Output: dl3p complex see above *
+* ier integer number of digits lost so far *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ii(6),jj(6),ier
+ DOUBLE COMPLEX dl3p,piDpj(ns,ns)
+*
+* local variables
+*
+ integer i,j,k,l,iperm(3,16),ii1,ii2,ii3,jj1,jj2,jj3,nl
+ DOUBLE PRECISION xmax,smax,absc
+ DOUBLE COMPLEX s(6),som,xheck,c
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement functions:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data iperm /1,2,3, 2,4,3, 3,4,1, 4,2,1,
+ + 1,2,6, 6,4,3, 3,1,6, 2,4,6,
+ + 2,5,3, 5,4,1, 1,3,5, 2,4,5,
+ + 1,6,5, 2,5,6, 3,6,5, 4,5,6/
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffcl3p: indices are'
+ print *,ii
+ print *,jj
+ endif
+ if ( ltest ) then
+ if ( ns .ne. 10 .and. ns .ne. 15 ) print *,'ffcl3p: error:',
+ + ' only tested for ns=10,15'
+ do 10 i=1,ns
+ xheck = +piDpj(i,ii(1))+piDpj(i,ii(2))
+ + +piDpj(i,ii(3))+piDpj(i,ii(4))
+ xmax = max(absc(piDpj(i,ii(1))),absc(piDpj(i,ii(2))),
+ + absc(piDpj(i,ii(3))),absc(piDpj(i,ii(4))))
+ if ( xloss*absc(xheck) .gt. precc*xmax ) print *,
+ + 'ffcl3p: error: momenta i1234 do not add to 0:',
+ + piDpj(i,ii(1)),piDpj(i,ii(2)),piDpj(i,ii(3)),
+ + piDpj(i,ii(4)),xheck,i
+ xheck = piDpj(i,ii(6))-piDpj(i,ii(2))-piDpj(i,ii(3))
+ xmax = max(absc(piDpj(i,ii(6))),absc(piDpj(i,ii(2))),
+ + absc(piDpj(i,ii(3))))
+ if ( xloss*absc(xheck) .gt. precc*xmax ) print *,
+ + 'ffcl3p: error: momenta i623 do not add to 0:',
+ + piDpj(i,ii(6)),piDpj(i,ii(2)),piDpj(i,ii(3)),
+ + xheck,i
+ if ( ns .eq. 10 ) then
+ xheck = piDpj(i,ii(5))+piDpj(i,ii(1))+piDpj(i,ii(2))
+ else
+ xheck = piDpj(i,ii(5))-piDpj(i,ii(1))-piDpj(i,ii(2))
+ endif
+ xmax = max(absc(piDpj(i,ii(5))),absc(piDpj(i,ii(1))),
+ + absc(piDpj(i,ii(2))))
+ if ( xloss*absc(xheck) .gt. precc*xmax ) print *,
+ + 'ffcl3p: error: momenta i512 do not add to 0:',
+ + piDpj(i,ii(5)),piDpj(i,ii(1)),piDpj(i,ii(2)),
+ + xheck,i
+ xheck = +piDpj(i,jj(1))+piDpj(i,jj(2))
+ + +piDpj(i,jj(3))+piDpj(i,jj(4))
+ xmax = max(absc(piDpj(i,jj(1))),absc(piDpj(i,jj(2))),
+ + absc(piDpj(i,jj(3))),absc(piDpj(i,jj(4))))
+ if ( xloss*absc(xheck) .gt. precc*xmax ) print *,
+ + 'ffcl3p: error: momenta j1234 do not add to 0:',
+ + piDpj(i,jj(1)),piDpj(i,jj(2)),piDpj(i,jj(3)),
+ + piDpj(i,jj(4)),xheck,i
+ xheck = piDpj(i,jj(6))-piDpj(i,jj(2))-piDpj(i,jj(3))
+ xmax = max(absc(piDpj(i,jj(6))),absc(piDpj(i,jj(2))),
+ + absc(piDpj(i,jj(3))))
+ if ( xloss*absc(xheck) .gt. precc*xmax ) print *,
+ + 'ffcl3p: error: momenta j623 do not add to 0:',
+ + piDpj(i,jj(6)),piDpj(i,jj(2)),piDpj(i,jj(3)),
+ + xheck,i
+ if ( ns .eq. 10 ) then
+ xheck = piDpj(i,jj(5))+piDpj(i,jj(1))+piDpj(i,jj(2))
+ else
+ xheck = piDpj(i,jj(5))-piDpj(i,jj(1))-piDpj(i,jj(2))
+ endif
+ xmax = max(absc(piDpj(i,jj(5))),absc(piDpj(i,jj(1))),
+ + absc(piDpj(i,jj(2))))
+ if ( xloss*absc(xheck) .gt. precc*xmax ) print *,
+ + 'ffcl3p: error: momenta j512 do not add to 0:',
+ + piDpj(i,jj(5)),piDpj(i,jj(1)),piDpj(i,jj(2)),
+ + xheck,i
+ 10 continue
+ endif
+* #] check input:
+* #[ calculations:
+ if ( ii(1).eq.jj(1) .and. ii(2).eq.jj(2) .and. ii(3).eq.jj(3) )
+ + then
+*
+* symmetric - fewer possibilities
+*
+ nl = 1
+ else
+ nl = 16
+ endif
+*
+* try all (1,16)*16 permutations
+*
+ xmax = 0
+ do 101 l=1,nl
+ do 100 i=1,16
+ ii1 = ii(iperm(1,i))
+ ii2 = ii(iperm(2,i))
+ ii3 = ii(iperm(3,i))
+ j = i+l-1
+ if ( j .gt. 16 ) j=j-16
+ jj1 = jj(iperm(1,j))
+ jj2 = jj(iperm(2,j))
+ jj3 = jj(iperm(3,j))
+ s(1) = +piDpj(ii1,jj1)*piDpj(ii2,jj2)*piDpj(ii3,jj3)
+ s(2) = +piDpj(ii2,jj1)*piDpj(ii3,jj2)*piDpj(ii1,jj3)
+ s(3) = +piDpj(ii3,jj1)*piDpj(ii1,jj2)*piDpj(ii2,jj3)
+ s(4) = -piDpj(ii1,jj1)*piDpj(ii3,jj2)*piDpj(ii2,jj3)
+ s(5) = -piDpj(ii3,jj1)*piDpj(ii2,jj2)*piDpj(ii1,jj3)
+ s(6) = -piDpj(ii2,jj1)*piDpj(ii1,jj2)*piDpj(ii3,jj3)
+ som = 0
+ smax = 0
+ do 80 k=1,6
+ som = som + s(k)
+ smax = max(smax,absc(som))
+ 80 continue
+ if ( ns .eq. 15 .and. (i.gt.8 .neqv. j.gt.8) )
+ + som = -som
+ if ( i .eq. 1 .or. smax .lt. xmax ) then
+ dl3p = som
+ xmax = smax
+ endif
+ if ( lwrite ) then
+ print *,'dl3p = +',i-1+16*(l-1),' = ',som,smax
+ endif
+ if ( absc(dl3p) .ge. xloss*smax ) goto 110
+ 100 continue
+ 101 continue
+ if ( lwarn ) call ffwarn(138,ier,absc(dl3p),xmax)
+ 110 continue
+* #] calculations:
+*###] ffcl3p:
+ end
diff --git a/ff-2.0/ffcel5.f b/ff-2.0/ffcel5.f
new file mode 100644
index 0000000..3e4dfff
--- /dev/null
+++ b/ff-2.0/ffcel5.f
@@ -0,0 +1,575 @@
+* $Id: ffcel5.f,v 1.2 1995/12/08 10:37:10 gj Exp $
+*###[ ffcel5:
+ subroutine ffcel5(del5,xpi,pDp,ns,iquad,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate del5(pDp) = det(si.sj) with *
+* the momenta as follows: *
+* p(1-5) = s(i) *
+* p(5-10) = p(i) *
+* p(11-15) = p(i)+p(i+1) *
+* *
+* Input: xpi(ns) (complex) the usual 5-pt momenta *
+* pDp(ns,ns) (complex) their dot products *
+* ns (integer) should be 15 *
+* iquad (integer) 0:normal, 1:no checking *
+* for canc., only 1 perm. *
+* ier (integer) usual error flag *
+* *
+* Output: del5 (complex) det(si.sj) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,iquad,ier
+ DOUBLE COMPLEX del5,xpi(15),pDp(15,15)
+*
+* local variables:
+*
+ integer mem,nperm,nsi
+ parameter(mem=10,nperm=1296,nsi=73)
+ integer i,j1,j2,j3,j4,j5,iperm(5,nperm),
+ + imem,memarr(mem,3),memind,inow,init,ifile,ier0
+ DOUBLE COMPLEX s(nsi),del5p,cc
+ DOUBLE PRECISION xmax,xmaxp,absc
+ save iperm,memind,memarr,inow,init
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ data:
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1/
+ data inow /1/
+ data init /0/
+*
+* read permutations from file ffperm5.dat. Included as DATA
+* statements they generated too much code in Absoft (54K)
+*
+ if ( init .eq. 0 ) then
+ init = 1
+ call ffopen(ifile,'ffperm5.dat',ier0)
+ if ( ier0 .ne. 0 ) goto 910
+ read(ifile,*)
+ read(ifile,*)
+ do 1 i=1,nperm,4
+ read(ifile,*,err=920,end=920)
+ + ((iperm(j1,j2),j1=1,5),j2=i,i+3)
+ 1 continue
+ close(ifile)
+ endif
+* #] data:
+* #[ check input:
+ if ( ltest .and. ns .ne. 15 ) then
+ print *,'ffcel5: error: ns <> 15!'
+ stop
+ endif
+ if ( lwrite ) then
+ print *,'ffcel5: xpi = ',xpi
+ endif
+* #] check input:
+* #[ out of memory:
+*
+* see if we know were to start, if not: go on as last time
+*
+ if ( iquad.ne.1 ) then
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) )
+ + then
+ inow = memarr(i,3)
+ if ( lwrite ) print *,'ffcel5: found in memory'
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+ else
+ inow = 1
+ endif
+* #] out of memory:
+* #[ calculations:
+ imem = inow
+ del5 = 0
+ xmax = 0
+
+ 10 continue
+*
+* we only try the diagonal elements: top==bottom
+*
+ j1 = iperm(1,inow)
+ j2 = iperm(2,inow)
+ j3 = iperm(3,inow)
+ j4 = iperm(4,inow)
+ j5 = iperm(5,inow)
+*
+* The following was generated with the Form program
+* V p1,p2,p3,p4,p5;
+* L f = (e_(p1,p2,p3,p4,p5))**2;
+* Contract;
+* print +s;
+* .end
+* plus the substituion //p#@1\./p#@2/=/pDp(j@1,j@2)/
+*
+* #[ terms:
+ s(1)=+ xpi(j1)*xpi(j2)*xpi(j3)*xpi(j4)*xpi(j5)
+ s(2)=- xpi(j1)*xpi(j2)*xpi(j3)*pDp(j4,j5)**2
+ s(3)=- xpi(j1)*xpi(j2)*pDp(j3,j4)**2*xpi(j5)
+ s(4)=+2*xpi(j1)*xpi(j2)*pDp(j3,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(5)=- xpi(j1)*xpi(j2)*pDp(j3,j5)**2*xpi(j4)
+ s(6)=- xpi(j1)*pDp(j2,j3)**2*xpi(j4)*xpi(j5)
+ s(7)=+ xpi(j1)*pDp(j2,j3)**2*pDp(j4,j5)**2
+ s(8)=+2*xpi(j1)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j4)*xpi(j5)
+ s(9)=-2*xpi(j1)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(10)=-2*xpi(j1)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j4)*pDp(j4,j5)
+ s(11)=+2*xpi(j1)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j5)*xpi(j4)
+ s(12)=- xpi(j1)*pDp(j2,j4)**2*xpi(j3)*xpi(j5)
+ s(13)=+ xpi(j1)*pDp(j2,j4)**2*pDp(j3,j5)**2
+ s(14)=+2*xpi(j1)*pDp(j2,j4)*pDp(j2,j5)*xpi(j3)*pDp(j4,j5)
+ s(15)=-2*xpi(j1)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j4)*pDp(j3,j5)
+ s(16)=- xpi(j1)*pDp(j2,j5)**2*xpi(j3)*xpi(j4)
+ s(17)=+ xpi(j1)*pDp(j2,j5)**2*pDp(j3,j4)**2
+ s(18)=- pDp(j1,j2)**2*xpi(j3)*xpi(j4)*xpi(j5)
+ s(19)=+ pDp(j1,j2)**2*xpi(j3)*pDp(j4,j5)**2
+ s(20)=+ pDp(j1,j2)**2*pDp(j3,j4)**2*xpi(j5)
+ s(21)=-2*pDp(j1,j2)**2*pDp(j3,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(22)=+ pDp(j1,j2)**2*pDp(j3,j5)**2*xpi(j4)
+ s(23)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j3)*xpi(j4)*xpi(j5)
+ s(24)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j3)*pDp(j4,j5)**2
+ s(25)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j4)*pDp(j3,j4)*xpi(j5)
+ s(26)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(27)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j5)*pDp(j3,j4)*pDp(j4,j5)
+ s(28)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j5)*pDp(j3,j5)*xpi(j4)
+ s(29)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j3)*pDp(j3,j4)*xpi(j5)
+ s(30)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j3)*pDp(j3,j5)*pDp(j4,j5)
+ s(31)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j4)*xpi(j3)*xpi(j5)
+ s(32)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j4)*pDp(j3,j5)**2
+ s(33)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j5)*xpi(j3)*pDp(j4,j5)
+ s(34)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j5)*pDp(j3,j4)*pDp(j3,j5)
+ s(35)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j3)*pDp(j3,j4)*pDp(j4,j5)
+ s(36)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j3)*pDp(j3,j5)*xpi(j4)
+ s(37)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j4)*xpi(j3)*pDp(j4,j5)
+ s(38)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j4)*pDp(j3,j4)*pDp(j3,j5)
+ s(39)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j5)*xpi(j3)*xpi(j4)
+ s(40)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j5)*pDp(j3,j4)**2
+ s(41)=- pDp(j1,j3)**2*xpi(j2)*xpi(j4)*xpi(j5)
+ s(42)=+ pDp(j1,j3)**2*xpi(j2)*pDp(j4,j5)**2
+ s(43)=+ pDp(j1,j3)**2*pDp(j2,j4)**2*xpi(j5)
+ s(44)=-2*pDp(j1,j3)**2*pDp(j2,j4)*pDp(j2,j5)*pDp(j4,j5)
+ s(45)=+ pDp(j1,j3)**2*pDp(j2,j5)**2*xpi(j4)
+ s(46)=+2*pDp(j1,j3)*pDp(j1,j4)*xpi(j2)*pDp(j3,j4)*xpi(j5)
+ s(47)=-2*pDp(j1,j3)*pDp(j1,j4)*xpi(j2)*pDp(j3,j5)*pDp(j4,j5)
+ s(48)=-2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j3)*pDp(j2,j4)*xpi(j5)
+ s(49)=+2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j3)*pDp(j2,j5)*pDp(j4,j5)
+ s(50)=+2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j5)
+ s(51)=-2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j5)**2*pDp(j3,j4)
+ s(52)=-2*pDp(j1,j3)*pDp(j1,j5)*xpi(j2)*pDp(j3,j4)*pDp(j4,j5)
+ s(53)=+2*pDp(j1,j3)*pDp(j1,j5)*xpi(j2)*pDp(j3,j5)*xpi(j4)
+ s(54)=+2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j4)*pDp(j4,j5)
+ s(55)=-2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j5)*xpi(j4)
+ s(56)=-2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j4)**2*pDp(j3,j5)
+ s(57)=+2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j4)
+ s(58)=- pDp(j1,j4)**2*xpi(j2)*xpi(j3)*xpi(j5)
+ s(59)=+ pDp(j1,j4)**2*xpi(j2)*pDp(j3,j5)**2
+ s(60)=+ pDp(j1,j4)**2*pDp(j2,j3)**2*xpi(j5)
+ s(61)=-2*pDp(j1,j4)**2*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j5)
+ s(62)=+ pDp(j1,j4)**2*pDp(j2,j5)**2*xpi(j3)
+ s(63)=+2*pDp(j1,j4)*pDp(j1,j5)*xpi(j2)*xpi(j3)*pDp(j4,j5)
+ s(64)=-2*pDp(j1,j4)*pDp(j1,j5)*xpi(j2)*pDp(j3,j4)*pDp(j3,j5)
+ s(65)=-2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)**2*pDp(j4,j5)
+ s(66)=+2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j5)
+ s(67)=+2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j4)
+ s(68)=-2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j4)*pDp(j2,j5)*xpi(j3)
+ s(69)=- pDp(j1,j5)**2*xpi(j2)*xpi(j3)*xpi(j4)
+ s(70)=+ pDp(j1,j5)**2*xpi(j2)*pDp(j3,j4)**2
+ s(71)=+ pDp(j1,j5)**2*pDp(j2,j3)**2*xpi(j4)
+ s(72)=-2*pDp(j1,j5)**2*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j4)
+ s(73)=+ pDp(j1,j5)**2*pDp(j2,j4)**2*xpi(j3)
+* #] terms:
+*
+ del5p = 0
+ xmaxp = 0
+ do 20 i=1,nsi
+ del5p = del5p + s(i)
+ xmaxp = max(xmaxp,absc(s(i)))
+ 20 continue
+ if ( iquad.ne.1 .and. absc(del5p) .lt. xloss**2*xmaxp ) then
+ if ( lwrite ) print *,'del5+',inow,' = ',del5p,xmaxp,
+ + j1,j2,j3,j4,j5
+ if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
+ del5 = del5p
+ xmax = xmaxp
+ endif
+ inow = inow + 1
+ if ( inow .gt. nperm ) inow = 1
+ if ( inow .eq. imem ) then
+ if ( lwarn ) call ffwarn(160,ier,absc(del5),xmax)
+ goto 800
+ endif
+ goto 10
+ endif
+ if ( inow .ne. imem ) then
+ if ( lwrite ) print *,'del5+',inow,' = ',del5p,xmaxp,
+ + j1,j2,j3,j4,j5
+ endif
+ del5 = del5p
+ xmax = xmaxp
+* #] calculations:
+* #[ into memory:
+ 800 continue
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+* #] into memory:
+* #[ error messages:
+ return
+ 910 print *,'ffcel5: error: cannot open file ffperm5.dat with data'
+ stop
+ 920 print *,'ffcel5: error: error reading from ffperm5.dat'
+ stop
+* #] error messages:
+*###] ffcel5:
+ end
+*###[ ffcl4p:
+ subroutine ffcl4p(cl4p,cpi,cpiDpj,ns,ii,ier)
+***#[*comment:***********************************************************
+* calculate in a numerically stable way *
+* *
+* p1 p2 p3 p4 *
+* delta *
+* p1 p2 p3 p4 *
+* *
+* with pn = xpi(ii(n)), n=1,4 *
+* p5 = -p1-p2-p3-p4 *
+* xpi(ii(n+5)) = pn+p(n+1), n=1,5 *
+* *
+* ier is the usual error flag. *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ii(10),ier
+ DOUBLE COMPLEX cl4p,cpi(ns),cpiDpj(ns,ns)
+*
+* local variables
+*
+ integer i,j,jj(10)
+ DOUBLE PRECISION dl4p,xpi(10),piDpj(10,10),sprecx
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ calculations:
+ do 20 i=1,10
+ jj(i) = i
+ xpi(i) = DBLE(cpi(ii(i)))
+ do 10 j=1,10
+ piDpj(j,i) = DBLE(cpiDpj(ii(j),ii(i)))
+ 10 continue
+ 20 continue
+ sprecx = precx
+ precx = precc
+ call ffdl4p(dl4p,xpi,piDpj,10,jj,ier)
+ cl4p = dl4p
+ precx = sprecx
+* #] calculations:
+* #[ debug output:
+ if ( lwrite ) then
+ print *,'ffcl4p: input'
+ print *,'ii = ',ii
+ print *,'cpi = ',cpi
+ print *,'xpi = ',xpi
+ print *,'ffdl4s: output ',dl4p
+ endif
+* #] debug output:
+*###] ffcl4p:
+ end
+*###[ ffcl4r:
+ subroutine ffcl4r(dl4r,xpi,piDpj,ns,miss,ier)
+***#[*comment:***********************************************************
+* calculate in a numerically stable way *
+* *
+* s1 s2 s3 s4 *
+* delta *
+* p1 p2 p3 p4 *
+* *
+* with s(miss) NOT included *
+* *
+* ier is the usual error flag. *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,miss,ier
+ DOUBLE COMPLEX dl4r,xpi(ns),piDpj(ns,ns)
+*
+* local variables
+*
+ integer i,j,k,ii(4),jj(4),ipermp(4,125),iperms(4,125),
+ + iplace(11,5),minus(125),mem,msign
+ parameter(mem=10)
+ integer memarr(mem,4),inow,jnow,imem,jmem,memind
+ DOUBLE COMPLEX s(24),som,cc,cnul
+ DOUBLE PRECISION xmax,smax,absc
+ save ipermp,iperms,iplace,minus,memarr,inow,jnow,memind
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ data:
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1,mem*1/
+ data inow,jnow /1,1/
+*
+* data (see getpermp.for)
+*
+ data ipermp/
+ + 1,2,3,4,1,2,5,3,1,2,3,8,1,2,10,3,1,2,4,5,1,2,7,4,1,2,8,4,1,2,4,
+ + 9,1,2,4,10,1,2,5,7,1,2,9,5,1,2,7,8,1,2,10,7,1,2,8,9,1,2,9,10,1,
+ + 3,5,4,1,3,4,6,1,3,4,7,1,3,9,4,1,3,10,4,1,3,6,5,1,3,7,5,1,3,5,8,
+ + 1,3,5,9,1,3,8,6,1,3,6,10,1,3,8,7,1,3,7,10,1,3,9,8,1,3,10,8,1,3,
+ + 10,9,1,4,5,6,1,4,8,5,1,4,6,7,1,4,6,8,1,4,9,6,1,4,10,6,1,4,7,8,1,
+ + 4,8,9,1,4,8,10,1,5,7,6,1,5,6,9,1,5,8,7,1,5,9,8,1,6,7,8,1,6,10,7,
+ + 1,6,8,9,1,6,9,10,1,7,10,8,1,8,10,9,2,3,4,5,2,3,6,4,2,3,4,9,2,3,
+ + 5,6,2,3,8,5,2,3,9,5,2,3,5,10,2,3,6,8,2,3,10,6,2,3,8,9,2,3,9,10,
+ + 2,4,6,5,2,4,5,7,2,4,5,8,2,4,10,5,2,4,7,6,2,4,8,6,2,4,6,9,2,4,6,
+ + 10,2,4,9,7,2,4,9,8,2,4,10,9,2,5,6,7,2,5,9,6,2,5,7,8,2,5,7,9,2,5,
+ + 10,7,2,5,8,9,2,5,9,10,2,6,8,7,2,6,7,10,2,6,9,8,2,6,10,9,2,7,8,9,
+ + 2,7,9,10,3,4,7,5,3,4,5,10,3,4,6,7,3,4,10,6,3,4,7,9,3,4,9,10,3,5,
+ + 7,6,3,5,6,10,3,5,8,7,3,5,9,7,3,5,7,10,3,5,10,8,3,5,10,9,3,6,7,8,
+ + 3,6,10,7,3,6,8,10,3,7,9,8,3,7,10,9,3,8,9,10,4,5,6,7,4,5,10,6,4,
+ + 5,7,8,4,5,8,10,4,6,8,7,4,6,7,9,4,6,10,8,4,6,9,10,4,7,8,9,4,8,10,
+ + 9,5,6,9,7,5,6,7,10,5,6,10,9,5,7,9,8,5,7,8,10,5,8,9,10,6,7,8,9,6,
+ + 7,10,8,6,7,9,10,6,8,10,9,7,8,9,10/
+ data iperms/
+ + 1,2,3,4,1,2,3,7,1,2,8,3,1,2,3,10,1,2,6,4,1,2,4,7,1,2,4,9,1,2,6,7
+ + ,1,2,8,6,1,2,6,10,1,2,7,8,1,2,7,9,1,2,10,7,1,2,9,8,1,2,10,9,1,3,
+ + 4,5,1,3,6,4,1,3,10,4,1,3,7,5,1,3,5,8,1,3,10,5,1,3,6,7,1,3,8,6,1,
+ + 3,6,10,1,3,10,7,1,3,8,10,1,4,5,6,1,4,7,5,1,4,9,5,1,4,6,7,1,4,6,9
+ + ,1,4,6,10,1,4,10,7,1,4,10,9,1,5,6,7,1,5,8,6,1,5,6,10,1,5,7,8,1,5
+ + ,7,9,1,5,10,7,1,5,9,8,1,5,10,9,1,6,8,7,1,6,9,7,1,6,8,9,1,6,8,10,
+ + 1,6,9,10,1,7,10,8,1,7,10,9,1,8,9,10,2,3,4,5,2,3,8,4,2,3,9,4,2,3,
+ + 7,5,2,3,5,8,2,3,10,5,2,3,8,7,2,3,9,7,2,3,8,9,2,3,8,10,2,3,9,10,2
+ + ,4,5,6,2,4,7,5,2,4,9,5,2,4,6,8,2,4,6,9,2,4,8,7,2,4,9,7,2,4,8,9,2
+ + ,5,6,7,2,5,8,6,2,5,6,10,2,5,7,8,2,5,7,9,2,5,10,7,2,5,9,8,2,5,10,
+ + 9,2,6,8,7,2,6,9,7,2,6,8,9,2,6,8,10,2,6,9,10,2,7,10,8,2,7,10,9,2,
+ + 8,9,10,3,4,5,6,3,4,8,5,3,4,9,5,3,4,5,10,3,4,6,8,3,4,6,9,3,4,10,8
+ + ,3,4,10,9,3,5,6,7,3,5,8,6,3,5,6,10,3,5,7,8,3,5,7,9,3,5,10,7,3,5,
+ + 9,8,3,5,10,9,3,6,8,7,3,6,9,7,3,6,8,9,3,6,8,10,3,6,9,10,3,7,10,8,
+ + 3,7,10,9,3,8,9,10,4,5,6,7,4,5,8,6,4,5,6,10,4,5,7,8,4,5,7,9,4,5,1
+ + 0,7,4,5,9,8,4,5,10,9,4,6,8,7,4,6,9,7,4,6,8,9,4,6,8,10,4,6,9,10,4
+ + ,7,10,8,4,7,10,9,4,8,9,10/
+ data iplace /
+ + 2,3,4,5, 07,08,09,15, +12,+13, 17,
+ + 1,3,4,5, 11,08,09,10, -14,+13, 18,
+ + 1,2,4,5, 06,12,09,10, -14,-15, 19,
+ + 1,2,3,5, 06,07,13,10, +11,-15, 20,
+ + 1,2,3,4, 06,07,08,14, +11,+12, 16/
+ data minus /
+ + +1,+1,+1,+1,+1,+1,-1,+1,+1,+1,+1,-1,+1,-1,-1,+1,
+ + +1,+1,+1,+1,+1,+1,+1,+1,+1,+1,+1,+1,-1,+1,-1,+1,
+ + +1,-1,+1,+1,+1,+1,-1,+1,-1,-1,+1,-1,-1,+1,-1,+1,
+ + -1,-1,+1,+1,-1,+1,+1,+1,+1,-1,-1,+1,-1,+1,+1,-1,
+ + +1,-1,+1,-1,-1,+1,+1,+1,+1,-1,+1,-1,-1,+1,-1,-1,
+ + +1,-1,+1,-1,-1,+1,+1,-1,+1,+1,-1,+1,-1,+1,+1,+1,
+ + +1,-1,+1,-1,-1,+1,-1,-1,+1,-1,+1,-1,-1,+1,+1,+1,
+ + +1,-1,+1,-1,-1,+1,-1,-1,+1,-1,+1,-1,-1/
+* #] data:
+* #[ check input:
+ if ( ltest ) then
+ if ( miss.gt.5 .or. miss.lt.1 ) then
+ print *,'ffcl4r: error: miss < 1 or > 5: ',miss
+ stop
+ endif
+ do 4 i=1,15
+ cnul = 0
+ xmax = 0
+ do 1 j=6,10
+ cnul = cnul + piDpj(j,i)
+ xmax = max(xmax,absc(piDpj(j,i)))
+ 1 continue
+ if ( xloss*absc(cnul) .gt. precx*xmax ) print *,
+ + 'ffcl4r: error: \sum p',i,'.p6-10 do not add ',
+ + 'up to 0: ',cnul,xmax
+ cnul = 0
+ xmax = 0
+ do 2 j=11,15
+ cnul = cnul + piDpj(j,i)
+ xmax = max(xmax,absc(piDpj(j,i)))
+ 2 continue
+ if ( xloss*absc(cnul) .gt. precx*xmax ) print *,
+ + 'ffcl4r: error: \sum p',i,'.p11-15 do not add ',
+ + 'up to 0: ',cnul,xmax
+ do 3 j=6,10
+ k = j+1
+ if ( k.eq.11 ) k=6
+ cnul = piDpj(i,j) + piDpj(i,k) - piDpj(i,j+5)
+ xmax = max(abs(piDpj(i,j)),abs(piDpj(i,k)))
+ if ( xloss*absc(cnul) .gt. precx*xmax ) print *,
+ + 'ffcl4r: error: \sum p',i,'.p',j,k,j+5,' do ',
+ + 'not add up to 0: ',cnul,xmax
+ 3 continue
+ 4 continue
+ endif
+* #] check input:
+* #[ out of memory:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) )
+ + then
+ inow = memarr(i,3)
+ jnow = memarr(i,4)
+ if ( lwrite ) then
+ print *,'ffcl4r: found in memory'
+ print *,' inow, jnow = ',inow,jnow
+ endif
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] out of memory:
+* #[ calculations:
+*
+* loop over all permutations of the si and the pi -
+* we have 125*125 = 15625 possibilities before we give up ....
+* 15-feb-1993: well, let's only consider 25 at a time, otherwise
+* the time spent here becomes ludicrous
+*
+ imem = inow
+ jmem = jnow
+ dl4r = 0
+ xmax = -1
+*
+ do 110 i=1,5
+ ii(1) = abs(iplace((iperms(1,inow)),miss))
+ ii(2) = abs(iplace((iperms(2,inow)),miss))
+ ii(3) = abs(iplace((iperms(3,inow)),miss))
+ ii(4) = abs(iplace((iperms(4,inow)),miss))
+ msign = sign(1,iplace((iperms(1,inow)),miss))*
+ + sign(1,iplace((iperms(2,inow)),miss))*
+ + sign(1,iplace((iperms(3,inow)),miss))*
+ + sign(1,iplace((iperms(4,inow)),miss))
+ do 100 j=1,5
+ jj(1) = ipermp(1,jnow) + 5
+ jj(2) = ipermp(2,jnow) + 5
+ jj(3) = ipermp(3,jnow) + 5
+ jj(4) = ipermp(4,jnow) + 5
+*
+ s( 1) = +piDpj(ii(1),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(4),jj(4))
+ s( 2) = +piDpj(ii(2),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(4),jj(4))
+ s( 3) = +piDpj(ii(3),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(4),jj(4))
+ s( 4) = -piDpj(ii(1),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(4),jj(4))
+ s( 5) = -piDpj(ii(3),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(4),jj(4))
+ s( 6) = -piDpj(ii(2),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(4),jj(4))
+*
+ s( 7) = -piDpj(ii(1),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(3),jj(4))
+ s( 8) = -piDpj(ii(2),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(3),jj(4))
+ s( 9) = -piDpj(ii(4),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(3),jj(4))
+ s(10) = +piDpj(ii(1),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(3),jj(4))
+ s(11) = +piDpj(ii(4),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(3),jj(4))
+ s(12) = +piDpj(ii(2),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(3),jj(4))
+*
+ s(13) = -piDpj(ii(1),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(2),jj(4))
+ s(14) = -piDpj(ii(4),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(2),jj(4))
+ s(15) = -piDpj(ii(3),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(2),jj(4))
+ s(16) = +piDpj(ii(1),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(2),jj(4))
+ s(17) = +piDpj(ii(3),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(2),jj(4))
+ s(18) = +piDpj(ii(4),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(2),jj(4))
+*
+ s(19) = -piDpj(ii(4),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(1),jj(4))
+ s(20) = -piDpj(ii(2),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(1),jj(4))
+ s(21) = -piDpj(ii(3),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(1),jj(4))
+ s(22) = +piDpj(ii(4),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(1),jj(4))
+ s(23) = +piDpj(ii(3),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(1),jj(4))
+ s(24) = +piDpj(ii(2),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(1),jj(4))
+*
+ som = 0
+ smax = 0
+ do 80 k=1,24
+ som = som + s(k)
+ smax = max(smax,absc(som))
+ 80 continue
+ if ( smax .lt. xmax .or. xmax .lt. 0 ) then
+ dl4r = msign*minus(inow)*som
+ xmax = smax
+ endif
+ if ( lwrite ) then
+ print *,'dl4r+',i-1,j-1,' = ',msign*minus(inow)*som,smax
+ print *,' inow,ii = ',inow,ii
+ print *,' jnow,jj = ',jnow,jj
+ endif
+ if ( absc(dl4r) .ge. xloss**2*xmax ) goto 120
+ 99 continue
+* increase with something that is relative prime to 125 so that
+* eventually we cover all possibilities, but with a good
+* scatter.
+ jnow = jnow + 49
+ if ( jnow .gt. 125 ) jnow = jnow - 125
+ 100 continue
+ 109 continue
+* again, a number relative prime to 125 and a few times smaller
+ inow = inow + 49
+ if ( inow .gt. 125 ) inow = inow - 125
+ 110 continue
+ if ( lwarn ) call ffwarn(169,ier,absc(dl4r),xmax)
+ 120 continue
+* #] calculations:
+* #[ into memory:
+ 800 continue
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+ memarr(memind,4) = jnow
+* #] into memory:
+*###] ffcl4r:
+ end
+
diff --git a/ff-2.0/ffceta.f b/ff-2.0/ffceta.f
new file mode 100644
index 0000000..b059342
--- /dev/null
+++ b/ff-2.0/ffceta.f
@@ -0,0 +1,463 @@
+ subroutine ffceta(ceta,ipi,cpi,a,y,z,dyz,alpha,dha,ii,ier)
+***#[*comment:***********************************************************
+* *
+* get the eta terms associated with the S_i as used in the *
+* complex 4point function, see s.frm. EXPERIMENTAL. *
+* *
+* Input: cpi complex p_i^2 UNtransformed, hence real *
+* a(3) complex a(1)=A_{i+1}/(A_{i+1}-A_i), *
+* a(3)=1-a(1) *
+* z(4) complex z roots *
+* y(4) complex y roots *
+* dyz(2,2) complex y-z *
+* alpha(3) complex alpha of shift (only when ii=2) *
+* dha complex h-a *
+* ii integer i=1,2,3 for S1,S2,S3 *
+* (h=1,alpha,0 for S1,S2,S3) *
+* *
+* Output: ceta complex output *
+* ipi integer factors i*pi *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ipi,ier,ii
+ DOUBLE COMPLEX ceta,cpi,a(3),z(4),y(4),dyz(2,2),
+ + dha,alpha(3)
+*
+* local variables
+*
+ integer i,n,ns,ier0,ier1,n19a
+ parameter(ns=21)
+ DOUBLE PRECISION absc,xmax,xnul
+ DOUBLE COMPLEX s(ns),c,zz,v(2:4),w(4),dvw(2:2,2),
+ + d1az(2),d1ay,daw(2),dav(2:2),dhw(2)
+ integer nffeta,nffet1
+ DOUBLE COMPLEX zfflog,zfflo1
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffceta: eta terms for S',ii
+ print *,'cpi= ',cpi
+ print *,'a = ',a
+ print *,'y = ',y
+ print *,'z = ',z
+ print *,'dyz= ',dyz
+ endif
+ if ( ltest ) then
+ if ( ii .eq. 1 ) then
+ if ( dha .ne. a(3) ) print *,'ffceta: error: dha!=1-a ',
+ + dha,a(3)
+ elseif ( ii .eq. 2 ) then
+ xnul = absc(dha - alpha(1) + a(1))
+ if ( xloss*abs(xnul) .gt. precc*max(absc(dha),
+ + absc(alpha(1)),absc(a(1))) ) print *,
+ + 'ffceta: error: dha!=alpha-a ',dha,alpha(1),
+ + a(1),xnul
+ elseif ( ii .eq. 3 ) then
+ if ( dha .ne. -a(1) ) print *,'ffceta: error: dha!=-a ',
+ + dha,a(1)
+ else
+ print *,'ffceta: error: ii != 1,2,3: ',ii
+ endif
+ endif
+* #] check input:
+* #[ get differences a and y,z:
+*
+ ier1 = 0
+ ier0 = 0
+ if ( absc(a(1)) .lt. absc(a(3)) ) then
+ d1ay = y(4) - a(1)
+ xmax = absc(a(1))
+ else
+ d1ay = a(3) - y(2)
+ xmax = absc(a(3))
+ endif
+ if ( absc(d1ay) .lt. xloss*xmax ) then
+ call ffwarn(175,ier0,absc(d1ay),xmax)
+ if ( lwrite ) print *,' a,y,1-a,1-y,1-a-y = ',
+ + a(1),y(2),a(3),y(4),d1ay
+ ier1 = max(ier1,ier0)
+ endif
+ do 2 i=1,2
+ ier0 = 0
+ if ( absc(a(1)) .lt. absc(a(3)) ) then
+ d1az(i) = z(i+2) - a(1)
+ xmax = absc(a(1))
+ else
+ d1az(i) = a(3) - z(i)
+ xmax = absc(a(3))
+ endif
+ if ( absc(d1az(i)) .lt. xloss*xmax ) then
+ call ffwarn(176,ier0,absc(d1az(i)),xmax)
+ if ( lwrite ) print *,' a,z,1-a,1-z,1-a-z = ',
+ + a(1),z(i),a(3),z(i+2),d1az(i)
+ ier1 = max(ier1,ier0)
+ endif
+ 2 continue
+ ier = ier + ier1
+*
+* #] get differences a and y,z:
+* #[ get untransformed roots:
+*
+ v(2) = -a(1)*y(2)/d1ay
+ v(4) = +a(3)*y(4)/d1ay
+ w(1) = -a(1)*z(1)/d1az(1)
+ w(2) = -a(1)*z(2)/d1az(2)
+ w(3) = +a(3)*z(3)/d1az(1)
+ w(4) = +a(3)*z(4)/d1az(2)
+ dvw(2,1) = -a(1)*a(3)*dyz(2,1)/(d1ay*d1az(1))
+ dvw(2,2) = -a(1)*a(3)*dyz(2,2)/(d1ay*d1az(2))
+ dav(2) = a(1)*a(3)/d1ay
+ daw(1) = a(1)*a(3)/d1az(1)
+ daw(2) = a(1)*a(3)/d1az(2)
+*
+ if ( ii .eq. 1 ) then
+ dhw(1) = w(3)
+ dhw(2) = w(4)
+ elseif ( ii .eq. 2 ) then
+ if ( absc(alpha(1)) .lt. absc(alpha(3)) ) then
+ dhw(1) = alpha(1) - w(1)
+ dhw(2) = alpha(1) - w(2)
+ else
+ dhw(1) = w(3) - alpha(3)
+ dhw(2) = w(4) - alpha(3)
+ endif
+ xmax = min(absc(alpha(1)),absc(alpha(3)))
+ ier0 = 0
+ if ( absc(dhw(1)) .lt. xloss*xmax )
+ + call ffwarn(173,ier0,absc(dhw(1)),xmax)
+ ier1 = 0
+ if ( absc(dhw(2)) .lt. xloss*xmax )
+ + call ffwarn(174,ier1,absc(dhw(2)),xmax)
+ ier = ier + max(ier0,ier1)
+ elseif ( ii .eq. 3 ) then
+ dhw(1) = w(1)
+ dhw(2) = w(2)
+ else
+ print *,'ffceta: error: ii != 1,2,3 ',ii
+ stop
+ endif
+*
+ if ( lwrite ) then
+ print *,'v = ',v
+ print *,'w = ',w
+ print *,'dvw = ',dvw
+ print *,'dav = ',dav
+ print *,'daw = ',daw
+ endif
+* #] get untransformed roots:
+* #[ zero:
+ ipi = 0
+ do 10 i=1,ns
+ s(i) = 0
+ 10 continue
+ ier1 = 0
+* #] zero:
+* #[ from form:
+
+* Scompl =
+
+ if ( lwrite ) print *,'log number 1'
+ ier0 = 0
+ n =
+ + + nffeta( - w(1), - w(2),ier0)
+ + - nffeta(dvw(2,1),1/(dhw(1)),ier0)
+ + - nffeta(dvw(2,1),dvw(2,2),ier0)
+ + - nffeta(dvw(2,2),1/(dhw(2)),ier0)
+ + + 2*nffeta( - dav(2),1/(dha),ier0)
+ + - nffet1(DCMPLX(DBLE(cpi),-DBLE(x1)),dvw(2,1)*dvw(2,2),
+ * dvw(2,1)*dvw(2,2)*cpi,ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog( - 1/(v(2))*v(4),99,c0,ier0)
+ s(1) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 2'
+ ier0 = 0
+ n =
+ + + nffeta(1/(a(1))*w(1), - 1/(w(1))/(dav(2))*a(1)*dvw(2,1),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(1/(a(1))*daw(1),99,c0,ier0)
+ s(2) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 3'
+ ier0 = 0
+ n =
+ + + nffeta(1/(a(1))*w(2), - 1/(w(2))/(dav(2))*a(1)*dvw(2,2),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(1/(a(1))*daw(2),99,c0,ier0)
+ s(3) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 4'
+ ier0 = 0
+ n =
+ + - nffeta( - w(1), - w(2),ier0)
+ + - nffeta(a(3),1/(daw(1)),ier0)
+ + - nffeta(a(3),1/(daw(2)),ier0)
+ + - nffeta(dvw(2,1), - 1/(dav(2)),ier0)
+ + + nffeta(dvw(2,1),1/(dhw(1)),ier0)
+ + + nffeta(dvw(2,1),dvw(2,2),ier0)
+ + - nffeta(dvw(2,2), - 1/(dav(2)),ier0)
+ + + nffeta(dvw(2,2),1/(dhw(2)),ier0)
+ + - 2*nffeta( - dav(2),1/(dha),ier0)
+ + + nffet1(DCMPLX(DBLE(cpi),-DBLE(x1)),dvw(2,1)*dvw(2,2),
+ * dvw(2,1)*dvw(2,2)*cpi,ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog( - 1/(a(1))*a(3),99,c0,ier0)
+ s(4) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 5'
+ ier0 = 0
+ n =
+ + - nffeta(1/(a(3))*w(3), - 1/(w(3))/(dav(2))*a(3)*dvw(2,1),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(-1/(a(3))*daw(1),99,c0,ier0)
+ s(5) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 6'
+ ier0 = 0
+ n =
+ + - nffeta(1/(a(3))*w(4), - 1/(w(4))/(dav(2))*a(3)*dvw(2,2),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(-1/(a(3))*daw(2),99,c0,ier0)
+ s(6) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 7'
+ ier0 = 0
+ n =
+ + + nffeta( - 1/(dvw(2,1))*w(1), - 1/(w(1))/(dav(2))*a(1)*dvw(2,
+ * 1),ier0)
+ + + nffeta( - w(1),1/(dvw(2,1)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(1/(dvw(2,1))*v(2),99,c0,ier0)
+ s(7) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 8'
+ ier0 = 0
+ n =
+ + - nffeta(1/(dvw(2,1))*w(3), - 1/(w(3))/(dav(2))*a(3)*dvw(2,1),
+ * ier0)
+ + - nffeta(w(3),1/(dvw(2,1)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog( - 1/(dvw(2,1))*v(4),99,c0,ier0)
+ s(8) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 9'
+ ier0 = 0
+ n =
+ + + nffeta( - 1/(dvw(2,2))*w(2), - 1/(w(2))/(dav(2))*a(1)*dvw(2,
+ * 2),ier0)
+ + + nffeta( - w(2),1/(dvw(2,2)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(1/(dvw(2,2))*v(2),99,c0,ier0)
+ s(9) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 10'
+ ier0 = 0
+ n =
+ + - nffeta(1/(dvw(2,2))*w(4), - 1/(w(4))/(dav(2))*a(3)*dvw(2,2),
+ * ier0)
+ + - nffeta(w(4),1/(dvw(2,2)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog( - 1/(dvw(2,2))*v(4),99,c0,ier0)
+ s(10) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 11'
+ ier0 = 0
+ n =
+ + - 2*nffeta( - a(1), - 1/(dav(2)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog( - 1/(dav(2))*v(2),99,c0,ier0)
+ s(11) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 12'
+ ier0 = 0
+ n =
+ + + 2*nffeta(a(3), - 1/(dav(2)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(1/(dav(2))*v(4),99,c0,ier0)
+ s(12) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 13'
+ ier0 = 0
+ n =
+ + - nffeta( - 1/(a(1))*a(3),1/(dav(2))*a(1),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog( - 1/(dav(2))*dvw(2,1),99,c0,ier0)
+ s(13) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 14'
+ ier0 = 0
+ n =
+ + - nffeta( - 1/(a(1))*a(3),1/(dav(2))*a(1),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog( - 1/(dav(2))*dvw(2,2),99,c0,ier0)
+ s(14) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 15'
+ ier0 = 0
+ n =
+ + - nffeta( - w(1),1/(daw(1)),ier0)
+ if ( n .ne. 0 ) then
+ c = -w(1)/daw(1)
+ if ( absc(c) .lt. xloss ) then
+ zz = zfflo1(c,ier0)
+ else
+ zz = zfflog(1/(daw(1))*a(1),99,c0,ier0)
+ endif
+ s(15) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 16'
+ ier0 = 0
+ n =
+ + + nffeta(w(3),1/(daw(1)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog( - 1/(daw(1))*a(3),99,c0,ier0)
+ s(16) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 17'
+ ier0 = 0
+ n =
+ + - nffeta( - w(2),1/(daw(2)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(1/(daw(2))*a(1),99,c0,ier0)
+ s(17) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 18'
+ ier0 = 0
+ n =
+ + + nffeta(w(4),1/(daw(2)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog( - 1/(daw(2))*a(3),99,c0,ier0)
+ s(18) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 19'
+ ier0 = 0
+ n =
+ + + nffeta( - a(1),1/(daw(1)),ier0)
+ + + nffeta( - a(1),1/(daw(2)),ier0)
+ + - nffeta(a(3),1/(daw(1)),ier0)
+ + - nffeta(a(3),1/(daw(2)),ier0)
+ if ( n .ne. 0 ) then
+ if ( DBLE(a(1)) .lt. 0 ) then
+ zz = zfflog( - a(1),99,c0,ier0)
+ else
+ zz = zfflog(a(1),99,c0,ier0)
+ if ( DIMAG(a(1)) .gt. 0 ) then
+ ipi = ipi - n
+ elseif ( DIMAG(a(1)) .lt. 0 ) then
+ ipi = ipi + n
+ endif
+ endif
+ s(19) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 20'
+ ier0 = 0
+ n =
+ + - nffeta( - a(1),1/(daw(1)),ier0)
+ + + nffeta(a(3),1/(daw(1)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(daw(1),99,c0,ier0)
+ s(20) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 21'
+ ier0 = 0
+ n =
+ + - nffeta( - a(1),1/(daw(2)),ier0)
+ + + nffeta(a(3),1/(daw(2)),ier0)
+ if ( n .ne. 0 ) then
+ zz = zfflog(daw(2),99,c0,ier0)
+ s(21) = n*zz
+ endif
+ ier1 = max(ier1,ier0)
+
+ if ( lwrite ) print *,'log number 22'
+ ier0 = 0
+ n =
+ + + nffeta( - a(1),1/(daw(1)),ier0)**2
+ + + nffeta( - a(1),1/(daw(2)),ier0)**2
+ + - nffeta(a(3),1/(daw(1)),ier0)**2
+ + - nffeta(a(3),1/(daw(2)),ier0)**2
+ if ( n .ne. 0 ) then
+ ipi = ipi + n
+ endif
+ ier1 = max(ier1,ier0)
+
+* #[ from form:
+* #[ add:
+ ceta = 0
+ xmax = 0
+ do 20 i=1,ns
+ ceta = ceta + s(i)
+ xmax = max(xmax,absc(s(i)))
+ 20 continue
+ ier = ier + ier1
+ if ( absc(ceta) .lt. xloss*xmax ) then
+ call ffwarn(172,ier,absc(ceta),xmax)
+ endif
+* #] add:
+* #[ debug:
+ if ( lwrite ) then
+ print *,'ffceta: eta terms for complex 4point function'
+ do 900 i=1,ns
+ print '(i2,2g18.6)',i,s(i)
+ 900 continue
+ if ( ipi .ne. 0 ) print '(a,2g18.6)','pi',ipi*c2ipi/2
+ print *,'---------------- +'
+ print '(2x,2g18.6,i4,g18.6)',ceta,ipi,xmax
+ if ( ipi .ne. 0 ) print '(a,3g18.6)','= ',ceta+ipi*c2ipi/2
+ endif
+* #] debug:
+ end
diff --git a/ff-2.0/ffcli2.f b/ff-2.0/ffcli2.f
new file mode 100644
index 0000000..c1c3571
--- /dev/null
+++ b/ff-2.0/ffcli2.f
@@ -0,0 +1,720 @@
+*###[ ffzli2:
+ subroutine ffzli2(zdilog,zlog,cx,lreal,ier)
+***#[*comment:***********************************************************
+* *
+* Computes the dilogarithm (Li2, Sp) for any (complex) cx *
+* to a precision precc. It assumes that cx is already in the *
+* area |cx|<=1, Re(cx)<=1/2. As it is available it also returns *
+* log(1-cx) = zlog. *
+* *
+* Input: cx (complex) *
+* lreal (logical) indicates whether only the real part *
+* is needed *
+* *
+* Output: zdilog (complex) Li2(cx) *
+* zlog (complex) log(1-cx) = -Li1(cx) *
+* ier (integer) 0=OK,1=num,2=err *
+* *
+* Calls: log,zfflo1,(d/a)imag,real/dble *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ logical lreal
+ DOUBLE COMPLEX cx,zlog,zdilog
+*
+* local variables
+*
+ DOUBLE PRECISION xprec,bdn02,bdn05,bdn10,bdn15,bdn20,
+ + xi,xr,xdilog,xlog,x,absc,xa,a,ffbnd
+ DOUBLE COMPLEX cc,cz,cz2,zfflo1
+ save xprec,bdn02,bdn05,bdn10,bdn15,bdn20
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+* #] declarations:
+* #[ initialisations:
+ data xprec /-1./
+ if ( xprec .ne. precc ) then
+ xprec = precc
+ bdn02 = ffbnd(1,2,bf)
+ bdn05 = ffbnd(1,5,bf)
+ bdn10 = ffbnd(1,10,bf)
+ bdn15 = ffbnd(1,15,bf)
+ bdn20 = ffbnd(1,19,bf)
+* we don't have bf(21) ...
+ endif
+* #] initialisations:
+* #[ check input:
+* (throw out later)
+ if ( ltest .and. absc(cx).gt.1.5 .or. DBLE(cx).gt..75 ) then
+ call fferr(30,ier)
+ print *,'cx = ',cx
+ endif
+* #] check input:
+* #[ exceptional cases:
+ xi = DIMAG(cx)
+ xr = DBLE(cx)
+ if ( xi .eq. 0) then
+ call ffxli2(xdilog,xlog,xr,ier)
+ zdilog = xdilog
+ zlog = xlog
+ return
+ endif
+ xa = abs(xi) + abs(xr)
+ if ( xa .lt. precc ) then
+ zdilog = cx
+ zlog = -cx
+ return
+ endif
+* #] exceptional cases:
+* #[ get log,dilog:
+ if ( xa .lt. xloss**2 ) then
+ zlog = zfflo1(cx,ier)
+ else
+ zlog = log(1-cx)
+ endif
+ cz = -zlog
+ if ( absc(cz) .lt. xclog2 ) then
+ zdilog = cz
+ else
+ cz2 = cz*cz
+ a = xa**2
+ if ( lwarn .and. a .gt. bdn20 ) then
+ call ffwarn(61,ier,precc,abs(bf(20))*a**20)
+ endif
+ if ( a .gt. bdn15 ) then
+ zdilog = cz2*(DBLE(bf(16)) + cz2*(DBLE(bf(17))
+ + + cz2*(DBLE(bf(18)) + cz2*(DBLE(bf(19))
+ + + cz2*(DBLE(bf(20)))))))
+ else
+ zdilog = 0
+ endif
+ if ( a .gt. bdn10 ) then
+ zdilog = cz2*(DBLE(bf(11)) + cz2*(DBLE(bf(12))
+ + + cz2*(DBLE(bf(13)) + cz2*(DBLE(bf(14))
+ + + cz2*(DBLE(bf(15)) + zdilog)))))
+ endif
+ if ( a .gt. bdn05 ) then
+ zdilog = cz2*(DBLE(bf(6)) + cz2*(DBLE(bf(7))
+ + + cz2*(DBLE(bf(8)) + cz2*(DBLE(bf(9))
+ + + cz2*(DBLE(bf(10)) + zdilog)))))
+ endif
+ if ( a .gt. bdn02 ) then
+ zdilog = cz2*(DBLE(bf(3)) + cz2*(DBLE(bf(4))
+ + + cz2*(DBLE(bf(5)) + zdilog)))
+ endif
+* watch the powers of z.
+ zdilog = cz + cz2*(DBLE(bf(1)) + cz*(DBLE(bf(2)) + zdilog))
+ endif
+* #] get log,dilog:
+* #[ check for numerical problems:
+*
+* if we just need the real part the dominant term is xi^2/4
+*
+ if ( lreal .and. abs(DBLE(zdilog)) .lt. xloss*xi**2/4 ) then
+* think of something more intelligent later ...
+ x = DBLE(zdilog)
+ if ( lwarn ) call ffwarn(151,ier,x,xi**2/4)
+ endif
+* #] check for numerical problems:
+*###] ffzli2:
+ end
+*###[ ffzzdl:
+ subroutine ffzzdl(zdilog,ipi12,zlog,cx,ier)
+***#[*comment:***************************************************
+* *
+* Computes the dilogarithm (Li2, Sp) for any (complex) cx *
+* to about 15 significant figures. This can be improved *
+* by adding more of the bf's. For real cx > 1 an error is *
+* generated as the imaginary part is undefined then. *
+* For use in ffcdbd zlog = log(1-cx) is also calculated *
+* *
+* Input: cx (complex) *
+* *
+* Output: zdilog (complex) Li2(cx) mod factors pi^2/12 *
+* ipi12 (integer) these factors *
+* zlog (complex) log(1-cx) *
+* *
+* Calls: log,zfflo1,(d/a)imag,real/dble *
+* *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ipi12,ier
+ DOUBLE COMPLEX zdilog,zlog,cx
+*
+* local variables
+*
+ integer jsgn
+ DOUBLE PRECISION xprec,bdn02,bdn05,bdn10,bdn15,bdn20,
+ + xi,xr,s1,s2,xa,a,absc,ffbnd
+ DOUBLE COMPLEX cfact,cx1,cy,cz,cz2,zfflo1,c
+ save xprec,bdn02,bdn05,bdn10,bdn15,bdn20
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ initialisations:
+ data xprec /-1./
+ if ( xprec .ne. precc ) then
+ xprec = precc
+ bdn02 = ffbnd(1,2,bf)
+ bdn05 = ffbnd(1,5,bf)
+ bdn10 = ffbnd(1,10,bf)
+ bdn15 = ffbnd(1,15,bf)
+ bdn20 = ffbnd(1,19,bf)
+ endif
+* #] initialisations:
+* #[ debug:
+* if ( lwrite ) print *,'ffzzdl(',cx,')'
+* #] debug:
+* #[ exceptional cases:
+ xi = DIMAG(cx)
+ xr = DBLE(cx)
+ if ( xi .eq. 0 ) then
+ if ( xr .gt. 1 ) call fferr(31,ier)
+ call ffzxdl(zdilog,ipi12,zlog,xr,1,ier)
+ return
+ endif
+ if ( abs(xi) .lt. xalog2 ) then
+ s1 = 0
+ else
+ s1 = xi**2
+ endif
+ if ( abs(xr) .lt. xalog2 ) then
+ s2 = 0
+ else
+ s2 = xr**2
+ endif
+ xa = sqrt(s1 + s2)
+ if ( xa .lt. precc ) then
+ zdilog = cx
+ zlog = -cx
+ ipi12 = 0
+ return
+ endif
+* #] exceptional cases:
+* #[ transform to |x|<1, Re(x) < 0.5:
+ if ( xr .le. x05) then
+ if (xa .gt. 1) then
+ if ( 1/xa .lt. xalogm ) then
+ cfact = 0
+ elseif ( 1/xa .lt. xclogm ) then
+ cx1 = cx*DBLE(1/xa)
+ cfact = log(-cx1) + log(DBLE(xa))
+ else
+ cfact = log(-cx)
+ endif
+ cy = - cfact**2/2
+ ipi12 = -2
+ if ( xa*xloss**2 .gt. 1) then
+ if ( 1/xa .lt. xclogm ) then
+ cx1 = cx*DBLE(1/xa)
+ cx1 = 1/cx1
+ cx1 = cx1*DBLE(1/xa)
+ else
+ cx1 = 1/cx
+ endif
+ cz = -zfflo1(cx1,ier)
+ else
+ cz = -log(1-1/cx)
+ endif
+ zlog = log(1-cx)
+ jsgn = -1
+ else
+ cy = 0
+ ipi12 = 0
+ if ( xa .lt. xloss**2 ) then
+ zlog = zfflo1(cx,ier)
+ else
+ zlog = log(1-cx)
+ endif
+ cz = -zlog
+ jsgn = 1
+ endif
+ else
+ if (xa .le. sqrt(2*xr)) then
+ cz = -log(cx)
+ if ( abs(xr-1) + abs(xi) .lt. xclogm ) then
+ if ( lwarn )
+ + call ffwarn(65,ier,abs(1-xr)+abs(xi),xclogm)
+ cy = 0
+ else
+ zlog = log(1-cx)
+ cy = cz*zlog
+ endif
+ ipi12 = 2
+ jsgn = -1
+ else
+ if ( 1/xa .lt. xalogm ) then
+ cfact = 0
+ elseif ( 1/xa .lt. xclogm ) then
+ cx1 = cx*DBLE(1/xa)
+ cfact = log(-cx1) + log(DBLE(xa))
+ else
+ cfact = log(-cx)
+ endif
+ cy = - cfact**2/2
+ ipi12 = -2
+ if ( xa*xloss .gt. 1) then
+ if ( 1/xa .lt. xclogm ) then
+ cx1 = cx*DBLE(1/xa)
+ cx1 = 1/cx1
+ cx1 = cx1*DBLE(1/xa)
+ else
+ cx1 = 1/cx
+ endif
+ cz = -zfflo1(cx1,ier)
+ else
+ cz = -log(1-1/cx)
+ endif
+ zlog = log(1-cx)
+ jsgn = -1
+ endif
+ endif
+* #] transform to |x|<1, Re(x) < 0.5:
+* #[ get dilog:
+ if ( absc(cz) .lt. xclogm ) then
+ zdilog = cz
+ else
+ cz2 = cz*cz
+ a = DBLE(cz)**2 + DIMAG(cz)**2
+ if ( lwarn .and. a .gt. bdn20 ) then
+ call ffwarn(67,ier,precc,abs(bf(20))*a**20)
+ endif
+ if ( a .gt. bdn15 ) then
+ zdilog = cz2*(DBLE(bf(16)) + cz2*(DBLE(bf(17))
+ + + cz2*(DBLE(bf(18)) + cz2*(DBLE(bf(19))
+ + + cz2*(DBLE(bf(20)))))))
+ else
+ zdilog = 0
+ endif
+ if ( a .gt. bdn10 ) then
+ zdilog = cz2*(DBLE(bf(11)) + cz2*(DBLE(bf(12))
+ + + cz2*(DBLE(bf(13)) + cz2*(DBLE(bf(14))
+ + + cz2*(DBLE(bf(15)) + zdilog)))))
+ endif
+ if ( a .gt. bdn05 ) then
+ zdilog = cz2*(DBLE(bf(6)) + cz2*(DBLE(bf(7))
+ + + cz2*(DBLE(bf(8)) + cz2*(DBLE(bf(9))
+ + + cz2*(DBLE(bf(10)) + zdilog)))))
+ endif
+ if ( a .gt. bdn02 ) then
+ zdilog = cz2*(DBLE(bf(3)) + cz2*(DBLE(bf(4))
+ + + cz2*(DBLE(bf(5)) + zdilog)))
+ endif
+* watch the powers of z.
+ zdilog = cz + cz2*(DBLE(bf(1)) + cz*(DBLE(bf(2)) + zdilog))
+ endif
+ if(jsgn.eq.1)then
+ zdilog = zdilog + cy
+ else
+ zdilog = -zdilog + cy
+ endif
+* #] get dilog:
+*###] ffzzdl:
+ end
+*###[ zfflog:
+ DOUBLE COMPLEX function zfflog(cx,ieps,cy,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the complex logarithm of cx. The following cases *
+* are treted separately: *
+* |cx| too small: give warning and return 0 *
+* (for Absoft, Apollo DN300) *
+* Im(cx) = 0, Re(cx) < 0: take sign according to ieps *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+*
+* arguments
+*
+ implicit none
+ integer ieps,ier
+ DOUBLE COMPLEX cx,cy
+*
+* local variables
+*
+ DOUBLE COMPLEX c,ctroep
+ DOUBLE PRECISION absc,xa,xlog1p
+*
+* common blocks, statement function
+*
+ include 'ff.h'
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if ( lwarn .and. absc(cx-1) .lt. xloss ) then
+ call ffwarn(128,ier,absc(cx-1),x1)
+ endif
+* #] check input:
+* #[ calculations:
+ xa = absc(cx)
+ if ( xa .lt. xalogm ) then
+ if ( cx .ne. 0 ) call fferr(23,ier)
+ zfflog = 0
+ elseif ( DBLE(cx) .lt. 0 .and. DIMAG(cx) .eq. 0 ) then
+* + abs(DIMAG(cx)) .lt. precc*abs(DBLE(cx)) ) then
+ xlog1p = log(-DBLE(cx))
+* checked imaginary parts 19-May-1988
+ if ( abs(ieps) .eq. 1 ) then
+ if ( ieps*DBLE(cy) .lt. 0 ) then
+ zfflog = DCMPLX(xlog1p,-pi)
+ elseif ( ieps*DBLE(cy) .gt. 0 ) then
+ zfflog = DCMPLX(xlog1p,pi)
+ else
+ call fferr(51,ier)
+ zfflog = DCMPLX(xlog1p,pi)
+ endif
+ elseif ( ieps .ge. 2 .and. ieps .le. 3 ) then
+ zfflog = DCMPLX(xlog1p,-pi)
+ elseif ( ieps .le. -2 .and. ieps .ge. -3 ) then
+ zfflog = DCMPLX(xlog1p,pi)
+ else
+ call fferr(51,ier)
+ zfflog = DCMPLX(xlog1p,pi)
+ endif
+ if ( ltest .and. DIMAG(cx) .ne. 0 ) then
+ if ( DIMAG(zfflog) .gt. 0 .neqv. DIMAG(cx) .gt. 0 )
+ + call fferr(56,ier)
+ endif
+ elseif ( xa .lt. xclogm .or. 1/xa .lt. xclogm ) then
+ ctroep = cx*DBLE(1/xa)
+ zfflog = log(ctroep) + DBLE(log(xa))
+ else
+* print *,'zfflog: neem log van ',cx
+ zfflog = log(cx)
+ endif
+* #] calculations:
+*###] zfflog:
+ end
+*###[ zfflo1:
+ DOUBLE COMPLEX function zfflo1(cx,ier)
+***#[*comment:***************************************************
+* calculates log(1-x) for |x|<.14 in a faster way to ~15 *
+* significant figures. *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+ integer ier
+ DOUBLE COMPLEX cx,c,zfflog
+ DOUBLE PRECISION xprec,bdn01,bdn05,bdn10,bdn15,bdn19,
+ + absc,xa,ffbnd
+ save xprec,bdn01,bdn05,bdn10,bdn15,bdn19
+ include 'ff.h'
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ initialisations:
+ data xprec /-1./
+ if ( precc .ne. xprec ) then
+ xprec = precc
+* determine the boundaries for 1,5,10,15 terms
+ bdn01 = ffbnd(1,1,xninv)
+ bdn05 = ffbnd(1,5,xninv)
+ bdn10 = ffbnd(1,10,xninv)
+ bdn15 = ffbnd(1,15,xninv)
+ bdn19 = ffbnd(1,19,xninv)
+ endif
+* #] initialisations:
+* #[ calculations:
+ xa = absc(cx)
+ if ( xa .gt. bdn19 ) then
+ if ( lwarn .and. xa .lt. xloss ) call ffwarn(63,ier,xa,x1)
+ c = cx-1
+ xa = absc(c)
+ if ( lwarn .and. xa .lt. xloss ) call ffwarn(133,ier,xa,x1)
+ zfflo1 = zfflog(1-cx,0,c0,ier)
+ return
+ endif
+ if ( xa .gt. bdn15 ) then
+ zfflo1 = cx*( DBLE(xninv(16)) + cx*( DBLE(xninv(17))
+ + + cx*( DBLE(xninv(18)) + cx*( DBLE(xninv(19))
+ + + cx*( DBLE(xninv(20)) )))))
+ else
+ zfflo1 = 0
+ endif
+ if ( xa .gt. bdn10 ) then
+ zfflo1 = cx*( DBLE(xninv(11)) + cx*( DBLE(xninv(12))
+ + + cx*( DBLE(xninv(13)) + cx*( DBLE(xninv(14))
+ + + cx*( DBLE(xninv(15)) + zfflo1 )))))
+ endif
+ if ( xa .gt. bdn05 ) then
+ zfflo1 = cx*( DBLE(xninv(6)) + cx*( DBLE(xninv(7))
+ + + cx*( DBLE(xninv(8)) + cx*( DBLE(xninv(9))
+ + + cx*( DBLE(xninv(10)) + zfflo1 )))))
+ endif
+ if ( xa .gt. bdn01 ) then
+ zfflo1 = cx*( DBLE(xninv(2)) + cx*( DBLE(xninv(3))
+ + + cx*( DBLE(xninv(4)) + cx*( DBLE(xninv(5))
+ + + zfflo1 ))))
+ endif
+ zfflo1 = - cx*( DBLE(xninv(1)) + zfflo1 )
+* #] calculations:
+*###] zfflo1:
+ end
+*###[ zfflo2:
+ DOUBLE COMPLEX function zfflo2(x,ier)
+***#[*comment:***************************************************
+* calculates log(1-x)+x for |x|<.14 in a faster way to *
+* ~15 significant figures. *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+ integer ier,ier0
+ DOUBLE COMPLEX x,d1,zfflo1,cc
+ DOUBLE PRECISION bdn01,bdn05,bdn10,bdn15,bdn18,xprec,xa,xheck,
+ + ffbnd,absc
+ save xprec,bdn01,bdn05,bdn10,bdn15,bdn18
+ include 'ff.h'
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+* #] declarations:
+* #[ initialisation:
+ data xprec /-1./
+ if ( xprec .ne. precc ) then
+ xprec = precx
+ precx = precc
+* determine the boundaries for 1,5,10,15 terms
+ bdn01 = ffbnd(1,1,xninv(2))
+ bdn05 = ffbnd(1,5,xninv(2))
+ bdn10 = ffbnd(1,10,xninv(2))
+ bdn15 = ffbnd(1,15,xninv(2))
+ bdn18 = ffbnd(1,18,xninv(2))
+ precx = xprec
+ xprec = precc
+ endif
+* #] initialisation:
+* #[ calculations:
+ xa = absc(x)
+ if ( xa .gt. bdn18 ) then
+ zfflo2 = zfflo1(x,ier) + x
+ if ( lwarn .and. absc(zfflo2).lt.xloss*abs(x) )
+ + call ffwarn(234,ier,absc(zfflo2),absc(x))
+ return
+ endif
+ if ( xa .gt. bdn15 ) then
+ zfflo2 = x*( DBLE(xninv(17)) + x*( DBLE(xninv(18)) +
+ + x*( DBLE(xninv(19)) + x*( DBLE(xninv(20)) ))))
+ else
+ zfflo2 = 0
+ endif
+ if ( xa .gt. bdn10 ) then
+ zfflo2 = x*( DBLE(xninv(12)) + x*( DBLE(xninv(13)) +
+ + x*( DBLE(xninv(14)) + x*( DBLE(xninv(15)) +
+ + x*( DBLE(xninv(16)) + zfflo2 )))))
+ endif
+ if ( xa .gt. bdn05 ) then
+ zfflo2 = x*( DBLE(xninv(7)) + x*( DBLE(xninv(8)) +
+ + x*( DBLE(xninv(9)) +x*( DBLE(xninv(10)) +
+ + x*( DBLE(xninv(11)) + zfflo2 )))))
+ endif
+ if ( xa .gt. bdn01 ) then
+ zfflo2 = x*( DBLE(xninv(3)) + x*( DBLE(xninv(4)) +
+ + x*( DBLE(xninv(5)) + x*( DBLE(xninv(6)) + zfflo2 ))))
+ endif
+ zfflo2 = - x**2*( DBLE(xninv(2)) + zfflo2 )
+* #] calculations:
+* #[ check output:
+ if ( ltest ) then
+ ier0 = ier
+ d1 = zfflo1(x,ier0) + x
+ xheck = absc(d1-zfflo2)
+ if ( xloss*abs(xheck) .gt. precc ) print *,'zfflo2: error:',
+ + ' answer is not OK',d1,zfflo2,xheck
+ endif
+* #] check output:
+*###] zfflo2:
+ end
+*###[ zfflo3:
+ DOUBLE COMPLEX function zfflo3(x,ier)
+***#[*comment:***************************************************
+* calculates log(1-x)+x+x^2/2 for |x|<.14 in a faster *
+* way to ~15 significant figures. *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+ integer ier,ier0
+ DOUBLE COMPLEX x,d1,zfflo2,cc
+ DOUBLE PRECISION bdn01,bdn05,bdn10,bdn15,xprec,xa,xheck,ffbnd,
+ + absc
+ save xprec,bdn01,bdn05,bdn10,bdn15
+ include 'ff.h'
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+* #] declarations:
+* #[ initialisation:
+ data xprec /-1./
+ if ( xprec .ne. precx ) then
+ xprec = precx
+ precx = precc
+* determine the boundaries for 1,5,10,15 terms
+ bdn01 = ffbnd(1,1,xninv(3))
+ bdn05 = ffbnd(1,5,xninv(3))
+ bdn10 = ffbnd(1,10,xninv(3))
+ bdn15 = ffbnd(1,15,xninv(3))
+ precx = xprec
+ xprec = precc
+ endif
+* #] initialisation:
+* #[ calculations:
+ xa = absc(x)
+ if ( xa .gt. bdn15 ) then
+ zfflo3 = zfflo2(x,ier) + x**2/2
+ if ( lwarn .and. absc(zfflo3).lt.xloss*absc(x**2)/2 )
+ + call ffwarn(235,ier,absc(zfflo3),absc(x**2/2))
+ return
+ endif
+ if ( xa .gt. bdn10 ) then
+ zfflo3 = x*( DBLE(xninv(13)) + x*( DBLE(xninv(14)) +
+ + x*( DBLE(xninv(15)) + x*( DBLE(xninv(16)) +
+ + x*( DBLE(xninv(17)) )))))
+ else
+ zfflo3 = 0
+ endif
+ if ( xa .gt. bdn05 ) then
+ zfflo3 = x*( DBLE(xninv(8)) + x*( DBLE(xninv(9)) +
+ + x*( DBLE(xninv(10)) + x*( DBLE(xninv(11)) +
+ + x*( DBLE(xninv(12)) + zfflo3 )))))
+ endif
+ if ( xa .gt. bdn01 ) then
+ zfflo3 = x*( DBLE(xninv(4)) + x*( DBLE(xninv(5)) +
+ + x*( DBLE(xninv(6)) + x*( DBLE(xninv(7)) + zfflo3 ))))
+ endif
+ zfflo3 = - x**3*( DBLE(xninv(3)) + zfflo3 )
+* #] calculations:
+* #[ check output:
+ if ( ltest ) then
+ ier0 = ier
+ d1 = zfflo2(x,ier0) + x**2/2
+ xheck = absc(d1-zfflo3)
+ if ( xloss*abs(xheck) .gt. precc ) print *,'zfflo3: error:',
+ + ' answer is not OK',d1,zfflo3,xheck
+ endif
+* #] check output:
+*###] zfflo3:
+ end
+*###[ zff0li:
+ DOUBLE COMPLEX function zff0li(r2)
+***#[*comment:***********************************************************
+* *
+* computes complex value z such that abs(z)**2 = r2 < 1 *
+* and Re(Li2(z))=0 *
+* written by P.Noguiero (Lisboa) * *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE PRECISION r2
+*
+* local variables
+*
+ integer i
+ DOUBLE PRECISION c1(30),c2(30),zr,zx
+ save c1,c2
+*
+* common blocks
+*
+* #] declarations:
+* #[ data:
+*
+ data c1(1) / 0.2500000000000000 /
+ data c1(2) / -1.0416666666666667D-02 /
+ data c1(3) / 1.2152777777777778D-03 /
+ data c1(4) / -2.1959738756613757D-04 /
+ data c1(5) / 4.9439553020282187D-05 /
+ data c1(6) / -1.2675094665654561D-05 /
+ data c1(7) / 3.5389820153701292D-06 /
+ data c1(8) / -1.0493857656770419D-06 /
+ data c1(9) / 3.2537695998679074D-07 /
+ data c1(10) / -1.0442280388149559D-07 /
+ data c1(11) / 3.4441733990714665D-08 /
+ data c1(12) / -1.1615493272944038D-08 /
+ data c1(13) / 3.9902649974583553D-09 /
+ data c1(14) / -1.3922421108836989D-09 /
+ data c1(15) / 4.9225507537640102D-10 /
+ data c1(16) / -1.7605266995285916D-10 /
+ data c1(17) / 6.3596990550536869D-11 /
+ data c1(18) / -2.3176654407515461D-11 /
+ data c1(19) / 8.5124040210417827D-12 /
+ data c1(20) / -3.1483106624053104D-12 /
+ data c1(21) / 1.1717062820424101D-12 /
+ data c1(22) / -4.3854323145311313D-13 /
+ data c1(23) / 1.6498013217746003D-13 /
+ data c1(24) / -6.2356193829603354D-14 /
+ data c1(25) / 2.3669242668432088D-14 /
+
+ data c2(1) / 0.2500000000000000 /
+ data c2(2) / 5.2083333333333333D-02 /
+ data c2(3) / 6.4236111111111111D-03 /
+ data c2(4) / 4.7484705687830688D-04 /
+ data c2(5) / 1.4303971009700176D-05 /
+ data c2(6) / -1.1031735071448613D-06 /
+ data c2(7) / -1.6930087449913219D-07 /
+ data c2(8) / -9.5437325895661167D-09 /
+ data c2(9) / -1.1765492620111313D-10 /
+ data c2(10) / 1.5727493777091249D-11 /
+ data c2(11) / 6.7654901409698409D-13 /
+ data c2(12) / -4.6807758765169774D-15 /
+ data c2(13) / -2.4871711489610564D-15 /
+ data c2(14) / -1.3622942781034796D-16 /
+ data c2(15) / 3.8201988176071429D-17 /
+ data c2(16) / -3.2258659308514033D-19 /
+ data c2(17) / -4.5613496077409173D-19 /
+ data c2(18) / 5.1177130568324641D-20 /
+ data c2(19) / 5.4099028875697205D-22 /
+ data c2(20) / -8.5181489051619174D-22 /
+ data c2(21) / 9.6732395493921367D-23 /
+ data c2(22) / 2.1141447009853665D-24 /
+ data c2(23) / -1.8622848688015854D-24 /
+ data c2(24) / 1.9077807703926496D-25 /
+ data c2(25) / 8.0274683356039559E-27 /
+*
+* #] data:
+* #[ work:
+*
+ if ( abs(r2).le.0.1d0)t h en
+ zx = 0
+ do i=10,1,-1
+ zx = r2*(zx+c1(i))
+ enddo
+ elseif ( abs(r2).le.0.5d0 ) then
+ zx = 0
+ do i=20,1,-1
+ zx = r2*(zx+c1(i))
+ enddo
+ elseif ( abs(r2).le.1.0d0 ) then
+ zr = 2*log(1 + r2/2)
+ zx = 0
+ do i=13,1,-1
+ zx = zr*(zx+c2(i))
+ enddo
+ else
+ print *,'zff0li: error: argumnet must <= 1, not ',r2
+ zx = 0
+ endif
+
+ zff0li = DCMPLX(zx,sqrt(r2-zx*zx))
+*
+* #] work:
+*###] zff0li:
+ end
+
diff --git a/ff-2.0/ffcrr.f b/ff-2.0/ffcrr.f
new file mode 100644
index 0000000..6f22aee
--- /dev/null
+++ b/ff-2.0/ffcrr.f
@@ -0,0 +1,844 @@
+*--#[ log:
+* $Id: ffcrr.f,v 1.5 1995/11/10 19:04:23 gj Exp $
+* $Log: ffcrr.f,v $
+c Revision 1.5 1995/11/10 19:04:23 gj
+c Added nicer logging header...
+c
+c Revision 1.4 1995/10/17 06:55:07 gj
+c Fixed ieps error in ffdcrr (ffcxs4.f), added real case in ffcrr, debugging
+c info in ffxd0, and warned against remaining errors for del2=0 in ffrot4
+c (ffxd0h.f)
+c
+c Revision 1.3 1995/10/06 09:17:20 gj
+c Found stupid typo in ffxc0p which caused the result to be off by pi^2/3 in
+c some equal-mass cases. Added checks to ffcxs4.f ffcrr.f.
+c
+*--#] log:
+*###[ ffcrr:
+ subroutine ffcrr(crr,ipi12,cy,cy1,cz,cz1,cdyz,ld2yzz,cd2yzz,czz,
+ + czz1,isoort,ieps,ier)
+***#[*comment:***********************************************************
+* *
+* calculates R as defined in appendix b: *
+* *
+* /1 log(y-y1+ieps) - log(y0-y1+ieps) *
+* r(y0,y1,iesp) = \ dy -------------------------------- *
+* /0 y-y0 *
+* *
+* = li2(c1) - li2(c2) *
+* + eta(-y1,1/(y0-y1))*log(c1) *
+* - eta(1-y1,1/(y0-y1))*log(c2) *
+* with *
+* c1 = y0 / (y0-y1), c2 = (y0-1) / (y0-y1) *
+* *
+* the factors pi^2/12 are passed separately in the integer ipi12 *
+* ier is a status flag: 0=ok, 1=numerical problems, 2=error *
+* *
+* Input: cy (complex) *
+* cy1 (complex) 1-y *
+* cz (complex) *
+* cz1 (complex) 1-z *
+* cdyz (complex) y-z *
+* ieps (integer) denotes sign imaginary part of *
+* argument logs (0: don't care; *
+* +/-1: add -ieps to z; +/-2: *
+* direct in dilogs, no eta's) *
+* *
+* Output crr (complex) R modulo factors pi^2/12 *
+* ipi12 (integer) these factors *
+* ier (integer) lost ier digits, >100: error *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ipi12,isoort,ieps,ier
+ logical ld2yzz,lreal
+ DOUBLE COMPLEX crr(7),cy,cy1,cz,cz1,cdyz,cd2yzz,czz,czz1
+*
+* local variables
+*
+ DOUBLE COMPLEX check,cfact,cc1,cc2,cc1p,cc2p,carg1,carg2,carg3,
+ + cli1,cli2,cli3,clo1,clo2,clo3,clog1p,clog2p,chill,
+ + cd2,cd21,cd2n,cd21n1,cc1n,cterm,ctot,zfflo1,clog1,clog2,
+ + cr,cr1,cc,cli4,clo4
+ DOUBLE COMPLEX clia,clib,ctroep,zfflog
+ DOUBLE PRECISION xa,xr,absc,rloss,xprec,bndtay,ffbnd
+ DOUBLE PRECISION y,y1,z,z1,dyz,d2yzz,zz,zz1
+ integer i,nffeta,nffet1,iclas1,iclas2,ier0,n1,n2,n3,ntot,ipi121,
+ + ipi122,isign,i2pi,n3p
+ save xprec,bndtay
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+* #] declarations:
+* #[ initialisations:
+ data xprec /-1./
+ if ( xprec .ne. precx ) then
+ xprec = precx
+ bndtay = ffbnd(2,18,xn2inv)
+* print *,'bndtay = ',bndtay
+ endif
+* #] initialisations:
+* #[ check input:
+ if ( ltest ) then
+ if ( ipi12.ne.0 ) then
+ print *,'ffcrr: error: why is ipi12 != 0? ',ipi12
+ endif
+ if ( (isoort.eq.-1 .or. isoort.eq.-3) .and. abs(ieps).eq.1
+ + .and. abs(DIMAG(cz)).gt.precc*abs(DBLE(cz)) ) then
+ if ( DIMAG(cz).gt.0 .eqv. ieps.gt.0 ) then
+ print *,'ffcrr: error: imaginary signs cz and ',
+ + 'ieps do not agree: ',cz,ieps
+ endif
+ endif
+ rloss = xloss*DBLE(10)**(-mod(ier,50)-2)
+ check = cy + cy1 - 1
+ if ( rloss*absc(check) .gt. precc*max(absc(cy),
+ + absc(cy1),x1)) then
+ print *,'ffcrr: error: cy <> 1-cy1',cy,cy1,check
+ endif
+ check = cz + cz1 - 1
+ if( rloss*absc(check) .gt. precc*max(absc(cz),
+ + absc(cz1),x1)) then
+ print *,'ffcrr: error: cz <> 1-cz1',cz,cz1,check
+ endif
+ check = cdyz - cy + cz
+ if ( rloss*absc(check) .gt. precc*max(absc(cy),
+ + absc(cz),absc(cdyz)) ) then
+ print *,'ffcrr: error: cdyz <> cy-cz',cdyz,cy,cz,check
+ endif
+ if ( ld2yzz ) then
+ check = cd2yzz-2*cy+cz+czz
+ if( rloss*absc(check).gt.precc*max(absc(cd2yzz),
+ + 2*absc(cy),absc(cz),absc(czz)))then
+ print *,'ffcrr: error: cd2yzz<>2cy-cz-czz',cd2yzz,
+ + 2*cy,cz,czz,check
+ endif
+ check = czz + czz1 - 1
+ if ( rloss*absc(check) .gt. precc*max(absc(czz),
+ + absc(czz1),x1) ) then
+ print *,'ffcrr: error: 1-czz <> czz1',czz,czz1,check
+ endif
+ endif
+ endif
+ if ( lwrite ) then
+ print *,'ffcrr: input:'
+ print *,' cy = ',cy,cy1
+ print *,' cz = ',cz,cz1
+ print *,' cdyz = ',cdyz
+ if ( ld2yzz ) then
+ print *,' cd2yzz= ',cd2yzz
+ print *,' czz = ',czz,czz1
+ endif
+ print *,' cz->cz-eps*',ieps
+ print *,' isoort= ',isoort
+ endif
+* #] check input:
+* #[ real case:
+ if ( DIMAG(cy).eq.0 .and. DIMAG(cy1).eq.0 .and. DIMAG(cz).eq.0
+ + .and. DIMAG(cz1).eq.0 ) then
+ if ( lwrite ) then
+ print *,'ffcrr: all arguments are real'
+ print *,' calling ffcxr'
+ endif
+ y = DBLE(cy)
+ y1 = DBLE(cy1)
+ z = DBLE(cz)
+ z1 = DBLE(cz1)
+ dyz = DBLE(cdyz)
+ d2yzz = DBLE(cd2yzz)
+ zz = DBLE(czz)
+ zz1 = DBLE(czz1)
+ call ffcxr(crr,ipi12,y,y1,z,z1,dyz,ld2yzz,d2yzz,zz,zz1,
+ + .FALSE.,x0,ieps,ier)
+ return
+ endif
+* #] real case:
+* #[ arguments:
+*
+* get the arguments
+*
+ xa = absc(cdyz)
+ if ( xa .eq. 0 ) then
+ if ( lwarn ) call ffwarn(48,ier,absc(cdyz),x1)
+ return
+* This line is for 68000 compilers that have a limited range for
+* complex division (Absoft, Apollo, Gould NP1):
+ elseif ( DBLE(cdyz) .lt. xclogm .or. DIMAG(cdyz) .lt. xclogm
+ + .or. 1/xa .lt. xclogm ) then
+ ctroep = cdyz*DBLE(1/xa)
+ cfact = 1/ctroep
+ cfact = DBLE(1/xa)*cfact
+ else
+ cfact = 1/cdyz
+ endif
+ cc1 = cy * cfact
+ cc2 = - cy1 * cfact
+*
+* see if we just need the real part
+*
+ lreal = mod(isoort,5) .eq. 0
+* #] arguments:
+* #[ which area?:
+*
+* determine the area: 1={|x|<=1,Re(x)<=1/2},
+* 2={|1-x|<=1,Re(x)>1/2}
+* 3={|x|>1,|1-x|>1}
+*
+ xr = DBLE(cc1)
+ xa = absc(cc1)
+ if ( xa .gt. 1 .and. xa .lt. 1+sqrt(2.) ) then
+* we need a more accurate estimate
+ xa = xr**2 + DIMAG(cc1)**2
+ endif
+ if ( ld2yzz .and. absc(cc1+1) .lt. xloss/2 ) then
+ iclas1 = 4
+ cc1p = cc1
+ elseif ( xa .le. 1 .and. xr .le. 0.5 ) then
+ iclas1 = 1
+ cc1p = cc1
+ elseif ( xa .lt. 1+sqrt(2.) .and. xa .lt. 2*xr ) then
+ iclas1 = 2
+ cc1p = -cz * cfact
+ if ( abs(DIMAG(cc1p)) .lt. precc*abs(DBLE(cc1p)) )
+ + cc1p = DBLE(cc1p)
+ else
+ iclas1 = 3
+ if ( 1/xa .lt. xclogm ) then
+ ctroep = cc1*DBLE(1/xa)
+ ctroep = 1/ctroep
+ cc1p = ctroep*DBLE(1/xa)
+ else
+ cc1p = 1/cc1
+ endif
+ endif
+ xr = DBLE(cc2)
+ xa = absc(cc2)
+ if ( xa .gt. 1 .and. xa .lt. 1+sqrt(2.) ) then
+ xa = xr**2 + DIMAG(cc2)**2
+ endif
+ if ( ld2yzz .and. absc(cc2+1) .lt. xloss ) then
+ iclas2 = 4
+ cc2p = cc2
+ elseif ( xa .le. 1 .and. xr .le. 0.5 ) then
+ iclas2 = 1
+ cc2p = cc2
+ elseif ( xa .lt. 1+sqrt(2.) .and. xa .lt. 2*xr ) then
+ iclas2 = 2
+ cc2p = cz1 * cfact
+ if ( abs(DIMAG(cc2p)) .lt. precc*abs(DBLE(cc2p)) )
+ + cc2p = DBLE(cc2p)
+ else
+ iclas2 = 3
+ if ( 1/xa .lt. xclogm ) then
+ ctroep = cc2*DBLE(1/xa)
+ ctroep = 1/ctroep
+ cc2p = ctroep*DBLE(1/xa)
+ else
+ cc2p = 1/cc2
+ endif
+ endif
+*
+* throw together if they are close
+*
+ if ( iclas1 .ne. iclas2 .and. absc(cc1-cc2) .lt. 2*xloss )
+ + then
+* we don't want trouble with iclasn = 4
+ if ( iclas1 .eq. 4 ) iclas1 = 1
+ if ( iclas2 .eq. 4 ) iclas2 = 1
+ if ( iclas1 .eq. iclas2 ) goto 5
+* go on
+ if ( iclas1 .le. iclas2 ) then
+ iclas2 = iclas1
+ if ( iclas1 .eq. 1 ) then
+ cc2p = cc2
+ else
+ cc2p = cz1*cfact
+ endif
+ else
+ iclas1 = iclas2
+ if ( iclas1 .eq. 1 ) then
+ cc1p = cc1
+ else
+ cc1p = -cz*cfact
+ endif
+ endif
+ endif
+ 5 continue
+* #] which area?:
+* #[ eta's:
+*
+* get eta1 and eta2
+*
+ if ( abs(ieps) .ge. 2 .or. isoort .eq. -2 ) then
+ n1 = 0
+ n2 = 0
+ else
+ if ( DIMAG(cz) .eq. 0 .or. DIMAG(cz1) .eq. 0 ) then
+ if ( DIMAG(cz1) .eq. 0 ) then
+ if ( DIMAG(cz) .eq. 0 ) then
+* cz is really real, the hard case:
+ if ( cz .eq. 0 ) then
+* multiplied with log(1), so don't care:
+ n1 = 0
+* look at ieps for guidance
+* n2 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,cfact,ier) = 0
+ n2 = 0
+ elseif ( cz1 .eq. 0 ) then
+ n1 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,
+ + -cfact,ier)
+ n2 = 0
+ else
+ n1 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,
+ + -cz*cfact,ier)
+ n2 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,
+ + cz1*cfact,ier)
+ endif
+ else
+ n1 = nffet1(-cz,cfact,-cz*cfact,ier)
+ n2 = nffet1(-cz,cfact,cz1*cfact,ier)
+ endif
+ else
+ n1 = nffet1(cz1,cfact,-cz*cfact,ier)
+ n2 = nffet1(cz1,cfact,cz1*cfact,ier)
+ endif
+ else
+* the imaginary part of cc1, cc1p is often very unstable.
+* make sure it agrees with the actual sign used.
+ if ( iclas1 .eq. 2 ) then
+ if ( DIMAG(cc1p) .eq. 0 ) then
+* if y (or y1 further on) is purely imaginary
+* give a random shift, this will also be used in
+* the transformation terms. Checked 7-mar-94 that it
+* is independent of the sign used.
+ if ( DBLE(cy).eq.0 ) cy = cy +
+ + isgnal*DBLE(precc)*DIMAG(cy)
+ n1 = nffet1(-cz,cfact,DCMPLX(DBLE(0),ieps*DBLE(cy)),
+ + ier)
+ else
+ n1 = nffet1(-cz,cfact,cc1p,ier)
+ endif
+ else
+ if ( DIMAG(cc1) .eq. 0 ) then
+ if ( DBLE(cy1).eq.0 ) cy1 = cy1 +
+ + isgnal*DBLE(precc)*DIMAG(cy)
+ n1 = nffet1(-cz,cfact,DCMPLX(DBLE(0),
+ + -ieps*DBLE(cy1)),ier)
+ else
+ n1 = nffet1(-cz,cfact,-cc1,ier)
+ endif
+ endif
+ if ( iclas2 .eq. 2 ) then
+ if ( DIMAG(cc2p) .eq. 0 ) then
+ if ( DBLE(cy).eq.0 ) cy = cy +
+ + isgnal*DBLE(precc)*DIMAG(cy)
+ n2 = nffet1(cz1,cfact,DCMPLX(DBLE(0),ieps*DBLE(cy)),
+ + ier)
+ else
+ n2 = nffet1(cz1,cfact,cc2p,ier)
+ endif
+ else
+ if ( DIMAG(cc2) .eq. 0 ) then
+ if ( DBLE(cy1).eq.0 ) cy1 = cy1 +
+ + isgnal*DBLE(precc)*DIMAG(cy)
+ n2 = nffet1(cz1,cfact,DCMPLX(DBLE(0),
+ + -ieps*DBLE(cy1)),ier)
+ else
+ n2 = nffet1(cz1,cfact,-cc2,ier)
+ endif
+ endif
+ endif
+ endif
+ if ( lwrite ) then
+ print *,'n1, n2 = ',n1,n2
+ endif
+* #] eta's:
+* #[ calculations:
+* 3-oct-1995 changed code to only use second criterium if the
+* Taylor expansion is used - otherwise the Hill identity will
+* only make things worse
+ if ( iclas1 .eq. iclas2 .and. isoort .ne. -2 .and.
+ + ( absc(cc1p-cc2p) .lt. 2*xloss*absc(cc1p)
+ + .or. lreal .and. abs(DBLE(cc1p-cc2p)) .lt. 2*xloss*
+ + abs(DBLE(cc1p)) .and. (abs(DBLE(cc2p)) +
+ + DIMAG(cc2p)**2/4) .lt. xloss .and.
+ + abs(DIMAG(cc2p)) .lt. bndtay ) ) then
+* Close together:
+* -#[ handle dilog's:
+ if ( .not.lreal .and. absc(cc2p) .gt. xloss
+ + .or. lreal .and. ( (abs(DBLE(cc2p)) + DIMAG(cc2p)**2/4)
+ + .gt. xloss .or. abs(DIMAG(cc2p)) .gt. bndtay ) )
+ + then
+*--#[ Hill identity:
+*
+* Use the Hill identity to get rid of the cancellations.
+*
+*
+* first get the arguments:
+*
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ carg1 = 1/cy
+ carg2 = 1/cz1
+ carg3 = carg2/cc1p
+ elseif ( iclas1 .eq. 2 ) then
+ carg1 = 1/cz
+ carg2 = 1/cy1
+ carg3 = carg2/cc1p
+ elseif ( iclas1 .eq. 3 ) then
+ carg1 = 1/cy1
+ carg3 = 1/cz1
+ carg2 = carg3*cc1p
+ endif
+ call ffzli2(cli1,clo1,carg1,lreal,ier)
+ call ffzli2(cli2,clo2,carg2,lreal,ier)
+ call ffzli2(cli3,clo3,carg3,lreal,ier)
+ if ( absc(cc2p) .lt. xloss ) then
+ clog2p = zfflo1(cc2p,ier)
+ else
+ clog2p = zfflog(1-cc2p,0,c0,ier)
+ endif
+ chill = clo1*clog2p
+*debug the sum of these terms should be Li2(cc1p)-Li2(cc2p)
+* if ( lwrite ) then
+* csum = cli1 + cli2 - cli3 + chill
+* call ffzli2(clia,ctroep,cc1p,lreal,ier0)
+* call ffzli2(clib,ctroep,cc2p,lreal,ier0)
+* print *,' check Hill'
+* print *,' oorspr:',clia - clib
+* print *,' nu :',csum
+* endif
+*--#] Hill identity:
+ else
+*--#[ Taylor expansion:
+*
+* if the points are close to zero do a Taylor
+* expansion of the first and last dilogarithm
+*
+* Li2(cc1p) - Li2(cc2p)
+* = sum cc1p^i ( 1-(1-cd2)^i ) /i^2
+*
+* with cd2 = 1-cc2p/cc1p = ...
+*
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ cd2 = 1/cy
+ elseif ( iclas1 .eq. 2 ) then
+ cd2 = 1/cz
+ elseif ( iclas1 .eq. 3 ) then
+ cd2 = 1/cy1
+ endif
+ cd21 = 1-cd2
+ cd21n1 = 1
+ cc1n = cc1p
+ cd2n = cd2
+ ctot = cc1p*cd2
+ do 50 i=2,20
+ cc1n = cc1n*cc1p
+ cd21n1 = cd21n1*cd21
+ cd2n = cd2n + cd2*cd21n1
+ cterm = cc1n*cd2n*DBLE(xn2inv(i))
+ ctot = ctot + cterm
+ if ( absc(cterm) .le. precc*absc(ctot) .or.
+ + lreal .and. abs(DBLE(cterm)) .le. precc*
+ + abs(DBLE(ctot)) ) goto 51
+ 50 continue
+ if ( lwarn ) call ffwarn(54,ier,absc(ctot),absc(cterm))
+ 51 continue
+ cli1 = ctot
+ cli2 = 0
+ cli3 = 0
+ chill = 0
+* for the eta+transformation section we also need
+ if ( iclas1.ne.1 .or. n1.ne.0 .or. n2.ne.0 )
+ + clo1 = zfflo1(cd2,ier)
+ if ( iclas1.eq.2 ) clo2 = zfflo1(1/cy1,ier)
+* check of Taylor expansion
+ if (lwrite) then
+ call ffzli2(clia,ctroep,cc1p,lreal,ier0)
+ call ffzli2(clib,ctroep,cc2p,lreal,ier0)
+ print *,' check Taylor'
+ print *,' oorspr:',clia-clib
+ print *,' nu :',cli1
+ endif
+*--#] Taylor expansion:
+ endif
+*
+* -#] handle dilog's:
+* -#[ handle eta + transformation terms:
+ if ( iclas1.eq.1 .or. iclas1.eq.4 ) then
+*--#[ no transformation:
+*
+* no transformation was made.
+*
+* crr(5) = 0
+ if ( n1 .ne. n2 ) then
+ if ( lwarn ) call ffwarn(49,ier,x1,x0)
+ if ( absc(cc1) .lt. xclogm ) then
+ call fferr(23,ier)
+ else
+* imaginary part not checked
+ ier = ier + 50
+ crr(5) = (n1-n2)*c2ipi*zfflog(cc1,ieps,-cy,ier)
+ endif
+ endif
+* crr(6) = 0
+* crr(7) = 0
+ if ( n2.ne.0 ) then
+ crr(6) = - n2*c2ipi*clo1
+ n3 = nffeta(cc2,1/cc1,ier)
+ if ( n3 .ne. 0 ) then
+ if ( lwarn ) call ffwarn(49,ier,x1,x0)
+ crr(7) = n2*n3*c2ipi**2
+* else
+* crr(7) = 0
+ endif
+ endif
+ if (lwrite) then
+ clog1 = zfflog(cc1,ieps,-cy,ier)
+ clog2 = zfflog(cc2,ieps,cy1,ier)
+ print *,' check geen trans'
+ print *,' oorspr:',c2ipi*(n1*clog1-n2*clog2)
+ print *,' nu :',crr(5)+crr(6)+crr(7)
+ endif
+*--#] no transformation:
+ elseif ( iclas1 .eq. 2 ) then
+*--#[ transform 1-x:
+*
+* we tranformed to 1-x for both dilogs
+*
+ if ( absc(cc1p) .lt. xloss ) then
+ clog1 = zfflo1(cc1p,ier)
+ else
+ clog1 = zfflog(cc1,ieps,-cy,ier)
+ endif
+ if ( DIMAG(cc2p).eq.0 ) then
+ if ( DIMAG(cc1p).eq.0 ) then
+* use the ieps instead
+ n3 = 0
+ else
+ n3 = nffet1(DCMPLX(DBLE(0),ieps*DBLE(cy)),
+ + 1/cc1p,cc2p/cc1p,ier)
+ endif
+ else
+ if ( DIMAG(cc1p).eq.0 ) then
+ n3 =nffet1(cc2p,DCMPLX(DBLE(0),-ieps*DBLE(cy1)),
+ + cc2p/cc1p,ier)
+ else
+ n3 = nffet1(cc2p,1/cc1p,cz,ier)
+ endif
+ endif
+ ntot = n1-n2-n3
+ crr(5) = (ntot*c2ipi + clo1)*clog1
+ clog2p = zfflog(cc2p,ieps,cy,ier)
+ crr(6) = clo2*(n2*c2ipi - clog2p)
+* crr(7) = 0
+* if (lwrite) then
+* clog1p = zfflog(cc1p,ieps,cy,ier)
+* clog2 = zfflog(cc2,ieps,cy1,ier)
+* print *,' check trans 1-x'
+* print *,' oorspr:',c2ipi*(n1*clog1-n2*clog2)-
+* + clog1*clog1p+clog2*clog2p
+* print *,' nu :',crr(5)+crr(6)+crr(7)
+* endif
+*--#] transform 1-x:
+ elseif ( iclas1 .eq. 3 ) then
+*--#[ transform 1/x:
+*
+* we transformed to 1/x for both dilogs
+*
+*should be in clas=4:if ( ld2yzz .and. absc(cc2p+1) .lt. xloss ) then
+* ctroep = czz1 - cd2yzz
+* if ( lwarn .and. absc(ctroep) .lt. xloss*absc(czz1) )
+* + call ffwarn(57,ier,absc(ctroep),absc(czz1))
+* clog2p = zfflo1(ctroep/cy1,ier)
+* else
+ clog2p = zfflog(-cc2p,ieps,cy1,ier)
+* endif
+ if ( DIMAG(cc2p).eq.0 .or. DIMAG(cc1).eq.0 ) then
+* we chose the eta's already equal, no worry.
+ n3 = 0
+ n3p = 0
+ else
+ n3 = nffet1(-cc2p,-cc1,-cy/cy1,ier)
+ n3p = nffet1(cc2p,cc1,-cy/cy1,ier)
+ endif
+ if ( n3.ne.0 .or. n3p.ne.0 .or. n1.ne.n2 ) then
+ if ( lwarn ) call ffwarn(49,ier,x1,x0)
+* for the time being the normal terms, I'll have to think of
+* something smarter one day
+ clog1p = zfflog(-cc1p,ieps,-cy,ier)
+ crr(5) = -clog1p**2/2
+ crr(6) = +clog2p**2/2
+ crr(7) = (n1*zfflog(cc1,ieps,cy,ier) -
+ + n2*zfflog(cc2,ieps,-cy1,ier))*c2ipi
+ else
+ crr(5) = clo1*(n2*c2ipi + clog2p - clo1/2)
+ endif
+*--#] transform 1/x:
+ endif
+* -#] handle eta + transformation terms:
+* -#[ add up and print out:
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ crr(1) = cli1
+ crr(2) = cli2
+ crr(3) = - cli3
+ crr(4) = chill
+ else
+ crr(1) = - cli1
+ crr(2) = - cli2
+ crr(3) = cli3
+ crr(4) = - chill
+ endif
+ if ( lwrite ) then
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ isign = 1
+ else
+ isign = -1
+ endif
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ cr = cli1+cli2-cli3+chill+crr(5)+crr(6)+crr(7)
+ else
+ cr = -cli1-cli2+cli3-chill+crr(5)+crr(6)+crr(7)
+ endif
+ print *,'ffcrr: Close together'
+ print *,' oorspronkeijk:',cc1
+ print *,' :',cc2
+ print *,' iclas = ',iclas1
+ print *,' Li2''s:',cli1*isign
+ print *,' :',cli2*isign
+ print *,' :',-cli3*isign
+ print *,' logs :',chill*isign
+ print *,' eta''s:',crr(5)
+ print *,' :',crr(6)
+ print *,' :',crr(7)
+ print '(a,2g24.15,2i6)',' cr is dus:',cr,ipi12,ier
+ endif
+* -#] add up and print out:
+ else
+* Normal case:
+* -#[ handle dilogs:
+*
+* the dilogs will not come close together so just go on
+* only the special case cc1p ~ (-1,0) needs special attention
+*
+ if ( iclas1 .ne. 4 .or. .not. ld2yzz ) then
+ call ffzli2(cli1,clo1,cc1p,lreal,ier)
+ else
+ cd2 = cd2yzz + czz
+ if ( absc(cd2) .lt. xloss*absc(cd2yzz) ) then
+ if ( lwrite ) print *,'cd2 = ',cd2
+ cd2 = cy + cdyz
+ if ( lwrite ) print *,'cd2+ = ',cd2
+ if ( lwarn .and. abs(cd2) .lt. xloss*absc(cdyz) )
+ + call ffwarn(56,ier,absc(cd2),absc(cdyz))
+ endif
+ cd2 = cd2/cdyz
+ cfact = 1/(2-cd2)
+ call ffzli2(cli1,clo1,cd2*cfact,lreal,ier)
+ call ffzli2(cli3,clo3,-cd2*cfact,lreal,ier)
+ call ffzli2(cli4,clo4,cd2,lreal,ier)
+ endif
+ if ( iclas2 .ne. 4 .or. .not. ld2yzz ) then
+ call ffzli2(cli2,clo2,cc2p,lreal,ier)
+ else
+ if ( iclas1 .eq. 4 ) call fferr(26,ier)
+ cd2 = cd2yzz - czz1
+ if ( absc(cd2) .lt. xloss*absc(cd2yzz) ) then
+ if ( lwrite ) print *,'cd2 = ',cd2
+ cd2 = cdyz - cy1
+ if ( lwrite ) print *,'cd2+ = ',cd2
+ if ( lwarn .and. absc(cd2) .lt. xloss*absc(cdyz) )
+ + call ffwarn(57,ier,absc(cd2),absc(cdyz))
+ endif
+ cd2 = cd2/cdyz
+ cfact = 1/(2-cd2)
+ call ffzli2(cli2,clo2,cd2*cfact,lreal,ier)
+ call ffzli2(cli3,clo3,-cd2*cfact,lreal,ier)
+ call ffzli2(cli4,clo4,cd2,lreal,ier)
+ endif
+* -#] handle dilogs:
+* -#[ handle eta terms:
+*
+* the eta's
+*
+ if ( n1 .ne. 0 ) then
+ if ( iclas1 .ne. 2 .or. absc(cc1p) .gt. xloss ) then
+ if ( DBLE(cc1) .gt. -abs(DIMAG(cc1)) ) then
+ clog1 = zfflog(cc1,ieps,cy,ier)
+ else
+* take apart the factor i*pi^2
+ if ( iclas1 .eq. 4 ) then
+ clog1 = zfflo1(cd2,ier)
+ else
+ clog1 = zfflog(-cc1,0,cy,ier)
+ endif
+ if ( DIMAG(cc1) .lt. 0 ) then
+ i2pi = -1
+ elseif ( DIMAG(cc1) .gt. 0 ) then
+ i2pi = +1
+ elseif ( DBLE(cy)*ieps .lt. 0 ) then
+ i2pi = -1
+ elseif ( DBLE(cy)*ieps .gt. 0 ) then
+ i2pi = +1
+ else
+ call fferr(51,ier)
+ i2pi = 0
+ endif
+ ipi12 = ipi12 - n1*24*i2pi
+ endif
+ else
+ clog1 = zfflo1(cc1p,ier)
+ endif
+ crr(5) = n1*c2ipi*clog1
+* else
+* crr(5) = 0
+ endif
+ if ( n2 .ne. 0 ) then
+ if ( iclas2 .ne. 2 .or. absc(cc2p) .gt. xloss ) then
+ if ( DBLE(cc2) .gt. -abs(DIMAG(cc2)) ) then
+ clog2 = zfflog(cc2,ieps,cy,ier)
+ else
+* take apart the factor i*pi^2
+ if ( iclas2 .eq. 4 ) then
+ clog2 = zfflo1(cd2,ier)
+ else
+ clog2 = zfflog(-cc2,0,c0,ier)
+ endif
+ if ( DIMAG(cc2) .lt. 0 ) then
+ i2pi = -1
+ elseif ( DIMAG(cc2) .gt. 0 ) then
+ i2pi = +1
+ elseif ( DBLE(cy)*ieps .lt. 0 ) then
+ i2pi = -1
+ elseif ( DBLE(cy)*ieps .gt. 0 ) then
+ i2pi = +1
+ else
+ call fferr(51,ier)
+ i2pi = 0
+ endif
+ ipi12 = ipi12 + n2*24*i2pi
+ endif
+ else
+ clog2 = zfflo1(cc2p,ier)
+ endif
+ crr(6) = n2*c2ipi*clog2
+* else
+* crr(6) = 0
+ endif
+* -#] handle eta terms:
+* -#[ handle transformation terms:
+*
+* transformation of cc1
+*
+ if ( iclas1 .eq. 1 ) then
+* crr(3) = 0
+ elseif( iclas1 .eq. 2 ) then
+ cli1 = -cli1
+ ipi12 = ipi12 + 2
+ crr(3) = - clo1*zfflog(cc1p,ieps,cy,ier)
+ elseif ( iclas1 .eq. 3 ) then
+ cli1 = -cli1
+ ipi12 = ipi12 - 2
+ clog1p = zfflog(-cc1p,ieps,cy1,ier)
+ crr(3) = - clog1p**2/2
+ if ( lwrite ) print *,'clog1p = ',clog1p
+ elseif ( iclas1 .eq. 4 ) then
+* Note that this sum does not cause problems as d2<<1
+ crr(3) = -cli3 - cli4 + clo4*zfflog(cfact,0,c0,ier)
+ ipi12 = ipi12 - 1
+ if ( lwrite ) then
+ print *,'Check iclas1 = 4'
+ print '(a,2g14.8)','Nu: ',cli1+crr(3)
+ call ffzli2(clia,ctroep,cc1p,lreal,ier)
+ print '(a,2g14.8)','Eerst:',clia+DBLE(pi12)
+ endif
+ else
+ call fferr(25,ier)
+ endif
+*
+* transformation of cc2
+*
+ if ( iclas2 .eq. 1 ) then
+* crr(4) = 0
+ elseif( iclas2 .eq. 2 ) then
+ cli2 = -cli2
+ ipi12 = ipi12 - 2
+ crr(4) = clo2*zfflog(cc2p,ieps,cy,ier)
+ elseif ( iclas2 .eq. 3 ) then
+ cli2 = -cli2
+ ipi12 = ipi12 + 2
+ clog2p = zfflog(-cc2p,ieps,cy1,ier)
+ crr(4) = clog2p**2/2
+ if ( lwrite ) print *,'clog2p = ',clog2p
+ elseif ( iclas2 .eq. 4 ) then
+* Note that this sum does not cause problems as d2<<1
+ crr(4) = cli3 + cli4 - clo4*zfflog(cfact,0,c0,ier)
+ ipi12 = ipi12 + 1
+ if ( lwrite ) then
+ print *,'Check iclas2 = 4'
+ print '(a,2g14.8)','Nu: ',-cli2+crr(4)
+ call ffzli2(clia,ctroep,cc2p,lreal,ier)
+ print '(a,2g14.8)','Eerst:',-clia-DBLE(pi12)
+ endif
+ else
+ call fferr(27,ier)
+ endif
+* -#] handle transformation terms:
+* -#[ sum and print:
+ crr(1) = cli1
+ crr(2) = - cli2
+ crr(6) = - crr(6)
+* crr(7) = 0
+ if(lwrite)then
+ cr = cli1 - cli2 + crr(5) + crr(6) + crr(3) + crr(4)
+ print *,'ffcrr: Normal case'
+ print *,' oorspronkelijk:',cc1
+ print *,' iclas1 = ',iclas1
+ if(iclas1.ne.1)print *,' nu:',cc1p
+ print *,' Li21 :',cli1
+ if(n1.ne.0)print *,' eta1 :',crr(5)
+ if(iclas1.ne.1)print *,' tran1:',crr(3)
+ print *,' oorspronkelijk:',cc2
+ print *,' iclas2 = ',iclas2
+ if(iclas2.ne.1)print *,' nu:',cc2p
+ print *,' Li22 :',cli2
+ if(n2.ne.0)print *,' eta2 :',-crr(6)
+ if(iclas2.ne.1)print *,' tran2:',-crr(4)
+ print '(a,2g24.15,2i6)',' cr is dus:',cr,ipi12,ier
+ if(ipi12.ne.0)print '(a,2g24.15)',' =',
+ + cr+ipi12*DBLE(pi12)
+ endif
+* -#] sum and print:
+ endif
+* #] calculations:
+* #[ debug:
+ if(lwrite)then
+ ier0 = 0
+ call ffzzdl(cli1,ipi121,ctroep,cc1,ier0)
+ call ffzzdl(cli2,ipi122,ctroep,cc2,ier0)
+ if ( n1 .ne. 0 .and. absc(cc1) .gt. xclogm ) then
+ clo1 = log(cc1)
+ else
+ clo1 = 0
+ endif
+ if ( n2 .ne. 0 .and. absc(cc2) .gt. xclogm ) then
+ clo2 = log(cc2)
+ else
+ clo2 = 0
+ endif
+ cr1 = cli1-cli2+c2ipi*(n1*clo1-n2*clo2)+(ipi121-ipi122)*
+ + DBLE(pi12)
+ print '(a,2g24.15,i3)',' verg. cr1:',cr1
+ if(n1.ne.0)print *,' met n1*clo1 = ',n1*clo1*c2ipi
+ if(n2.ne.0)print *,' met n2*clo2 = ',n2*clo2*c2ipi
+ endif
+* #] debug:
+*###] ffcrr:
+ end
diff --git a/ff-2.0/ffcxr.f b/ff-2.0/ffcxr.f
new file mode 100644
index 0000000..81949b0
--- /dev/null
+++ b/ff-2.0/ffcxr.f
@@ -0,0 +1,634 @@
+*--#[ log:
+* $Id: ffcxr.f,v 1.2 1995/11/10 19:04:24 gj Exp $
+* $Log: ffcxr.f,v $
+c Revision 1.2 1995/11/10 19:04:24 gj
+c Added nicer logging header...
+c
+*--#] log:
+*###[ ffcxr:
+ subroutine ffcxr(crr,ipi12,y,y1,z,z1,dyz,ld2yzz,d2yzz,zz,zz1,
+ + ldy2z,dy2z,ieps,ier)
+***#[*comment:***********************************************************
+* *
+* calculates R as defined in appendix b: *
+* *
+* /1 log(x-z+i*eps) - log(y-z+i*eps) *
+* r(y,z) = \ dx ----------------------------------- *
+* /0 x-y *
+* *
+* = li2(y/(y-z)+i*eps') - li2((y-1)/(y-z)+i*eps') *
+* *
+* y,z are real, ieps integer denoting the sign of i*eps. *
+* factors pi^2/12 are passed in the integer ipi12. *
+* *
+* Input: y (real) *
+* y1 (real) 1-y *
+* z (real) *
+* z1 (real) 1-z *
+* dyz (real) y-z *
+* *
+* ld2yzz (logical) if .TRUE. also defined are: *
+* d2yzz (real) 2*y - z^+ - z^- *
+* zz (real) the other z-root *
+* zz1 (real) 1 - zz *
+* *
+* ieps (integer) if +/-1 denotes sign imaginary *
+* part of argument logs *
+* ieps (integer) if +/-2 denotes sign imaginary *
+* part of argument dilogs *
+* *
+* Output crr (complex) R modulo factors pi^2/12 *
+* ipi12 (integer) these factors *
+* ier (intger) 0=ok, 1=num prob, 2=error *
+* *
+* Calls: ffxli2,(test: ffzxdl),dfflo1,zxfflg *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ipi12,ieps,ier
+ logical ld2yzz,ldy2z
+ DOUBLE PRECISION y,y1,z,z1,dyz,d2yzz,zz,zz1,dy2z(3)
+ DOUBLE COMPLEX crr(7)
+*
+* local variables
+*
+ integer i,iclas1,iclas2,iteken,ieps1,ieps2,ipi121,ipi122,ierdum
+ logical taylor
+ DOUBLE PRECISION xheck,fact,xx1,xx2,xx1p,xx2p,arg2,arg3,
+ + xli1,xli2,xli3,xlo1,xlo2,xlo3,xhill,xlog1,
+ + xlog2p,xx1n,d2,d21,d2n,d21n1,term,tot,xlia,xtroep,xli4,
+ + xlo4,rloss,som,xmax
+ DOUBLE COMPLEX cr,cr1,clog1p,clog2p,ctroep,cli1,cli2
+ DOUBLE PRECISION dfflo1
+ DOUBLE COMPLEX zxfflg
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffcxr: input:'
+ print *,' y = ',y,y1
+ print *,' z = ',z,z1
+ print *,' dyz = ',dyz
+ if ( ld2yzz ) then
+ print *,' d2yzz= ',d2yzz
+ print *,' zz = ',zz,zz1
+ endif
+ if ( ldy2z ) then
+ print *,' dy2z = ',dy2z(1),dy2z(3)
+ endif
+ print *,' z->z - eps*',ieps
+ endif
+ if ( ltest ) then
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ xheck = y + y1 - 1
+ if ( rloss*abs(xheck).gt.precx*max(abs(y),abs(y1),x1) ) then
+ print *,'ffcxr: error: 1-y <> y1',y,y1,xheck,ier
+ endif
+ xheck = z + z1 - 1
+ if ( rloss*abs(xheck).gt.precx*max(abs(z),abs(z1),x1) ) then
+ print *,'ffcxr: error: 1-z <> z1',z,z1,xheck,ier
+ endif
+ xheck = dyz - y + z
+ if ( rloss*abs(xheck).gt.precx*max(abs(z),abs(y),abs(dyz)) )
+ + then
+ print *,'ffcxr: error: dyz<>y-z',dyz,y,z,xheck,ier
+ endif
+ if ( ld2yzz ) then
+ xheck = d2yzz-2*y+z+zz
+ if ( rloss*abs(xheck).gt.precx*max(abs(d2yzz),abs(2*y),
+ + abs(z),abs(zz)) ) then
+ print *,'ffcxr: error: d2yzz<>2y-z-zz',d2yzz,2*y,z,
+ + zz,xheck,ier
+ endif
+ xheck = zz + zz1 - 1
+ if ( rloss*abs(xheck) .gt. precx*max(abs(zz),abs(zz1),
+ + x1)) then
+ print *,'ffcxr: error: 1-zz <> zz1',zz,zz1,xheck
+ endif
+ endif
+ if ( ldy2z ) then
+ xheck = dy2z(1)-y+2*z
+ if ( rloss*abs(xheck).gt.precx*max(abs(dy2z(1)),abs(y),
+ + abs(2*z)) ) then
+ print *,'ffcxr: error: dy2z<>y-2z',dy2z(1),y,2*z,
+ + xheck,ier
+ endif
+ xheck = dy2z(3)-y1+2*z1
+ if ( rloss*abs(xheck).gt.precx*max(abs(dy2z(2)),abs(y1),
+ + abs(2*z1)) ) then
+ print *,'ffcxr: error: dy2z1<>y1-2z1',dy2z(3),y1,
+ + 2*z1,xheck,ier
+ endif
+ endif
+ if ( abs(ieps).gt.2 ) then
+ print*,'ffcxr: ieps is not -2,..2 ',ieps
+ endif
+ endif
+* #] check input:
+* #[ groundwork:
+ taylor = .FALSE.
+*
+* get the arguments
+*
+ if ( dyz .eq. 0 ) then
+ if ( lwarn ) call ffwarn(51,ier,dyz,x1)
+ return
+ endif
+ fact = 1/dyz
+ xx1 = y * fact
+ xx2 = - y1 * fact
+*
+* #] groundwork:
+* #[ which area?:
+*
+* determine the area: 1 = [-1+xloss,1/2]
+* 2 = (1/2,2-xloss]
+* 3 = [2+xloss,->) U (<-,-1-xloss]
+* 4 = [-1-xloss,-1+xloss]
+* 5 = [2-xloss,2+xloss]
+*
+ if ( xx1 .lt. -1-xloss/2 ) then
+ iclas1 = 3
+ xx1p = 1/xx1
+ elseif( xx1 .lt. -1+xloss/2 ) then
+ if ( ld2yzz ) then
+ iclas1 = 4
+ else
+ iclas1 = 1
+ endif
+ xx1p = xx1
+ elseif( xx1 .le. x05 ) then
+ iclas1 = 1
+ xx1p = xx1
+ elseif ( xx1 .lt. 2-xloss ) then
+ iclas1 = 2
+ xx1p = -z*fact
+ elseif ( ldy2z .and. xx1 .lt. 2+xloss ) then
+ iclas1 = 5
+ xx1p = dy2z(1)*fact
+ else
+ iclas1 = 3
+ xx1p = 1/xx1
+ endif
+ if ( xx2 .lt. -1-xloss/2 ) then
+ iclas2 = 3
+ xx2p = 1/xx2
+ elseif( xx2 .lt. -1+xloss/2 ) then
+ if ( ld2yzz ) then
+ iclas2 = 4
+ else
+ iclas2 = 1
+ endif
+ xx2p = xx2
+ elseif ( xx2 .le. x05 ) then
+ iclas2 = 1
+ xx2p = xx2
+ elseif ( xx2 .lt. 2-xloss ) then
+ iclas2 = 2
+ xx2p = z1*fact
+ elseif ( ldy2z .and. xx2 .lt. 2+xloss ) then
+ iclas2 = 5
+ xx2p = -dy2z(3)*fact
+ else
+ iclas2 = 3
+ xx2p = 1/xx2
+ endif
+*
+* throw together if they are close
+*
+ if ( iclas1 .ne. iclas2 .and. abs(xx1-xx2) .lt. 2*xloss )
+ + then
+* we don't want trouble with iclasn = 4,5
+ if ( iclas1 .eq. 4 ) then
+ iclas1 = 1
+ elseif ( iclas1 .eq. 5 ) then
+ iclas1 = 3
+ xx1p = 1/xx1
+ endif
+ if ( iclas2 .eq. 4 ) then
+ iclas2 = 1
+ elseif ( iclas2 .eq. 5 ) then
+ iclas2 = 3
+ xx2p = 1/xx2
+ endif
+ if ( iclas1 .eq. iclas2 ) goto 5
+* go on
+ if ( iclas1 .le. iclas2 ) then
+ iclas2 = iclas1
+ if ( iclas1 .eq. 1 ) then
+ xx2p = xx2
+ else
+ xx2p = z1*fact
+ endif
+ else
+ iclas1 = iclas2
+ if ( iclas1 .eq. 1 ) then
+ xx1p = xx1
+ else
+ xx1p = -z*fact
+ endif
+ endif
+ endif
+* #] which area?:
+* #[ calculations:
+ 5 if ( iclas1 .eq. iclas2 .and.
+ + abs(xx1p-xx2p) .lt. 2*xloss*max(abs(xx1p),abs(xx2p))
+ + .and. iclas1 .ne. 5 ) then
+* |----->temporary!
+* Close together:
+* -#[ handle dilog's:
+ if ( abs(xx2p) .gt. xloss ) then
+*--#[ Hill identity:
+*
+* Use the Hill identity to get rid of the cancellations.
+*
+*
+* first get the arguments:
+*
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ d2 = 1/y
+ arg2 = 1/z1
+ arg3 = arg2/xx1p
+ elseif ( iclas1 .eq. 2 ) then
+ d2 = 1/z
+ arg2 = 1/y1
+ arg3 = arg2/xx1p
+ elseif ( iclas1 .eq. 3 ) then
+ d2 = 1/y1
+ arg3 = 1/z1
+ arg2 = arg3*xx1p
+ endif
+ call ffxli2(xli1,xlo1,d2,ier)
+ call ffxli2(xli2,xlo2,arg2,ier)
+ call ffxli2(xli3,xlo3,arg3,ier)
+ if ( abs(xx2p) .lt. xloss ) then
+ xlog2p = dfflo1(xx2p,ier)
+ else
+ xlog2p = zxfflg(1-xx2p,0,x1,ier)
+ endif
+ xhill = xlo1*xlog2p
+*--#] Hill identity:
+ else
+*--#[ Taylor expansion:
+*
+* if the points are close to zero do a Taylor
+* expansion of the first and last dilogarithm
+*
+* Li2(xx1p) - Li2(xx2p)
+* = sum xx1p^i ( 1-(1-d2)^i ) /i^2
+*
+* with d2 = 1-xx2p/xx1p = ...
+*
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ d2 = 1/y
+ elseif ( iclas1 .eq. 2 ) then
+ d2 = 1/z
+ elseif ( iclas1 .eq. 3 ) then
+ d2 = 1/y1
+ endif
+* flag to the print section that we did a Taylor expansion
+ if ( lwrite ) taylor = .TRUE.
+ d21 = 1-d2
+ d21n1 = 1
+ xx1n = xx1p
+ d2n = d2
+ tot = xx1p*d2
+* check for possible underflow on the next line
+ if ( abs(xx1p) .lt. xalog2 ) goto 51
+ do 50 i=2,20
+ xx1n = xx1n*xx1p
+ d21n1 = d21n1*d21
+ d2n = d2n + d2*d21n1
+ term = xx1n*d2n*xn2inv(i)
+ tot = tot + term
+ if ( abs(term) .le. precx*abs(tot) ) goto 51
+ 50 continue
+ if ( lwarn ) call ffwarn(55,ier,abs(tot),abs(term))
+ 51 continue
+ xli1 = tot
+ xli2 = 0
+ xli3 = 0
+ xhill = 0
+* for the eta+transformation section we also need
+ if ( iclas1 .ne. 1 ) then
+ if ( abs(d2) .lt. xloss ) then
+ xlo1 = dfflo1(d2,ier)
+ else
+ xlo1 = zxfflg(d21,0,x1,ier)
+ endif
+ endif
+ if ( iclas1 .eq. 2 ) xlo2 = dfflo1(1/y1,ier)
+*--#] Taylor expansion:
+ endif
+*
+* -#] handle dilog's:
+* -#[ handle transformation terms:
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+*
+* no transformation was made.
+*
+* crr(5) = 0
+* crr(6) = 0
+ elseif ( iclas1 .eq. 2 ) then
+*
+* we tranformed to 1-x for both dilogs
+*
+ if ( abs(xx1p) .lt. xloss ) then
+ xlog1 = dfflo1(xx1p,ier)
+ else
+ xlog1 = zxfflg(xx1,0,x1,ier)
+ endif
+ crr(5) = xlo1*xlog1
+ clog2p = zxfflg(xx2p,ieps,-y1,ier)
+* if ( abs(xx2p) .lt. xalogm ) then
+* if ( lwarn .and. xx2p .ne. 0 ) call ffwarn(53,ier,xx2p,xalogm)
+* clog2p = 0
+* elseif ( xx2p .gt. 0 ) then
+* clog2p = log(xx2p)
+* else
+* xlog2p = log(-xx2p)
+* checked imaginary parts 19-May-1988
+* if ( abs(ieps) .eq. 1 ) then
+* if ( y1*ieps .gt. 0 ) then
+* clog2p = DCMPLX(xlog2p,-pi)
+* else
+* clog2p = DCMPLX(xlog2p,pi)
+* endif
+* elseif ( ieps .eq. 2 ) then
+* clog2p = DCMPLX(xlog2p,-pi)
+* else
+* clog2p = DCMPLX(xlog2p,pi)
+* endif
+* endif
+ crr(6) = -DBLE(xlo2)*clog2p
+ if (lwrite) then
+ clog1p = zxfflg(xx1p,ieps,y,ier)
+ endif
+ elseif ( iclas1 .eq. 3 ) then
+*
+* we transformed to 1/x for both dilogs
+*
+ clog2p = zxfflg(-xx2p,-ieps,-y1,ier)
+* if ( abs(xx2p) .lt. xalogm ) then
+* if ( lwarn ) call ffwarn(53,ier,xx2p,xalogm)
+* clog2p = 0
+* elseif ( xx2p .lt. 0 ) then
+* clog2p = log(-xx2p)
+* else
+* xlog2p = log(xx2p)
+* checked imaginary parts 19-May-1988
+* if ( abs(ieps) .eq. 1 ) then
+* if ( ieps*y1 .gt. 0 ) then
+* clog2p = DCMPLX(xlog2p,pi)
+* else
+* clog2p = DCMPLX(xlog2p,-pi)
+* endif
+* elseif ( ieps .eq. 2 ) then
+* clog2p = DCMPLX(xlog2p,-pi)
+* else
+* clog2p = DCMPLX(xlog2p,pi)
+* endif
+* endif
+ crr(5) = DBLE(xlo1)*(clog2p - DBLE(xlo1)/2)
+* crr(6) = 0
+ if (lwrite) then
+ clog1p = zxfflg(xx1p,ieps,y,ier)
+ endif
+ endif
+* -#] handle transformation terms:
+* -#[ add up and print out:
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ crr(1) = xli1
+ crr(2) = xli2
+ crr(3) = - xli3
+ crr(4) = xhill
+ else
+ crr(1) = - xli1
+ crr(2) = - xli2
+ crr(3) = xli3
+ crr(4) = - xhill
+ endif
+* crr(7) = 0
+* ipi12 = 0
+ if ( lwrite ) then
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ iteken = 1
+ else
+ iteken = -1
+ endif
+ if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
+ cr = DBLE(xli1+xli2-xli3+xhill) + crr(5) + crr(6)
+ else
+ cr = DBLE(-xli1-xli2+xli3-xhill) + crr(5) + crr(6)
+ endif
+ print *,'ffcxr: Close together'
+ print *,' oorspronkeijk:',xx1
+ print *,' :',xx2
+ print *,' iclas = ',iclas1
+ print *,' Li2''s:',xli1*iteken
+ if ( .not.taylor ) then
+ print *,' :',xli2*iteken
+ print *,' :',-xli3*iteken
+ endif
+ print *,' log''s:',xhill*iteken
+ print *,' eta''s:',crr(5)
+ print *,' :',crr(6)
+ print '(a,2g24.15,2i3)',' cr is dus:',cr,ipi12,ier
+ endif
+* -#] add up and print out:
+ else
+* Normal case:
+* -#[ handle dilogs:
+*
+* the dilogs will not come close together so just go on
+* only the special case xx1p ~ -1 needs special attention
+* - and the special case xx1 ~ 2 also needs special attention
+*
+ if ( iclas1 .eq. 4 ) then
+ d2 = d2yzz + zz
+ xmax = abs(d2yzz)
+ if ( abs(d2) .lt. xloss*xmax ) then
+ if ( lwrite ) print *,'d2 = ',d2,xmax
+ som = y + dyz
+ if ( lwrite ) print *,'d2+ = ',som,abs(y)
+ if ( abs(y).lt.xmax ) then
+ d2 = som
+ xmax = abs(y)
+ endif
+ if ( lwarn .and. abs(d2) .lt. xloss*xmax ) then
+ call ffwarn(58,ier,d2,xmax)
+ endif
+ endif
+ d2 = d2/dyz
+ fact = 1/(2-d2)
+ call ffxli2(xli1,xlo1,d2*fact,ier)
+ call ffxli2(xli3,xlo3,-d2*fact,ier)
+ call ffxli2(xli4,xlo4,d2,ier)
+ elseif ( iclas1 .eq. 5 ) then
+ call ffxl22(xli1,xx1p,ier)
+ ipi12 = ipi12 + 3
+ else
+ call ffxli2(xli1,xlo1,xx1p,ier)
+ endif
+ if ( iclas2 .eq. 4 ) then
+ if ( iclas1 .eq. 4 ) call fferr(26,ier)
+ d2 = d2yzz - zz1
+ xmax = abs(d2yzz)
+ if ( abs(d2) .lt. xloss*xmax ) then
+ if ( lwrite ) print *,'d2 = ',d2,xmax
+ som = dyz - y1
+ if ( lwrite ) print *,'d2+ = ',som,abs(y1)
+ if ( abs(y1).lt.xmax ) then
+ d2 = som
+ xmax = abs(y1)
+ endif
+ if ( lwarn .and. abs(d2) .lt. xloss*xmax ) then
+ call ffwarn(59,ier,d2,xmax)
+ endif
+ endif
+ d2 = d2/dyz
+ fact = 1/(2-d2)
+ call ffxli2(xli2,xlo2,d2*fact,ier)
+ call ffxli2(xli3,xlo3,-d2*fact,ier)
+ call ffxli2(xli4,xlo4,d2,ier)
+ elseif ( iclas2 .eq. 5 ) then
+ call ffxl22(xli2,xx2p,ier)
+ ipi12 = ipi12 - 3
+ else
+ call ffxli2(xli2,xlo2,xx2p,ier)
+ endif
+* -#] handle dilogs:
+* -#[ handle transformation terms xx1:
+*
+* transformation of c1
+*
+ if ( iclas1 .eq. 1 ) then
+ crr(1) = xli1
+ elseif( iclas1 .eq. 2 ) then
+ crr(1) = -xli1
+ ipi12 = ipi12 + 2
+ clog1p = zxfflg(xx1p,ieps,y,ier)
+ crr(3) = - DBLE(xlo1)*clog1p
+ elseif ( iclas1 .eq. 3 ) then
+ crr(1) = -xli1
+ ipi12 = ipi12 - 2
+ clog1p = zxfflg(-xx1p,-ieps,y,ier)
+ crr(3) = - clog1p**2/2
+ elseif ( iclas1 .eq. 4 ) then
+ crr(1) = xli1
+* Note that this sum does not cause problems as d2<<1
+ crr(3) = DBLE(-xli3-xli4) + DBLE(xlo4)*
+ + zxfflg(fact,0,x0,ier)
+ ipi12 = ipi12 - 1
+ if ( lwrite ) then
+ print *,'Check iclas1 = 4'
+ print '(a,2g14.8)','Nu: ',crr(1)+crr(3)
+ call ffxli2(xlia,xtroep,xx1p,ier)
+ print '(a,2g14.8)','Eerst:',xlia+pi12,x0
+ endif
+ elseif ( iclas1 .eq. 5 ) then
+ crr(1) = xli1
+* supply an imaginary part
+ clog1p = zxfflg(-1/xx1,-ieps,y,ier)
+ xtroep = -DIMAG(clog1p)*DBLE(clog1p)
+ crr(3) = DCMPLX(x0,xtroep)
+ else
+ call fferr(26,ier)
+ endif
+* -#] handle transformation terms xx1:
+* -#[ handle transformation terms xx2:
+*
+* transformation of c2
+*
+ if ( iclas2 .eq. 1 ) then
+ crr(2) = -xli2
+ elseif( iclas2 .eq. 2 ) then
+ crr(2) = +xli2
+ ipi12 = ipi12 - 2
+ clog2p = zxfflg(xx2p,ieps,-y1,ier)
+ crr(4) = + DBLE(xlo2)*clog2p
+ elseif ( iclas2 .eq. 3 ) then
+ crr(2) = +xli2
+ ipi12 = ipi12 + 2
+ clog2p = zxfflg(-xx2p,-ieps,-y1,ier)
+ crr(4) = clog2p**2/2
+ elseif ( iclas2 .eq. 4 ) then
+ crr(2) = -xli2
+* Note that this sum does not cause problems as d2<<1
+ crr(4) = DBLE(xli3+xli4) - DBLE(xlo4)*
+ + zxfflg(fact,0,x0,ier)
+ ipi12 = ipi12 + 1
+ if ( lwrite ) then
+ print *,'Check iclas2 = 4'
+ print '(a,2g14.8)','Nu: ',-DBLE(xli2)+crr(4)
+ call ffxli2(xlia,xtroep,xx2p,ier)
+ print '(a,2g14.8)','Eerst:',-xlia-pi12,x0
+ endif
+ elseif ( iclas2 .eq. 5 ) then
+ crr(2) = -xli2
+* supply an imaginary part
+ clog2p = zxfflg(-1/xx2,-ieps,-y1,ier)
+ xtroep = DIMAG(clog2p)*DBLE(clog2p)
+ crr(4) = DCMPLX(x0,xtroep)
+ else
+ call fferr(28,ier)
+ endif
+* -#] handle transformation terms xx2:
+* -#[ sum and print:
+ if ( lwrite ) then
+ cr = crr(1) + crr(2) + crr(3) + crr(4) + crr(5) + crr(6)
+ print *,'ffcxr: Normal case'
+ print *,' oorspronkelijk:',xx1
+ print *,' iclas1 = ',iclas1
+ if(iclas1.ne.1)print *,' nu:',xx1p
+ print *,' Li21 :',crr(1)
+ if(iclas1.ne.1)print *,' tran1:',crr(3)
+ if(crr(5).ne.0)print *,' :',crr(5)
+ if(crr(6).ne.0)print *,' :',crr(6)
+ print *,' oorspronkelijk:',xx2
+ print *,' iclas2 = ',iclas2
+ if(iclas2.ne.1)print *,' nu:',xx2p
+ print *,' Li22 :',-crr(2)
+ if(iclas2.ne.1)print *,' tran2:',-crr(4)
+ if(crr(5).ne.0)print *,' :',-crr(5)
+ if(crr(6).ne.0)print *,' :',-crr(6)
+ print '(a,2g24.15,2i6)',' cr is dus:',cr,ipi12,ier
+ if(ipi12.ne.0)print '(a,2g24.15)',' =',
+ + cr+ipi12*DBLE(pi12)
+ endif
+* -#] sum and print:
+ endif
+* #] calculations:
+* #[ debug:
+ if ( lwrite ) then
+ if ( abs(ieps) .eq. 1 ) then
+ if ( y .lt. 0 ) then
+ ieps1 = ieps
+ else
+ ieps1 = -ieps
+ endif
+ if ( y1 .lt. 0 ) then
+ ieps2 = -ieps
+ else
+ ieps2 = ieps
+ endif
+ else
+ ieps1 = ieps
+ ieps2 = ieps
+ endif
+ ierdum = 0
+ call ffzxdl(cli1,ipi121,ctroep,xx1,ieps1,ierdum)
+ call ffzxdl(cli2,ipi122,ctroep,xx2,ieps2,ierdum)
+ cr1 = cli1 - cli2 + (ipi121-ipi122)*DBLE(pi12)
+ print '(a,2g24.15,i6)',' verg. cr1:',cr1,ierdum
+ endif
+* #] debug:
+*###] ffcxr:
+ end
diff --git a/ff-2.0/ffcxs3.f b/ff-2.0/ffcxs3.f
new file mode 100644
index 0000000..ebf1f72
--- /dev/null
+++ b/ff-2.0/ffcxs3.f
@@ -0,0 +1,779 @@
+*###[ ffcxs3:
+ subroutine ffcxs3(cs3,ipi12,y,z,dyz,d2yzz,dy2z,xpi,piDpj,ii,ns,
+ + isoort,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the s3 as defined in appendix b. *
+* (ip = ii+3, is1 = ii, is2 = ii+1) *
+* *
+* log( xk*y^2 + (-xk+xm1-xm2)*y + xm2 - i*eps ) *
+* /1 - log( ... ) |y=yi *
+* s3 = \ dy -------------------------------------------------- *
+* /0 y - yi *
+* *
+* = r(yi,y-,+) + r(yi,y+,-) *
+* *
+* with y+- the roots of the argument of the logarithm. *
+* the sign of the argument to the logarithms in r is passed *
+* in ieps *
+* *
+* input: y(4),z(4) (real) roots in form (z-,z+,1-z-,1-z+) *
+* dyz(2,2),d2yzz, (real) y() - z(), y+ - z- - z+ *
+* dy2z(4) (real) y() - 2z() *
+* xpi (real(ns)) p(i).p(i) (B&D metric) i=1,3 *
+* m(i)^2 = si.si i=4,6 *
+* ii (integer) xk = xpi(ii+3) etc *
+* ns (integer) size of arrays *
+* isoort (integer) returns kind of action taken *
+* cs3 (complex)(20) assumed zero. *
+* ccy (complex)(3) if i0 != 0: complex y *
+* *
+* output: cs3 (complex) mod factors pi^2/12, in array *
+* ipi12 (integer) these factors *
+* ier (integer) 0=ok 1=inaccurate 2=error *
+* *
+* calls: ffcrr,ffcxr,real/dble,DCMPLX,log,ffadd1,ffadd2,ffadd3 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(2),ii,ns,isoort(2),ier
+ DOUBLE COMPLEX cs3(20)
+ DOUBLE PRECISION y(4),z(4),dyz(2,2),d2yzz,dy2z(4),
+ + xpi(ns),piDpj(ns,ns)
+*
+* local variables:
+*
+ integer i,ip,ieps(2),ipi12p(2),ier0,i2,i3
+ DOUBLE COMPLEX c,csum,cs3p(14)
+ DOUBLE PRECISION yy,yy1,zz,zz1,dyyzz,xdilog,xlog,x00(3)
+ DOUBLE PRECISION absc,xmax
+ logical ld2yzz
+*
+* common blocks
+*
+ include 'ff.h'
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ get counters:
+ if ( ltest .and. ns .ne. 6 )
+ + print *,'ffcxs3: error: only for ns=6, not ',ns
+ ip = ii+3
+ if ( isoort(2) .ne. 0 ) then
+ if ( (z(2).gt.z(1) .or. z(1).eq.z(2) .and. z(4).lt.z(3) )
+ + .eqv. xpi(ip) .gt. 0 ) then
+ ieps(1) = +1
+ ieps(2) = -1
+ else
+ ieps(1) = -1
+ ieps(2) = +1
+ endif
+ else
+ if ( piDpj(ip,ii) .gt. 0 ) then
+ ieps(1) = +1
+ else
+ ieps(1) = -1
+ endif
+ endif
+ i2 = mod(ii,3) + 1
+ i3 = mod(i2,3) + 1
+* #] get counters:
+* #[ special case |z| >> |y|:
+ if ( xpi(ip).lt.0 .and. max(abs(y(2)),abs(y(4))) .lt.
+ + xloss*min(abs(z(1)), abs(z(2)))/2 ) then
+*
+* we will obtain cancellations of the type Li_2(x) + Li_2(-x)
+* with x small.
+*
+ if ( lwrite ) then
+ print *,'ffcxs3: special case |z| >> |y|'
+ print *,' y,y1 = ',y(2),y(4)
+ print *,' z,z1- = ',z(1),z(3)
+ print *,' z,z1+ = ',z(2),z(4)
+ endif
+ yy = dyz(2,1)/d2yzz
+ yy1 = dyz(2,2)/d2yzz
+ if ( y(2) .eq. 0 ) goto 10
+ zz = z(2)*yy/y(2)
+ zz1 = 1-zz
+ if ( lwarn .and. abs(zz) .lt. xloss )
+ + call ffwarn(44,ier,abs(zz),x1)
+ dyyzz = dyz(2,2)*yy/y(2)
+ call ffcxr(cs3(1),ipi12(1),yy,yy1,zz,zz1,dyyzz,.FALSE.,x0,
+ + x0,x0,.FALSE.,x00,0,ier)
+ 10 continue
+ if ( y(4) .eq. 0 ) goto 30
+ zz = yy*z(4)/y(4)
+ zz1 = 1-zz
+ if ( lwarn .and. abs(zz) .lt. xloss )
+ + call ffwarn(44,ier,abs(zz),x1)
+ dyyzz = -yy*dyz(2,2)/y(4)
+ call ffcxr(cs3(8),ipi12(2),yy,yy1,zz,zz1,dyyzz,.FALSE.,x0,
+ + x0,x0,.FALSE.,x00,0,ier)
+ do 20 i=8,14
+ 20 cs3(i) = -cs3(i)
+ 30 continue
+* And now the remaining Li_2(x^2) terms
+ call ffxli2(xdilog,xlog,(y(2)/dyz(2,1))**2,ier)
+ cs3(15) = +xdilog/2
+ call ffxli2(xdilog,xlog,(y(4)/dyz(2,1))**2,ier)
+ cs3(16) = -xdilog/2
+ if ( lwrite ) then
+ lwrite = .FALSE.
+ ipi12p(1) = 0
+ ipi12p(2) = 0
+ ier0 = 0
+ do 40 i=1,14
+ 40 cs3p(i) = 0
+ call ffcxr(cs3p(1),ipi12p(1),y(2),y(4),z(1),z(3),
+ + dyz(2,1),.FALSE.,x0,x0,x0,.FALSE.,x00,ieps(1),ier0)
+ call ffcxr(cs3p(8),ipi12p(2),y(2),y(4),z(2),z(4),
+ + dyz(2,2),.FALSE.,x0,x0,x0,.FALSE.,x00,ieps(2),ier0)
+ csum = 0
+ xmax = 0
+ do 50 i=1,14
+ csum = csum + cs3p(i)
+ xmax = max(xmax,absc(csum))
+ 50 continue
+ csum = csum + (ipi12p(1)+ipi12(2))*DBLE(pi12)
+ print '(a,3g20.10,3i3)','cmp',csum,xmax,ipi12p,ier0
+ lwrite = .TRUE.
+ endif
+ goto 900
+ endif
+* #] special case |z| >> |y|:
+* #[ normal:
+ if ( xpi(ip) .eq. 0 ) then
+ ld2yzz = .FALSE.
+ else
+ ld2yzz = .TRUE.
+ endif
+ if ( lwrite ) print *, 'ieps = ',ieps
+ if ( isoort(1) .ne. 0 ) call ffcxr(cs3(1),ipi12(1),y(2),y(4),
+ + z(1),z(3),dyz(2,1),ld2yzz,d2yzz,z(2),z(4),.TRUE.,dy2z(1),
+ + ieps(1),ier)
+ if ( isoort(2) .ne. 0 ) then
+ if ( mod(isoort(2),10) .eq. 2 ) then
+* both roots are equal: multiply by 2
+ if ( lwrite ) print *,'ffcxs3: skipped next R as it ',
+ + 'is the conjugate'
+ do 60 i=1,7
+ cs3(i) = 2*DBLE(cs3(i))
+ 60 continue
+ ipi12(1) = 2*ipi12(1)
+ else
+ call ffcxr(cs3(8),ipi12(2),y(2),y(4),z(2),z(4),dyz(2,2),
+ + ld2yzz,d2yzz,z(1),z(3),.TRUE.,dy2z(2),ieps(2),ier)
+ endif
+ endif
+*
+* #] normal:
+* #[ print output:
+ 900 if (lwrite) then
+ print *,' cs3 ='
+ do 905 i=1,20
+ if ( cs3(i).ne.0 ) print '(i3,2g20.10,1x)',i,cs3(i)
+ 905 continue
+ print '(a3,2g20.10,1x)','pi ',(ipi12(1)+ipi12(2))*pi12
+ print *,'+-----------'
+ csum = 0
+ do 910 i=1,20
+ 910 csum = csum + cs3(i)
+ csum = csum+(ipi12(1)+ipi12(2))*DBLE(pi12)
+ print '(a,2g20.10)','Si ',csum
+ print *,' ipi12,ier=',ipi12,ier
+ print *,' '
+ endif
+* #] print output:
+*###] ffcxs3:
+ end
+*###[ ffcs3:
+ subroutine ffcs3(cs3,ipi12,cy,cz,cdyz,cd2yzz,cpi,cpiDpj,ii,ns,
+ + isoort,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the s3 as defined in appendix b. *
+* *
+* log( cpi(ii+3)*y^2 + (cpi(ii+3)+cpi(ii)-cpi(ii+1))*y *
+* /1 + cpi(ii+1)) - log( ... ) |y=cyi *
+* s3 = \ dy ---------------------------------------------------- *
+* /0 y - cyi *
+* *
+* = r(cyi,cy+) + r(cyi,cy-) + ( eta(-cy-,-cy+) - *
+* eta(1-cy-,1-cy+) - eta(...) )*log(1-1/cyi) *
+* *
+* with y+- the roots of the argument of the logarithm. *
+* *
+* input: cy(4) (complex) cy(1)=y^-,cy(2)=y^+,cy(i+2)=1-cy(1) *
+* cz(4) (complex) cz(1)=z^-,cz(2)=z^+,cz(i+2)=1-cz(1) *
+* cpi(6) (complex) masses & momenta (B&D) *
+* ii (integer) position of cp,cma,cmb in cpi *
+* ns (integer) size of arrays *
+* isoort(2)(integer) returns the kind of action taken *
+* cs3 (complex)(14) assumed zero. *
+* *
+* output: cs3 (complex) mod factors ipi12 *
+* ipi12(2) (integer) these factors *
+* ier (integer) 0=ok, 1=numerical problems, 2=error *
+* *
+* calls: ffcrr,DIMAG,DBLE,zfflog *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(2),ii,ns,isoort(2),ier
+ DOUBLE COMPLEX cs3(20),cpi(ns),cpiDpj(ns,ns)
+ DOUBLE COMPLEX cy(4),cz(4),cdyz(2,2),cd2yzz
+*
+* local variables:
+*
+ integer i,ip,ieps(2),ieps0,ni(4),ipi12p(2),ier0,ntot,i2,i3
+ logical ld2yzz
+ DOUBLE COMPLEX c,csum,zdilog,zlog,cyy,cyy1,czz,czz1,cdyyzz
+ + ,cs3p(14)
+ DOUBLE PRECISION absc,xmax,y,y1,z,z1,dyz,d2yzz,zz,zz1,
+ + x00(3),sprec
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ get ieps:
+ if ( ltest ) then
+ if ( ns .ne. 6 ) then
+ print *,'ffcs3: error: only for ns=6, not ',ns
+ stop
+ endif
+ endif
+ ip = ii+3
+ call ffieps(ieps,cz(1),cpi(ip),cpiDpj(ip,ii),isoort)
+ i2 = mod(ii,3) + 1
+ i3 = mod(i2,3) + 1
+* #] get ieps:
+* #[ special case |cz| >> |cy|:
+ if ( isoort(2) .ne. 0 .and. max(absc(cy(2)),absc(cy(4))) .lt.
+ + xloss*min(absc(cz(1)),absc(cz(2)))/2 ) then
+*
+* we will obtain cancellations of the type Li_2(x) + Li_2(-x)
+* with x small.
+*
+ if ( lwrite ) print *,'Special case |cz| >> |cy|'
+ cyy = cdyz(2,1)/cd2yzz
+ cyy1 = cdyz(2,2)/cd2yzz
+ if ( absc(cy(2)) .lt. xclogm ) then
+ if ( DIMAG(cy(2)) .eq. 0 .and. abs(DBLE(cy(2))) .gt.
+ + xalogm ) then
+ czz = cz(2)*cyy*DCMPLX(1/DBLE(cy(2)))
+ cdyyzz = cyy*cdyz(2,2)*DCMPLX(1/DBLE(cy(2)))
+ elseif ( cy(2) .eq. 0 .and. cz(2) .ne. 0 .and. cyy
+ + .ne. 0 ) then
+* the answer IS zero
+ goto 30
+ else
+* the answer is rounded off to zero
+ if (lwarn) call ffwarn(42,ier,absc(cy(2)),xclogm)
+ endif
+ else
+ czz = cz(2)*cyy/cy(2)
+ cdyyzz = cyy*cdyz(2,2)/cy(2)
+ endif
+ czz1 = 1-czz
+ if ( lwarn .and. absc(czz) .lt. xloss )
+ + call ffwarn(43,ier,absc(czz),x1)
+ if ( isoort(1) .eq. -10 ) then
+* no eta terms.
+ ieps0 = 99
+ else
+* do not know the im part
+ ieps0 = 0
+ endif
+ call ffcrr(cs3(1),ipi12(1),cyy,cyy1,czz,czz1,cdyyzz,.FALSE.,
+ + c0,c0,c0,-1,ieps0,ier)
+ 30 continue
+ if ( absc(cy(4)) .lt. xclogm ) then
+ if ( DIMAG(cy(4)) .eq. 0 .and. abs(DBLE(cy(4))) .gt.
+ + xalogm ) then
+ czz = cz(4)*cyy*DCMPLX(1/DBLE(cy(4)))
+ cdyyzz = -cyy*cdyz(2,2)*DCMPLX(1/DBLE(cy(4)))
+ elseif ( cy(4) .eq. 0 .and. cz(4) .ne. 0 .and. cyy
+ + .ne. 0 ) then
+* the answer IS zero
+ goto 50
+ else
+* the answer is rounded off to zero
+ if (lwarn) call ffwarn(42,ier,absc(cy(4)),xclogm)
+ endif
+ else
+ czz = cz(4)*cyy/cy(4)
+ cdyyzz = -cyy*cdyz(2,2)/cy(4)
+ endif
+ czz1 = 1-czz
+ if ( lwarn .and. absc(czz) .lt. xloss )
+ + call ffwarn(43,ier,absc(czz),x1)
+ call ffcrr(cs3(8),ipi12(2),cyy,cyy1,czz,czz1,cdyyzz,.FALSE.,
+ + c0,c0,c0,-1,ieps0,ier)
+ do 40 i=8,14
+ cs3(i) = -cs3(i)
+ 40 continue
+ 50 continue
+*
+* And now the remaining Li_2(x^2) terms
+* stupid Gould NP1
+*
+ c = cy(2)*cy(2)/(cdyz(2,1)*cdyz(2,1))
+ call ffzli2(zdilog,zlog,c,.FALSE.,ier)
+ cs3(15) = +zdilog/2
+* stupid Gould NP1
+ c = cy(4)*cy(4)/(cdyz(2,1)*cdyz(2,1))
+ call ffzli2(zdilog,zlog,c,.FALSE.,ier)
+ cs3(16) = -zdilog/2
+ if ( lwrite ) then
+ lwrite = .FALSE.
+ ipi12p(1) = 0
+ ipi12p(2) = 0
+ ier0 = 0
+ do 60 i=1,14
+ cs3p(i) = 0
+ 60 continue
+ call ffcrr(cs3p(1),ipi12p(1),cy(2),cy(4),cz(1),
+ + cz(3),cdyz(2,1),.TRUE.,cd2yzz,cz(2),
+ + cz(4),isoort(1),ieps(1),ier0)
+ call ffcrr(cs3p(8),ipi12p(2),cy(2),cy(4),cz(2),
+ + cz(4),cdyz(2,2),.TRUE.,cd2yzz,cz(1),
+ + cz(3),isoort(2),ieps(2),ier0)
+ csum = 0
+ xmax = 0
+ do 70 i=1,14
+ csum = csum + cs3p(i)
+ xmax = max(xmax,absc(csum))
+ 70 continue
+ csum = csum + (ipi12p(1)+ipi12(2))*DBLE(pi12)
+ print '(a,3g20.10,3i3)','cmp',csum,xmax,ipi12p,ier0
+ lwrite = .TRUE.
+ endif
+ goto 900
+ endif
+* #] special case |cz| >> |cy|:
+* #[ normal:
+ if ( isoort(2) .eq. 0 ) then
+ ld2yzz = .FALSE.
+ else
+ ld2yzz = .TRUE.
+ endif
+ if ( isoort(1) .eq. 0 ) then
+* do nothing
+ elseif ( mod(isoort(1),10).eq.0 .or. mod(isoort(1),10).eq.-1
+ + .or. mod(isoort(1),10).eq.-3 ) then
+ call ffcrr(cs3(1),ipi12(1),cy(2),cy(4),cz(1),cz(3),
+ + cdyz(2,1),ld2yzz,cd2yzz,cz(2),cz(4),isoort(1),
+ + ieps(1),ier)
+ elseif ( mod(isoort(1),10) .eq. -5 .or. mod(isoort(1),10) .eq.
+ + -6 ) then
+ y = DBLE(cy(2))
+ y1 = DBLE(cy(4))
+ z = DBLE(cz(1))
+ z1 = DBLE(cz(3))
+ dyz = DBLE(cdyz(2,1))
+ d2yzz = DBLE(cd2yzz)
+ zz = DBLE(cz(2))
+ zz1 = DBLE(cz(4))
+ sprec = precx
+ precx = precc
+ call ffcxr(cs3(1),ipi12(1),y,y1,z,z1,dyz,ld2yzz,d2yzz,zz,zz1
+ + ,.FALSE.,x00,ieps(1),ier)
+ precx = sprec
+ else
+ call fferr(12,ier)
+ endif
+ if ( isoort(2) .eq. 0 ) then
+* do nothing
+ elseif ( mod(isoort(2),5) .eq. 0 ) then
+ if ( lwrite ) print *,'ffcs3: skipped next R as it is the ',
+ + 'conjugate'
+ do 100 i=1,7
+ 100 cs3(i) = 2*DBLE(cs3(i))
+ ipi12(1) = 2*ipi12(1)
+ elseif ( mod(isoort(2),10).eq.-1 .or. mod(isoort(1),10).eq.-3 )
+ + then
+ call ffcrr(cs3(8),ipi12(2),cy(2),cy(4),cz(2),cz(4),
+ + cdyz(2,2),ld2yzz,cd2yzz,cz(1),cz(3),isoort(2),
+ + ieps(2),ier)
+ elseif ( mod(isoort(2),10) .eq. -6 ) then
+ y = DBLE(cy(2))
+ y1 = DBLE(cy(4))
+ z = DBLE(cz(2))
+ z1 = DBLE(cz(4))
+ dyz = DBLE(cdyz(2,2))
+ d2yzz = DBLE(cd2yzz)
+ zz = DBLE(cz(1))
+ zz1 = DBLE(cz(3))
+ sprec = precx
+ precx = precc
+ call ffcxr(cs3(8),ipi12(2),y,y1,z,z1,dyz,ld2yzz,d2yzz,zz,zz1
+ + ,.FALSE.,x00,ieps(2),ier)
+ precx = sprec
+ else
+ call fferr(13,ier)
+ endif
+* #] normal:
+* #[ eta's:
+ if ( mod(isoort(1),10).eq.-5 .or. mod(isoort(1),10).eq.-6 )
+ + then
+ if ( mod(isoort(2),10).ne.-5 .and. mod(isoort(1),10).ne.-6
+ + ) then
+ print *,'ffcxs3: error: I assumed both would be real!'
+ ier = ier + 50
+ endif
+* we called ffcxr - no eta's
+ elseif ( DIMAG(cpi(ip)).eq.0 ) then
+ call ffgeta(ni,cz(1),cdyz(1,1),cd2yzz,
+ + cpi(ip),cpiDpj(ii,ip),ieps,isoort,ier)
+ if ( lwrite ) print *,'ffcs3: eta''s are ',ni
+ ntot = ni(1) + ni(2) + ni(3) + ni(4)
+ if ( ntot .ne. 0 ) call ffclgy(cs3(15),ipi12(2),ntot,
+ + cy(1),cz(1),cd2yzz,ier)
+ else
+*
+* cpi(ip) is really complex (occurs in transformed
+* 4pointfunction)
+*
+ print *,'THIS PART IS NOT READY ',
+ + 'and should not be reached'
+ stop
+ endif
+* #] eta's:
+* #[ print output:
+ 900 if (lwrite) then
+ print *,' cs3 ='
+ do 905 i=1,20
+ if ( cs3(i).ne.0 ) print '(i3,2g20.10,1x)',i,cs3(i)
+ 905 continue
+ print '(a3,2g20.10,1x)','pi ',(ipi12(1)+ipi12(2))*pi12
+ print *,'+-----------'
+ csum = 0
+ do 910 i=1,20
+ 910 csum = csum + cs3(i)
+ csum = csum+(ipi12(1)+ipi12(2))*DBLE(pi12)
+ print '(a,2g20.10)','Si ',csum
+ print *,' ipi12,ier=',ipi12,ier
+ endif
+* #] print output:
+*###] ffcs3:
+ end
+*###[ ffclgy:
+ subroutine ffclgy(cs3,ipi12,ntot,cy,cz,cd2yzz,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the the difference of two S's with cy(3,4),cz(3,4), *
+* cy(4)cz(3)-cy(3)cz(4) given. Note the difference with ffdcs4, *
+* in which the cy's are the same and only the cz's different. *
+* Here both can be different. Also we skip an intermediat *
+* level. *
+* *
+* input: cy(4) (complex) cy,1-cy in S with s3,s4 *
+* cz(4) (complex) cz,1-cz in S with s3,s4 *
+* cdyz(2,2) (complex) cy - cz *
+* cd2yzz (complex) 2*cy - cz+ - cz- *
+* cdyzzy(4) (complex) cy(i,4)*cz(i,4)-cy(i,3)*cz(i,4) *
+* cpiDpj(6,6) (complex) usual *
+* cs3 (complex) assumed zero. *
+* *
+* output: cs3 (complex) mod factors pi^2/12, in array *
+* ipi12 (integer) these factors *
+* isoort (integer) returns kind of action taken *
+* ier (integer) number of digits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cs3
+ DOUBLE COMPLEX cy(4),cz(4),cd2yzz
+ integer ipi12,ntot,ier
+*
+* local variables
+*
+ integer ipi
+ DOUBLE COMPLEX c,cc,clogy,c2y1,zfflog,zfflo1,csum
+ DOUBLE PRECISION absc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ calculations:
+ ipi = 0
+ if ( 1 .lt. xloss*absc(cy(2)) ) then
+ clogy = zfflo1(1/cy(2),ier)
+ else
+ if ( absc(cy(2)) .lt. xclogm .or. absc(cy(4)) .lt. xclogm )
+ + then
+ if ( ntot .ne. 0 ) call fferr(15,ier)
+ clogy = 0
+ else
+ c = -cy(4)/cy(2)
+ if ( DBLE(c) .gt. -abs(DIMAG(c)) ) then
+ clogy = zfflog(c,0,c0,ier)
+ else
+* take out the factor 2*pi^2
+ cc = c+1
+ if ( absc(cc) .lt. xloss ) then
+ c2y1 = -cd2yzz - cz(1) + cz(4)
+ if ( absc(c2y1) .lt. xloss*max(absc(cz(1)),
+ + absc(cz(4))) ) then
+ c2y1 = -cd2yzz - cz(2) + cz(3)
+ if ( lwarn .and. absc(c2y1) .lt. xloss*max(
+ + absc(cz(2)),absc(cz(3))) ) call ffwarn(
+ + 56,ier,absc(c2y1),absc(cy(2)))
+ endif
+ csum = -c2y1/cy(2)
+ clogy = zfflo1(csum,ier)
+ if ( lwrite ) then
+ print *,'c = ',c
+ print *,'c+ = ',-1+csum
+ endif
+ else
+ csum = 0
+ clogy = zfflog(-c,0,c0,ier)
+ endif
+ if ( DIMAG(c) .lt. -precc*absc(c) .or.
+ + DIMAG(csum) .lt. -precc*absc(csum) ) then
+ ipi = -1
+ elseif ( DIMAG(c) .gt. precc*absc(c) .or.
+ + DIMAG(csum) .gt. precc*absc(csum) ) then
+ ipi = +1
+ else
+ call fferr(51,ier)
+ ipi = 0
+ endif
+ endif
+ endif
+ endif
+ if ( ltest .and. cs3 .ne. 0 ) then
+ print *,'ffclgy: error: cs3 al bezet! ',cs3
+ endif
+ cs3 = cs3 + ntot*c2ipi*clogy
+ if ( ipi .ne. 0 ) then
+ ipi12 = ipi12 - 24*ntot*ipi
+ endif
+* #] calculations:
+*###] ffclgy:
+ end
+*###[ ffieps:
+ subroutine ffieps(ieps,cz,cp,cpDs,isoort)
+***#[*comment:***********************************************************
+* *
+* Get the ieps prescription in such a way that it is compatible *
+* with the imaginary part of cz if non-zero, compatible with the *
+* real case if zero. *
+* *
+* Input: cz complex(4) the roots z-,z+,1-z-,1-z+ *
+* cp complex p^2 *
+* cpDs complex p.s *
+* isoort integer(2) which type of Ri *
+* *
+* Output: ieps integer(2) z -> z-ieps*i*epsilon *
+* will give correct im part *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ieps(2),isoort(2)
+ DOUBLE COMPLEX cp,cpDs,cz(4)
+*
+* #] declarations:
+* #[ work:
+ if ( DIMAG(cp) .ne. 0 ) then
+* do not calculate ANY eta terms, we'll do them ourselves.
+ ieps(1) = 99
+ ieps(2) = 99
+ elseif ( isoort(2) .ne. 0 ) then
+ if ( DIMAG(cz(1)) .lt. 0 ) then
+ ieps(1) = +1
+ if ( DIMAG(cz(2)) .lt. 0 ) then
+ ieps(2) = +1
+ else
+ ieps(2) = -1
+ endif
+ elseif ( DIMAG(cz(1)) .gt. 0 ) then
+ ieps(1) = -1
+ if ( DIMAG(cz(2)) .le. 0 ) then
+ ieps(2) = +1
+ else
+ ieps(2) = -1
+ endif
+ else
+ if ( DIMAG(cz(2)) .lt. 0 ) then
+ ieps(1) = -1
+ ieps(2) = +1
+ elseif ( DIMAG(cz(2)) .gt. 0 ) then
+ ieps(1) = +1
+ ieps(2) = -1
+ else
+ if ( (DBLE(cz(2)).gt.DBLE(cz(1))
+ + .or. (DBLE(cz(1)).eq.DBLE(cz(2))
+ + .and. DBLE(cz(4)).lt.DBLE(cz(3)))
+ + ) .eqv. DBLE(cp).gt.0 ) then
+ ieps(1) = +1
+ ieps(2) = -1
+ else
+ ieps(1) = -1
+ ieps(2) = +1
+ endif
+ endif
+ endif
+ else
+ if ( DIMAG(cz(1)) .lt. 0 ) then
+ ieps(1) = +1
+ elseif ( DIMAG(cz(1)) .gt. 0 ) then
+ ieps(1) = -1
+ elseif ( DBLE(cpDs) .gt. 0 ) then
+ ieps(1) = +1
+ else
+ ieps(1) = -1
+ endif
+ ieps(2) = -9999
+ endif
+* #] work:
+*###] ffieps:
+ end
+*###[ ffgeta:
+ subroutine ffgeta(ni,cz,cdyz,cd2yzz,cp,cpDs,ieps,isoort,ier)
+***#[*comment:***********************************************************
+* *
+* Get the eta terms which arise from splitting up *
+* log(p2(x-z-)(x-z+)) - log(p2(y-z-)(y-z+)) *
+* *
+* Input: cz complex(4) the roots z-,z+,1-z-,1-z+ *
+* cdyz complex(2,2) y-z *
+* cd2yzz complex(2) 2y-(z-)-(z+) *
+* cp complex p^2 *
+* cpDs complex p.s *
+* ieps integer(2) the assumed im part if Im(z)=0 *
+* isoort integer(2) which type of Ri *
+* *
+* Output: ni integer(4) eta()/(2*pi*i) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ni(4),ieps(2),isoort(2),ier
+ DOUBLE COMPLEX cp,cpDs,cz(4),cdyz(2,2),cd2yzz
+*
+* local variables
+*
+ integer i,nffeta,nffet1
+ DOUBLE COMPLEX cmip
+*
+* common
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ complex masses or imaginary roots:
+*
+* only complex because of complex roots in y or z
+* [checked and in agreement with ieps definition 23-sep-1991]
+*
+ if ( lwrite ) print *,'ffgeta: isoort = ',isoort
+*
+* isoort = +1: y is real, z is real
+* isoort = -1-n*10: y is complex, possibly z as well
+* isoort = -3-n*10: y,z complex, (y-z-)*(y-z+) real
+* isoort = 0: y is complex, one z root only
+* isoort = -10-n*10: y is real, z is complex
+* isoort = -5,6-n*10: y,z real
+*
+ if ( isoort(1) .gt. 0 ) then
+*
+* really a real case
+*
+ ni(1) = 0
+ ni(2) = 0
+ ni(3) = 0
+ ni(4) = 0
+ elseif ( mod(isoort(1),10) .ne. 0 .and. isoort(2) .ne. 0 ) then
+ cmip = DCMPLX(DBLE(x0),-DBLE(cp))
+*
+* ni(1) = eta(p2,(x-z-)(x-z+)) = 0 by definition (see ni(3))
+* ni(2) = eta(x-z-,x-z+)
+*
+ ni(1) = 0
+ if ( ieps(1) .gt. 0 .neqv. ieps(2) .gt. 0 ) then
+ ni(2) = 0
+ else
+ ni(2) = nffet1(-cz(1),-cz(2),cmip,ier)
+ if ( cz(3).ne.0 .and. cz(4).ne.0 ) then
+ i = nffet1(cz(3),cz(4),cmip,ier)
+ if ( i .ne. ni(2) ) call fferr(53,ier)
+ endif
+ endif
+*
+* ni(3) compensates for whatever convention we chose in ni(1)
+* ni(4) = -eta(y-z-,y-z+)
+*
+*** if ( DBLE(cd2yzz).eq.0 .and. ( DIMAG(cz(1)).eq.0 .and.
+*** + DIMAG(cz(2)).eq.0 .or. DBLE(cdyz(2,1)).eq.0 .and.
+*** + DBLE(cdyz(2,2)) .eq. 0 ) ) then
+ if ( mod(isoort(1),10).eq.-3 ) then
+* follow the i*epsilon prescription as (y-z-)(y-z+) real
+ ni(3) = 0
+ if ( ltest ) then
+ if ( DIMAG(cdyz(2,1)).eq.0 .or. DIMAG(cdyz(2,2))
+ + .eq.0 ) print *,'ffgeta: error: calling nffet1',
+ + ' with im(y-z-)=im(y-z+)=0: ',cdyz(2,1),cdyz(2,2)
+ endif
+ ni(4) = -nffet1(cdyz(2,1),cdyz(2,2),cmip,ier)
+ else
+ if ( DBLE(cp) .lt. 0 .and. DIMAG(cdyz(2,1)*
+ + cdyz(2,2)) .lt. 0 ) then
+ ni(3) = -1
+ else
+ ni(3) = 0
+ endif
+ ni(4) = -nffeta(cdyz(2,1),cdyz(2,2),ier)
+ endif
+ elseif ( (mod(isoort(1),10).eq.-1 .or. mod(isoort(1),10).eq.-3)
+ + .and. isoort(2) .eq. 0 ) then
+ ni(1) = 0
+ if ( DIMAG(cz(1)) .ne. 0 ) then
+ ni(2) = nffet1(-cpDs,-cz(1),DCMPLX(DBLE(0),
+ + DBLE(-1)),ier)
+ else
+ ni(2) = nffet1(-cpDs,DCMPLX(DBLE(0),DBLE(1)),
+ + DCMPLX(DBLE(0),DBLE(-1)),ier)
+ endif
+ ni(3) = 0
+ ni(4) = -nffeta(-cpDs,cdyz(2,1),ier)
+ else
+ ni(1) = 0
+ ni(2) = 0
+ ni(3) = 0
+ ni(4) = 0
+ endif
+* #] complex masses or imaginary roots:
+*###] ffgeta:
+ end
diff --git a/ff-2.0/ffcxs4.f b/ff-2.0/ffcxs4.f
new file mode 100644
index 0000000..1ec9bc1
--- /dev/null
+++ b/ff-2.0/ffcxs4.f
@@ -0,0 +1,1021 @@
+* $Id: ffcxs4.f,v 1.3 1995/10/17 06:55:09 gj Exp $
+* $Log: ffcxs4.f,v $
+c Revision 1.3 1995/10/17 06:55:09 gj
+c Fixed ieps error in ffdcrr (ffcxs4.f), added real case in ffcrr, debugging
+c info in ffxd0, and warned against remaining errors for del2=0 in ffrot4
+c (ffxd0h.f)
+c
+c Revision 1.2 1995/10/06 09:17:22 gj
+c Found stupid typo in ffxc0p which caused the result to be off by pi^2/3 in
+c some equal-mass cases. Added checks to ffcxs4.f ffcrr.f.
+c
+*###[ ffcxs4:
+ subroutine ffcxs4(cs3,ipi12,w,y,z,dwy,dwz,dyz,d2yww,d2yzz,
+ + xpi,piDpj,ii,ns,isoort,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the 8 Spence functions = 4 R's = 2 dR's *
+* *
+* *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(4),ii,ns,isoort(4),ier
+ DOUBLE COMPLEX cs3(40)
+ DOUBLE PRECISION w(4),y(4),z(4),dwy(2,2),dwz(2,2),dyz(2,2),
+ + d2yww,d2yzz,xpi(ns),piDpj(ns,ns),x00(3)
+*
+* local variables:
+*
+ integer iepz(2),iepw(2)
+ logical ld2yzz,ld2yww
+* DOUBLE COMPLEX c
+* DOUBLE PRECISION absc
+*
+* common blocks
+*
+ include 'ff.h'
+* absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ groundwork:
+ if ( ltest .and. ns .ne. 6 )
+ + print *,'ffcxs4: error: only for ns=6, not ',ns
+ if ( isoort(2) .eq. 0 ) then
+ ld2yzz = .FALSE.
+ else
+ ld2yzz = .TRUE.
+ endif
+ if ( isoort(4) .eq. 0 ) then
+ ld2yww = .FALSE.
+ else
+ ld2yww = .TRUE.
+ endif
+ if ( isoort(2) .ne. 0 ) then
+ if ( z(2) .gt. z(1) .eqv. xpi(ii+3) .gt. 0 ) then
+ iepz(1) = +1
+ iepz(2) = -1
+ else
+ iepz(1) = -1
+ iepz(2) = +1
+ endif
+ else
+ print *,'ffcxs4: error: untested algorithm'
+ if ( piDpj(ii,ii+3) .gt. 0 ) then
+ iepz(1) = +1
+ else
+ iepz(1) = -1
+ endif
+ endif
+ if ( isoort(4) .ne. 0 ) then
+ if ( w(2) .gt. w(1) .eqv. xpi(5) .gt. 0 ) then
+ iepw(1) = 1
+ iepw(2) = -1
+ else
+ iepw(1) = -1
+ iepw(2) = 1
+ endif
+ else
+ print *,'ffcxs4: error: untested algorithm'
+ if ( piDpj(2,5) .gt. 0 ) then
+ iepw(1) = +1
+ else
+ iepw(1) = -1
+ endif
+ endif
+* #] groundwork:
+* #[ zm and wp:
+ if ( isoort(4) .eq. 0 ) then
+ if (lwrite) print *,'ffcxs4: to ffcxr(zm)'
+ call ffcxr(cs3(1),ipi12(1),y(2),y(4),z(1),z(3),dyz(2,1),
+ + ld2yzz,d2yzz,z(2),z(4),.FALSE.,x00,iepz(1),ier)
+ else
+ if (lwrite) print *,'ffcxs4: to ffdcxr(zm,wp)'
+ if ( .not. ( dwz(2,1).eq.0 .and. iepz(1).eq.iepw(2) ) )
+ + call ffdcxr(cs3( 1),ipi12(1),y(2),y(4),z(1),z(3),
+ + z(2),z(4),d2yzz,w(2),w(4),w(1),w(3),d2yww,
+ + dyz(2,1),dwy(2,2),dwz(2,1),iepz(1),iepw(2),ier)
+ endif
+* #] zm and wp:
+* #[ zp and wm:
+ if ( isoort(2) .eq. 0 ) then
+ if (lwrite) print *,'ffcxs4: to ffcxr(wm)'
+ call ffcxr(cs3(1),ipi12(1),y(2),y(4),w(1),w(3),-dwy(1,2),
+ + ld2yww,d2yww,w(2),w(4),.FALSE.,x00,iepw(1),ier)
+ else
+ if (lwrite) print *,'ffcxs4: to ffdcxr(zp,wm)'
+ if ( .not. ( dwz(1,2).eq.0 .and. iepz(2).eq.iepw(1) ) )
+ + call ffdcxr(cs3(21),ipi12(3),y(2),y(4),z(2),z(4),
+ + z(1),z(3),d2yzz,w(1),w(3),w(2),w(4),d2yww,
+ + dyz(2,2),dwy(1,2),dwz(1,2),iepz(2),iepw(1),ier)
+ endif
+* #] zp and wm:
+*###] ffcxs4:
+ end
+*###[ ffcs4:
+ subroutine ffcs4(cs3,ipi12,cw,cy,cz,cdwy,cdwz,cdyz,cd2yww,cd2yzz
+ + ,cpi,cpiDpj,cp2p,cetami,ii,ns,isoort,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the 8 Spence functions = 4 R's = 2 dR's *
+* *
+* *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(4),ii,ns,isoort(4),ier
+ DOUBLE COMPLEX cs3(40)
+ DOUBLE COMPLEX cw(4),cy(4),cz(4),cdwy(2,2),cdwz(2,2),cdyz(2,2)
+ DOUBLE COMPLEX cd2yww,cd2yzz,cpi(ns),cp2p,cpiDpj(ns,ns),
+ + cetami(6)
+*
+* local variables:
+*
+ logical ld2yzz,ld2yww
+ integer i,j,ip,iepz(2),iepw(2),nz(4),nw(4),ntot,i2pi
+ DOUBLE COMPLEX c,cc,clogy,c2y1,cdyw(2,2)
+ DOUBLE COMPLEX zfflo1,zfflog
+ DOUBLE PRECISION absc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ get counters:
+ if ( ltest ) then
+ if ( ns .ne. 6 ) then
+ print *,'ffcs4: error: only for ns=6, not ',ns
+ stop
+ endif
+ do i=1,4
+ if ( ipi12(i).ne.0 ) then
+ print *,'ffcs4: error: ipi12(',i,') non-zero! ',
+ + ipi12(i)
+ endif
+ enddo
+ endif
+ ip = ii+3
+ if ( isoort(2) .eq. 0 ) then
+ ld2yzz = .FALSE.
+ else
+ ld2yzz = .TRUE.
+ endif
+ if ( isoort(4) .eq. 0 ) then
+ ld2yww = .FALSE.
+ else
+ ld2yww = .TRUE.
+ endif
+ call ffieps(iepz,cz,cpi(ip),cpiDpj(ip,ii),isoort)
+ call ffieps(iepw,cw,cp2p,cpiDpj(ip,ii),isoort(3))
+ if ( isoort(4) .eq. 0 ) then
+ print *,'ffcs4: error: case not implemented'
+ ier = ier + 50
+ endif
+* #] get counters:
+* #[ R's:
+ if ( isoort(4) .eq. 0 ) then
+ call ffcrr(cs3(1),ipi12(1),cy(2),cy(4),cz(1),cz(3),cdyz(2,1)
+ + ,ld2yzz,cd2yzz,cz(2),cz(4),isoort(4),iepz(1),ier)
+ else
+ if (lwrite) print *,'ffcs4: to ffdcrr(zm,wp)'
+ if ( .not. ( cdwz(2,1).eq.0 .and. iepz(1).eq.iepw(2) ) )
+ + call ffdcrr(cs3( 1),ipi12(1),cy(2),cy(4),cz(1),cz(3),cz(2),
+ + cz(4),cd2yzz,cw(2),cw(4),cw(1),cw(3),cd2yww,cdyz(2,1),
+ + cdwy(2,2),cdwz(2,1),isoort(4),iepz(1),iepw(2),ier)
+ endif
+ if ( isoort(2) .eq. 0 ) then
+ call ffcrr(cs3(1),ipi12(1),cy(2),cy(4),cw(1),cw(3),-cdwy(1,2
+ + ),ld2yww,cd2yww,cw(2),cw(4),isoort(2),iepw(1),ier)
+ else
+ if (lwrite) print *,'ffcs4: to ffdcrr(zp,wm)'
+ if ( .not. ( cdwz(1,2).eq.0 .and. iepz(2).eq.iepw(1) ) )
+ + call ffdcrr(cs3(21),ipi12(3),cy(2),cy(4),cz(2),cz(4),cz(1),
+ + cz(3),cd2yzz,cw(1),cw(3),cw(2),cw(4),cd2yww,cdyz(2,2),
+ + cdwy(1,2),cdwz(1,2),iepz(2),isoort(2),iepw(1),ier)
+ endif
+* #] R's:
+* #[ eta's:
+ if ( DIMAG(cpi(ip)) .eq. 0 ) then
+ call ffgeta(nz,cz,cdyz,cd2yzz,
+ + cpi(ip),cpiDpj(ii,ip),iepz,isoort,ier)
+ do 120 i=1,2
+ do 110 j=1,2
+ cdyw(i,j) = cdwy(j,i)
+ 110 continue
+ 120 continue
+ call ffgeta(nw,cw,cdyw,cd2yww,
+ + cp2p,cpiDpj(ii,ip),iepw,isoort(3),ier)
+ else
+ print *,'ffcs4: error: not ready for complex D0 yet'
+ endif
+ ntot = nz(1)+nz(2)+nz(3)+nz(4)-nw(1)-nw(2)-nw(3)-nw(4)
+ if ( ntot .ne. 0 ) then
+ i2pi = 0
+ if ( 1/absc(cy(2)) .lt. xloss ) then
+ clogy = zfflo1(1/cy(2),ier)
+ else
+ c = -cy(4)/cy(2)
+ if ( DBLE(c) .gt. -abs(DIMAG(c)) ) then
+ clogy = zfflog(c,0,c0,ier)
+ else
+* take out the factor 2*pi^2
+ cc = c+1
+ if ( absc(cc) .lt. xloss ) then
+ c2y1 = -cd2yzz - cz(1) + cz(4)
+ if ( absc(c2y1) .lt. xloss*max(absc(cz(1)),
+ + absc(cz(4))) ) then
+ c2y1 = -cd2yzz - cz(2) + cz(3)
+ if ( lwarn .and. absc(c2y1) .lt. xloss*max(
+ + absc(cz(2)),absc(cz(3))) ) then
+ call ffwarn(134,ier,absc(c2y1),
+ + absc(cy(2)))
+ endif
+ endif
+ if ( lwrite ) then
+ print *,'1+c = ',1+c
+ print *,'-c2y1/cy(2) = ',-c2y1/cy(2)
+ endif
+ clogy = zfflo1(-c2y1/cy(2),ier)
+ else
+ clogy = zfflog(-c,0,c0,ier)
+ endif
+ if ( DIMAG(c) .lt. 0 ) then
+ i2pi = -1
+ elseif ( DIMAG(c) .gt. 0 ) then
+ i2pi = +1
+ else
+ call fferr(51,ier)
+ i2pi = 0
+ endif
+ ipi12(2) = ipi12(2) - ntot*24*i2pi
+ endif
+ endif
+ if ( cs3(40) .ne. 0 ) print *,'ffcs4: error: cs3(40) != 0'
+ cs3(40) = ntot*c2ipi*clogy
+ endif
+ if ( lwrite ) then
+ print *,'eta''s:'
+ print *,'nzi :',nz
+ print *,'nwi :',nw
+ print *,'total:',ntot*c2ipi*clogy
+ if ( i2pi .ne. 0 ) print *,' +',-ntot*24*i2pi*pi12
+ print *,' =',ntot,' *( ',c2ipi*clogy,' + ',24*i2pi*pi12,
+ + ')'
+ endif
+* #] eta's:
+*###] ffcs4:
+ end
+*###[ ffdcxr:
+ subroutine ffdcxr(cs3,ipi12,y,y1,z,z1,zp,zp1,d2yzz,
+ + w,w1,wp,wp1,d2yww,dyz,dwy,dwz,iepsz,iepsw,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate *
+* *
+* R(y,z,iepsz) - R(y,w,iepsw) *
+* *
+* Input: *
+* a = [yzw] (real) see definition *
+* a1 = 1 - a (real) *
+* dab = a - b (real) *
+* ieps[zw] (integer) sign of imaginary part *
+* of argument logarithm *
+* cs3(20) (complex) assumed zero *
+* *
+* Output: *
+* cs3(20) (complex) the results, not added *
+* ipi12(2) (integer) factors pi^2/12 *
+* *
+* Calls: ffcxr *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(2),iepsz,iepsw,ier
+ DOUBLE COMPLEX cs3(20)
+ DOUBLE PRECISION y,z,w,y1,z1,w1,dyz,dwy,dwz,zp,zp1,d2yzz,wp,wp1,
+ + d2yww
+*
+* local variables:
+*
+ integer i,ieps,ipi12p(2),ier1,ier2,isign,inorm
+ logical again
+ DOUBLE PRECISION yy,yy1,zz,zz1,dyyzz,xx1,xx1n,term,tot,d2,d3,
+ + d21,d31,d2n,d3n,d21n1,d31n1,dw,xlogy,x00(3)
+ DOUBLE COMPLEX csum,csum1,csum2,cs3p(20),chulp
+ DOUBLE PRECISION dfflo1
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+* absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+ inorm = 0
+* #] declarations:
+* #[ groundwork:
+ if ( dwz .eq. 0 .and. iepsz .eq. iepsw ) return
+ if ( dyz .eq. 0 ) then
+ call fferr(75,ier)
+ return
+ endif
+ xx1 = y/dyz
+ dw = dwz/dyz
+ if ( xx1 .le. x05 .or. xx1 .gt. 2 ) then
+ d2 = 1/y
+ dw = dw*y/w
+ else
+ d2 = 1/z1
+ endif
+ again = .FALSE.
+ 123 continue
+* #] groundwork:
+* #[ trivial case:
+ if ( dw .eq. 0 ) then
+ if ( lwrite ) print *,' Trivial case'
+* #] trivial case:
+* #[ normal case:
+ elseif ( abs(dw) .gt. xloss .or. again ) then
+* nothing's the matter
+ if ( lwrite ) print *,' Normal case'
+ inorm = 1
+ call ffcxr(cs3( 1),ipi12(1),y,y1,z,z1,dyz,
+ + .TRUE.,d2yzz,zp,zp1,.FALSE.,x00,iepsz,ier)
+ call ffcxr(cs3(11),ipi12(2),y,y1,w,w1,-dwy,
+ + .TRUE.,d2yww,wp,wp1,.FALSE.,x00,iepsw,ier)
+ do 10 i=11,20
+ 10 cs3(i) = -cs3(i)
+ ipi12(2) = -ipi12(2)
+* #] normal case:
+* #[ only cancellations in w, not in y:
+ elseif ( abs(d2) .gt. xloss ) then
+* there are no cancellations the other way:
+ if ( lwrite ) print *,' Cancellations one way, turned Rs'
+ if ( iepsz .ne. iepsw .and. ( y/dyz .gt. 1 .or.-y/dwy .gt.
+ + 1 ) ) then
+ again = .TRUE.
+ if ( lwrite ) then
+ print *,'ffdcxr: problems with ieps, solvable,'
+ print *,' but for the moment just call the ',
+ + 'normal case'
+ endif
+ again = .TRUE.
+ goto 123
+* call fferr(21,ier)
+ endif
+ yy = dwy/dwz
+ zz = yy*z/y
+ yy1 = dyz/dwz
+ zz1 = yy1*w/y
+ dyyzz = yy*dyz/y
+ if ( y .lt. 0 ) then
+ ieps = iepsz
+ else
+ ieps = -iepsz
+ endif
+ call ffcxr(cs3( 1),ipi12(1),yy,yy1,zz,zz1,dyyzz,.FALSE.,x0,
+ + x0,x0,.FALSE.,x00,2*ieps,ier)
+ zz = yy*z1/y1
+ zz1 = yy1*w1/y1
+ dyyzz = -yy*dyz/y1
+ if ( y1 .gt. 0 ) then
+ ieps = iepsz
+ else
+ ieps = -iepsz
+ endif
+ call ffcxr(cs3(11),ipi12(2),yy,yy1,zz,zz1,dyyzz,.FALSE.,x0,
+ + x0,x0,.FALSE.,x00,2*ieps,ier)
+ do 20 i=11,20
+ cs3(i) = -cs3(i)
+ 20 continue
+ ipi12(2) = -ipi12(2)
+* #] only cancellations in w, not in y:
+* #[ Hill identity:
+ elseif ( ( 1 .gt. xloss*abs(y) .or. abs(xx1) .gt. xloss )
+ + .and. ( 1 .gt. xloss*abs(z) .or. abs(z/dyz) .gt. xloss )
+ + .and. ( 1 .gt. xloss*abs(y) .or. abs(dyz/y) .gt. xloss )
+ + ) then
+* do a Hill identity on the y,y-1 direction
+ if ( lwrite ) print *,' Hill identity to split z,w'
+ yy = -y*w1/dwy
+ yy1 = w*y1/dwy
+ zz = -z*w1/dwz
+ zz1 = w*z1/dwz
+ dyyzz = -w*w1*(dyz/(dwy*dwz))
+ if ( y*dwz .gt. 0 .eqv. (y+dwz) .gt. 0 ) then
+ ieps = 2*iepsw
+ else
+ ieps = -2*iepsw
+ endif
+ call ffcxr(cs3( 1),ipi12(1),yy,yy1,zz,zz1,dyyzz,.FALSE.,x0,
+ + x0,x0,.FALSE.,x00,ieps,ier)
+ yy = w1
+ yy1 = w
+ zz = -w1*z/dwz
+ zz1 = w*z1/dwz
+ dyyzz = w*w1/dwz
+ call ffcxr(cs3( 9),ipi12(2),yy,yy1,zz,zz1,dyyzz,.FALSE.,x0,
+ + x0,x0,.FALSE.,x00,ieps,ier)
+ do 30 i=9,16
+ 30 cs3(i) = -cs3(i)
+ ipi12(2) = -ipi12(2)
+* the extra logarithms ...
+ if ( 1 .lt. xloss*abs(w) ) then
+ chulp = dfflo1(1/w,ier)
+ elseif ( w1 .lt. 0 .or. w .lt. 0 ) then
+ chulp = log(-w1/w)
+ else
+ chulp = DCMPLX(DBLE(log(w1/w)),DBLE(-iepsw*pi))
+ endif
+ cs3(20) = -DBLE(dfflo1(dwz/dwy,ier))*chulp
+* #] Hill identity:
+* #[ Taylor expansion:
+ elseif ( (w.lt.0..or.w1.lt.0) .and. (z.lt.0..or.z1.lt.0) ) then
+* do a Taylor expansion
+ if ( abs(xx1) .lt. xloss ) then
+ if ( lwrite ) print *,'ffdcxr: Taylor expansion, normal'
+ d3 = dwz/dwy
+* isign = 1
+ xx1n = xx1
+ d2n = d2
+ d3n = d3
+ d21 = 1-d2
+ d21n1 = 1
+ d31 = 1-d3
+ d31n1 = 1
+ tot = xx1*d2*d3
+ do 50 i=2,20
+ xx1n = xx1n*xx1
+ d21n1 = d21n1*d21
+ d31n1 = d31n1*d31
+ d2n = d2n + d2*d21n1
+ d3n = d3n + d3*d31n1
+ term = xx1n*d2n*d3n*xn2inv(i)
+ tot = tot + term
+ if ( abs(term) .le. precx*abs(tot) ) goto 51
+ 50 continue
+ if ( lwarn ) call ffwarn(46,ier,tot,term)
+ 51 continue
+* if ( isign .eq. 1 ) then
+ cs3(1) = tot
+* else
+* cs3(1) = -tot
+* endif
+ elseif ( abs(z/dyz) .lt. xloss ) then
+ if ( lwrite ) print *,' Normal case'
+ inorm = 1
+ call ffcxr(cs3( 1),ipi12(1),y,y1,z,z1,dyz,
+ + .TRUE.,d2yzz,zp,zp1,.FALSE.,x00,iepsz,ier)
+ call ffcxr(cs3(11),ipi12(2),y,y1,w,w1,-dwy,
+ + .TRUE.,d2yww,wp,wp1,.FALSE.,x00,iepsw,ier)
+ do 110 i=11,20
+ 110 cs3(i) = -cs3(i)
+* if ( lwrite ) print *,'ffdcxr: Taylor expansion, 1-x'
+* print *,'NOT YET READY !!!'
+* ier = ier + 100
+* yy = y1*dwz/(z1*dwy)
+* if ( abs(yy) .lt. xloss ) then
+* cs3(10) = -dfflo1(1/y,ier)*dfflo1(yy,ier)
+* else
+* yy1 = -w1*dyz/(z1*dwy)
+* if ( yy1 .gt. xalogm ) then
+* cs3(10) = -dfflo1(1/y,ier)*log(yy1)
+* elseif ( yy1 .gt. -xalogm ) then
+* if ( lwarn ) call ffwarn(80,ier,yy1,xalogm)
+* else
+* xlogy = log(-yy1)
+* if ( lwarn .and. iepsz.ne.iepsw )
+* + call ffwarn(81,ier,x1,x1)
+* if ( (w1+dyz)*dwz*y1*iepsz .lt. 0 ) then
+* cs3(10) = -dfflo1(1/y,ier)*DCMPLX(DBLE(xlogy),DBLE(pi))
+* else
+* cs3(10) = -dfflo1(1/y,ier)*DCMPLX(DBLE(xlogy),DBLE(-pi))
+* endif
+* endif
+* endif
+* cs3(11) = -dfflo1(1/z,ier)*dfflo1(dwz/dwy,ier)
+* yy = dwz/(w*z1)
+* if ( abs(yy) .lt. xloss ) then
+* cs3(12) = -dfflo1(w/dwy,ier)*dfflo1(yy,ier)
+* else
+* yy1 = z*w1/(w*z1)
+* if ( yy1 .gt. xalogm ) then
+* cs3(12) = -dfflo1(w/dwy,ier)*log(yy1)
+* elseif ( yy .gt. -xalogm ) then
+* if ( lwarn ) call ffwarn(80,ier,yy,xalogm)
+* else
+* xlogy = log(-yy1)
+* if ( lwarn .and. iepsz.ne.iepsw )
+* + call ffwarn(81,ier,x1,x1)
+* if ( dwz*(dwz+1)*ieps .gt. 0 ) then
+* cs3(12) = -dfflo1(w/dwy,ier)*DCMPLX(DBLE(xlogy),DBLE(pi))
+* else
+* cs3(12) =-dfflo1(w/dwy,ier)*DCMPLX(DBLE(xlogy),DBLE(-pi))
+* endif
+* endif
+* endif
+* isign = -1
+* xx1 = -z/dyz
+* d2 = 1/z
+* d3 = dwz/dwy
+ else
+ if ( lwrite ) print *,'ffdcxr: Taylor expansion, 1/x'
+ call fferr(22,ier)
+ return
+ endif
+ else
+ if ( lwrite ) print *,'Not clear, take normal route'
+ inorm = 1
+ call ffcxr(cs3( 1),ipi12(1),y,y1,z,z1,dyz,.FALSE.,x0,x0,x0,
+ + .FALSE.,x00,iepsz,ier)
+ call ffcxr(cs3(11),ipi12(2),y,y1,w,w1,-dwy,.FALSE.,x0,x0,x0,
+ + .FALSE.,x00,iepsw,ier)
+ do 40 i=11,20
+ 40 cs3(i) = -cs3(i)
+ ipi12(2) = -ipi12(2)
+ endif
+* #] Taylor expansion:
+* #[ debug output:
+ if ( lwrite ) then
+ csum = 0
+ do 900 i=1,20
+ csum = csum + cs3(i)
+ print '(i2,2g16.8)',i,cs3(i)
+ 900 continue
+ print '(a)','---------------------------------'
+ print '(2x,2g16.8,2i3)',csum,ipi12
+ print '(a,i3)','ier = ',ier
+ if ( inorm .eq. 0 ) then
+ lwrite = .FALSE.
+ ier1 = 0
+ ier2 = 0
+ do 905 i=1,20
+ 905 cs3p(i) = 0
+ ipi12p(1) = 0
+ ipi12p(2) = 0
+ call ffcxr(cs3p( 1),ipi12p(1),y,y1,z,z1,dyz,.FALSE.,x0,x0,
+ + x0,.FALSE.,x00,iepsz,ier1)
+ call ffcxr(cs3p(11),ipi12p(2),y,y1,w,w1,-dwy,.FALSE.,x0,x0,
+ + x0,.FALSE.,x00,iepsw,ier2)
+ csum1 = 0
+ do 910 i=1,10
+ 910 csum1 = csum1 + cs3p(i)
+ csum2 = 0
+ do 920 i=11,20
+ 920 csum2 = csum2 - cs3p(i)
+ csum = csum1 + csum2 + (ipi12p(1)-ipi12p(2))*DBLE(pi12)
+ print *,'cmp with:'
+ print '(i2,2g16.8,i3)',1,csum1,ier1
+ print '(i2,2g16.8,i3)',2,csum2,ier2
+ print *,'------------------+'
+ print '(2x,2g16.8,3i3)',csum1+csum2,ipi12p,max(ier1,ier2)
+ print '(2x,2g16.8,3i3)',csum
+ lwrite = .TRUE.
+ endif
+ endif
+* #] debug output:
+*###] ffdcxr:
+ end
+*###[ ffdcrr:
+ subroutine ffdcrr(cs3,ipi12,cy,cy1,cz,cz1,czp,czp1,cd2yzz,cw,cw1
+ + ,cwp,cwp1,cd2yww,cdyz,cdwy,cdwz,isoort,iepsz,iepsw,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate *
+* *
+* R(cy,cz,iepsz) - R(cy,cw,iepsw) *
+* *
+* Input: *
+* a = [yzw] (real) see definition *
+* a1 = 1 - a (real) *
+* dab = a - b (real) *
+* ieps[zw] (integer) sign of imaginary part *
+* of argument logarithm *
+* cs3(20) (complex) assumed zero *
+* *
+* Output: *
+* cs3(20) (complex) the results, not added *
+* ipi12(2) (integer) factors pi^2/12 *
+* *
+* Calls: ffcrr *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(2),isoort,iepsz,iepsw,ier
+ DOUBLE COMPLEX cs3(20)
+ DOUBLE COMPLEX cy,cz,czp,cw,cwp,cy1,cz1,czp1,cw1,cwp1,
+ + cdyz,cdwy,cdwz,cd2yzz,cd2yww
+*
+* local variables:
+*
+ integer i,ieps,ieps1,ieps2,ipi12p(2),ier1,ier2,isign,inorm,i2pi,
+ + nffeta,nffet1,n1,n2,n3,n4,n5,n6
+ logical ld2yyz
+ DOUBLE COMPLEX cyy,cyy1,czz,czz1,cdyyzz,chulp,zfflo1,zfflog,
+ + cc1,cdw,cc1n,cterm,ctot,cd2,cd3,
+ + cd21,cd31,cd2n,cd3n,cd21n1,cd31n1,
+ + cc2,cfactz,cfactw,czzp,czzp1,cd2yyz
+ DOUBLE COMPLEX csum,csum1,csum2,cs3p(20),c,check
+ DOUBLE PRECISION absc,xlosn
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+ inorm = 0
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ xlosn = xloss*DBLE(10)**(-1-mod(ier,50))
+ check = cd2yzz - 2*cy + cz + czp
+ if ( xlosn*absc(check) .gt. precc*max(2*absc(cy),absc(cz),
+ + absc(czp)) ) then
+ print *,'ffdcrr: error: cd2yzz != 2*cy - cz - czp:',
+ + cd2yzz,cy,cz,czp,check
+ endif
+ check = cd2yww - 2*cy + cw + cwp
+ if ( xlosn*absc(check) .gt. precc*max(2*absc(cy),absc(cw),
+ + absc(cwp)) ) then
+ print *,'ffdcrr: error: cd2yww != 2*cy - cw - cwp:',
+ + cd2yww,cy,cw,cwp,check
+ endif
+ endif
+* #] check input:
+* #[ groundwork:
+ if ( cdwz .eq. 0 ) then
+ if ( abs(DIMAG(cz)) .gt. precc*abs(DBLE(cz)) .or.
+ + iepsz .eq. iepsw ) return
+ if ( DBLE(cz) .ge. 0 .and. DBLE(cz1) .ge. 0 ) return
+ call fferr(76,ier)
+ return
+ endif
+ if ( cdyz .eq. 0 ) then
+ call fferr(77,ier)
+ return
+ endif
+ cc1 = cy/cdyz
+ cdw = cdwz/cdyz
+ if ( DBLE(cc1) .le. x05 .or. abs(cc1-1) .gt. 1 ) then
+ cd2 = 1/cy
+ cdw = cdw*cy/cw
+ else
+ cd2 = 1/cz1
+ endif
+* #] groundwork:
+* #[ trivial case:
+ if ( absc(cdw) .eq. 0 ) then
+ if ( lwrite ) print *,' Trivial case'
+* #] trivial case:
+* #[ normal case:
+*
+* if no cancellations are expected OR the imaginary signs differ
+* and are significant
+*
+ elseif ( absc(cdw) .gt. xloss .or. (iepsz.ne.iepsw .and.
+ + (DBLE(cy/cdyz).gt.1 .or. DBLE(-cy1/cdyz).gt.1) ) ) then
+* nothing's the matter
+ if ( lwrite ) print *,'ffdcrr: Normal case'
+ inorm = 1
+* special case to avoid bug found 15-oct=1995
+ if ( iepsz.eq.iepsw ) then
+ if ( DIMAG(cz).eq.0 .and. DIMAG(cz1).eq.0 ) then
+ print *,'ffdcrr: flipping sign iepsz'
+ iepsz = -iepsz
+ elseif ( DIMAG(cw).eq.0 .and. DIMAG(cw1).eq.0 ) then
+ print *,'ffdcrr: flipping sign iepsw'
+ iepsw = -iepsw
+ else
+ print *,'ffdcrr: error: missing eta terms!'
+ ier = ier + 100
+ endif
+ endif
+ call ffcrr(cs3(1),ipi12(1),cy,cy1,cz,cz1,cdyz,.TRUE.,
+ + cd2yzz,czp,czp1,isoort,iepsz,ier)
+ call ffcrr(cs3(8),ipi12(2),cy,cy1,cw,cw1,-cdwy,.TRUE.,
+ + cd2yww,cwp,cwp1,isoort,iepsw,ier)
+ do 10 i=8,14
+ cs3(i) = -cs3(i)
+ 10 continue
+ ipi12(2) = -ipi12(2)
+* #] normal case:
+* #[ only cancellations in cw, not in cy:
+ elseif ( absc(cd2) .gt. xloss ) then
+* there are no cancellations the other way:
+ if ( lwrite ) print *,'ffdcrr: Cancellations one way, ',
+ + 'turned Rs'
+ cyy = cdwy/cdwz
+ czz = cz*cyy/cy
+ cyy1 = cdyz/cdwz
+ czz1 = cyy1*cw/cy
+ cdyyzz = cdyz*cyy/cy
+ if ( DBLE(cy) .gt. 0 ) then
+ ieps1 = -3*iepsz
+ else
+ ieps1 = +3*iepsz
+ endif
+* Often 2y-z-z is relevant, but 2*yy-zz-zz is not, solve by
+* introducing zzp.
+ czzp = czp*cyy/cy
+ cd2yyz = cd2yzz*cyy/cy
+ czzp1 = 1 - czzp
+ if ( absc(czzp1) .lt. xloss ) then
+* later try more possibilities
+ ld2yyz = .FALSE.
+ else
+ ld2yyz = .TRUE.
+ endif
+ call ffcrr(cs3(1),ipi12(1),cyy,cyy1,czz,czz1,cdyyzz,
+ + ld2yyz,cd2yyz,czzp,czzp1,isoort,ieps1,ier)
+ czz = cyy*cz1/cy1
+ czz1 = cyy1*cw1/cy1
+ if ( DBLE(-cy1) .gt. 0 ) then
+ ieps2 = -3*iepsz
+ else
+ ieps2 = +3*iepsz
+ endif
+ cdyyzz = -cyy*cdyz/cy1
+ czzp = czp1*cyy/cy1
+ cd2yyz = -cd2yzz*cyy/cy1
+ czzp1 = 1 - czzp
+ if ( absc(czzp1) .lt. xloss ) then
+* later try more possibilities
+ ld2yyz = .FALSE.
+ else
+ ld2yyz = .TRUE.
+ endif
+ call ffcrr(cs3(8),ipi12(2),cyy,cyy1,czz,czz1,cdyyzz,
+ + .TRUE.,cd2yyz,czzp,czzp1,isoort,ieps2,ier)
+ do 20 i=8,14
+ cs3(i) = -cs3(i)
+ 20 continue
+ ipi12(2) = -ipi12(2)
+* eta terms (are not calculated in ffcrr as ieps = 3)
+ cfactz = 1/cdyz
+ if ( DIMAG(cz) .eq. 0 ) then
+ if ( DIMAG(cy) .eq. 0 ) then
+ n1 = 0
+ n2 = 0
+ else
+ n1 = nffet1(DCMPLX(DBLE(0),DBLE(iepsz)),cfactz,
+ + -cz*cfactz,ier)
+ n2 = nffet1(DCMPLX(DBLE(0),DBLE(iepsz)),cfactz,
+ + cz1*cfactz,ier)
+ endif
+ else
+ n1 = nffeta(-cz,cfactz,ier)
+ n2 = nffeta(cz1,cfactz,ier)
+ endif
+ cfactw = -1/cdwy
+ if ( DIMAG(cw) .eq. 0 ) then
+ if ( DIMAG(cy) .eq. 0 ) then
+ n4 = 0
+ n5 = 0
+ else
+ n4 = nffet1(DCMPLX(DBLE(0),DBLE(iepsw)),cfactw,
+ + -cw*cfactw,ier)
+ n5 = nffet1(DCMPLX(DBLE(0),DBLE(iepsw)),cfactw,
+ + cw1*cfactw,ier)
+ endif
+ else
+ n4 = nffeta(-cw,cfactw,ier)
+ n5 = nffeta(cw1,cfactw,ier)
+ endif
+*
+* we assume that cs3(15-17) are not used, this is always true
+*
+ n3 = 0
+ n6 = 0
+ if ( n1.eq.n4 ) then
+ if ( n1.eq.0 ) then
+* nothing to do
+ else
+ cc1 = cdwz/cdyz
+ if ( absc(cc1) .lt. xloss ) then
+ cs3(15) = n1*c2ipi*zfflo1(cc1,ier)
+ else
+ cc1 = -cdwy/cdyz
+ cs3(15) = n1*c2ipi*zfflog(cc1,0,c0,ier)
+ endif
+ cc1 = cy*cfactz
+ cc2 = cy*cfactw
+ if ( DIMAG(cc1).eq.0 .or. DIMAG(cc2).eq.0 ) then
+ n3 = 0
+ else
+ n3 = nffeta(cc1,1/cc2,ier)
+ endif
+ if ( n3.ne.0 ) then
+ print *,'ffdcrr: error: untested algorithm'
+ ier = ier + 50
+ ipi12(1) = ipi12(1) + 4*12*n1*n3
+ endif
+ endif
+ else
+ cc1 = cy*cfactz
+ cc2 = cy*cfactw
+ cs3(15) = (n1*zfflog(cc1,ieps1,c0,ier) +
+ + n4*zfflog(cc2,ieps1,c0,ier))*c2ipi
+ endif
+ if ( n2.eq.n5 ) then
+ if ( n2.eq.0 ) then
+* nothing to do
+ else
+ cc1 = cdwz/cdyz
+ if ( absc(cc1) .lt. xloss ) then
+ cs3(16) = n2*c2ipi*zfflo1(cc1,ier)
+ else
+ cc1 = -cdwy/cdyz
+ cs3(16) = n2*c2ipi*zfflog(cc1,0,c0,ier)
+ endif
+ cc1 = -cy1*cfactz
+ cc2 = -cy1*cfactw
+ if ( DIMAG(cc1).eq.0 .or. DIMAG(cc2).eq.0 ) then
+ n6 = 0
+ else
+ n6 = nffeta(cc1,1/cc2,ier)
+ endif
+ if ( n6.ne.0 ) then
+ print *,'ffdcrr: error: untested algorithm'
+ ier = ier + 50
+ ipi12(2) = ipi12(2) + 4*12*n2*n6
+ endif
+ endif
+ else
+ cc1 = -cy1*cfactz
+ cc2 = -cy1*cfactw
+ cs3(15) = (n2*zfflog(cc1,ieps2,c0,ier) +
+ + n5*zfflog(cc2,ieps2,c0,ier))*c2ipi
+ endif
+ if ( lwrite ) then
+ print *,' eta''s z are :',n1,n2,n3
+ print *,' eta''s w are :',n4,n5,n6
+ endif
+* #] only cancellations in cw, not in cy:
+* #[ Hill identity:
+ elseif ( ( 1.gt.xloss*absc(cy) .or. absc(cc1).gt.xloss )
+ + .and. ( 1.gt.xloss*absc(cz) .or. absc(cz/cdyz).gt.xloss )
+ + .and. ( 1.gt.xloss*absc(cy) .or. absc(cdyz/cy).gt.xloss )
+ + ) then
+* do a Hill identity on the cy,cy-1 direction
+ if ( lwrite ) print *,'ffdcrr: Hill identity to split cz,cw'
+ cyy = -cy*cw1/cdwy
+ cyy1 = cw*cy1/cdwy
+ czz = -cz*cw1/cdwz
+ czz1 = cw*cz1/cdwz
+ cdyyzz = -cw*cw1*(cdyz/(cdwy*cdwz))
+ ieps = -2*iepsz
+ call ffcrr(cs3(1),ipi12(1),cyy,cyy1,czz,czz1,cdyyzz,
+ + .FALSE.,c0,c0,c0,isoort,ieps,ier)
+ cyy = cw1
+ cyy1 = cw
+ czz = -cw1*cz/cdwz
+ czz1 = cw*cz1/cdwz
+ cdyyzz = cw*cw1/cdwz
+ call ffcrr(cs3(8),ipi12(2),cyy,cyy1,czz,czz1,cdyyzz,
+ + .FALSE.,c0,c0,c0,isoort,0,ier)
+ do 30 i=8,14
+ 30 cs3(i) = -cs3(i)
+ ipi12(2) = -ipi12(2)
+* the extra logarithms ...
+ if ( 1 .lt. xloss*absc(cw) ) then
+ chulp = zfflo1(1/cw,ier)
+ else
+ chulp = zfflog(-cw1/cw,0,c0,ier)
+ endif
+ cs3(15) = -zfflo1(cdwz/cdwy,ier)*chulp
+* #] Hill identity:
+* #[ Taylor expansion:
+ else
+* Do a Taylor expansion
+ if ( absc(cc1) .lt. xloss ) then
+ if ( lwrite ) print *,'ffdcrr: Taylor expansion, normal'
+ cd3 = cdwz/cdwy
+* isign = 1
+ cc1n = cc1
+ cd2n = cd2
+ cd3n = cd3
+ cd21 = 1-cd2
+ cd21n1 = 1
+ cd31 = 1-cd3
+ cd31n1 = 1
+ ctot = cc1*cd2*cd3
+ do 50 i=2,20
+ cc1n = cc1n*cc1
+ cd21n1 = cd21n1*cd21
+ cd31n1 = cd31n1*cd31
+ cd2n = cd2n + cd2*cd21n1
+ cd3n = cd3n + cd3*cd31n1
+ cterm = cc1n*cd2n*cd3n*DBLE(xn2inv(i))
+ ctot = ctot + cterm
+ if ( absc(cterm) .lt. precc*absc(ctot) ) goto 51
+ 50 continue
+ if ( lwarn ) call ffwarn(45,ier,absc(ctot),absc(cterm))
+ 51 continue
+* if ( isign .eq. 1 ) then
+ cs3(1) = ctot
+* else
+* cs3(1) = -ctot
+* endif
+ elseif ( absc(cz/cdyz) .lt. xloss ) then
+ if ( lwrite ) print *,'ffdcrr: Normal case'
+ inorm = 1
+ call ffcrr(cs3(1),ipi12(1),cy,cy1,cz,cz1,cdyz,.TRUE.,
+ + cd2yzz,czp,czp1,isoort,iepsz,ier)
+ call ffcrr(cs3(8),ipi12(2),cy,cy1,cw,cw1,-cdwy,.TRUE.,
+ + cd2yww,cwp,cwp1,isoort,iepsw,ier)
+ do 110 i=8,14
+ 110 cs3(i) = -cs3(i)
+ ipi12(2) = -ipi12(2)
+* if ( lwrite ) print *,'ffdcrr: Taylor expansion, 1-x'
+* print *,'NOT YET READY !!'
+* ier = ier + 100
+* cyy = cy1*cdwz/(cz1*cdwy)
+* if ( absc(cyy) .lt. xloss ) then
+* cs3(10) = -zfflo1(1/cy,ier)*zfflo1(cyy,ier)
+* else
+* cyy1 = -cw1*cdyz/(cz1*cdwy)
+* cs3(10) = -zfflo1(1/cy,ier)*zfflog(cyy1,0,cy,ier)
+* endif
+* cs3(11) = -zfflo1(1/cz,ier)*zfflo1(cdwz/cdwy,ier)
+* cyy = cdwz/(cw*cz1)
+* if ( absc(cyy) .lt. xloss ) then
+* cs3(12) = -zfflo1(cw/cdwy,ier)*zfflo1(cyy,ier)
+* else
+* cyy1 = cz*cw1/(cw*cz1)
+* cs3(12) = -zfflo1(cw/cdwy,ier)*zfflog(cyy1,0,c0,ier)
+* endif
+* isign = -1
+* cc1 = -cz/cdyz
+* cd2 = 1/cz
+* cd3 = cdwz/cdwy
+ else
+ if ( lwrite ) print *,'ffdcrr: Taylor expansion, 1/x'
+ call fferr(20,ier)
+ return
+ endif
+ endif
+* #] Taylor expansion:
+* #[ debug output:
+ if ( lwrite ) then
+ csum = 0
+ do 900 i=1,20
+ csum = csum + cs3(i)
+ print '(i2,2g16.8)',i,cs3(i)
+ 900 continue
+ print '(a)','---------------------------------'
+ print '(2x,2g16.8,2i3)',csum,ipi12
+ print '(a,2g16.8)','= ',csum+(ipi12(1)+ipi12(2))*DBLE(pi12)
+ print '(a,i3)','ier = ',ier
+ if ( inorm .eq. 0 ) then
+ lwrite = .FALSE.
+ ier1 = 0
+ ier2 = 0
+ do 905 i=1,14
+ 905 cs3p(i) = 0
+ ipi12p(1) = 0
+ ipi12p(2) = 0
+ call ffcrr(cs3p(1),ipi12p(1),cy,cy1,cz,cz1,cdyz,
+ + .TRUE.,cd2yzz,czp,czp1,isoort,iepsz,ier1)
+ call ffcrr(cs3p(8),ipi12p(2),cy,cy1,cw,cw1,-cdwy,
+ + .TRUE.,cd2yww,cwp,cwp1,isoort,iepsw,ier2)
+ csum1 = 0
+ do 910 i=1,7
+ 910 csum1 = csum1 + cs3p(i)
+ csum2 = 0
+ do 920 i=8,14
+ 920 csum2 = csum2 - cs3p(i)
+ print *,'cmp with:'
+ print '(i2,2g16.8,i2)',1,csum1,ier1
+ print '(i2,2g16.8,i2)',2,csum2,ier2
+ print *,'------------------+'
+ print '(2x,2g16.8,3i3)',csum1+csum2,ipi12p,
+ + max(ier1,ier2)
+ print '(a,2g16.8,3i3)','= ',csum1+csum2+
+ + (ipi12p(1)-ipi12p(2))*DBLE(pi12)
+ lwrite = .TRUE.
+ endif
+ endif
+* #] debug output:
+*###] ffdcrr:
+ end
diff --git a/ff-2.0/ffcxyz.f b/ff-2.0/ffcxyz.f
new file mode 100644
index 0000000..d0dce8d
--- /dev/null
+++ b/ff-2.0/ffcxyz.f
@@ -0,0 +1,375 @@
+*###[ ffcxyz:
+ subroutine ffcxyz(cy,cz,cdyz,cd2yzz,ivert,sdelpp,sdelps,etalam,
+ + etami,delps,xpi,piDpj,isoort,ldel2s,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* *
+* cz(1,2) = (-p(ip1).p(is2) +/- sdelpp)/xpi(ip1) *
+* cy(1,2) = (-p(ip1).p(is2) +/- sdisc)/xpi(ip1) *
+* disc = slam1 + 4*eta*xpi(ip)/slam *
+* *
+* cy(3,4) = 1-cy(1,2) *
+* cz(3.4) = 1-cz(1,2) *
+* cdyz(i,j) = cy(i) - cz(j) *
+* *
+* Input: ivert (integer) 1,2 of 3 *
+* sdelpp (real) sqrt(lam(p1,p2,p3))/2 *
+* sdelps (real) sqrt(-lam(p,ma,mb))/2 *
+* etalam (real) det(si.sj)/det(pi.pj) *
+* etami(6) (real) si.si - etalam *
+* xpi(ns) (real) standard *
+* piDpj(ns,ns) (real) standard *
+* ns (integer) dim of xpi,piDpj *
+* *
+* Output: cy(4),cz(4),cdyz(4,4) (complex) see above *
+* *
+* Calls: ?? *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ivert,isoort(2),ns,ier
+ logical ldel2s
+ DOUBLE COMPLEX cy(4),cz(4),cdyz(2,2),cd2yzz
+ DOUBLE PRECISION sdelpp,sdelps,etalam,etami(6),delps,xpi(ns),
+ + piDpj(ns,ns)
+*
+* local variables:
+*
+ integer i,j,ip1,ip2,ip3,is1,is2,is3
+ DOUBLE COMPLEX c
+ DOUBLE PRECISION absc,y(4)
+ DOUBLE PRECISION delps1,disc,hulp,xlosn
+*
+* common blocks:
+*
+ include 'ff.h'
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ set up pointers:
+ if ( ldel2s .and. ivert .ne. 1 ) goto 100
+ is1 = ivert
+ is2 = ivert+1
+ if ( is2 .eq. 4 ) is2 = 1
+ is3 = ivert-1
+ if ( is3 .eq. 0 ) is3 = 3
+ ip1 = is1 + 3
+* ip2 = is2 + 3
+* ip3 = is3 + 3
+ isoort(1) = -10
+ isoort(2) = -10
+* #] set up pointers:
+* #[ test input:
+ if ( ltest .and. xpi(ip1) .eq. 0 ) then
+ call fferr(47,ier)
+ return
+ endif
+* #] test input:
+* #[ get cypm,czpm:
+ hulp = sdelps/xpi(ip1)
+ cz(1) = DCMPLX(piDpj(ip1,is2)/xpi(ip1),-hulp)
+ cz(2) = DCMPLX(piDpj(ip1,is2)/xpi(ip1),+hulp)
+ disc = delps/sdelpp
+ call ffroot(y(1),y(2),xpi(ip1),piDpj(ip1,is2),etami(is2),disc,
+ + ier)
+ cy(1) = y(1)
+ cy(2) = y(2)
+* #] get cypm,czpm:
+* #[ get cypm1,czpm1:
+ if ( xpi(is1) .eq. xpi(is2) ) then
+ cy(4) = cy(1)
+ cy(3) = cy(2)
+ cz(4) = cz(1)
+ cz(3) = cz(2)
+ else
+ cz(3) = 1 - cz(1)
+ cz(4) = 1 - cz(2)
+ if ( absc(cz(3)).lt.xloss .or. absc(cz(4)).lt.xloss ) then
+ cz(3) =DCMPLX(-piDpj(ip1,is1)/xpi(ip1),+hulp)
+ cz(4) =DCMPLX(-piDpj(ip1,is1)/xpi(ip1),-hulp)
+ endif
+ y(3) = 1 - y(1)
+ y(4) = 1 - y(2)
+ if ( abs(y(3)) .lt. xloss .or. abs(y(4)) .lt. xloss ) then
+ call ffroot(y(4),y(3),xpi(ip1),-piDpj(ip1,is1),
+ + etami(is1),disc,ier)
+ endif
+ cy(3) = y(3)
+ cy(4) = y(4)
+ endif
+* #] get cypm1,czpm1:
+* #[ get cdypzp, cdypzm:
+ cdyz(2,1) = DCMPLX(disc/xpi(ip1),+hulp)
+ cdyz(2,2) = DCMPLX(disc/xpi(ip1),-hulp)
+ cdyz(1,1) = -cdyz(2,2)
+ cdyz(1,2) = -cdyz(2,1)
+ cd2yzz = 2*disc/xpi(ip1)
+ goto 200
+* #] get cdypzp, cdypzm:
+* #[ special case, get indices:
+ 100 continue
+ if ( ivert.eq.2 ) then
+ is1 = 2
+ ip1 = 5
+ else
+ is1 = 1
+ ip1 = 6
+ endif
+ isoort(1) = -100
+ isoort(2) = -100
+* #] special case, get indices:
+* #[ get cypm,czpm:
+*
+* special case del2s = 0, hence the roots are not the real roots
+* but z_2'' = (z_2'-1)/delta, z''_3 = -z'_3/delta
+*
+ hulp = sdelps/xpi(3)
+ disc = delps/sdelpp
+ if ( ivert .eq. 3 ) then
+ hulp = -hulp
+ disc = -disc
+ endif
+ cz(1) = DCMPLX(piDpj(is1,3)/xpi(3),-hulp)
+ cz(2) = DCMPLX(piDpj(is1,3)/xpi(3),+hulp)
+ call ffroot(y(1),y(2),xpi(3),piDpj(is1,3),etami(is1),disc,ier)
+ cy(1) = y(1)
+ cy(2) = y(2)
+* #] get cypm,czpm:
+* #[ get cypm1,czpm1:
+ cz(3) = 1 - cz(1)
+ cz(4) = 1 - cz(2)
+ if ( absc(cz(3)).lt.xloss .or. absc(cz(4)).lt.xloss ) then
+ if ( lwrite ) print *,'cz(3,4) = ',cz(3),cz(4)
+ if ( ivert.eq.2 ) then
+ cz(3) =DCMPLX(piDpj(ip1,3)/xpi(3),+hulp)
+ cz(4) =DCMPLX(piDpj(ip1,3)/xpi(3),-hulp)
+ else
+ cz(3) =DCMPLX(-piDpj(ip1,3)/xpi(3),+hulp)
+ cz(4) =DCMPLX(-piDpj(ip1,3)/xpi(3),-hulp)
+ endif
+ if ( lwrite ) print *,'cz(3,4)+= ',cz(3),cz(4)
+ endif
+ y(3) = 1 - y(1)
+ y(4) = 1 - y(2)
+ if ( abs(y(3)) .lt. xloss .or. abs(y(4)) .lt. xloss ) then
+ if ( lwrite ) print *,'y(3,4) = ',y(3),y(4)
+ if ( ivert .eq. 2 ) then
+ call ffroot(y(4),y(3),xpi(3),piDpj(ip1,3),etami(ip1),
+ + disc,ier)
+ else
+ call ffroot(y(4),y(3),xpi(3),-piDpj(ip1,3),etami(ip1),
+ + disc,ier)
+ endif
+ if ( lwrite ) print *,'y(3,4)+= ',y(3),y(4)
+ endif
+ cy(3) = y(3)
+ cy(4) = y(4)
+* #] get cypm1,czpm1:
+* #[ get cdypzp, cdypzm:
+ cdyz(2,1) = DCMPLX(disc/xpi(3),+hulp)
+ cdyz(2,2) = DCMPLX(disc/xpi(3),-hulp)
+ cdyz(1,1) = -cdyz(2,2)
+ cdyz(1,2) = -cdyz(2,1)
+ cd2yzz = 2*disc/xpi(3)
+* #] get cdypzp, cdypzm:
+* #[ test output:
+ 200 continue
+ if ( ltest ) then
+ xlosn = xloss**2*DBLE(10)**(-mod(ier,50))
+ do 99 i=1,2
+ if ( xlosn*absc(cy(i)+cy(i+2)-1) .gt. precc*max(absc(
+ + cy(i)),absc(cy(i+2)),x1)) print *,'ffcxyz: error: ',
+ + 'cy(',i+2,')<>1-cy(',i,'):',cy(i+2),cy(i),cy(i+2)+
+ + cy(i)-1
+ if ( xlosn*absc(cz(i)+cz(i+2)-1) .gt. precc*max(absc(
+ + cz(i)),absc(cz(i+2)),x1)) print *,'ffcxzz: error: ',
+ + 'cz(',i+2,')<>1-cz(',i,'):',cz(i+2),cz(i),cz(i+2)+
+ + cz(i)-1
+ do 98 j=1,2
+ if ( xlosn*absc(cdyz(i,j)-cy(i)+cz(j)) .gt. precc*
+ + max(absc(cdyz(i,j)),absc(cy(i)),absc(cz(j))) )
+ + print *,'ffcxyz: error: cdyz(',i,j,') <> cy(',i,
+ + ')-cz(',j,'):',cdyz(i,j),cy(i),cz(j),cdyz(i,j)-
+ + cy(i)+cz(j)
+ 98 continue
+ 99 continue
+ endif
+* #] test output:
+*###] ffcxyz:
+ end
+*###[ ffcdwz:
+ subroutine ffcdwz(cdwz,cw,cz,i1,j1,l,calpha,calph1,cpi,cdpipj,
+ + cpiDpj,csdeli,csdel2,ns,ier)
+***#[*comment:***********************************************************
+* *
+* Recalculate cdwz(i1,j1) = cw(i1) - cz(j1) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer i1,j1,l,ns,ier
+ DOUBLE COMPLEX cdwz(2,2),cw(4),cz(4),calpha,calph1,cpi(ns)
+ DOUBLE COMPLEX cdpipj(ns,ns),cpiDpj(ns,ns),csdeli(3),csdel2
+*
+* local variables:
+*
+ integer i,n
+ DOUBLE COMPLEX cs(8),csum,cfac,c,cddel
+ DOUBLE PRECISION xmax,absc,afac
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ calculations:
+ if ( l .eq. 1 ) then
+ if ( j1 .eq. 1 ) then
+ if ( absc(csdeli(1)+csdel2) .lt. xloss*absc(csdel2) )
+ + then
+* for example in e-> e g* with eeg loop
+* first get the difference of csdeli(1) and csdel2:
+ cs(1) = cpi(4)*cdpipj(2,5)
+ cs(2) = -cpiDpj(4,3)*cpiDpj(4,2)
+ cs(3) = cpiDpj(4,3)*cpiDpj(4,5)
+ csum = cs(1)+cs(2)+cs(3)
+ xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)))
+ if ( absc(csum) .lt. xloss*xmax ) then
+ if ( lwrite ) print *,'ffcdwz: canc in cddel'
+ ier = 1
+ goto 5
+ endif
+ cddel = csum/(csdel2-csdeli(1))
+ if ( i1 .eq. 1 ) then
+ cs(1) = cpi(4)*csdeli(2)
+ else
+ cs(1) = -cpi(4)*csdeli(2)
+ endif
+ cs(2) = cddel*cpiDpj(4,2)
+ cs(3) = -cpiDpj(4,3)*csdeli(1)
+ cs(4) = cpiDpj(4,3)*cpiDpj(4,5)
+ cs(5) = -cpi(4)*cpiDpj(5,3)
+ cs(6) = -cddel*csdel2
+ n = 6
+ else
+ if ( lwrite ) print *,'ffcdwz: ',
+ + 'cannot handle this case yet'
+ ier = ier + 100
+ goto 5
+ endif
+ csum = 0
+ xmax = 0
+ do 1 i=1,n
+ csum = csum + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ 1 continue
+ if ( absc(csum) .lt. xloss*xmax ) then
+ if ( lwrite ) print *,'ffcdwz: still cancellations',
+ + ' in cdwz(',i1,j1,l,'): ',csum,xmax
+ ier = ier + 1
+ endif
+ if (lwrite) print *,' cdwz(',i1,j1,l,') =',cdwz(i1,j1)
+ + ,min(absc(cw(i1)),absc(cw(i1+2)))
+ cdwz(i1,j1) = csum/calph1/cpi(4)/cpi(5)
+ if ( cdwz(i1,j1) .eq. 0 .and. csum .ne. 0 ) then
+ print *,'?#$&!! cdwz = 0 but csum != 0, try again'
+ afac = 1/absc(csum)
+ csum = csum*DBLE(afac)
+ cdwz(i1,j1) = csum/calph1/cpi(4)/cpi(5)
+ afac = 1/afac
+ cdwz(i1,j1) = cdwz(i1,j1)*DBLE(afac)
+ endif
+ if (lwrite) print *,' cdwz(',i1,j1,l,')+ =',cdwz(i1,j1)
+ + ,xmax/absc(calph1*cpi(4)*cpi(5))
+ else
+ if ( lwrite ) print *,'ffcdwz: warning: cannot handle',
+ + ' this case cdwz(',i1,j1,l,') yet'
+ ier = ier + 100
+ endif
+ 5 continue
+ elseif ( l .eq. 3 ) then
+ if ( (i1.eq.2 .and. j1.eq.1) .or. (i1.eq.1 .and. j1.eq.2 ) )
+ + then
+ cfac = 1/(csdeli(2) + csdeli(3))
+ cs(1) = cdpipj(6,5)*cz(j1)
+ cs(2) = -calph1*cpi(5)*cz(j1+2)
+ if ( max(absc(cdpipj(2,1)),absc(cdpipj(5,6))) .lt.
+ + max(absc(cdpipj(2,6)),absc(cdpipj(5,1))) ) then
+ cs(3) = cdpipj(2,1)/2
+ cs(4) = cdpipj(5,6)/2
+ else
+ cs(3) = cdpipj(2,6)/2
+ cs(4) = cdpipj(5,1)/2
+ endif
+ cs(5) = cpiDpj(4,3)*cpiDpj(5,3)*cfac
+ cs(6) = -cpiDpj(4,3)*cpiDpj(6,3)*cfac
+ cs(7) = cpi(3)*cdpipj(5,6)*cfac
+ if ( i1 .eq. 1 ) then
+ csum = cs(1)+cs(2)+cs(3)+cs(4) - (cs(5)+cs(6)+cs(7))
+ else
+ csum = cs(1)+cs(2)+cs(3)+cs(4) + cs(5)+cs(6)+cs(7)
+ endif
+ xmax = absc(cs(1))
+ do 10 i=2,7
+ xmax = max(xmax,absc(cs(i)))
+ 10 continue
+ if ( absc(csum) .lt. xloss*xmax ) then
+* this result is not used if it is not accurate (see
+* ffxc0p)
+ if ( lwrite ) then
+ call ffwarn(78,ier,absc(csum),xmax)
+ else
+ ier = ier + 1
+ endif
+ xmax = xmax/absc(calpha*cpi(5))
+ if ( xmax .lt. min(absc(cz(j1)),absc(cz(j1+2))) )
+ + then
+ if (lwrite) print *,' cdwz(',i1,j1,l,') = ',
+ + cdwz(i1,j1),min(absc(cw(i1)),absc(cw(i1+2)))
+ cdwz(i1,j1) = csum/(calpha*cpi(5))
+ if (lwrite) print *,' cdwz(',i1,j1,l,')+ = ',
+ + cdwz(i1,j1),xmax
+ endif
+ else
+ if (lwrite) print *,' cdwz(',i1,j1,l,') = ',
+ + cdwz(i1,j1),min(absc(cw(i1)),absc(cw(i1+2)))
+ cdwz(i1,j1) = csum/(calpha*cpi(5))
+ if (lwrite) print *,' cdwz(',i1,j1,l,')+ = ',
+ + cdwz(i1,j1),xmax/absc(calpha*cpi(5))
+ endif
+ else
+ if ( lwrite ) print *,'ffcdwz: warning: cannot handle',
+ + ' this case cdwz(',i1,j1,l,') yet'
+ ier = ier + 100
+ endif
+ else
+ if ( lwrite ) print *,'ffcdwz: error: l <> 1 or 3 but ',l
+ ier = ier + 100
+ endif
+* #] calculations:
+* #[ test output:
+ if ( ltest .and. ier .eq. 0 ) then
+ if ( xloss**2*absc(cdwz(i1,j1)-cw(i1)+cz(j1)) .gt. precc*
+ + max(absc(cdwz(i1,j1)),absc(cw(i1)),absc(cz(j1))) )
+ + print *,'ffcdwz: error: cdwz(',i1,j1,l,') <> cw - cz :'
+ + ,cdwz(i1,j1),cw(i1),cz(j1),cw(i1)-cz(j1),
+ + cdwz(i1,j1)-cw(i1)+cz(j1)
+ if ( xloss**2*absc(cdwz(i1,j1)+cw(i1+2)-cz(j1+2)) .gt.
+ + precc*max(absc(cdwz(i1,j1)),absc(cw(i1+2)),
+ + absc(cz(j1+2))) ) print *,'ffcdwz: error: cdwz(',i1,j1,
+ + l,') <> cz1- cw1:',cdwz(i1,j1),cz(i1+2),cw(j1+2),
+ + cz(i1+2)-cw(j1+2),cdwz(i1,j1)+cw(i1+2)-cz(j1+2)
+ endif
+* #] test output:
+*###] ffcdwz:
+ end
diff --git a/ff-2.0/ffdcc0.f b/ff-2.0/ffdcc0.f
new file mode 100644
index 0000000..11ae1a1
--- /dev/null
+++ b/ff-2.0/ffdcc0.f
@@ -0,0 +1,443 @@
+*###[ ffdcc0:
+ subroutine ffdcc0(cs3,ipi12,isoort,clogi,ilogi,xpi,dpipj,piDpj,
+ + xqi,dqiqj,qiDqj,sdel2,del2s,etalam,etami,delpsi,alph,
+ + ddel2s,ldel2s,npoin,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the difference of two threepoint functions *
+* C(3,...a) - C(4,...b) *
+* *
+* Input: xpi(6,3:4) (complex) transformed mi,pi squared in Ci *
+* dpipj(6,6,3:4)(complex) xpi(i)-xpi(j) *
+* piDpj(6,6,3:4)(complex) pi(i).pi(j) *
+* xqi(10,10) (complex) transformed mi,pi squared in D *
+* dqiqj(10,10) (complex) xqi(i)-xqi(j) *
+* qiDqj(10,10) (complex) qi(i).qi(j) *
+* sdel2 (complex) sqrt(delta_{p_1 p_2}^{p_1 p_2}) *
+* del2s(3,3:4) (complex) delta_{p_i s_i}^{p_i s_i} *
+* etalam(3:4) (complex) delta_{s_1 s_2 s_3}^{s_1 s_2 s_3}
+* /delta_{p_1 p_2}^{p_1 p_2} *
+* etami(6,3:4) (complex) m_i^2 - etalam *
+* ddel2s(2:3) (complex) del2s(i,3) - del2s(i,4) *
+* alph(3) (complex) alph(1)=alpha, alph(3)=1-alpha *
+* *
+* Output: cs3 (complex)(160) C0(3)-C0(4), not yet summed. *
+* ipi12 (integer)(6) factors pi^2/12, not yet summed *
+* slam (complex) lambda(p1,p2,p3). *
+* isoort (integer)(16) indication of he method used *
+* clogi (complex)(6) log(-dyz(2,1,i)/dyz(2,2,i)) *
+* ilogi (integer)(6) factors i*pi in this *
+* ier (integer) 0=ok, 1=inaccurate, 2=error *
+* *
+* Calls: ... *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(16),isoort(16),ilogi(6),npoin,ier
+ logical ldel2s
+ DOUBLE COMPLEX cs3(160),clogi(6)
+ DOUBLE COMPLEX xqi(10),dqiqj(10,10),qiDqj(10,10),
+ + xpi(6,3:4),dpipj(6,6,3:4),piDpj(6,6,3:4),
+ + sdel2,del2s(3,3:4),etalam(3:4),etami(6,3:4),alph(3),
+ + ddel2s(2:3),delpsi(3,3:4)
+*
+* local variables:
+*
+ integer i,j,k,ip,ii,ifirst,ieri(8)
+ DOUBLE COMPLEX c,cc
+ DOUBLE COMPLEX sdel2i(3,3:4),s(5),som,zfflo1,xhck,
+ + y(4,3:4,3),z(4,3:4,3),dyz(2,2,3:4,3),d2yzz(3:4,3),
+ + dyzzy(4,3),dsdel2,dyyzz(2,3)
+ DOUBLE PRECISION smax,absc,xmax,rloss
+ DOUBLE COMPLEX zfflog
+*for Absoft
+** DOUBLE COMPLEX csqrt
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ call ffchck(xpi(1,3),dpipj(1,1,3),6,ier)
+ call ffchck(xpi(1,4),dpipj(1,1,4),6,ier)
+ call ffchck(xqi,dqiqj,10,ier)
+ if ( ldel2s ) print *,'ffdcc0: error: cannot handle this ',
+ + 'case yet!!'
+ endif
+* #] check input:
+* #[ get y,z-roots:
+ if ( lwrite ) print '(a)',' ##[ get roots: (ffdcc0)'
+ do 20 k=3,4
+ do 10 i=1,3
+*
+* get roots (y,z)
+*
+ ip = i+3
+ sdel2i(i,k) = sqrt(-del2s(i,k))
+* then handle the special case Si = 0
+ if ( xpi(ip,k) .eq. 0 ) then
+ if ( i .eq. 1 .and. alph(3) .eq. 0 .or.
+ + i .eq. 3 .and. alph(1) .eq. 0 ) then
+ isoort(2*i-1+8*(k-3)) = 0
+ isoort(2*i+8*(k-3)) = 0
+ goto 10
+ endif
+ endif
+ call ffccyz(y(1,k,i),z(1,k,i),dyz(1,1,k,i),d2yzz(k,i),i,
+ + sdel2,sdel2i(i,k),etalam(k),etami(1,k),delpsi(i,k),
+ + xpi(1,k),piDpj(1,1,k),isoort(2*i-1+8*(k-3)),6,ier)
+ 10 continue
+ 20 continue
+* #] get y,z-roots:
+* #[ get differences:
+*
+* the only important differences are y4z3-z3y4 and (1-y4)(1-z3)-
+* (1-y3)(1-z4). Note that the errors work in parallel.
+*
+ do 199 i=1,8
+ ieri(i) = 0
+ 199 continue
+ if ( isoort(1) .eq. isoort(9) ) then
+* #[ vertices (1):
+ som = qiDqj(7,2)/sdel2
+*
+* flag if we have a cancellation
+*
+ if ( absc(som) .lt. xloss ) then
+ isoort(1) = isoort(1) - 10
+ isoort(9) = isoort(9) - 10
+ endif
+ do 201 k=1,4
+ dyzzy(k,1) = som*z(k,3,1)
+ if ( k .gt. 2 ) dyzzy(k,1) = -dyzzy(k,1)
+ if ( lwrite ) then
+ ii = 2*((k+1)/2)
+ print *,'dyzzy(',k,'1) = ',y(ii,4,1)*z(k,3,1) -
+ + y(ii,3,1)*z(k,4,1),absc(y(ii,4,1)*z(k,3,1))
+ print *,'dyzzy(',k,'1)+ = ',dyzzy(k,1)
+ endif
+ 201 continue
+ dyyzz(1,1) = som
+ dyyzz(2,1) = som
+ if ( lwrite ) then
+ print *,'dyyzz(1,1) =',y(2,4,1)-y(2,3,1)
+ print *,'dyyzz(1,1)+=',dyyzz(1,1)
+ endif
+* #] vertices (1):
+ endif
+ if ( isoort(3) .eq. isoort(11) ) then
+* #[ vertices (2):
+ ifirst = 0
+ do 22 j=1,2
+ do 21 k=1,2
+ ii = 2*(j-1) + k
+ dyzzy(ii,2) = y(2*j,4,2)*z(ii,3,2)-y(2*j,3,2)*z(ii,4,2)
+ xmax = absc(y(2*j,4,2)*z(ii,3,2))
+ if ( absc(dyzzy(ii,2)) .ge. xmax ) goto 21
+ isoort(3) = isoort(3) - 10
+ isoort(11) = isoort(11) - 10
+ if ( lwrite ) print *,'dyzzy(',ii,'2) = ',dyzzy(ii,2),
+ + xmax
+ if ( ifirst .eq. 0 ) then
+ if ( ddel2s(2) .eq. 0 ) then
+ dsdel2 = 0
+ else
+ dsdel2 = ddel2s(2)/(sdel2i(2,3)+sdel2i(2,4))
+ endif
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 ) then
+ s(1) = xqi(6)*qiDqj(7,4)*qiDqj(5,4)/sdel2
+ s(2) = -qiDqj(7,4)*sdel2i(2,3)
+ s(3) = +qiDqj(6,4)*dsdel2
+ else
+ s(1) = xqi(6)*qiDqj(7,2)*qiDqj(5,2)/sdel2
+ s(2) = -qiDqj(7,2)*sdel2i(2,3)
+ s(3) = +qiDqj(6,2)*dsdel2
+ endif
+ endif
+ if ( ifirst .le. 0 ) then
+ ifirst = 2
+ s(4) = -qiDqj(5,10)*qiDqj(7,4)*sdel2i(2,3)/sdel2
+ s(5) = delpsi(2,3)*dsdel2/sdel2
+ endif
+ if ( k .eq. 1 ) then
+ som = s(1) + s(2) + s(3) + s(4) + s(5)
+ else
+ som = s(1) - s(2) - s(3) - s(4) - s(5)
+ endif
+ smax = max(absc(s(1)),absc(s(2)),absc(s(3)),absc(s(4)),
+ + absc(s(5)))/DBLE(xqi(6))**2
+ if ( lwrite ) then
+ print *,'dyzzy(',ii,'2)+ = ',som/xqi(6)**2,smax
+ print *,(s(i)/xqi(6)**2,i=1,5)
+ endif
+ if ( smax .lt. xmax ) then
+ dyzzy(ii,2) = som*(1/DBLE(xqi(6))**2)
+ xmax = smax
+ endif
+ if ( lwarn .and. absc(dyzzy(ii,2)).lt.xloss*xmax ) then
+ call ffwarn(142,ieri(2*k+j-2),absc(dyzzy(ii,2)),xmax)
+ endif
+ 21 continue
+*
+* get dyyzz
+*
+ if ( ldel2s ) then
+ dyyzz(j,2) = dyz(2,j,4,2) - dyz(2,j,3,2)
+ xmax = absc(dyz(2,j,4,2))
+ if ( absc(dyyzz(j,2)) .ge. xloss*xmax ) goto 22
+ 1002 format(a,i1,a,2g22.14,g12.4)
+ if ( lwrite ) print 1002,'dyyzz(',j,'2) =',dyyzz(j,2),
+ + xmax
+ print *,'ffdcc0: under construction!'
+*
+* (could be copied from real case)
+*
+ if ( lwarn .and. absc(dyyzz(j,2)).lt.xloss*xmax ) then
+ call ffwarn(147,ieri(7+j),absc(dyyzz(j,2)),xmax)
+ endif
+ endif
+*
+* bookkeeping
+*
+ ifirst = ifirst - 1
+ 22 continue
+* #] vertices (2):
+ endif
+ if ( isoort(5) .eq. isoort(13) ) then
+* #[ vertices (3):
+ ifirst = 0
+ do 26 j=1,2
+ do 25 k=1,2
+ ii = 2*(j-1) + k
+ dyzzy(ii,3) = y(2*j,4,3)*z(ii,3,3)-y(2*j,3,3)*z(ii,4,3)
+ xmax = absc(y(2*j,4,3)*z(ii,3,3))
+ if ( absc(dyzzy(ii,3)) .ge. xmax ) goto 25
+ isoort(5) = isoort(5) - 10
+ isoort(13) = isoort(13) - 10
+ if ( lwrite ) print *,'dyzzy(',ii,'3) = ',dyzzy(ii,3),
+ + xmax
+ if ( ifirst .eq. 0 ) then
+ if ( ddel2s(2) .eq. 0 ) then
+ dsdel2 = 0
+ else
+ dsdel2 = ddel2s(3)/(sdel2i(3,3)+sdel2i(3,4))
+ endif
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 ) then
+ s(1) = xqi(8)*qiDqj(7,1)*qiDqj(5,1)/sdel2
+ s(2) = +qiDqj(7,1)*sdel2i(3,3)
+ s(3) = +qiDqj(9,1)*dsdel2
+ else
+ s(1) = xqi(8)*qiDqj(7,4)*qiDqj(5,4)/sdel2
+ s(2) = +qiDqj(7,4)*sdel2i(3,3)
+ s(3) = +qiDqj(9,4)*dsdel2
+ endif
+ endif
+ if ( ifirst .le. 0 ) then
+ ifirst = 2
+ s(4) = -qiDqj(5,9)*qiDqj(7,1)*sdel2i(3,3)/sdel2
+ s(5) = delpsi(3,3)*dsdel2/sdel2
+ endif
+ if ( k .eq. 1 ) then
+ som = s(1) + s(2) + s(3) + s(4) + s(5)
+ else
+ som = s(1) - s(2) - s(3) - s(4) - s(5)
+ endif
+ smax = max(absc(s(1)),absc(s(2)),absc(s(3)),absc(s(4)),
+ + absc(s(5)))/DBLE(xqi(8))**2
+ if ( lwrite ) then
+ print *,'dyzzy(',ii,'3)+ = ',som/xqi(8)**2,smax
+ print *,(s(i)/xqi(8)**2,i=1,5)
+ endif
+ if ( smax .lt. xmax ) then
+ dyzzy(ii,3) = som*(1/DBLE(xqi(8))**2)
+ xmax = smax
+ endif
+ if ( lwarn .and. absc(dyzzy(ii,3)).lt.xloss*xmax ) then
+ call ffwarn(142,ieri(2*k+j+2),absc(dyzzy(ii,3)),xmax)
+ endif
+ 25 continue
+*
+* get dyyzz
+*
+ if ( ldel2s ) then
+ dyyzz(j,3) = dyz(2,j,4,3) - dyz(2,j,3,3)
+ xmax = absc(dyz(2,j,4,3))
+ if ( absc(dyyzz(j,3)) .ge. xloss*xmax ) goto 24
+ print *,'ffdcc0: under construction!'
+*
+* (could be copied from real case)
+*
+ if ( lwrite ) print 1002,'dyyzz(',j,'3) =',dyyzz(j,3),
+ + xmax
+ if ( lwarn .and. absc(dyyzz(j,3)).lt.xloss*xmax ) then
+ call ffwarn(147,ieri(9+j),absc(dyyzz(j,3)),xmax)
+ endif
+ endif
+*
+* bookkeeping
+*
+ 24 continue
+ ifirst = ifirst - 1
+ 26 continue
+* #] vertices (3):
+ endif
+ ier = ier + max(ieri(1),ieri(2),ieri(3),ieri(4),ieri(5),ieri(6),
+ + ieri(7),ieri(8))
+* #] get differences:
+* #[ check differences:
+ if ( ltest ) then
+ rloss = xloss*DBLE(10)**(-mod(ier,50))
+ do 30 i=1,3
+ if ( isoort(2*i-1) .ne. isoort(2*i+7) ) goto 30
+ do 29 j=1,2
+ xhck = dyzzy(j,i) - y(2,4,i)*z(j,3,i)
+ + + z(j,4,i)*y(2,3,i)
+ if ( rloss*absc(xhck) .gt. precc*max(abs(y(2,4,i)*
+ + z(j,3,i)),abs(z(j,4,i)*y(2,3,i))) ) print *,
+ + 'ffdcc0: error: ','dyzzy(',j,i,') <> terms, ',
+ + dyzzy(j,i),y(2,4,i)*z(j,3,i),z(j,4,i)*y(2,3,i),
+ + xhck
+ xhck = dyzzy(j+2,i) - y(4,4,i)*z(j+2,3,i)
+ + + z(j+2,4,i)*y(4,3,i)
+ if ( rloss*absc(xhck) .gt. precc*max(abs(y(4,4,i)*
+ + z(j+2,3,i)),abs(z(j+2,4,i)*y(4,3,i))) ) print*,
+ + 'ffdcc0: error: ','dyzzy(',j+2,i,') <> terms, ',
+ + dyzzy(j+2,i),y(4,4,i)*z(j+2,3,i),z(j+2,4,i)*
+ + y(4,3,i),xhck
+ 29 continue
+ 30 continue
+ endif
+* #] check differences:
+* #[ write output:
+ if ( lwrite ) then
+ print *,'ffdcc0: found roots:'
+ do 86 k=3,4
+ do 85 i=1,3
+ print *,' k = ',i
+ if ( isoort(2*i+8*(k-3)) .ne. 0 ) then
+ print *,' ym,ym1 = ',y(1,k,i),y(3,k,i),
+ + ' (not used)'
+ print *,' yp,yp1 = ',y(2,k,i),y(4,k,i)
+ print *,' zm,zm1 = ',z(1,k,i),z(3,k,i)
+ print *,' zp,zp1 = ',z(2,k,i),z(4,k,i)
+ elseif ( isoort(2*i+8*(k-3)) .eq. 0 ) then
+ if ( isoort(2*i-1+8*(k-3)) .eq. 0 ) then
+ print *,' no roots, all is zero'
+ else
+ print *,' yp,yp1 = ',y(2,k,i),y(4,k,i)
+ print *,' zp,zp1 = ',z(2,k,i),z(4,k,i)
+ endif
+ endif
+ 85 continue
+ 86 continue
+ endif
+ if ( lwrite ) print '(a)',' ##] get roots:'
+* #] write output:
+* #[ logarithms for 4point function:
+ if ( npoin .eq. 4 ) then
+ if ( lwrite ) print '(a)',' ##[ logarithms for Ai<0:'
+ do 96 k = 3,4
+ do 95 i = 1,3
+ ii = i+3*(k-3)
+ if ( ilogi(ii) .ne. -999 ) goto 95
+ if ( isoort(2*i+8*(k-3)) .ne. 0 ) then
+* maybe add sophisticated factors i*pi later
+ c = -dyz(2,1,i,k)/dyz(2,2,i,k)
+ cc = c-1
+ if ( absc(cc) .lt. xloss ) then
+ s(1) = d2yzz(i,k)/dyz(2,2,i,k)
+ clogi(ii) = zfflo1(s(1),ier)
+ ilogi(ii) = 0
+ if ( lwrite ) then
+ print *,'c = ',c
+ print *,'c+= ',1-s(1)
+ endif
+ elseif ( DBLE(c) .gt. 0 ) then
+ clogi(ii) = zfflog(c,0,c0,ier)
+ ilogi(ii) = 0
+ else
+ cc = c+1
+ if ( absc(cc) .lt. xloss ) then
+ s(1) = -2*sdel2i(i,k)/dyz(2,2,i,k)/
+ + DBLE(xpi(i+3,k))
+ clogi(ii) = zfflo1(s(1),ier)
+ if ( lwrite ) then
+ print *,'c = ',c
+ print *,'c+= ',-1+s(1)
+ endif
+ else
+ s(1) = 0
+ clogi(ii) = zfflog(-c,0,c0,ier)
+ endif
+ if ( DIMAG(c) .lt. -precc*absc(c) .or. DIMAG(s(1))
+ + .lt. -precc*absc(s(1)) ) then
+ ilogi(ii) = -1
+ elseif ( DIMAG(c) .gt. precc*absc(c) .or.
+ + DIMAG(s(1)) .gt. precc*absc(s(1)) ) then
+ ilogi(ii) = +1
+ elseif ( DBLE(dyz(2,2,i,k)) .eq. 0 ) then
+ ilogi(ii) = -nint(sign(DBLE(x1),
+ + DBLE(xpi(i+3,k))))
+ ier = ier + 50
+ print *,'doubtful imaginary part ',ilogi(ii)
+ else
+ call fferr(78,ier)
+ print *,'c = ',c
+ endif
+ endif
+ endif
+ 95 continue
+ 96 continue
+ if ( lwrite ) print '(a)',' ##] logarithms for Ai<0:'
+ endif
+* #] logarithms for 4point function:
+* #[ integrals:
+ do 100 i=1,3
+ if ( lwrite ) print '(a,i1,a)',' ##[ dcs nr ',i,':'
+ j = 2*i-1
+ if ( isoort(j) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdcc0: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j),isoort(j+1)
+ endif
+ if ( isoort(j+8) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdcc0: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j+8),isoort(j+9)
+ endif
+ else
+ call ffcs3(cs3(20*i+61),ipi12(j+8),y(1,4,i),
+ + z(1,4,i),dyz(1,1,4,i),d2yzz(4,i),
+ + xpi(1,4),piDpj(1,1,4),i,6,isoort(j+8),ier)
+ endif
+ elseif ( isoort(j+8) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdcc0: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j),isoort(j+1)
+ endif
+ call ffcs3(cs3(20*i-19),ipi12(j),y(1,3,i),
+ + z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),
+ + xpi(1,3),piDpj(1,1,3),i,6,isoort(j),ier)
+ else
+ call ffdcs(cs3(20*i-19),ipi12(j),y(1,3,i),z(1,3,i),
+ + dyz(1,1,3,i),d2yzz(3,i),dyzzy(1,i),dyyzz(1,i),
+ + xpi,piDpj,i,6,isoort(j),ier)
+ endif
+ if ( lwrite ) print '(a,i1,a)',' ##] dcs nr ',i,':'
+ 100 continue
+* #] integrals:
+*###] ffdcc0:
+ end
diff --git a/ff-2.0/ffdcxs.f b/ff-2.0/ffdcxs.f
new file mode 100644
index 0000000..d8e4874
--- /dev/null
+++ b/ff-2.0/ffdcxs.f
@@ -0,0 +1,931 @@
+*--#[ log:
+* $Id: ffdcxs.f,v 1.7 1996/03/22 08:13:30 gj Exp $
+* $Log: ffdcxs.f,v $
+c Revision 1.7 1996/03/22 08:13:30 gj
+c Fixed bug in bugfix of ffdcxs.f
+c
+c Revision 1.6 1996/03/14 15:53:13 gj
+c Fixed bug in ffcb0: cp in C, cma=cmb=0 was computed incorrectly.
+c
+c Revision 1.5 1996/03/13 15:43:36 gj
+c Fixed bug, when ieps unknown already some things were computed and not zero'd.
+c Now I first check ieps, and then compute.
+c
+c Revision 1.4 1995/12/08 10:38:16 gj
+c Fixed too long line
+c
+*--#] log:
+*###[ ffdcxs:
+ subroutine ffdcxs(cs3,ipi12,y,z,dyz,d2yzz,dy2z,dyzzy,xpi,piDpj,
+ + ii,ns,isoort,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the the difference of two S's with y(3,4),z(3,4) and *
+* y(4)z(3)-y(3)z(4) given. Note the difference with ffdcxs4, in *
+* which the y's are the same and only the z's different. Here *
+* both can be different. Also we skip an intermediate level. *
+* Note also that this routine is much less conservative than *
+* ffcxs3 in its expectations of the order of the roots: it knows *
+* that it is (z-,z+,1-z-,1-z+)! *
+* *
+* input: y(4,3:4) (real) y,1-y in S with s3,s4 *
+* z(4,3:4) (real) z,1-z in S with s3,s4 *
+* dyz(2,2,3:4) (real) y - z *
+* d2yzz(3:4) (real) 2*y - z+ - z- *
+* dy2z(4,3:4) (real) y - 2*z *
+* dyzzy(4) (real) y(i,4)*z(i,4)-y(i,3)*z(i,4) *
+* xpi(6,3:4) (real) usual *
+* piDpj(6,3:4) (real) usual *
+* cs3(40) (complex) assumed zero. *
+* *
+* output: cs3(40) (complex) mod factors pi^2/12, in array *
+* ipi12(6)(integer) these factors *
+* isoort(6)(integer) returns kind of action taken *
+* ier (integer) 0=ok 1=inaccurate 2=error *
+* *
+* calls: ffcrr,ffcxr,real/dble,DCMPLX,log,ffadd1,ffadd2,ffadd3 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cs3(100)
+ DOUBLE PRECISION y(4,3:4),z(4,3:4),dyz(2,2,3:4),d2yzz(3:4),
+ + dy2z(4,3:4),dyzzy(4),xpi(6,3:4),piDpj(6,6,3:4)
+ integer ipi12(10),ii,ns,isoort(10),ier
+*
+* local variables
+*
+ integer i,j,k,l,m,ier0,iepsi(4),iepsj(2,2),ipi12p(4),ipitot,
+ + ipitop
+ logical normal
+ DOUBLE COMPLEX cs1,cs2,cs1p,cs2p,cs3p(40),c
+ DOUBLE PRECISION yy,zz,yy1,zz1,dyyzz,hulp3,hulp4,absc,xhck,xmax,
+ + rloss,xm1,xm2,xm1p,xm2p,x00(3)
+ save iepsi
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data iepsi /-2,+2,+2,-2/
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) +abs(DIMAG(c))
+*
+* check constants
+ if ( ltest .and. ns .ne. 6 ) print *,'ffdcxs: error: ns <> 6'
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ if ( lwrite ) print *,'rloss = ',rloss
+ do 2 k=3,4
+ do 1 i=1,2
+ xhck = y(i,k) + y(i+2,k) - 1
+ xmax = max(abs(y(i,k)),x1)
+ if ( rloss*xhck .gt. precx*xmax ) print *,'ffdcxs:',
+ + ' error: 1 - y(',i,k,') <> 1-y(',i,k,'): ',
+ + y(i,k),y(i+2,k),xhck
+ xhck = z(i,k) + z(i+2,k) - 1
+ xmax = max(abs(z(i,k)),x1)
+ if ( rloss*xhck .gt. precx*xmax ) print *,'ffdcxs:',
+ + ' error: 1 - z(',i,k,') <> 1-z(',i,k,'): ',
+ + z(i,k),z(i+2,k),xhck
+ xhck = dyz(2,i,k) - y(2,k) + z(i,k)
+ xmax = max(abs(y(2,k)),abs(z(i,k)))
+ if ( rloss*xhck .gt. precx*xmax ) print *,'ffdcxs:',
+ + ' error: dyz(2',i,k,')<>y(2',k,')-z(',i,k,'): ',
+ + dyz(2,i,k),y(2,k),z(i,k),xhck
+ xhck = dy2z(i,k) - y(2,k) + 2*z(i,k)
+ xmax = max(abs(y(2,k)),2*abs(z(i,k)))
+ if ( rloss*xhck .gt. precx*xmax ) print *,'ffdcxs:',
+ + ' error: dy2z(',i,k,')<>y(2',k,')-2*z(',i,k,
+ + '): ',dy2z(i,k),y(2,k),2*z(i,k),xhck
+ xhck = dy2z(i+2,k) - y(4,k) + 2*z(i+2,k)
+ xmax = max(abs(y(4,k)),2*abs(z(i+2,k)))
+ if ( rloss*xhck .gt. precx*xmax ) print *,'ffdcxs:',
+ + ' error: dy2z(',i+2,k,')<>y(4',k,')-2z(',i+2,k,
+ + '): ',dy2z(i+2,k),y(4,k),2*z(i+2,k),xhck
+ l = 2*k+i - 6
+ m = 2*(k/2)
+ xhck = dyzzy(l) - y(m,4)*z(m+i-2,3) +
+ + y(m,3)*z(m+i-2,4)
+ xmax = max(abs(dyzzy(l)),abs(y(m,4)*z(m+i-2,3)))
+ if ( rloss*xhck .gt. precx*xmax ) print *,'ffdcxs:',
+ + ' error: dyzzy(',l,') <> ...',dyzzy(l),
+ + y(m,4)*z(m+i-2,3),y(m,3)*z(m+i-2,4),xhck
+ 1 continue
+ 2 continue
+ endif
+* #] check input:
+* #[ normal case:
+ normal = .FALSE.
+ 10 continue
+ if ( normal .or. isoort(1) .ne. isoort(9) .or. isoort(1) .lt.
+ + 10 ) then
+ if ( lwrite ) print *,'ffdcxs: normal case'
+ call ffcxs3(cs3( 1),ipi12(1),y(1,3),z(1,3),dyz(1,1,3),
+ + d2yzz(3),dy2z(1,3),xpi(1,3),piDpj(1,1,3),ii,6,
+ + isoort(1),ier)
+ call ffcxs3(cs3(81),ipi12(9),y(1,4),z(1,4),dyz(1,1,4),
+ + d2yzz(4),dy2z(1,4),xpi(1,4),piDpj(1,1,4),ii,6,
+ + isoort(9),ier)
+ return
+ endif
+* #] normal case:
+* #[ rotate R's:
+ if ( abs(y(2,3)) .lt. 1/xloss ) then
+ if ( lwrite ) print *,'ffdcxs: rotating R''s'
+ do 102 i=1,2
+ do 101 j=1,2
+* iepsi() = /-2,+2,+2,-2/
+* BUT I AM NOT YET SURE OF THE SIGNS (29/6/89)
+ k = 2*(i-1)+j
+ if ( y(2*i,3) .gt. 0 ) then
+ iepsj(j,i) = iepsi(k)
+ else
+ iepsj(j,i) = -iepsi(k)
+ endif
+ if ( y(2*i,3) .gt. 0 .neqv. y(2*i,4) .gt. 0 ) then
+* I have no clue to the ieps, take normal route
+* iepsj(j,i) = 0
+ if ( lwrite ) print *,'ffdcxs: don''t know ieps ',i
+ normal = .TRUE.
+ goto 10
+ endif
+ 101 continue
+ 102 continue
+* loop over y,z , 1-y,1-z
+ do 120 i=1,2
+* loop over z+ , z-
+ do 110 j=1,2
+ if ( j .eq. 2 ) then
+* do not calculate if not there (isoort=0, one root)
+* (this is probably not needed as this case should
+* have been dealt with in ffdxc0)
+ if ( isoort(9) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdcxs: isoort(9).eq.0, not needed'
+ endif
+ goto 110
+ endif
+* or if not needed (isoort=2, two equal roots)
+ if ( mod(isoort(9),10) .eq. 2 ) then
+ if ( lwrite ) print *,'ffdcxs: skipped next ',
+ + 'R as it is equal'
+* we use that l still contains the correct value
+ do 105 m=1,7
+ cs3(10*(l-1)+m) = 2*DBLE(cs3(10*(l-1)+m))
+ 105 continue
+ ipi12(l) = 2*ipi12(l)
+ goto 110
+ endif
+ endif
+ k = 2*(i-1)+j
+ l = 8*(i-1)+j
+ if ( dyzzy(k) .ne. 0 ) then
+* minus sign wrong in thesis (2.78)
+ hulp3 = -dyz(2,j,3)/dyzzy(k)
+ hulp4 = +dyz(2,j,4)/dyzzy(k)
+ yy = y(2*i,3)*hulp4
+ yy1 = y(2*i,4)*hulp3
+ zz = z(k,3)*hulp4
+ zz1 = z(k,4)*hulp3
+ dyyzz = dyz(2,j,3)*hulp4
+ if ( i .eq. 2 ) then
+ yy = -yy
+ yy1 = -yy1
+ zz = -zz
+ zz1 = -zz1
+ endif
+* if ( ltest ) then
+* if ( rloss*abs(yy+yy1-1) .gt. precx*max(abs(yy),
+* + x1) ) print *,'ffdcxs: error: 1 - yy ',
+* + '<> yy1',yy,yy1,yy+yy1-1
+* if ( rloss*abs(zz+zz1-1) .gt. precx*max(abs(zz),
+* + x1) ) print *,'ffdcxs: error: 1 - zz ',
+* + '<>zz1',zz,zz1,zz+zz1-1
+* if ( rloss*abs(dyyzz-yy+zz) .gt. precx*max(abs(
+* + yy),abs(zz)) ) print *,'ffdcxs: error:',
+* ' dyyzz<>yy-zz',dyyzz,yy,zz,dyyzz-yy+zz
+* endif
+ if ( lwrite ) then
+ do 109 m=3,4
+ print *,'arg1',m,' was ',+y(2,m)/dyz(2,k,m)
+ print *,'arg2',m,' was ',-y(4,m)/dyz(2,k,m)
+ 109 continue
+ print *,'arg1',m,' is ',+yy/dyyzz
+ print *,'arg2',m,' is ',-yy1/dyyzz
+ endif
+ call ffcxr(cs3(10*l-9),ipi12(l),yy,yy1,zz,zz1,dyyzz,
+ + .FALSE.,x0,x0,x0,.FALSE.,x00,iepsj(j,i),ier)
+ else
+ if ( lwrite ) print *,' y(4)z(3)-y(3)z(4)=0 -> S=0'
+ endif
+ 110 continue
+ 120 continue
+ goto 800
+ endif
+* #] rotate R's:
+* #[ other cases (not ready):
+ if ( lwrite ) print *,'ffdcxs: warning: special case not',
+ + ' yet implemented, trying normal route'
+ call ffcxs3(cs3( 1),ipi12(1),y(1,3),z(1,3),dyz(1,1,3),
+ + d2yzz(3),dy2z(1,3),xpi(1,3),piDpj(1,1,3),ii,ns,
+ + isoort(1),ier)
+ call ffcxs3(cs3(81),ipi12(9),y(1,4),z(1,4),dyz(1,1,4),
+ + d2yzz(4),dy2z(1,4),xpi(1,4),piDpj(1,1,4),ii,ns,
+ + isoort(9),ier)
+ return
+* #] other cases (not ready):
+* #[ debug:
+ 800 if ( lwrite ) then
+ ier0 = 0
+ do 805 i=1,40
+ cs3p(i) = 0
+ 805 continue
+ print '(a)',' #[ compare: '
+ call ffcxs3(cs3p( 1),ipi12p(1),y(1,3),z(1,3),dyz(1,1,3),
+ + d2yzz(3),dy2z(1,3),xpi(1,3),piDpj(1,1,3),ii,ns,
+ + isoort(1),ier0)
+ call ffcxs3(cs3p(21),ipi12p(3),y(1,4),z(1,4),dyz(1,1,4),
+ + d2yzz(4),dy2z(1,4),xpi(1,4),piDpj(1,1,4),ii,ns,
+ + isoort(9),ier0)
+ print '(a)',' #] compare: '
+ cs1 = 0
+ cs2 = 0
+ cs1p = 0
+ cs2p = 0
+ xm1 = 0
+ xm2 = 0
+ xm1p = 0
+ xm2p = 0
+ do 810 i=1,20
+ cs1 = cs1 + cs3(i)
+ xm1 = max(xm1,absc(cs1))
+ cs2 = cs2 + cs3(i+80)
+ xm2 = max(xm2,absc(cs2))
+ cs1p = cs1p + cs3p(i)
+ xm1p = max(xm1p,absc(cs1p))
+ cs2p = cs2p + cs3p(i+20)
+ xm2p = max(xm2p,absc(cs2p))
+ 810 continue
+ ipitot = ipi12(1) + ipi12(2) - ipi12(9) - ipi12(10)
+ ipitop = ipi12p(1) + ipi12p(2) - ipi12p(3) - ipi12p(4)
+ 1000 format(2g24.16,g12.4)
+ print *,'ffdcxs: compare:'
+ print *,' Originally:'
+ print 1000,cs1p,xm1p
+ print 1000,-cs2p,xm2p
+ if ( ipitot .ne. 0 ) print 1000,ipitot*pi12,0.
+ print *,'+ ------------'
+ print 1000,cs1p-cs2p+ipitot*DBLE(pi12),max(xm1p,xm2p)
+ print *,' Now:'
+ print 1000,cs1,xm1
+ print 1000,-cs2,xm2
+ if ( ipitop .ne. 0 ) print 1000,ipitop*pi12,0.
+ print *,'+ ------------'
+ print 1000,cs1-cs2+ipitop*DBLE(pi12),max(xm1,xm2)
+ endif
+* #] debug:
+*###] ffdcxs:
+ end
+*###[ ffdcs:
+ subroutine ffdcs(cs3,ipi12,cy,cz,cdyz,cd2yzz,cdyzzy,cdyyzz,
+ + cpi,cpiDpj,ii,ns,isoort,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the the difference of two S's with cy(3,4),cz(3,4), *
+* cy(4)cz(3)-cy(3)cz(4) given. Note the difference with ffdcs4, *
+* in which the cy's are the same and only the cz's different. *
+* Here both can be different. Also we skip an intermediat *
+* level. *
+* *
+* input: cy(4,3:4) (complex) cy,1-cy in S with s3,s4 *
+* cz(4,3:4) (complex) cz,1-cz in S with s3,s4 *
+* cdyz(2,2,3:4)(complex) cy - cz *
+* cd2yzz(3:4) (complex) 2*cy - cz+ - cz- *
+* cdyzzy(4) (complex) cy(i,4)*cz(i,4)-cy(i,3)*cz(i,4) *
+* cdyyzz(2) (complex) cy(i,4)-cz(i,4)-cy(i,3)+cz(i,4) *
+* cpi(6,3:4) (complex) usual *
+* cpiDpj(6,3:4)(complex) usual *
+* cs3(40) (complex) assumed zero. *
+* *
+* output: cs3(40) (complex) mod factors pi^2/12, in array *
+* ipi12(6) (integer) these factors *
+* isoort(6) (integer) returns kind of action taken *
+* ier (integer) number of digits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cs3(100)
+ DOUBLE COMPLEX cy(4,3:4),cz(4,3:4),cdyz(2,2,3:4),cd2yzz(3:4),
+ + cdyzzy(4),cdyyzz(2),cpi(6,3:4),cpiDpj(6,6,3:4)
+ integer ipi12(10),ii,ns,isoort(10),ier
+*
+* local variables
+*
+ integer i,j,k,l,m,n,ier0,ieps,ni(4,3:4),ntot(3:4),
+ + n1a,n1b,ii1,nffeta,nffet1,i2pi,n2a,ip,ipi12p(4),ipitot,
+ + ipitop
+ DOUBLE COMPLEX cs1,cs2,cs1p,cs2p,cs3p(40),c,cc,clogy,zfflog,
+ + zfflo1,cmip,yy,zz,yy1,zz1,dyyzz,hulp3,hulp4,xhck
+ DOUBLE PRECISION rloss,xm1,xm2,xm1p,xm2p,absc,xmax,s1,s2,s3,s4,
+ + y1m,y1m1,y1p,y1p1
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) +abs(DIMAG(c))
+*
+* check constants
+ if ( ltest .and. ns .ne. 6 ) print *,'ffdcs: error: ns <> 6'
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ rloss = xloss*DBLE(10)**(-mod(ier,50)-2)
+ if ( lwrite ) print *,'rloss = ',rloss
+ do 20 k=3,4
+ do 10 i=1,2
+ xhck = cy(i,k) + cy(i+2,k) - 1
+ xmax = max(absc(cy(i,k)),x1)
+ if ( rloss*absc(xhck) .gt. precc*xmax )
+ + print *,'ffdcs: error: 1 - cy(',i,k,') <> 1-cy('
+ + ,i,k,'): ',cy(i,k),cy(i+2,k),xhck
+ xhck = cz(i,k) + cz(i+2,k) - 1
+ xmax = max(absc(cz(i,k)),x1)
+ if ( rloss*absc(xhck) .gt. precc*xmax )
+ + print *,'ffdcs: error: 1 - cz(',i,k,') <> 1-cz('
+ + ,i,k,'): ',cz(i,k),cz(i+2,k),xhck
+ xhck = cdyz(2,i,k) - cy(2,k) + cz(i,k)
+ xmax = max(absc(cy(2,k)),absc(cz(i,k)))
+ if ( rloss*absc(xhck) .gt. precc*xmax )
+ + print *,'ffdcs: error: cdyz(2',i,k,')<>cy(2',k,
+ + ')-cz(',i,k,'): ',cdyz(2,i,k),cy(2,k),cz(i,k),
+ + xhck
+ l = 2*k+i - 6
+ m = 2*(k/2)
+ xhck = cdyzzy(l) - cy(m,4)*cz(m+i-2,3) +
+ + cy(m,3)*cz(m+i-2,4)
+ xmax =max(absc(cdyzzy(l)),absc(cy(m,4)*cz(m+i-2,3)))
+ if ( rloss*absc(xhck) .gt. precc*xmax )
+ + print *,'ffdcs: error: cdyzzy(',l,') <> ...',
+ + cdyzzy(l),cy(m,4)*cz(m+i-2,3),cy(m,3)*cz(m+i-2,4
+ + ),xhck,ier
+ 10 continue
+ 20 continue
+ endif
+* #] check input:
+* #[ normal case:
+ if ( mod(isoort(1),5).ne.mod(isoort(9),5) .or. isoort(1).gt.-5
+ + ) then
+ if ( lwrite ) print *,'ffdcs: normal case'
+ if ( ltest .and. isoort(1) .le. -100 ) then
+ print *,'ffdcs: error: wrong value for isoort'
+ endif
+ call ffcs3(cs3( 1),ipi12(1),cy(1,3),cz(1,3),cdyz(1,1,3),
+ + cd2yzz(3),cpi(1,3),cpiDpj(1,1,3),ii,6,isoort(1),ier)
+ call ffcs3(cs3(81),ipi12(9),cy(1,4),cz(1,4),cdyz(1,1,4),
+ + cd2yzz(4),cpi(1,4),cpiDpj(1,1,4),ii,6,isoort(9),ier)
+ return
+ endif
+* #] normal case:
+* #[ rotate R's:
+ if ( absc(cy(2,3)) .lt. 1/xloss .or. isoort(1) .le. -100 ) then
+ if ( lwrite ) print *,'ffdcs: rotated R''s'
+*
+* loop over cy,cz , 1-cy,1-cz
+ do 190 i=1,2
+
+ if ( isoort(1).le.-100 .and. i.eq.2 ) then
+*
+* special case del2s=0, a limit has been taken
+*
+ if ( ii .eq. 2 ) then
+*
+* we took the wrong sign for the dilogs...
+*
+ do 110 j=1,20
+ cs3(j) = -cs3(j)
+ 110 continue
+ ipi12(1) = -ipi12(1)
+ ipi12(2) = -ipi12(2)
+ endif
+*
+* now the remaining logs. take care to get the ieps
+* correct!
+*
+ if ( i.eq.1 .eqv. DBLE(cy(2*i,3)).gt.0 ) then
+ ieps = -3
+ else
+ ieps = +3
+ endif
+ call ffclg2(cs3(81),ipi12(9),cy(2,3),cz(1,3),
+ + cdyz(2,1,3),cy(2,4),cz(1,4),cdyz(2,1,4),
+ + cdyyzz(1),isoort(1),isoort(9),ii,ieps,ier)
+ if ( ii .eq. 2 ) then
+* we have the wrong sign
+ do 120 j=81,83
+ cs3(j) = -cs3(j)
+ 120 continue
+ ipi12(9) = -ipi12(9)
+ endif
+ if ( mod(isoort(1),5).eq.0 .and. mod(isoort(9),5).eq.0
+ + ) then
+ if ( lwrite ) print *,'ffdcs: skipped other logs ',
+ + 'as they are the complex conjugate'
+ do 130 j=81,83
+ cs3(j) = 2*DBLE(cs3(j))
+ 130 continue
+ ipi12(9) = 2*ipi12(9)
+ else
+ print *,'ffdcs: error: not yet tested'
+ call ffclg2(cs3(91),ipi12(10),cy(2,3),cz(2,3),
+ + cdyz(2,2,3),cy(2,4),cz(2,4),cdyz(2,2,4),
+ + cdyyzz(2),isoort(1),isoort(9),ii,-ieps,ier)
+ if ( ii .eq. 2 ) then
+* we have the wrong sign
+ do 140 j=91,93
+ cs3(j) = -cs3(j)
+ 140 continue
+ ipi12(10) = -ipi12(10)
+ endif
+ endif
+ goto 190
+ endif
+*
+* loop over cz- , cz+
+ do 180 j=1,2
+ if ( j .eq. 2 ) then
+ if ( isoort(9) .eq. 0 .or. isoort(1) .eq. 0 ) then
+*
+* (this is not correct as this case should
+* have been dealt with in ffdxc0,ffdcc0)
+*
+ call fferr(79,ier)
+ goto 180
+ elseif ( mod(isoort(9),5) .eq. 0 .and.
+ + mod(isoort(1),5) .eq. 0 ) then
+*
+* or if not needed (isoort=-10, two conjugate roots)
+*
+ if ( lwrite ) print *,'ffdcs: skipped next ',
+ + 'R as it is the conjugate'
+* we use that l still contains the correct value
+ do 150 m=1,9
+ cs3(10*(l-1)+m) = 2*DBLE(cs3(10*(l-1)+m))
+ 150 continue
+ ipi12(l) = 2*ipi12(l)
+ goto 180
+ elseif ( mod(isoort(9),10) .eq. 2 ) then
+ if ( lwrite ) print *,'ffdcs: skipped next ',
+ + 'R as it is equal'
+* we use that l still contains the correct value
+ do 160 m=1,9
+ cs3(10*(l-1)+m) = 2*cs3(10*(l-1)+m)
+ 160 continue
+ ipi12(l) = 2*ipi12(l)
+ goto 180
+ endif
+ endif
+ k = 2*(i-1)+j
+ l = 8*(i-1)+j
+ if ( cdyzzy(k) .ne. 0 ) then
+ hulp3 = -cdyz(2,j,3)/cdyzzy(k)
+ hulp4 = cdyz(2,j,4)/cdyzzy(k)
+ yy = cy(2*i,3)*hulp4
+ yy1 = cy(2*i,4)*hulp3
+ zz = cz(k,3)*hulp4
+ zz1 = cz(k,4)*hulp3
+ dyyzz = cdyz(2,j,3)*hulp4
+ if ( i .eq. 2 ) then
+ yy = -yy
+ yy1 = -yy1
+ zz = -zz
+ zz1 = -zz1
+ endif
+*
+* ieps = 3 means: dear ffcrr, do not use eta terms,
+* they are calculated here. The sign gives the sign
+* of the imag. part of the argument of the dilog, not
+* y-z.
+*
+ if ( i.eq.1 .eqv. j.eq.1 .eqv. DBLE(cy(2*i,3)).gt.0
+ + ) then
+ ieps = -3
+ else
+ ieps = +3
+ endif
+ call ffcrr(cs3(10*l-9),ipi12(l),yy,yy1,zz,zz1,dyyzz,
+ + .FALSE.,c0,c0,c0,isoort(j),ieps,ier)
+*
+* eta terms of the R's (eta(.)*log(c1)-eta(.)*log(c2))
+*
+ do 170 m=3,4
+* no eta terms in the real case
+ if ( DIMAG(cz(k,m)) .eq. 0 .and.
+ + DIMAG(cdyz(2,j,m)) .eq. 0 ) then
+ ni(k,m) = 0
+ elseif ( i .eq. 1 ) then
+ ni(k,m) = nffeta(-cz(k,m),1/cdyz(2,j,m),ier)
+ else
+ ni(k,m) = nffeta(cz(k,m),1/cdyz(2,j,m),ier)
+ endif
+ 170 continue
+ if ( ni(k,3) .ne. 0 .or. ni(k,4) .ne. 0 ) then
+ if ( lwrite ) print *,'n3,n4: ',ni(k,3),ni(k,4)
+ if ( ni(k,3) .ne. ni(k,4) ) then
+ do 175 m=3,4
+ c = cy(2*i,m)/cdyz(2,j,m)
+ if ( i .eq. 2 ) c = -c
+ cc = c-1
+ if ( absc(cc) .lt. xloss ) then
+ if ( lwrite ) print *,'c = ',c
+ c = cz(k,m)/cdyz(2,j,m)
+ if ( lwrite ) print *,'c+= ',1-c
+ clogy = zfflo1(c,ier)
+ else
+ clogy = zfflog(c,0,c0,ier)
+ endif
+ n = 10*l + (m-3) - 2
+ if ( ltest .and. cs3(n) .ne. 0 ) then
+ print *,'ffdcs: error: cs3(',n,
+ + ') != 0'
+ endif
+ if ( m .eq. 3 ) then
+ cs3(n) = + ni(k,m)*c2ipi*clogy
+ else
+ cs3(n) = - ni(k,m)*c2ipi*clogy
+ endif
+ if ( lwrite ) then
+ print *,'eta',n,'= ',ni(k,m)*c2ipi*clogy
+ if ( m .eq. 4 ) print *,'som = ',cs3(n)
+ + + cs3(n-1)
+ endif
+ 175 continue
+ else
+ if ( i .eq. 1 ) then
+ n1a = nffeta(cy(k,3)/cdyz(2,j,3),
+ + cdyz(2,j,4)/cy(k,4),ier)
+ else
+ n1a = nffeta(-cy(k,3)/cdyz(2,j,3),
+ + -cdyz(2,j,4)/cy(k,4),ier)
+ endif
+ if ( n1a .ne. 0 ) then
+ call fferr(80,ier)
+ endif
+ c =cy(k,3)*cdyz(2,j,4)/(cdyz(2,j,3)*cy(k,4))
+ cc = c-1
+ if ( absc(cc) .lt. xloss ) then
+ if ( lwrite ) print *,'1-c = ',1-c
+ c = -cdyzzy(k)/(cdyz(2,j,3)*cy(k,4))
+ if ( lwrite ) print *,'1-c+= ',c
+ clogy = zfflo1(c,ier)
+ else
+ clogy = zfflog(c,0,c0,ier)
+ endif
+ n = 10*l - 2
+ if ( ltest .and. cs3(n) .ne. 0 ) then
+ print *,'ffdcs: error: cs3(',n,') not 0'
+ endif
+ if ( i .eq. 1 ) then
+ cs3(n) = +ni(k,3)*c2ipi*clogy
+ else
+ cs3(n) = -ni(k,3)*c2ipi*clogy
+ endif
+ if ( lwrite ) print *,'both etas ',cs3(n)
+ endif
+ endif
+ else
+ if ( lwrite ) print *,' cy(4)cz(3)-cy(3)cz(4)=0',
+ + ' -> S=0'
+ endif
+ 180 continue
+ 190 continue
+ goto 700
+ endif
+* #] rotate R's:
+* #[ other cases (not ready):
+ if ( lwrite ) print *,'ffdcs: warning: special case not',
+ + ' yet implemented, trying normal route'
+ call ffcs3(cs3( 1),ipi12(1),cy(1,3),cz(1,3),cdyz(1,1,3),
+ + cd2yzz(3),cpi(1,3),cpiDpj(1,1,3),ii,ns,isoort(1),ier)
+ call ffcs3(cs3(81),ipi12(9),cy(1,4),cz(1,4),cdyz(1,1,4),
+ + cd2yzz(4),cpi(1,4),cpiDpj(1,1,4),ii,ns,isoort(9),ier)
+ return
+* #] other cases (not ready):
+* #[ get eta's:
+ 700 continue
+ ip = ii+3
+ do 740 k=3,4
+ l = 8*(k-3) + 1
+ if ( DIMAG(cpi(ip,k)) .eq. 0 ) then
+*
+* complex because of a complex root in y or z
+*
+ if ( (mod(isoort(l),10).eq.-1 .or. mod(isoort(l),10).eq.-3)
+ + .and. isoort(l+1) .ne. 0 ) then
+*
+* isoort = -1: y is complex, possibly z as well
+* isoort = -3: y,z complex, but (y-z-)(y-z+) real
+* isoort = 0: y is complex, one z root only
+* isoort = -10: y is real, z is complex
+* isoort = -5,-6: y,z both real
+*
+ cmip = DCMPLX(DBLE(x0),-DBLE(cpi(ip,k)))
+ if ( DIMAG(cz(1,k)) .eq. 0 ) then
+ ni(1,k) = 0
+ else
+ ni(1,k) = nffet1(-cz(1,k),-cz(2,k),cmip,ier)
+ i = nffet1(cz(3,k),cz(4,k),cmip,ier)
+ if ( i .ne. ni(1,k) ) call fferr(53,ier)
+ endif
+ ni(2,k) = 0
+ if ( DBLE(cd2yzz(k)).eq.0 .and. ( DIMAG(cz(1,k)).eq.0 .and.
+ + DIMAG(cz(2,k)).eq.0 .or. DBLE(cdyz(2,1,k)).eq.0 .and.
+ + DBLE(cdyz(2,2,k)) .eq. 0 ) ) then
+* follow the i*epsilon prescription as (y-z-)(y-z+) real
+ if ( DBLE(cpi(ip,k)) .lt. 0 ) then
+ ni(3,k) = -1
+ else
+ ni(3,k) = 0
+ endif
+ ni(4,k) = -nffet1(cdyz(2,1,k),cdyz(2,2,k),cmip,ier)
+ else
+ if ( DBLE(cpi(ip,k)) .lt. 0 .and. DIMAG(cdyz(2,1,k)*
+ + cdyz(2,2,k)) .lt. 0 ) then
+ ni(3,k) = -1
+ else
+ ni(3,k) = 0
+ endif
+ ni(4,k) = -nffeta(cdyz(2,1,k),cdyz(2,2,k),ier)
+ endif
+ elseif ( (mod(isoort(l),10).eq.-1 .or. mod(isoort(l),10).eq.-3)
+ + .and. isoort(l+1).eq.0 ) then
+ ni(1,k) = 0
+ if ( DIMAG(cz(1,k)) .ne. 0 ) then
+ ni(2,k) = nffet1(-cpiDpj(ii,ip,k),-cz(1,k),DCMPLX(DBLE(0
+ + ),DBLE(-1)),ier)
+ else
+ ni(2,k) = nffet1(-cpiDpj(ii,ip,k),DCMPLX(DBLE(0),
+ + DBLE(1)),DCMPLX(DBLE(0),DBLE(-1)),ier)
+ endif
+ ni(3,k) = 0
+ ni(4,k) = -nffeta(-cpiDpj(ii,ip,k),cdyz(2,1,k),ier)
+ else
+ if ( mod(isoort(l),5).ne.0 .and. mod(isoort(l),5).ne.-1
+ + .and. mod(isoort(l),5).ne.-3 ) then
+ call fferr(81,ier)
+ print *,'isoort(',l,') = ',isoort(l)
+ endif
+ ni(1,k) = 0
+ ni(2,k) = 0
+ ni(3,k) = 0
+ ni(4,k) = 0
+ endif
+ else
+ print *,'ffdcs: error: cpi complex should not occur'
+ stop
+ endif
+ 740 continue
+ if ( lwrite ) then
+ print *,'ffdcs: eta''s are: '
+ print *,'s3: ',(ni(i,3),i=1,4)
+ print *,'s4: ',(ni(i,4),i=1,4)
+ endif
+* #] get eta's:
+* #[ add eta's:
+ do 750 k=3,4
+ ntot(k) = ni(1,k)+ni(2,k)+ni(3,k)+ni(4,k)
+ 750 continue
+ if ( ntot(3) .ne. 0 .and. ntot(3) .eq. ntot(4) ) then
+ if ( lwrite ) print *,'ffdcs: warning: could be smarter...'
+ endif
+ do 760 k=3,4
+ if ( ntot(k) .ne. 0 ) call ffclgy(cs3(20+80*(k-3)),
+ + ipi12(2+8*(k-3)),ni(1,k),cy(1,k),cz(1,k),cd2yzz(k),ier)
+ 760 continue
+* #] add eta's:
+* #[ debug:
+ 800 if ( lwrite ) then
+ ier0 = 0
+ do 805 i=1,40
+ cs3p(i) = 0
+ 805 continue
+ do 806 i=1,4
+ ipi12p(i) = 0
+ 806 continue
+ if ( isoort(1) .gt. -100 ) then
+ print '(a)',' #[ compare: '
+ call ffcs3(cs3p( 1),ipi12p(1),cy(1,3),cz(1,3),cdyz(1,1,3
+ + ),cd2yzz(3),cpi(1,3),cpiDpj(1,1,3),ii,ns,
+ + isoort(1),ier0)
+ call ffcs3(cs3p(21),ipi12p(3),cy(1,4),cz(1,4),cdyz(1,1,4
+ + ),cd2yzz(4),cpi(1,4),cpiDpj(1,1,4),ii,ns,
+ + isoort(9),ier0)
+ print '(a)',' #] compare: '
+ endif
+ cs1 = 0
+ cs2 = 0
+ cs1p = 0
+ cs2p = 0
+ xm1 = 0
+ xm2 = 0
+ xm1p = 0
+ xm2p = 0
+ do 810 i=1,20
+ cs1 = cs1 + cs3(i)
+ xm1 = max(xm1,absc(cs1))
+ cs2 = cs2 + cs3(i+80)
+ xm2 = max(xm2,absc(cs2))
+ cs1p = cs1p + cs3p(i)
+ xm1p = max(xm1p,absc(cs1p))
+ cs2p = cs2p + cs3p(i+20)
+ xm2p = max(xm2p,absc(cs2p))
+ 810 continue
+ ipitot = ipi12(1) + ipi12(2) - ipi12(9) - ipi12(10)
+ ipitop = ipi12p(1) + ipi12p(2) - ipi12p(3) - ipi12p(4)
+ 1000 format(2g24.16,g12.4)
+ print *,'ffdcs: compare:'
+ print *,' Originally:'
+ print 1000,cs1p,xm1p
+ print 1000,-cs2p,xm2p
+ if ( ipitop .ne. 0 ) print 1000,ipitop*DBLE(pi12),0.
+ print *,'+ ------------'
+ print 1000,cs1p-cs2p+ipitop*DBLE(pi12),max(xm1p,xm2p)
+ print *,' Now:'
+ print 1000,cs1,xm1
+ print 1000,-cs2,xm2
+ if ( ipitot .ne. 0 ) print 1000,ipitot*pi12,0.
+ print *,'+ ------------'
+ print 1000,cs1-cs2+ipitot*DBLE(pi12),max(xm1,xm2)
+ endif
+* #] debug:
+*###] ffdcs:
+ end
+*###[ ffclg2:
+ subroutine ffclg2(cs3,ipi12,cy3,cz3,cdyz3,cy4,cz4,cdyz4,cdyyzz,
+ + isort3,isort4,ii,ieps,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the finite part of the divergent dilogs in case *
+* del2s=0. These are given by *
+* *
+* log^2(-cdyz3)/2 - log^2(-cdyz4)/2 *
+* *
+* Note that often we only need the imaginary part, which may be *
+* very unstable even if the total is not. *
+* *
+* *
+* Input: cy3,cz3,cdyz3 (complex) y,z,diff in C with s3 *
+* cy4,cz4,cdyz4 (complex) y,z,diff in C with s4 *
+* cdyyzz (complex) y4 - z4 - y3 + z3 *
+* isort3,4 (integer) *
+* *
+* Output cs3(4) (complex) output *
+* ipi12 (integer) terms pi^2/12 *
+* ier (integer) error flag *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cs3(3),cy3(3),cz3(3),cdyz3,cy4(3),cz4(3),cdyz4,
+ + cdyyzz
+ integer ipi12,ieps,ier,isort3,isort4,ii
+*
+* local variables
+*
+ integer n1,nffeta,nffet1,ipi3,ipi4
+ DOUBLE COMPLEX c,cc,chck,clog3,clog4,clog1,zfflo1,cipi
+ DOUBLE PRECISION absc,rloss
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( abs(ieps) .ne. 3 ) print *,'ffclg2: error: |ieps| <> 3'
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ if ( cs3(1) .ne. c0 .or. cs3(2) .ne. c0 .or. cs3(3) .ne. c0)
+ + print *,'ffclg2: error: cs3 <> 0',cs3
+ chck = cz3(1) + cz3(3) - 1
+ if ( rloss*absc(chck) .gt. precc*max(x1,absc(cz3(1))) )
+ + print *,'ffclg2: error: 1 - cz3 <> (1-cz3)',cz3(1),cz3(3
+ + ),chck
+ chck = cz4(1) + cz4(3) - 1
+ if ( rloss*absc(chck) .gt. precc*max(x1,absc(cz4(1))) )
+ + print *,'ffclg2: error: 1 - cz4 <> (1-cz4)',cz4(1),cz4(3
+ + ),chck
+ chck = cdyz3 - cy3(1) + cz3(1)
+ if ( rloss*absc(chck) .gt. precc*max(absc(cdyz3),absc(cz3(1)
+ + )) ) print *,'ffclg2: error: cdyz3 <> cy3-cz3',
+ + cdyz3,cy3(1),cz3(1),chck
+ chck = cdyz4 - cy4(1) + cz4(1)
+ if ( rloss*absc(chck) .gt. precc*max(absc(cdyz4),absc(cz4(1)
+ + )) ) print *,'ffclg2: error: cdyz4 <> cy4-cz4',
+ + cdyz4,cy4(1),cz4(1),chck
+ chck = cdyyzz - cy4(1) + cz4(1) + cy3(1) - cz3(1)
+ if ( rloss*absc(chck) .gt. precc*max(absc(cy4(1)),absc(cz4(1
+ + )),absc(cy3(1))) ) print *,'ffclg2: error: cdyyzz <> ',
+ + 'terms',cdyyzz,cy4(1),cz4(1),cy3(1),cz3(1),chck
+ endif
+* #] check input:
+* #[ calculations:
+ cipi = DCMPLX(DBLE(x0),DBLE(pi))
+ if ( DBLE(cdyz3) .lt. 0 ) then
+ clog3 = log(-cdyz3)
+ ipi3 = 0
+ else
+ clog3 = log(cdyz3)
+ if ( DIMAG(cdyz3) .gt. 0 ) then
+ ipi3 = -1
+ elseif ( DIMAG(cdyz3) .lt. 0 ) then
+ ipi3 = +1
+ else
+ ipi3 = sign(1,-ieps)
+ endif
+ endif
+ if ( DBLE(cdyz4) .lt. 0 ) then
+ clog4 = log(-cdyz4)
+ ipi4 = 0
+ else
+ clog4 = log(cdyz4)
+ if ( DIMAG(cdyz4) .gt. 0 ) then
+ ipi4 = -1
+ elseif ( DIMAG(cdyz4) .lt. 0 ) then
+ ipi4 = +1
+ else
+ ipi4 = sign(1,-ieps)
+ endif
+ endif
+ cc = clog3-clog4
+ if ( absc(cc) .ge. xloss*absc(clog3) ) then
+ cs3(1) = -(clog3+ipi3*cipi)**2/2
+ cs3(2) = +(clog4+ipi4*cipi)**2/2
+ if ( lwrite ) clog1 = -123
+ else
+ c = cdyyzz/cdyz4
+ clog1 = zfflo1(c,ier)
+*
+* notice that zfflog return log(a-ieps) (for compatibility
+* with the dilog) ^
+*
+ if ( DIMAG(cdyz3) .eq. 0 ) then
+ n1 = nffet1(DCMPLX(DBLE(0),DBLE(-ieps)),-1/cdyz4,-c,
+ + ier)
+ elseif ( DIMAG(cdyz3) .eq. 0 ) then
+ n1 = nffet1(-cdyz3,DCMPLX(DBLE(0),DBLE(ieps)),-c,ier)
+ else
+ n1 = nffeta(-cdyz3,-1/cdyz4,ier)
+ endif
+ if ( n1 .ne. 0 ) then
+ clog1 = clog1 - n1*c2ipi
+ endif
+ cs3(1) = -clog3*clog1/2
+ cs3(2) = -clog4*clog1/2
+ cs3(3) = -(ipi3+ipi4)*cipi*clog1/2
+* we could split off a factor 2*pi^2 if needed
+ endif
+* ATTENTION: now (23-jul-1989) ffdcs assumes that only *3* cs are
+* set. Change ffdcs as well if this is no longer true!
+* #] calculations:
+* #[ debug:
+ if ( lwrite ) then
+ if ( clog1 .ne. -123 ) then
+ print *,'ffclg2: originally:'
+ print '(a,2g24.15)','S3: ',+(clog3+ipi3*cipi)**2/2
+ print '(a,2g24.15)','S4: ',-(clog4+ipi4*cipi)**2/2
+ print '(a,2g24.15,2i6)','sum:',+(clog3+ipi3*cipi)**2/2
+ + -(clog4+ipi4*cipi)**2/2
+ endif
+ print *,'ffclg2: now:'
+ print '(a,2g24.15)','S3: ',-cs3(1)
+ print '(a,2g24.15)','S4: ',-cs3(2)
+ print '(a,2g24.15)','Spi:',-cs3(3)
+ print '(a,2g24.15,2i6)','sum:',-cs3(1)-cs3(2)-cs3(3),-ipi12,
+ + ier
+ endif
+* #] debug:
+*###] ffclg2:
+ end
diff --git a/ff-2.0/ffdel2.f b/ff-2.0/ffdel2.f
new file mode 100644
index 0000000..a9b1ffa
--- /dev/null
+++ b/ff-2.0/ffdel2.f
@@ -0,0 +1,801 @@
+*###[ ffdel2:
+ subroutine ffdel2(del2,piDpj,ns,i1,i2,i3,lerr,ier)
+*************************************************************************
+* calculate in a numerically stable way *
+* del2(piDpj(i1,i1),piDpj(i2,i2),piDpj(i3,i3)) = *
+* = piDpj(i1,i1)*piDpj(i2,i2) - piDpj(i1,i2)^2 *
+* = piDpj(i1,i1)*piDpj(i3,i3) - piDpj(i1,i3)^2 *
+* = piDpj(i2,i2)*piDpj(i3,i3) - piDpj(i2,i3)^2 *
+* ier is the usual error flag. *
+*************************************************************************
+ implicit none
+*
+* arguments:
+*
+ integer ns,i1,i2,i3,lerr,ier
+ DOUBLE PRECISION del2,piDpj(ns,ns)
+*
+* local variables
+*
+ DOUBLE PRECISION s1,s2
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* calculations
+*
+ idsub = idsub + 1
+ if ( abs(piDpj(i1,i2)) .lt. abs(piDpj(i1,i3)) .and.
+ + abs(piDpj(i1,i2)) .lt. abs(piDpj(i2,i3)) ) then
+ s1 = piDpj(i1,i1)*piDpj(i2,i2)
+ s2 = piDpj(i1,i2)**2
+ elseif ( abs(piDpj(i1,i3)) .lt. abs(piDpj(i2,i3)) ) then
+ s1 = piDpj(i1,i1)*piDpj(i3,i3)
+ s2 = piDpj(i1,i3)**2
+ else
+ s1 = piDpj(i2,i2)*piDpj(i3,i3)
+ s2 = piDpj(i2,i3)**2
+ endif
+ del2 = s1 - s2
+ if ( abs(del2) .lt. xloss*s2 ) then
+ if ( lerr .eq. 0 ) then
+* we know we have another chance
+ if ( del2.ne.0 ) then
+ ier = ier + int(log10(xloss*abs(s2/del2)))
+ else
+ ier = ier + int(log10(xloss*abs(s2)/xclogm))
+ endif
+ else
+ if ( lwarn ) call ffwarn(71,ier,del2,s1)
+ endif
+ endif
+*###] ffdel2:
+ end
+*###[ ffdl2p:
+ subroutine ffdl2p(delps1,xpi,dpipj,piDpj,
+ + ip1,ip2,ip3,is1,is2,is3,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* delta_{ip1,is2}^{ip1,ip2} *
+* ier is the usual error flag. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ip1,ip2,ip3,is1,is2,is3,ier
+ DOUBLE PRECISION delps1,xpi(ns),dpipj(ns,ns),piDpj(ns,ns)
+*
+* local variables
+*
+ DOUBLE PRECISION s1,s2,s3,xmax,som
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ stupid tree:
+* 1
+ s1 = xpi(ip1)*piDpj(ip2,is2)
+ s2 = piDpj(ip1,ip2)*piDpj(ip1,is2)
+ delps1 = s1 - s2
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
+ if ( lwrite ) print *,' delps1 = ',delps1,s1,s2
+ som = delps1
+ xmax = abs(s1)
+* 2
+ s1 = piDpj(ip1,ip2)*piDpj(ip3,is2)
+ s2 = piDpj(ip1,ip3)*piDpj(ip2,is2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+1 = ',delps1,s1,s2
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
+ if ( abs(s1) .lt. xmax ) then
+ som = delps1
+ xmax = abs(s1)
+ endif
+* 3
+ s1 = piDpj(ip1,ip3)*piDpj(ip1,is2)
+ s2 = xpi(ip1)*piDpj(ip3,is2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+2 = ',delps1,s1,s2
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
+ if ( abs(s1) .lt. xmax ) then
+ som = delps1
+ xmax = abs(s1)
+ endif
+* 4
+ s1 = xpi(ip1)*piDpj(ip2,is1)
+ s2 = piDpj(ip1,is1)*piDpj(ip1,ip2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+3 = ',delps1,s1,s2
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
+ if ( abs(s1) .lt. xmax ) then
+ som = delps1
+ xmax = abs(s1)
+ endif
+* 5
+ s1 = piDpj(ip1,is2)*piDpj(ip2,is1)
+ s2 = piDpj(ip1,is1)*piDpj(ip2,is2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+4 = ',delps1,s1,s2
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
+ if ( abs(s1) .lt. xmax ) then
+ som = delps1
+ xmax = abs(s1)
+ endif
+* 6
+ s1 = piDpj(ip1,ip2)*piDpj(ip3,is1)
+ s2 = piDpj(ip1,ip3)*piDpj(ip2,is1)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+5 = ',delps1,s1,s2
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
+ if ( abs(s1) .lt. xmax ) then
+ som = delps1
+ xmax = abs(s1)
+ endif
+* 7
+ s1 = piDpj(ip2,is2)*piDpj(ip3,is1)
+ s2 = piDpj(ip2,is1)*piDpj(ip3,is2)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+6 = ',delps1,s1,s2
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
+ if ( abs(s1) .lt. xmax ) then
+ som = delps1
+ xmax = abs(s1)
+ endif
+* 8
+ s1 = piDpj(ip1,ip3)*piDpj(ip1,is1)
+ s2 = xpi(ip1)*piDpj(ip3,is1)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+7 = ',delps1,s1,s2
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
+ if ( abs(s1) .lt. xmax ) then
+ som = delps1
+ xmax = abs(s1)
+ endif
+* 9
+ s1 = piDpj(ip1,is1)*piDpj(ip3,is2)
+ s2 = piDpj(ip1,is2)*piDpj(ip3,is1)
+ delps1 = s1 - s2
+ if ( lwrite ) print *,' delps1+8 = ',delps1,s1,s2
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
+ if ( abs(s1) .lt. xmax ) then
+ som = delps1
+ xmax = abs(s1)
+ endif
+*10 22-nov-1993 yet another one
+ if ( dpipj(1,1).eq.0 ) then
+ s1 = +xpi(ip1)*dpipj(is3,is2)/2
+ s2 = -piDpj(ip1,ip2)*dpipj(is2,is1)/2
+ s3 = +xpi(ip1)*piDpj(ip2,ip3)/2
+ delps1 = s1+s2+s3
+ if ( lwrite ) print *,' delps1+9 = ',delps1,s1,s2,s3
+ if ( abs(delps1) .ge. xloss*max(abs(s1),abs(s2)) ) goto 100
+ if ( max(abs(s1),abs(s2)) .lt. xmax ) then
+ som = delps1
+ xmax = abs(s1)
+ endif
+ endif
+* NO possibility
+ delps1 = som
+ if ( lwarn ) call ffwarn(92,ier,delps1,xmax)
+ if ( lwrite ) then
+ print *,'xpi = ',xpi
+ print *,'ip1,ip2,ip3,is1,is2,is3 = ',ip1,ip2,ip3,is1,is2,is3
+ endif
+ 100 continue
+* #] stupid tree:
+*###] ffdl2p:
+ end
+*###[ ffdl2s:
+ subroutine ffdl2s(delps1,xpi,piDpj,in,jn,jin,isji,
+ + kn,ln,lkn,islk,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* *
+* \delta_{si,sj}^{sk,sl} *
+* *
+* with p(ji) = isji*(sj-si) *
+* p(lk) = islk*(sl-sk) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer in,jn,jin,isji,kn,ln,lkn,islk,ns,ier
+ DOUBLE PRECISION delps1,xpi(ns),piDpj(ns,ns)
+*
+* local variables
+*
+ integer ii,jj,i,j,ji,k,l,lk,ihlp
+ DOUBLE PRECISION s1,s2,som,smax
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( abs(isji) .ne. 1 ) print *,'ffdl2s: error: abs(isji) ',
+ + ' <> 1 but ',isji
+ if ( abs(islk) .ne. 1 ) print *,'ffdl2s: error: abs(islk) ',
+ + ' <> 1 but ',islk
+ endif
+* #] check input:
+* #[ stupid tree:
+ idsub = idsub + 1
+ som = 0
+ smax = 0
+ i = in
+ j = jn
+ ji = jin
+ k = kn
+ l = ln
+ lk = lkn
+ do 20 ii=1,3
+ do 10 jj=1,3
+ s1 = piDpj(i,k)*piDpj(j,l)
+ s2 = piDpj(i,l)*piDpj(j,k)
+ delps1 = s1 - s2
+ if ( ii .gt. 1 ) delps1 = isji*delps1
+ if ( jj .gt. 1 ) delps1 = islk*delps1
+ if ( ii .eq. 3 .neqv. jj .eq. 3 ) delps1 = -delps1
+ if ( abs(delps1) .ge. xloss*abs(s1) ) goto 30
+
+ if ( lwrite ) print *,' delps1+',3*ii+jj-3,'=',delps1,
+ + abs(s1)
+*
+* Save the most accurate estimate so far:
+ if ( ii .eq. 1 .and. jj .eq. 1 .or. abs(s1) .lt. smax
+ + ) then
+ som = delps1
+ smax = abs(s1)
+ endif
+*
+* rotate the jj's
+ if ( lk .eq. 0 ) goto 20
+ ihlp = k
+ k = l
+ l = lk
+ lk = ihlp
+ 10 continue
+*
+* and the ii's
+ if ( ji .eq. 0 ) goto 25
+ ihlp = i
+ i = j
+ j = ji
+ ji = ihlp
+ 20 continue
+ 25 continue
+ delps1 = som
+ if ( lwarn ) call ffwarn(83,ier,delps1,smax)
+ 30 continue
+ if ( lwrite .and. 3*ii+jj-3.ne.1 .and. 3*ii+jj-3.ne.13 )
+ + print *,' delps1+',3*ii+jj-3,'=', delps1,s1,s2
+* #] stupid tree:
+*###] ffdl2s:
+ end
+*###[ ffdl2t:
+ subroutine ffdl2t(delps,piDpj,in,jn,kn,ln,lkn,islk,iss,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* *
+* \delta_{si,sj}^{sk,sl} *
+* *
+* with p(lk) = islk*(iss*sl - sk) (islk,iss = +/-1) *
+* and NO relationship between s1,s2 assumed (so 1/2 the *
+* possibilities of ffdl2s). *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer in,jn,ip1,kn,ln,lkn,islk,iss,ns,ier
+ DOUBLE PRECISION delps,piDpj(ns,ns)
+*
+* local variables
+*
+ integer i
+ DOUBLE PRECISION s1,s2,som,smax,xnul,xlosn
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( abs(islk) .ne. 1 )
+ + print *,'ffdl2i: error: |islk| != 1 ',islk
+ if ( abs(iss) .ne. 1 )
+ + print *,'ffdl2i: error: |iss| != 1 ',iss
+ xlosn = xloss*DBLE(10)**(-1-mod(ier,50))
+ do 10 i=1,ns
+ xnul = islk*iss*piDpj(ln,i) - islk*piDpj(kn,i) -
+ + piDpj(lkn,i)
+ smax = max(abs(piDpj(ln,i)),abs(piDpj(kn,i)))
+ if ( xlosn*abs(xnul) .gt. precx*smax ) then
+ print *,'ffdl2t: error: dotproducts ',islk*iss*ln,
+ + -islk*kn,-lkn,' with ',i,' do not add to 0:',
+ + islk*iss*piDpj(ln,i),-iss*piDpj(kn,i),-piDpj(lkn,i),
+ + xnul,ier
+ endif
+ 10 continue
+ endif
+* #] check input:
+* #[ calculations:
+ if ( in .eq. jn ) then
+ delps = 0
+ return
+ endif
+ s1 = piDpj(kn,in)*piDpj(ln,jn)
+ s2 = piDpj(ln,in)*piDpj(kn,jn)
+ delps = s1 - s2
+ if ( abs(delps) .ge. xloss*abs(s1) ) goto 20
+ if ( lwrite ) print *,' delps = ',delps,s1,-s2
+ som = delps
+ smax = abs(s1)
+
+ s1 = piDpj(kn,in)*piDpj(lkn,jn)
+ s2 = piDpj(lkn,in)*piDpj(kn,jn)
+ delps = iss*islk*(s1 - s2)
+ if ( lwrite ) print *,' delps+ = ',delps,islk,s1,-s2
+ if ( abs(delps) .ge. xloss*abs(s1) ) goto 20
+ if ( abs(s1) .lt. smax ) then
+ som = delps
+ smax = abs(s1)
+ endif
+
+ s1 = piDpj(lkn,in)*piDpj(ln,jn)
+ s2 = piDpj(ln,in)*piDpj(lkn,jn)
+ delps = islk*(- s1 + s2)
+ if ( lwrite ) print *,' delps++= ',delps,islk,-s1,s2
+ if ( abs(delps) .ge. xloss*abs(s1) ) goto 20
+ if ( abs(s1) .lt. smax ) then
+ som = delps
+ smax = abs(s1)
+ endif
+*
+* give up
+*
+ delps = som
+ if ( lwarn ) call ffwarn(93,ier,delps,smax)
+
+ 20 continue
+* #] calculations:
+*###] ffdl2t:
+ end
+*###[ ffdl3m:
+ subroutine ffdl3m(del3mi,ldel,del3,del2,xpi,dpipj,piDpj,ns,ip1n,
+ + ip2n,ip3n,is,itime,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate xpi(i)*del2 - del3(piDpj) *
+* *
+* / si mu \2 (This appears to be one of the harder *
+* = | d | determinants to calculate accurately. *
+* \ p1 p2 / Note that we allow a loss of xloss^2) *
+* *
+* Input: ldel iff .true. del2 and del3 exist *
+* del3 \delta^{s(1),p1,p2}_{s(1),p1,p2} *
+* del2 \delta^{p1,p2}_{p1,p2} *
+* xpi(ns) standard *
+* dpipj(ns,ns) standard *
+* piDpj(ns,ns) standard *
+* ipi pi = xpi(abs(ipi)) [p3=-p1 +/-p2] *
+* is si = xpi(is,is+1,..,is+itime-1) *
+* itime number of functions to calculate *
+* *
+* Output: del3mi(3) (\delta^{s_i \mu}_{p_1 p_2})^2 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ip1n,ip2n,ip3n,is,itime,ier
+ logical ldel
+ DOUBLE PRECISION del3mi(itime),del3,del2,xpi(ns),dpipj(ns,ns),
+ + piDpj(ns,ns)
+*
+* local variables:
+*
+ DOUBLE PRECISION s(7),som,smax,del2s,delps,xsom,xmax
+ integer i,j,k,ip1,ip2,ip3,ipn,is1,is2,isi,is3,ihlp,iqn,jsgnq,
+ + jsgn1,jsgn2,jsgn3,jsgnn,iadj(10,10,3:4),init,nm
+ save iadj,init
+ logical lsign,lmax,ltwist
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* data
+*
+ data iadj /200*0/
+ data init /0/
+* #] declarations:
+* #[ initialisations:
+ if ( init .eq. 0 ) then
+ init = 1
+*
+* Fill the array with adjacent values: if
+* x = iadj(i,j)
+* k = abs(mod(k,100))
+* jsgnk = sign(x)
+* jsgnj = 1-2*theta(x-100) (ie -1 iff |x|>100)
+* then
+* pi(k) = jsgnk*( p(i) - jsgnj*pi(j) )
+*
+ do 5 nm=3,4
+ do 4 i=1,nm
+ is1 = i
+ is2 = i+1
+ if ( is2 .gt. nm ) is2 = 1
+ is3 = i-1
+ if ( is3 .eq. 0 ) is3 = nm
+ ip1 = is1 + nm
+ iadj(is1,is2,nm) = -ip1
+ iadj(is2,is1,nm) = ip1
+ iadj(ip1,is2,nm) = -is1
+ iadj(is2,ip1,nm) = is1
+ iadj(is1,ip1,nm) = 100+is2
+ iadj(ip1,is1,nm) = 100+is2
+ if ( nm .eq. 3 ) then
+ iadj(ip1,is2+3,3) = -100-is3-3
+ iadj(is2+3,ip1,3) = -100-is3-3
+ endif
+ 4 continue
+ 5 continue
+
+ iadj(3,1,4) = -9
+ iadj(1,3,4) = 9
+ iadj(9,1,4) = -3
+ iadj(1,9,4) = 3
+ iadj(3,9,4) = 100+1
+ iadj(9,3,4) = 100+1
+
+ iadj(2,4,4) = -10
+ iadj(4,2,4) = 10
+ iadj(10,4,4) = -2
+ iadj(4,10,4) = 2
+ iadj(2,10,4) = 100+4
+ iadj(10,2,4) = 100+4
+
+ endif
+ if ( ns .eq. 6 ) then
+ nm = 3
+ else
+ nm = 4
+ endif
+* #] initialisations:
+* #[ superfluous code:
+* if ( ns .ne. 6 ) print *,'ffdl3m: called with ns <> 6 !!'
+* if ( ip1n .lt. 4 ) then
+* lsign = .TRUE.
+* else
+* lsign = .FALSE.
+* endif
+* if ( ltest .and. lsign ) then
+* if ( ip3n .eq. 4 ) then
+* if ( ip1n .ne. 1 .or. ip2n .ne. 2 ) goto 2
+* elseif ( ip3n .eq. 5 ) then
+* if ( ip1n .ne. 2 .or. ip2n .ne. 3 ) goto 2
+* elseif ( ip3n .eq. 6 ) then
+* if ( ip1n .ne. 3 .or. ip2n .ne. 1 ) goto 2
+* else
+* goto 2
+* endif
+* goto 3
+* 2 continue
+* print *,'ffdl3m: unexpected combination of indices',ip1,ip2,
+* + ip3
+* 3 continue
+* endif
+* this went at he end:
+* #[ special case 4,5,6:
+* Next try - I don't give up easily
+* if ( nm .eq. 6 .and. ip1n .eq. 4 .and. ip2n .eq. 5 .and.
+* + ip3n .eq. 6 .and. is .eq. 1 ) then
+* is3 = isi + 1
+* if ( is3 .eq. 4 ) is3 = 1
+* is1 = is3 + 1
+* if ( is1 .eq. 4 ) is1 = 1
+* ip1 = is1 + 3
+* ip2 = isi + 3
+* ip3 = is3 + 3
+* This is an algorithm of last resort. Add special
+* cases at will.
+* s(1) = xpi(ip1)*xpi(ip2)*xpi(ip3)
+* s(2) = dpipj(is1,isi)*dpipj(ip1,ip2)**2
+* s(3) = -dpipj(is1,isi)*xpi(ip3)*(xpi(ip1)+xpi(ip2))
+* s(4) = 2*dpipj(is1,isi)*dpipj(is1,is3)*
+* + piDpj(ip1,ip3)
+* s(5) = -2*dpipj(is1,is3)*xpi(ip1)*piDpj(ip2,ip3)
+* s(6) = dpipj(is1,isi)**2*xpi(ip3)
+* s(7) = dpipj(is1,is3)**2*xpi(ip1)
+* som = s(1)
+* smax = abs(s(1))
+* do 31 j=2,7
+* som = som + s(j)
+* smax = max(smax,abs(som))
+* 31 continue
+* som = som/4
+* smax = smax/4
+* if (lwrite) print *,' del3mi(',isi,')++= ',som,smax
+* if ( abs(som) .ge. xloss*smax ) goto 35
+* if ( smax .lt. xmax ) then
+* xsom = som
+* xmax = smax
+* endif
+* endif
+* #] special case 4,5,6:
+* #] superfluous code:
+* #[ easy tries:
+ do 40 i=1,itime
+ isi = i+is-1
+ lmax = .FALSE.
+*
+* get xpi(isi)*del2 - del3 ... if del3 and del2 are defined
+*
+ if ( ldel ) then
+ s(1) = xpi(isi)*del2
+ som = s(1) - del3
+ smax = abs(s(1))
+ if ( abs(som) .ge. xloss**2*smax ) goto 35
+ if ( lwrite ) print *,' del3mi(',isi,') =',som,s(1),
+ + del3
+ xsom = som
+ xmax = smax
+ lmax = .TRUE.
+ endif
+ ip1 = ip1n
+ ip2 = ip2n
+ ip3 = ip3n
+ do 20 j=1,3
+*
+* otherwise use the simple threeterm formula
+*
+ s(1) = xpi(ip2)*piDpj(ip1,isi)**2
+ s(2) = xpi(ip1)*piDpj(ip2,isi)*piDpj(ip2,isi)
+ s(3) = -2*piDpj(ip2,isi)*piDpj(ip2,ip1)*piDpj(ip1,isi)
+ som = s(1) + s(2) + s(3)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( lwrite .and. (ldel.or.j.ne.1) ) print *,
+ + ' del3mi(',isi,')+ =',som,(s(k),k=1,3)
+ if ( abs(som) .ge. xloss**2*smax ) goto 35
+ if ( lwrite .and. .not.(ldel.or.j.ne.1) ) print *,
+ + ' del3mi(',isi,') =',som,(s(k),k=1,3)
+ if ( .not. lmax .or. smax .lt. xmax ) then
+ xsom = som
+ xmax = smax
+ lmax = .TRUE.
+ endif
+*
+* if there are cancellations between two of the terms:
+* we try mixing with isi.
+*
+* First map cancellation to s(2)+s(3) (do not mess up
+* rotations...)
+*
+ if ( abs(s(1)+s(3)) .lt. abs(s(3))/2 ) then
+ ihlp = ip1
+ ip1 = ip2
+ ip2 = ihlp
+ som = s(1)
+ s(1) = s(2)
+ s(2) = som
+ ltwist = .TRUE.
+ else
+ ltwist = .FALSE.
+ endif
+ if ( abs(s(2)+s(3)) .lt. abs(s(3))/2 ) then
+*
+* switch to the vector pn so that si = jsgn1*p1 + jsgnn*pn
+*
+ k = iadj(isi,ip1,nm)
+ if ( k .ne. 0 ) then
+ ipn = abs(k)
+ jsgnn = isign(1,k)
+ if ( ipn .gt. 100 ) then
+ ipn = ipn - 100
+ jsgn1 = -1
+ else
+ jsgn1 = +1
+ endif
+ if (abs(dpipj(ipn,isi)).lt.xloss*abs(piDpj(ip1,isi))
+ + .and.
+ + abs(piDpj(ipn,ip2)).lt.xloss*abs(piDpj(ip2,isi))
+ + ) then
+* same: s(1) = xpi(ip2)*piDpj(ip1,isi)**2
+ s(2) = jsgnn*piDpj(isi,ip2)*piDpj(ipn,ip2)*
+ + xpi(ip1)
+ s(3) = jsgn1*piDpj(isi,ip2)*piDpj(ip1,ip2)*
+ + dpipj(ipn,isi)
+ som = s(1) + s(2) + s(3)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( lwrite ) print *,
+ + ' del3mi(',isi,')++=',som,(s(k),k=1,3)
+* print *,' (isi+ip1) with isi,ip1,ip2,ipn: ',
+* + isi,ip1,ip2,ipn
+* print *,'xpi(ip2),piDpj(ip1,isi)',xpi(ip2),
+* + piDpj(ip1,isi)
+* print *,'piDpj(isi,ip2),piDpj(ipn,ip2),xpi(ip1)'
+* + ,piDpj(isi,ip2),piDpj(ipn,ip2),xpi(ip1)
+ if ( abs(som) .ge. xloss**2*smax ) goto 35
+ if ( smax .lt. xmax ) then
+ xsom = som
+ xmax = smax
+ endif
+*
+* there may be a cancellation between s(1) and
+* s(2) left. Introduce a vector q such that
+* pn = jsgnq*q + jsgn2*p2. We also need the sign
+* jsgn3 in p3 = -p1 - jsgn3*p2
+*
+ k = iadj(ipn,ip2,nm)
+ if ( k .ne. 0 ) then
+ iqn = abs(k)
+*not used jsgnq = isign(1,k)
+ if ( iqn .gt. 100 ) then
+ iqn = iqn - 100
+ jsgn2 = -1
+ else
+ jsgn2 = +1
+ endif
+ k = iadj(ip1,ip2,nm)
+ if ( k .eq. 0 .or. k .lt. 100 ) then
+* we have p1,p2,p3 all p's
+ jsgn3 = +1
+ elseif ( k .lt. 0 ) then
+* ip1,ip2 are 2*s,1*p such that p2-p1=ip3
+ jsgn3 = -1
+ else
+ jsgn3 = 0
+ endif
+* we need one condition on the signs for this
+* to work
+ if ( ip3.ne.0 .and. jsgn1*jsgn2.eq.jsgnn*
+ + jsgn3 .and. abs(s(3)).lt.xloss*smax ) then
+ s(1) = piDpj(ip1,isi)**2*dpipj(iqn,ipn)
+ s(2) = -jsgn2*jsgn1*piDpj(ipn,ip2)*
+ + piDpj(ip1,isi)*dpipj(ipn,isi)
+* s(3) stays the same
+ s(4) = -jsgn2*jsgn1*piDpj(ipn,ip2)*
+ + xpi(ip1)*piDpj(isi,ip3)
+ som = s(1) + s(2) + s(3) + s(4)
+ smax =max(abs(s(1)),abs(s(2)),abs(s(3)),
+ + abs(s(4)))
+ if ( lwrite ) print *,
+ + ' del3mi(',isi,')+2=',som,(s(k),k=1,4)
+ if ( abs(som).ge.xloss**2*smax ) goto 35
+ if ( smax .lt. xmax ) then
+ xsom = som
+ xmax = smax
+ endif
+ endif
+ endif
+ endif
+ endif
+ k = iadj(isi,ip2,nm)
+ if ( k .ne. 0 ) then
+ ipn = abs(k)
+ jsgnn = isign(1,k)
+ if ( ipn .gt. 100 ) then
+ jsgn1 = -1
+ ipn = ipn - 100
+ else
+ jsgn1 = +1
+ endif
+ if (abs(dpipj(ipn,isi)).lt.xloss*abs(piDpj(ip2,isi))
+ + .and.
+ + abs(piDpj(ipn,ip1)).lt.xloss*abs(piDpj(ip1,isi))
+ + ) then
+ s(1) = jsgnn*piDpj(isi,ip1)*piDpj(ipn,ip1)*
+ + xpi(ip2)
+ s(2) = xpi(ip1)*piDpj(ip2,isi)**2
+ s(3) = jsgn1*piDpj(isi,ip1)*piDpj(ip2,ip1)*
+ + dpipj(ipn,isi)
+ som = s(1) + s(2) + s(3)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( lwrite ) print *,
+ + ' del3mi(',isi,')++=',som,(s(k),k=1,3)
+ print *,' (isi+ip2) with isi,ip1,ip2,ipn: ',
+ + isi,ip1,ip2,ipn
+ if ( abs(som) .ge. xloss**2*smax ) goto 35
+ if ( smax .lt. xmax ) then
+ xsom = som
+ xmax = smax
+ endif
+ endif
+ endif
+ endif
+*this does not suffice
+* if ( lsign ) then
+* if ( abs(s(1)) .lt. abs(s(2)) ) then
+* s(2) = piDpj(isi,ip2)*piDpj(isi,ip3)*xpi(ip1)
+* if ( j .eq. 2 ) s(2) = -s(2)
+* s(3) = piDpj(isi,ip1)*piDpj(isi,ip2)*
+* + dpipj(ip3,ip2)
+* else
+* s(1) = piDpj(isi,ip1)*piDpj(isi,ip3)*xpi(ip2)
+* if ( j .eq. 1 ) s(1) = -s(1)
+* s(3) = piDpj(isi,ip1)*piDpj(isi,ip2)*
+* + dpipj(ip3,ip1)
+* endif
+* if ( j .eq. 3 ) s(3) = -s(3)
+**
+* som = s(1) + s(2) + s(3)
+* smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+* if ( lwrite ) print *,
+* + ' del3mi(',isi,')++=',som,(s(k),k=1,3)
+* if ( abs(som) .ge. xloss**2*smax ) goto 35
+* if ( smax .lt. xmax ) then
+* xmax = smax
+* xsom = som
+* endif
+* endif
+*nor does this
+* if ( j .eq. 1 )
+* + call ffdel2(del2s,piDpj,6,ip1,ip2,ip3,1,ier)
+* call ffdl2t(delps,piDpj,isi,ip2,ip1,ip2,ip3,+1,+1,6,ier)
+* s(1) = piDpj(isi,ip2)**2*del2s/xpi(ip2)
+* s(2) = delps**2/xpi(ip2)
+* som = s(1) + s(2)
+* smax = abs(s(1))
+* if ( lwrite ) print *,
+* + ' del3mi(',isi,')++=',del3mi(i),(s(k),k=1,2)
+* if ( abs(som) .ge. xloss*smax ) goto 35
+* if ( smax .lt. xmax ) then
+* xmax = smax
+* xsom = som
+* endif
+*
+* rotate the ipi
+*
+ if ( ip3 .eq. 0 ) goto 30
+ if ( j .ne. 3 ) then
+ if ( .not. ltwist ) then
+ ihlp = ip1
+ ip1 = ip2
+ ip2 = ip3
+ ip3 = ihlp
+ else
+ ihlp = ip2
+ ip2 = ip3
+ ip3 = ihlp
+ endif
+ endif
+ 20 continue
+ 30 continue
+* #] easy tries:
+* #[ choose the best value:
+*
+* These values are the best found:
+*
+ som = xsom
+ smax = xmax
+ if ( lwarn ) call ffwarn(75,ier,som,smax)
+ if ( lwrite ) then
+ print *,'ffdl3m: giving up:'
+ print *,'ip1,ip2,ip3,is,itime =',ip1,ip2,ip3,is,itime
+ print *,'xpi = ',xpi
+ endif
+
+ 35 continue
+ del3mi(i) = som
+ 40 continue
+* #] choose the best value:
+*###] ffdl3m:
+ end
diff --git a/ff-2.0/ffdel3.f b/ff-2.0/ffdel3.f
new file mode 100644
index 0000000..9d5c9e7
--- /dev/null
+++ b/ff-2.0/ffdel3.f
@@ -0,0 +1,374 @@
+*###[ ffdel3:
+ subroutine ffdel3(del3,xpi,piDpj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate del3(piDpj) = det(si.sj) with *
+* the momenta as follows: *
+* p(1-3) = s(i) *
+* p(4-6) = p(i) *
+* *
+* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
+* piDpj(ns,ns) (real) *
+* ns (integer) *
+* ier (integer) *
+* *
+* Output: del3 (real) det(si.sj) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ier
+ DOUBLE PRECISION del3,xpi(6),piDpj(6,6)
+*
+* local variables:
+*
+ integer mem,nperm
+ parameter(mem=10,nperm=16)
+ integer i,jj(6),iperm(3,nperm),imem,memarr(mem,3),memind,inow
+ DOUBLE PRECISION s(6),xmax,del3p,xmaxp,rloss
+ save iperm,memind,memarr,inow
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ data:
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1/
+ data inow /1/
+*
+* these are all permutations that give a non-zero result with the
+* correct sign. This list was generated with getperm3.
+*
+ data iperm/
+ + 1,2,3, 1,2,5, 1,6,2, 1,4,3,
+ + 1,3,5, 1,4,5, 1,6,4, 1,5,6,
+ + 2,4,3, 2,3,6, 2,4,5, 2,6,4,
+ + 2,5,6, 3,4,5, 3,6,4, 3,5,6/
+* #] data:
+* #[ starting point in memory?:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
+ inow = memarr(i,3)
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] starting point in memory?:
+* #[ calculations:
+ imem = inow
+ del3 = 0
+ xmax = 0
+
+ 10 continue
+
+ jj(1) = iperm(1,inow)
+ jj(3) = iperm(2,inow)
+ jj(5) = iperm(3,inow)
+
+ jj(2) = iperm(1,inow)
+ jj(4) = iperm(2,inow)
+ jj(6) = iperm(3,inow)
+
+ s(1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(6))
+ s(2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(2))
+ s(3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(4))
+ s(4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(4))
+ s(5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(2))
+ s(6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(6))
+
+ del3p = 0
+ xmaxp = 0
+ do 20 i=1,6
+ del3p = del3p + s(i)
+ xmaxp = max(xmaxp,abs(s(i)))
+ 20 continue
+ if ( abs(del3p) .lt. xloss*xmaxp ) then
+ if ( lwrite ) print *,'del3+',inow,' = ',del3p,xmaxp
+ if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
+ del3 = del3p
+ xmax = xmaxp
+ endif
+ inow = inow + 1
+ if ( inow .gt. nperm ) inow = 1
+ if ( inow .eq. imem ) then
+ if ( lwarn ) call ffwarn(73,ier,del3,xmax)
+ goto 800
+ endif
+ goto 10
+ endif
+ if ( inow .ne. imem ) then
+ if ( lwrite ) print *,'del3+',inow,' = ',del3p,xmaxp
+ endif
+ del3 = del3p
+ xmax = xmaxp
+* #] calculations:
+* #[ into memory:
+ 800 continue
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+* #] into memory:
+* #[ check output:
+ if ( ltest ) then
+
+ s(1) = +piDpj(1,1)*piDpj(2,2)*piDpj(3,3)
+ s(2) = +piDpj(1,2)*piDpj(2,3)*piDpj(3,1)
+ s(3) = +piDpj(1,3)*piDpj(2,1)*piDpj(3,2)
+ s(4) = -piDpj(1,1)*piDpj(2,3)*piDpj(3,2)
+ s(5) = -piDpj(1,3)*piDpj(2,2)*piDpj(3,1)
+ s(6) = -piDpj(1,2)*piDpj(2,1)*piDpj(3,3)
+
+ del3p = 0
+ xmaxp = 0
+ do 820 i=1,6
+ del3p = del3p + s(i)
+ xmaxp = max(xmaxp,abs(s(i)))
+ 820 continue
+ rloss = xloss*DBLE(10)**(-mod(ier,50))
+ if ( rloss*abs(del3p-del3) .gt. precx*xmaxp ) then
+ print *,'ffdel3: error: result does not agree with',
+ + ' normal case'
+ print *,'result: ',del3,xmax
+ print *,'normal: ',del3p,xmaxp
+ print *,'diff.: ',del3-del3p
+ endif
+ endif
+* #] check output:
+*###] ffdel3:
+ end
+*(##[ ffdl3s:
+ subroutine ffdl3s(dl3s,xpi,piDpj,ii,ns,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate dl3s(piDpj) = det(si.sj) with *
+* the momenta indicated by the indices ii(1-6,1), ii(1-6,2) *
+* as follows: *
+* p(|ii(1,)|-|ii(3,)|) = s(i) *
+* p(|ii(4,)|-|ii(6,)|) = p(i) = sgn(ii())*(s(i+1) - s(i)) *
+* *
+* At this moment (26-apr-1990) only the diagonal is tried *
+* *
+* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
+* piDpj(ns,ns) (real) *
+* ii(6,2) (integer) see above *
+* ns (integer) *
+* ier (integer) *
+* *
+* Output: dl3s (real) det(si.sj) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ii(6,2),ns,ier
+ DOUBLE PRECISION dl3s,xpi(ns),piDpj(ns,ns)
+*
+* local variables:
+*
+ integer mem,nperm
+ parameter(mem=10,nperm=16)
+ integer i,j,jj(6),jsgn,iperm(3,nperm),imem,memarr(mem,3),
+ + memind,inow
+ DOUBLE PRECISION s(6),xmax,dl3sp,xmaxp,xlosn,xhck,rloss
+ save iperm,memind,memarr,inow
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ data:
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1/
+ data inow /1/
+*
+* these are all permutations that give a non-zero result with the
+* correct sign. This list was generated with getperm3.
+*
+ data iperm/
+ + 1,2,3, 1,2,5, 1,6,2, 1,4,3,
+ + 1,3,5, 1,4,5, 1,6,4, 1,5,6,
+ + 2,4,3, 2,3,6, 2,4,5, 2,6,4,
+ + 2,5,6, 3,4,5, 3,6,4, 3,5,6/
+* #] data:
+* #[ test input:
+ if ( ltest ) then
+* print *,'ffdl3s: input: ii(,1) = ',(ii(i,1),i=1,6)
+* print *,' ii(,2) = ',(ii(i,2),i=1,6)
+ xlosn = xloss*DBLE(10)**(-mod(ier,50))
+ do 3 j=1,2
+ do 1 i=1,6
+ if ( abs(ii(i,j)) .gt. ns ) print *,'ffdl3s: error: ',
+ + '|ii(i,j)| > ns: ',ii(i,j),ns
+ if ( abs(ii(i,j)) .eq. 0 ) print *,'ffdl3s: error: ',
+ + '|ii(i,j)| = 0: ',ii(i,j)
+ 1 continue
+ do 2 i=1,6
+
+ xhck = piDpj(abs(ii(i,j)),ii(1,j))
+ + - piDpj(abs(ii(i,j)),ii(2,j))
+ + + sign(1,ii(4,j))*piDpj(abs(ii(i,j)),abs(ii(4,j)))
+ xmax = max(abs(piDpj(abs(ii(i,j)),ii(1,j))),
+ + abs(piDpj(abs(ii(i,j)),ii(2,j))))
+ if ( xlosn*abs(xhck) .gt. precx*xmax ) print *,'ffdl3s:'
+ + ,' error: dotproducts 124 with ',i,' do not add to 0:'
+ + ,piDpj(abs(ii(i,j)),ii(1,j)),
+ + piDpj(abs(ii(i,j)),ii(2,j)),
+ + piDpj(abs(ii(i,j)),abs(ii(4,j))),xhck
+
+ xhck = piDpj(abs(ii(i,j)),ii(2,j))
+ + - piDpj(abs(ii(i,j)),ii(3,j))
+ + + sign(1,ii(5,j))*piDpj(abs(ii(i,j)),abs(ii(5,j)))
+ xmax = max(abs(piDpj(abs(ii(i,j)),ii(2,j))),
+ + abs(piDpj(abs(ii(i,j)),ii(3,j))))
+ if ( xlosn*abs(xhck) .gt. precx*xmax ) print *,'ffdl3s:'
+ + ,' error: dotproducts 235 with ',i,' do not add to 0:'
+ + ,piDpj(abs(ii(i,j)),ii(2,j)),
+ + piDpj(abs(ii(i,j)),ii(3,j)),
+ + piDpj(abs(ii(i,j)),abs(ii(5,j))),xhck
+
+ xhck = piDpj(abs(ii(i,j)),ii(3,j))
+ + - piDpj(abs(ii(i,j)),ii(1,j))
+ + + sign(1,ii(6,j))*piDpj(abs(ii(i,j)),abs(ii(6,j)))
+ xmax = max(abs(piDpj(abs(ii(i,j)),ii(3,j))),
+ + abs(piDpj(abs(ii(i,j)),ii(1,j))))
+ if ( xlosn*abs(xhck) .gt. precx*xmax ) print *,'ffdl3s:'
+ + ,' error: dotproducts 316 with ',i,' do not add to 0:'
+ + ,piDpj(abs(ii(i,j)),ii(3,j)),
+ + piDpj(abs(ii(i,j)),ii(1,j)),
+ + piDpj(abs(ii(i,j)),abs(ii(6,j))),xhck
+
+ xhck = sign(1,ii(4,j))*piDpj(abs(ii(i,j)),abs(ii(4,j)))
+ + + sign(1,ii(5,j))*piDpj(abs(ii(i,j)),abs(ii(5,j)))
+ + + sign(1,ii(6,j))*piDpj(abs(ii(i,j)),abs(ii(6,j)))
+ xmax = max(abs(piDpj(abs(ii(i,j)),abs(ii(4,j)))),
+ + abs(piDpj(abs(ii(i,j)),abs(ii(5,j)))))
+ if ( xlosn*abs(xhck) .gt. precx*xmax ) print *,'ffdl3s:'
+ + ,' error: dotproducts 456 with ',i,' do not add to 0:'
+ + ,piDpj(abs(ii(i,j)),abs(ii(4,j))),
+ + piDpj(abs(ii(i,j)),abs(ii(5,j))),
+ + piDpj(abs(ii(i,j)),abs(ii(6,j))),xhck
+
+ 2 continue
+ 3 continue
+ endif
+* #] test input:
+* #[ starting point in memory?:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
+ inow = memarr(i,3)
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] starting point in memory?:
+* #[ calculations:
+ imem = inow
+ dl3s = 0
+ xmax = 0
+
+ 10 continue
+
+ jj(1) = abs(ii(iperm(1,inow),1))
+ jj(3) = abs(ii(iperm(2,inow),1))
+ jj(5) = abs(ii(iperm(3,inow),1))
+
+ jj(2) = abs(ii(iperm(1,inow),2))
+ jj(4) = abs(ii(iperm(2,inow),2))
+ jj(6) = abs(ii(iperm(3,inow),2))
+
+ jsgn = sign(1,ii(iperm(1,inow),1))
+ + *sign(1,ii(iperm(2,inow),1))
+ + *sign(1,ii(iperm(3,inow),1))
+ + *sign(1,ii(iperm(1,inow),2))
+ + *sign(1,ii(iperm(2,inow),2))
+ + *sign(1,ii(iperm(3,inow),2))
+
+ s(1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(6))
+ s(2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(2))
+ s(3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(4))
+ s(4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(4))
+ s(5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(2))
+ s(6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(6))
+
+ dl3sp = 0
+ xmaxp = 0
+ do 20 i=1,6
+ dl3sp = dl3sp + s(i)
+ xmaxp = max(xmaxp,abs(s(i)))
+ 20 continue
+ if ( abs(dl3sp) .lt. xloss*xmaxp ) then
+ if ( lwrite ) print *,'dl3s+',inow,' = ',dl3sp,xmaxp
+ if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
+ dl3s = jsgn*dl3sp
+ xmax = xmaxp
+ endif
+ inow = inow + 1
+ if ( inow .gt. nperm ) inow = 1
+ if ( inow .eq. imem ) then
+ if ( lwarn ) call ffwarn(85,ier,dl3s,xmax)
+ goto 800
+ endif
+ goto 10
+ endif
+ if ( inow .ne. imem ) then
+ if ( lwrite ) print *,'dl3s+',inow,' = ',dl3sp,xmaxp
+ endif
+ dl3s = jsgn*dl3sp
+ xmax = xmaxp
+* #] calculations:
+* #[ into memory:
+ 800 continue
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+* #] into memory:
+* #[ check output:
+ if ( ltest ) then
+
+ s(1) = +piDpj(ii(1,1),ii(1,2))*piDpj(ii(2,1),ii(2,2))*
+ + piDpj(ii(3,1),ii(3,2))
+ s(2) = +piDpj(ii(1,1),ii(2,2))*piDpj(ii(2,1),ii(3,2))*
+ + piDpj(ii(3,1),ii(1,2))
+ s(3) = +piDpj(ii(1,1),ii(3,2))*piDpj(ii(3,1),ii(2,2))*
+ + piDpj(ii(2,1),ii(1,2))
+ s(4) = -piDpj(ii(1,1),ii(1,2))*piDpj(ii(2,1),ii(3,2))*
+ + piDpj(ii(3,1),ii(2,2))
+ s(5) = -piDpj(ii(1,1),ii(3,2))*piDpj(ii(2,1),ii(2,2))*
+ + piDpj(ii(3,1),ii(1,2))
+ s(6) = -piDpj(ii(1,1),ii(2,2))*piDpj(ii(2,1),ii(1,2))*
+ + piDpj(ii(3,1),ii(3,2))
+
+ dl3sp = 0
+ xmaxp = 0
+ do 820 i=1,6
+ dl3sp = dl3sp + s(i)
+ xmaxp = max(xmaxp,abs(s(i)))
+ 820 continue
+ rloss = xloss*DBLE(10)**(-mod(ier,50))
+ if ( rloss*abs(dl3sp-dl3s) .gt. precx*xmaxp ) then
+ print *,'ffdl3s: error: result does not agree with',
+ + ' normal case'
+ print *,'result: ',dl3s,xmax
+ print *,'normal: ',dl3sp,xmaxp
+ print *,'diff.: ',dl3s-dl3sp
+ endif
+ endif
+* #] check output:
+*)##] ffdl3s:
+ end
diff --git a/ff-2.0/ffdel4.f b/ff-2.0/ffdel4.f
new file mode 100644
index 0000000..2cbea20
--- /dev/null
+++ b/ff-2.0/ffdel4.f
@@ -0,0 +1,424 @@
+*###[ ffdel4:
+ subroutine ffdel4(del4,xpi,piDpj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate del4(piDpj) = det(si.sj) with *
+* the momenta as follows: *
+* p(1-4) = s(i) *
+* p(4-10) = p(i) *
+* *
+* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
+* piDpj(ns,ns) (real) *
+* ns (integer) *
+* ier (integer) *
+* *
+* Output: del4 (real) det(si.sj) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ier
+ DOUBLE PRECISION del4,xpi(10),piDpj(10,10)
+*
+* local variables:
+*
+ integer mem,nperm
+ parameter(mem=10,nperm=125)
+ integer i,jj(8),iperm(4,nperm),imem,jmem,memarr(mem,4),memind,
+ + inow,jnow,icount
+ DOUBLE PRECISION s(24),xmax,del4p,xmaxp,rloss
+ save iperm,memind,memarr,inow,jnow
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ data:
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1,mem*1/
+ data inow /1/
+ data jnow /1/
+*
+* these are all permutations that give a non-zero result with the
+* correct sign. This list was generated with getperm4.
+* (note: this used to be well-ordened, but then it had more than
+* 19 continuation lines)
+*
+ data iperm/
+ + 1,2,3,4,1,2,3,7,1,2,8,3,1,2,3,10,1,2,6,4,1,2,4,7,1,2,4,9,1,2,6,7
+ + ,1,2,8,6,1,2,6,10,1,2,7,8,1,2,7,9,1,2,10,7,1,2,9,8,1,2,10,9,1,3,
+ + 4,5,1,3,6,4,1,3,10,4,1,3,7,5,1,3,5,8,1,3,10,5,1,3,6,7,1,3,8,6,1,
+ + 3,6,10,1,3,10,7,1,3,8,10,1,4,5,6,1,4,7,5,1,4,9,5,1,4,6,7,1,4,6,9
+ + ,1,4,6,10,1,4,10,7,1,4,10,9,1,5,6,7,1,5,8,6,1,5,6,10,1,5,7,8,1,5
+ + ,7,9,1,5,10,7,1,5,9,8,1,5,10,9,1,6,8,7,1,6,9,7,1,6,8,9,1,6,8,10,
+ + 1,6,9,10,1,7,10,8,1,7,10,9,1,8,9,10,2,3,4,5,2,3,8,4,2,3,9,4,2,3,
+ + 7,5,2,3,5,8,2,3,10,5,2,3,8,7,2,3,9,7,2,3,8,9,2,3,8,10,2,3,9,10,2
+ + ,4,5,6,2,4,7,5,2,4,9,5,2,4,6,8,2,4,6,9,2,4,8,7,2,4,9,7,2,4,8,9,2
+ + ,5,6,7,2,5,8,6,2,5,6,10,2,5,7,8,2,5,7,9,2,5,10,7,2,5,9,8,2,5,10,
+ + 9,2,6,8,7,2,6,9,7,2,6,8,9,2,6,8,10,2,6,9,10,2,7,10,8,2,7,10,9,2,
+ + 8,9,10,3,4,5,6,3,4,8,5,3,4,9,5,3,4,5,10,3,4,6,8,3,4,6,9,3,4,10,8
+ + ,3,4,10,9,3,5,6,7,3,5,8,6,3,5,6,10,3,5,7,8,3,5,7,9,3,5,10,7,3,5,
+ + 9,8,3,5,10,9,3,6,8,7,3,6,9,7,3,6,8,9,3,6,8,10,3,6,9,10,3,7,10,8,
+ + 3,7,10,9,3,8,9,10,4,5,6,7,4,5,8,6,4,5,6,10,4,5,7,8,4,5,7,9,4,5,1
+ + 0,7,4,5,9,8,4,5,10,9,4,6,8,7,4,6,9,7,4,6,8,9,4,6,8,10,4,6,9,10,4
+ + ,7,10,8,4,7,10,9,4,8,9,10/
+* #] data:
+* #[ check input:
+ if ( ltest .and. ns .ne. 10 ) then
+ print *,'ffdel4: error: only for ns = 10, not ',ns
+ stop
+ endif
+* #] check input:
+* #[ get starting point from memory:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
+ inow = memarr(i,3)
+ jnow = memarr(i,4)
+ if ( lwrite ) print *,'ffcel4: from memory: ',id,idsub,
+ + inow,jnow
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] get starting point from memory:
+* #[ calculations:
+ imem = inow
+ jmem = jnow
+ del4 = 0
+ xmax = 0
+ icount = 0
+
+ 10 continue
+
+ jj(1) = iperm(1,inow)
+ jj(3) = iperm(2,inow)
+ jj(5) = iperm(3,inow)
+ jj(7) = iperm(4,inow)
+
+ jj(2) = iperm(1,jnow)
+ jj(4) = iperm(2,jnow)
+ jj(6) = iperm(3,jnow)
+ jj(8) = iperm(4,jnow)
+
+ s( 1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(7),jj(8))
+ s( 2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(7),jj(8))
+ s( 3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(7),jj(8))
+ s( 4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(7),jj(8))
+ s( 5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(7),jj(8))
+ s( 6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(7),jj(8))
+
+ s( 7) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(7),jj(6))*piDpj(jj(5),jj(8))
+ s( 8) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(7),jj(2))*piDpj(jj(5),jj(8))
+ s( 9) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(7),jj(4))*piDpj(jj(5),jj(8))
+ s(10) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(7),jj(4))*piDpj(jj(5),jj(8))
+ s(11) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(7),jj(2))*piDpj(jj(5),jj(8))
+ s(12) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(7),jj(6))*piDpj(jj(5),jj(8))
+
+ s(13) = -piDpj(jj(1),jj(2))*piDpj(jj(7),jj(4))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(3),jj(8))
+ s(14) = -piDpj(jj(1),jj(4))*piDpj(jj(7),jj(6))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(3),jj(8))
+ s(15) = -piDpj(jj(1),jj(6))*piDpj(jj(7),jj(2))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(3),jj(8))
+ s(16) = +piDpj(jj(1),jj(2))*piDpj(jj(7),jj(6))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(3),jj(8))
+ s(17) = +piDpj(jj(1),jj(6))*piDpj(jj(7),jj(4))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(3),jj(8))
+ s(18) = +piDpj(jj(1),jj(4))*piDpj(jj(7),jj(2))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(3),jj(8))
+
+ s(19) = -piDpj(jj(7),jj(2))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(1),jj(8))
+ s(20) = -piDpj(jj(7),jj(4))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(1),jj(8))
+ s(21) = -piDpj(jj(7),jj(6))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(1),jj(8))
+ s(22) = +piDpj(jj(7),jj(2))*piDpj(jj(3),jj(6))*
+ + piDpj(jj(5),jj(4))*piDpj(jj(1),jj(8))
+ s(23) = +piDpj(jj(7),jj(6))*piDpj(jj(3),jj(4))*
+ + piDpj(jj(5),jj(2))*piDpj(jj(1),jj(8))
+ s(24) = +piDpj(jj(7),jj(4))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(5),jj(6))*piDpj(jj(1),jj(8))
+
+ del4p = 0
+ xmaxp = 0
+ do 20 i=1,24
+ del4p = del4p + s(i)
+ xmaxp = max(xmaxp,abs(s(i)))
+ 20 continue
+ if ( abs(del4p) .lt. xloss*xmaxp ) then
+ if ( lwrite ) print *,'del4+',icount,' = ',del4p,xmaxp,inow,
+ + jnow
+ if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
+ del4 = del4p
+ xmax = xmaxp
+ endif
+* as the list is ordered we may have more luck stepping
+* through with large steps
+ inow = inow + 43
+ jnow = jnow + 49
+ if ( inow .gt. nperm ) inow = inow - nperm
+ if ( jnow .gt. nperm ) jnow = jnow - nperm
+ icount = icount + 1
+ if ( icount.gt.15 .or. inow.eq.imem .or. jnow.eq.jmem
+ + ) then
+ if ( lwarn ) call ffwarn(143,ier,del4,xmax)
+ goto 800
+ endif
+ goto 10
+ endif
+ if ( inow.ne.imem) then
+ if ( lwrite ) print *,'del4+',icount,' = ',del4p,xmaxp,inow,
+ + jnow
+ endif
+ del4 = del4p
+ xmax = xmaxp
+* #] calculations:
+* #[ into memory:
+ if ( lwrite ) print *,'ffcel4: into memory: ',id,idsub,inow,jnow
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+ memarr(memind,4) = jnow
+ 800 continue
+* #] into memory:
+* #[ check output:
+ if ( ltest ) then
+*
+ s( 1) = +piDpj(1,1)*piDpj(2,2)*piDpj(3,3)*piDpj(4,4)
+ s( 2) = +piDpj(1,2)*piDpj(2,3)*piDpj(3,1)*piDpj(4,4)
+ s( 3) = +piDpj(1,3)*piDpj(2,1)*piDpj(3,2)*piDpj(4,4)
+ s( 4) = -piDpj(1,1)*piDpj(2,3)*piDpj(3,2)*piDpj(4,4)
+ s( 5) = -piDpj(1,3)*piDpj(2,2)*piDpj(3,1)*piDpj(4,4)
+ s( 6) = -piDpj(1,2)*piDpj(2,1)*piDpj(3,3)*piDpj(4,4)
+ s( 7) = -piDpj(1,1)*piDpj(2,2)*piDpj(4,3)*piDpj(3,4)
+ s( 8) = -piDpj(1,2)*piDpj(2,3)*piDpj(4,1)*piDpj(3,4)
+ s( 9) = -piDpj(1,3)*piDpj(2,1)*piDpj(4,2)*piDpj(3,4)
+ s(10) = +piDpj(1,1)*piDpj(2,3)*piDpj(4,2)*piDpj(3,4)
+ s(11) = +piDpj(1,3)*piDpj(2,2)*piDpj(4,1)*piDpj(3,4)
+ s(12) = +piDpj(1,2)*piDpj(2,1)*piDpj(4,3)*piDpj(3,4)
+ s(13) = -piDpj(1,1)*piDpj(4,2)*piDpj(3,3)*piDpj(2,4)
+ s(14) = -piDpj(1,2)*piDpj(4,3)*piDpj(3,1)*piDpj(2,4)
+ s(15) = -piDpj(1,3)*piDpj(4,1)*piDpj(3,2)*piDpj(2,4)
+ s(16) = +piDpj(1,1)*piDpj(4,3)*piDpj(3,2)*piDpj(2,4)
+ s(17) = +piDpj(1,3)*piDpj(4,2)*piDpj(3,1)*piDpj(2,4)
+ s(18) = +piDpj(1,2)*piDpj(4,1)*piDpj(3,3)*piDpj(2,4)
+ s(19) = -piDpj(4,1)*piDpj(2,2)*piDpj(3,3)*piDpj(1,4)
+ s(20) = -piDpj(4,2)*piDpj(2,3)*piDpj(3,1)*piDpj(1,4)
+ s(21) = -piDpj(4,3)*piDpj(2,1)*piDpj(3,2)*piDpj(1,4)
+ s(22) = +piDpj(4,1)*piDpj(2,3)*piDpj(3,2)*piDpj(1,4)
+ s(23) = +piDpj(4,3)*piDpj(2,2)*piDpj(3,1)*piDpj(1,4)
+ s(24) = +piDpj(4,2)*piDpj(2,1)*piDpj(3,3)*piDpj(1,4)
+*
+ del4p = 0
+ xmaxp = 0
+ do 820 i=1,24
+ del4p = del4p + s(i)
+ xmaxp = max(xmaxp,abs(s(i)))
+ 820 continue
+ rloss = xloss*DBLE(10)**(-mod(ier,50)-1)
+ if ( rloss*abs(del4p-del4) .gt. precx*xmaxp ) then
+ print *,'ffdel4: error: result does not agree with',
+ + ' normal case'
+ print *,'result: ',del4,xmax
+ print *,'normal: ',del4p,xmaxp
+ print *,'diff.: ',del4-del4p,ier
+ endif
+ endif
+* #] check output:
+*###] ffdel4:
+ end
+*###[ ffdl3p:
+ subroutine ffdl3p(dl3p,piDpj,ns,ii,jj,ier)
+***#[*comment:***********************************************************
+* calculate in a numerically stable way *
+* *
+* p1 p2 p3 *
+* delta *
+* p1' p2' p3' *
+* *
+* with pn = xpi(ii(n)), p4 = -p1-p2-p3, p5 = -p1-p2, p6 = p2+p3 *
+* with pn'= xpi(jj(n)), p4'= etc. (when ns=15 p5=p1+p2) *
+* *
+* Input: piDpj real(ns,ns) dotpruducts *
+* ns integer either 10 or 15 *
+* ii,jj integer(6) location of pi in piDpj *
+* ier integer number of digits lost so far *
+* Output: dl3p real see above *
+* ier integer number of digits lost so far *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ii(6),jj(6),ier
+ DOUBLE PRECISION dl3p,piDpj(ns,ns)
+*
+* local variables
+*
+ integer i,j,k,l,iperm(3,16),ii1,ii2,ii3,jj1,jj2,jj3,i0
+ logical lsymm
+ DOUBLE PRECISION s(6),som,xmax,smax,xheck,xlosn,trylos
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data iperm /1,2,3, 2,4,3, 3,4,1, 4,2,1,
+ + 1,2,6, 6,4,3, 3,1,6, 2,4,6,
+ + 2,5,3, 5,4,1, 1,3,5, 2,4,5,
+ + 1,6,5, 2,5,6, 3,6,5, 4,5,6/
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffdl3p: indices are'
+ print *,ii
+ print *,jj
+ endif
+ if ( ltest ) then
+ if ( ns .ne. 10 .and. ns .ne. 15 ) print *,'ffdl3p: error:',
+ + ' only tested for ns=10,15'
+ xlosn = xloss**2*10.d0**(-mod(ier,50))
+ do 10 i=1,ns
+ xheck = +piDpj(i,ii(1))+piDpj(i,ii(2))
+ + +piDpj(i,ii(3))+piDpj(i,ii(4))
+ xmax = max(abs(piDpj(i,ii(1))),abs(piDpj(i,ii(2))),
+ + abs(piDpj(i,ii(3))),abs(piDpj(i,ii(4))))
+ if ( xlosn*xheck .gt. precx*xmax ) print *,
+ + 'ffdl3p: error: momenta i1234 do not add to 0:',
+ + i,piDpj(i,ii(1)),piDpj(i,ii(2)),piDpj(i,ii(3)),
+ + piDpj(i,ii(4)),xheck,ier
+ xheck = piDpj(i,ii(6))-piDpj(i,ii(2))-piDpj(i,ii(3))
+ xmax = max(abs(piDpj(i,ii(6))),abs(piDpj(i,ii(2))),
+ + abs(piDpj(i,ii(3))))
+ if ( xlosn*xheck .gt. precx*xmax ) print *,
+ + 'ffdl3p: error: momenta i623 do not add to 0:',
+ + i,piDpj(i,ii(6)),piDpj(i,ii(2)),piDpj(i,ii(3)),
+ + xheck,ier
+ if ( ns .eq. 10 ) then
+ xheck = piDpj(i,ii(5))+piDpj(i,ii(1))+piDpj(i,ii(2))
+ else
+ xheck = piDpj(i,ii(5))-piDpj(i,ii(1))-piDpj(i,ii(2))
+ endif
+ xmax = max(abs(piDpj(i,ii(5))),abs(piDpj(i,ii(1))),
+ + abs(piDpj(i,ii(2))))
+ if ( xlosn*xheck .gt. precx*xmax ) print *,
+ + 'ffdl3p: error: momenta i512 do not add to 0:',
+ + i,piDpj(i,ii(5)),piDpj(i,ii(1)),piDpj(i,ii(2)),
+ + xheck,ier
+ xheck = +piDpj(i,jj(1))+piDpj(i,jj(2))
+ + +piDpj(i,jj(3))+piDpj(i,jj(4))
+ xmax = max(abs(piDpj(i,jj(1))),abs(piDpj(i,jj(2))),
+ + abs(piDpj(i,jj(3))),abs(piDpj(i,jj(4))))
+ if ( xlosn*xheck .gt. precx*xmax ) print *,
+ + 'ffdl3p: error: momenta j1234 do not add to 0:',
+ + i,piDpj(i,jj(1)),piDpj(i,jj(2)),piDpj(i,jj(3)),
+ + piDpj(i,jj(4)),xheck,ier
+ xheck = piDpj(i,jj(6))-piDpj(i,jj(2))-piDpj(i,jj(3))
+ xmax = max(abs(piDpj(i,jj(6))),abs(piDpj(i,jj(2))),
+ + abs(piDpj(i,jj(3))))
+ if ( xlosn*xheck .gt. precx*xmax ) print *,
+ + 'ffdl3p: error: momenta j623 do not add to 0:',
+ + i,piDpj(i,jj(6)),piDpj(i,jj(2)),piDpj(i,jj(3)),
+ + xheck,ier
+ if ( ns .eq. 10 ) then
+ xheck = piDpj(i,jj(5))+piDpj(i,jj(1))+piDpj(i,jj(2))
+ else
+ xheck = piDpj(i,jj(5))-piDpj(i,jj(1))-piDpj(i,jj(2))
+ endif
+ xmax = max(abs(piDpj(i,jj(5))),abs(piDpj(i,jj(1))),
+ + abs(piDpj(i,jj(2))))
+ if ( xlosn*xheck .gt. precx*xmax ) print *,
+ + 'ffdl3p: error: momenta j512 do not add to 0:',
+ + i,piDpj(i,jj(5)),piDpj(i,jj(1)),piDpj(i,jj(2)),
+ + xheck,ier
+ 10 continue
+ endif
+* #] check input:
+* #[ calculations:
+ if ( ii(1).eq.jj(1) .and. ii(2).eq.jj(2) .and. ii(3).eq.jj(3) )
+ + then
+*
+* symmetric - fewer possibilities
+*
+ lsymm = .TRUE.
+ else
+ lsymm = .FALSE.
+ endif
+*
+* try all (8.5,16)*16 permutations
+*
+ xmax = 0
+ trylos = 1
+ do 101 l=1,16
+ if ( lsymm ) then
+ i0 = l
+ else
+ i0 = 1
+ endif
+ do 100 i=i0,16
+ ii1 = ii(iperm(1,i))
+ ii2 = ii(iperm(2,i))
+ ii3 = ii(iperm(3,i))
+ j = i+l-1
+ if ( j .gt. 16 ) j=j-16
+ jj1 = jj(iperm(1,j))
+ jj2 = jj(iperm(2,j))
+ jj3 = jj(iperm(3,j))
+ s(1) = +piDpj(ii1,jj1)*piDpj(ii2,jj2)*piDpj(ii3,jj3)
+ s(2) = +piDpj(ii2,jj1)*piDpj(ii3,jj2)*piDpj(ii1,jj3)
+ s(3) = +piDpj(ii3,jj1)*piDpj(ii1,jj2)*piDpj(ii2,jj3)
+ s(4) = -piDpj(ii1,jj1)*piDpj(ii3,jj2)*piDpj(ii2,jj3)
+ s(5) = -piDpj(ii3,jj1)*piDpj(ii2,jj2)*piDpj(ii1,jj3)
+ s(6) = -piDpj(ii2,jj1)*piDpj(ii1,jj2)*piDpj(ii3,jj3)
+ som = 0
+ smax = 0
+ do 80 k=1,6
+ som = som + s(k)
+ smax = max(smax,abs(som))
+ 80 continue
+ if ( ns .eq. 15 .and. (i.gt.8 .neqv. j.gt.8) )
+ + som = -som
+ if ( i .eq. 1 .or. smax .lt. xmax ) then
+ dl3p = som
+ xmax = smax
+ endif
+ if ( lwrite ) then
+ print *,'dl3p = +',i-1+16*(l-1),' = ',som,smax
+ endif
+ if ( abs(dl3p) .ge. xloss*smax ) goto 110
+* give up a bit more easily if I have tried many times
+ if ( trylos*abs(dl3p) .ge. xloss*smax ) goto 109
+ trylos = trylos*1.3
+ 100 continue
+ 101 continue
+ 109 continue
+ if ( lwarn ) call ffwarn(138,ier,dl3p,xmax)
+ 110 continue
+* #] calculations:
+*###] ffdl3p:
+ end
diff --git a/ff-2.0/ffdel5.f b/ff-2.0/ffdel5.f
new file mode 100644
index 0000000..6e4746a
--- /dev/null
+++ b/ff-2.0/ffdel5.f
@@ -0,0 +1,661 @@
+*###[ ffdel5:
+ subroutine ffdel5(del5,xpi,pDp,ns,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate del5(pDp) = det(si.sj) with *
+* the momenta as follows: *
+* p(1-5) = s(i) *
+* p(5-10) = p(i) *
+* p(11-15) = p(i)+p(i+1) *
+* *
+* Input: xpi(ns) (real) *
+* pDp(ns,ns) (real) *
+* ns (integer) *
+* ier (integer) *
+* *
+* Output: del5 (real) det(si.sj) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ier
+ DOUBLE PRECISION del5,xpi(15),pDp(15,15)
+*
+* local variables:
+*
+ integer mem,nperm,nsi,ier0
+ parameter(mem=10,nperm=1296,nsi=73)
+ integer i,j,j1,j2,j3,j4,j5,iperm(5,nperm),
+ + imem,memarr(mem,3),memind,inow,init,ifile
+ DOUBLE PRECISION s(nsi),xmax,del5p,xmaxp
+ save iperm,memind,memarr,inow,init
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ data:
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1/
+ data inow /1/
+ data init /0/
+*
+* read permutations from file ffperm5.dat. Included as DATA
+* statements they generated too much code in Absoft (54K)
+*
+ if ( init .eq. 0 ) then
+ init = 1
+ ier0 = 0
+ call ffopen(ifile,'ffperm5.dat',ier0)
+ if ( ier0 .ne. 0 ) goto 910
+ read(ifile,*)
+ read(ifile,*)
+ do 1 i=1,nperm,4
+ read(ifile,*,err=920,end=920)
+ + ((iperm(j1,j2),j1=1,5),j2=i,i+3)
+ 1 continue
+ close(ifile)
+ endif
+* #] data:
+* #[ check input:
+ if ( ltest .and. ns .ne. 15 ) then
+ print *,'ffdel5: error: ns <> 15!'
+ stop
+ endif
+ if ( lwrite ) then
+ print *,'ffdel5: xpi = ',xpi
+ endif
+* #] check input:
+* #[ out of memory:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
+ inow = memarr(i,3)
+ if ( lwrite ) print *,'ffdel5: found in memory'
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] out of memory:
+* #[ calculations:
+ imem = inow
+ del5 = 0
+ xmax = 0
+
+ 10 continue
+*
+* we only try the diagonal elements: top==bottom
+*
+ j1 = iperm(1,inow)
+ j2 = iperm(2,inow)
+ j3 = iperm(3,inow)
+ j4 = iperm(4,inow)
+ j5 = iperm(5,inow)
+*
+* The following was generated with the Form program
+* V p1,p2,p3,p4,p5;
+* L f = (e_(p1,p2,p3,p4,p5))**2;
+* Contract;
+* print +s;
+* .end
+* plus the substituion //p#@1\./p#@2/=/pDp(j@1,j@2)/
+*
+* #[ terms:
+ s(1)=+ xpi(j1)*xpi(j2)*xpi(j3)*xpi(j4)*xpi(j5)
+ s(2)=- xpi(j1)*xpi(j2)*xpi(j3)*pDp(j4,j5)**2
+ s(3)=- xpi(j1)*xpi(j2)*pDp(j3,j4)**2*xpi(j5)
+ s(4)=+2*xpi(j1)*xpi(j2)*pDp(j3,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(5)=- xpi(j1)*xpi(j2)*pDp(j3,j5)**2*xpi(j4)
+ s(6)=- xpi(j1)*pDp(j2,j3)**2*xpi(j4)*xpi(j5)
+ s(7)=+ xpi(j1)*pDp(j2,j3)**2*pDp(j4,j5)**2
+ s(8)=+2*xpi(j1)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j4)*xpi(j5)
+ s(9)=-2*xpi(j1)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(10)=-2*xpi(j1)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j4)*pDp(j4,j5)
+ s(11)=+2*xpi(j1)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j5)*xpi(j4)
+ s(12)=- xpi(j1)*pDp(j2,j4)**2*xpi(j3)*xpi(j5)
+ s(13)=+ xpi(j1)*pDp(j2,j4)**2*pDp(j3,j5)**2
+ s(14)=+2*xpi(j1)*pDp(j2,j4)*pDp(j2,j5)*xpi(j3)*pDp(j4,j5)
+ s(15)=-2*xpi(j1)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j4)*pDp(j3,j5)
+ s(16)=- xpi(j1)*pDp(j2,j5)**2*xpi(j3)*xpi(j4)
+ s(17)=+ xpi(j1)*pDp(j2,j5)**2*pDp(j3,j4)**2
+ s(18)=- pDp(j1,j2)**2*xpi(j3)*xpi(j4)*xpi(j5)
+ s(19)=+ pDp(j1,j2)**2*xpi(j3)*pDp(j4,j5)**2
+ s(20)=+ pDp(j1,j2)**2*pDp(j3,j4)**2*xpi(j5)
+ s(21)=-2*pDp(j1,j2)**2*pDp(j3,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(22)=+ pDp(j1,j2)**2*pDp(j3,j5)**2*xpi(j4)
+ s(23)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j3)*xpi(j4)*xpi(j5)
+ s(24)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j3)*pDp(j4,j5)**2
+ s(25)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j4)*pDp(j3,j4)*xpi(j5)
+ s(26)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(27)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j5)*pDp(j3,j4)*pDp(j4,j5)
+ s(28)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j5)*pDp(j3,j5)*xpi(j4)
+ s(29)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j3)*pDp(j3,j4)*xpi(j5)
+ s(30)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j3)*pDp(j3,j5)*pDp(j4,j5)
+ s(31)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j4)*xpi(j3)*xpi(j5)
+ s(32)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j4)*pDp(j3,j5)**2
+ s(33)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j5)*xpi(j3)*pDp(j4,j5)
+ s(34)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j5)*pDp(j3,j4)*pDp(j3,j5)
+ s(35)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j3)*pDp(j3,j4)*pDp(j4,j5)
+ s(36)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j3)*pDp(j3,j5)*xpi(j4)
+ s(37)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j4)*xpi(j3)*pDp(j4,j5)
+ s(38)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j4)*pDp(j3,j4)*pDp(j3,j5)
+ s(39)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j5)*xpi(j3)*xpi(j4)
+ s(40)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j5)*pDp(j3,j4)**2
+ s(41)=- pDp(j1,j3)**2*xpi(j2)*xpi(j4)*xpi(j5)
+ s(42)=+ pDp(j1,j3)**2*xpi(j2)*pDp(j4,j5)**2
+ s(43)=+ pDp(j1,j3)**2*pDp(j2,j4)**2*xpi(j5)
+ s(44)=-2*pDp(j1,j3)**2*pDp(j2,j4)*pDp(j2,j5)*pDp(j4,j5)
+ s(45)=+ pDp(j1,j3)**2*pDp(j2,j5)**2*xpi(j4)
+ s(46)=+2*pDp(j1,j3)*pDp(j1,j4)*xpi(j2)*pDp(j3,j4)*xpi(j5)
+ s(47)=-2*pDp(j1,j3)*pDp(j1,j4)*xpi(j2)*pDp(j3,j5)*pDp(j4,j5)
+ s(48)=-2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j3)*pDp(j2,j4)*xpi(j5)
+ s(49)=+2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j3)*pDp(j2,j5)*pDp(j4,j5)
+ s(50)=+2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j5)
+ s(51)=-2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j5)**2*pDp(j3,j4)
+ s(52)=-2*pDp(j1,j3)*pDp(j1,j5)*xpi(j2)*pDp(j3,j4)*pDp(j4,j5)
+ s(53)=+2*pDp(j1,j3)*pDp(j1,j5)*xpi(j2)*pDp(j3,j5)*xpi(j4)
+ s(54)=+2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j4)*pDp(j4,j5)
+ s(55)=-2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j5)*xpi(j4)
+ s(56)=-2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j4)**2*pDp(j3,j5)
+ s(57)=+2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j4)
+ s(58)=- pDp(j1,j4)**2*xpi(j2)*xpi(j3)*xpi(j5)
+ s(59)=+ pDp(j1,j4)**2*xpi(j2)*pDp(j3,j5)**2
+ s(60)=+ pDp(j1,j4)**2*pDp(j2,j3)**2*xpi(j5)
+ s(61)=-2*pDp(j1,j4)**2*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j5)
+ s(62)=+ pDp(j1,j4)**2*pDp(j2,j5)**2*xpi(j3)
+ s(63)=+2*pDp(j1,j4)*pDp(j1,j5)*xpi(j2)*xpi(j3)*pDp(j4,j5)
+ s(64)=-2*pDp(j1,j4)*pDp(j1,j5)*xpi(j2)*pDp(j3,j4)*pDp(j3,j5)
+ s(65)=-2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)**2*pDp(j4,j5)
+ s(66)=+2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j5)
+ s(67)=+2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j4)
+ s(68)=-2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j4)*pDp(j2,j5)*xpi(j3)
+ s(69)=- pDp(j1,j5)**2*xpi(j2)*xpi(j3)*xpi(j4)
+ s(70)=+ pDp(j1,j5)**2*xpi(j2)*pDp(j3,j4)**2
+ s(71)=+ pDp(j1,j5)**2*pDp(j2,j3)**2*xpi(j4)
+ s(72)=-2*pDp(j1,j5)**2*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j4)
+ s(73)=+ pDp(j1,j5)**2*pDp(j2,j4)**2*xpi(j3)
+* #] terms:
+*
+ del5p = 0
+ xmaxp = 0
+ do 20 i=1,nsi
+ del5p = del5p + s(i)
+ xmaxp = max(xmaxp,abs(s(i)))
+ 20 continue
+ if ( abs(del5p) .lt. xloss**2*xmaxp ) then
+ if ( lwrite ) print *,'del5+',inow,' = ',del5p,xmaxp,
+ + j1,j2,j3,j4,j5
+ if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
+ del5 = del5p
+ xmax = xmaxp
+ endif
+ inow = inow + 1
+ if ( inow .gt. nperm ) inow = 1
+ if ( inow .eq. imem ) then
+ if ( lwarn ) call ffwarn(160,ier,del5,xmax)
+ goto 800
+ endif
+ goto 10
+ endif
+ if ( inow .ne. imem ) then
+ if ( lwrite ) print *,'del5+',inow,' = ',del5p,xmaxp,
+ + j1,j2,j3,j4,j5
+ endif
+ del5 = del5p
+ xmax = xmaxp
+* #] calculations:
+* #[ into memory:
+ 800 continue
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+* #] into memory:
+* #[ error messages:
+ return
+ 910 print *,'ffdel5: error: cannot open file ffperm5.dat with data'
+ stop
+ 920 print *,'ffdel5: error: error reading from ffperm5.dat'
+ stop
+* #] error messages:
+*###] ffdel5:
+ end
+*###[ ffdl4p:
+ subroutine ffdl4p(dl4p,xpi,piDpj,ns,ii,ier)
+***#[*comment:***********************************************************
+* calculate in a numerically stable way *
+* *
+* p1 p2 p3 p4 *
+* delta *
+* p1 p2 p3 p4 *
+* *
+* with pn = xpi(ii(n)), n=1,4 *
+* p5 = -p1-p2-p3-p4 *
+* xpi(ii(n+5)) = pn+p(n+1), n=1,5 *
+* *
+* ier is the usual error flag. *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ii(10),ier
+ DOUBLE PRECISION dl4p,xpi(ns),piDpj(ns,ns)
+*
+* local variables
+*
+ integer i,j,k,jj(8),iperm(4,60)
+ DOUBLE PRECISION s(24),som,xmax,smax
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data (the permutations with 2 from each (1-5) and (6-10) are
+* still lacking)
+*
+ data ((iperm(j,i),j=1,4),i=1,35)
+ + /1,2,3,4, 2,3,4,5, 3,4,5,1, 4,5,1,2, 5,1,2,3,
+ + 6,2,3,4, 4,5,6,2, 5,6,2,3,
+ + 1,6,3,4, 4,5,1,6, 5,1,6,3,
+ + 1,7,3,4, 7,3,4,5, 5,1,7,3,
+ + 1,2,7,4, 2,7,4,5, 5,1,2,7,
+ + 1,2,8,4, 2,8,4,5, 8,4,5,1,
+ + 1,2,3,8, 2,3,8,5, 3,8,5,1,
+ + 2,3,9,5, 3,9,5,1, 9,5,1,2,
+ + 2,3,4,9, 3,4,9,1, 4,9,1,2,
+ + 3,4,10,1, 4,10,1,2, 10,1,2,3,
+ + 3,4,5,10, 4,5,10,2, 5,10,2,3/
+
+ data ((iperm(j,i),j=1,4),i=36,60)
+ + / 8,9,1,6, 1,6,7,8,
+ + 8,9,10,1, 10,1,7,8,
+ + 2,7,8,9, 9,10,2,7,
+ + 6,2,8,9, 9,10,6,2,
+ + 3,8,9,10, 10,6,3,8,
+ + 7,3,9,10, 10,6,7,3,
+ + 6,7,4,9, 4,9,10,6,
+ + 6,7,8,4, 8,4,10,6,
+ + 7,8,5,10, 5,10,6,7,
+ + 7,8,9,5, 9,5,6,7,
+ + 6,7,8,9, 7,8,9,10, 8,9,10,6, 9,10,6,7, 10,6,7,8/
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ do 10 i=1,10
+ if ( ii(i).lt.1 .or. ii(i).gt.ns ) then
+ print *,'ffdl4p: error: index out of bounds: ',ii
+ stop
+ endif
+ 10 continue
+ endif
+* #] check input:
+* #[ calculations:
+*
+* for the time being we just try the (60) diagonal elemnts.
+*
+ xmax = 0
+ do 100 i=1,60
+ jj(1) = ii(iperm(1,i))
+ jj(2) = ii(iperm(2,i))
+ jj(3) = ii(iperm(3,i))
+ jj(4) = ii(iperm(4,i))
+
+ s( 1) = +piDpj(jj(1),jj(1))*piDpj(jj(2),jj(2))*
+ + piDpj(jj(3),jj(3))*piDpj(jj(4),jj(4))
+ s( 2) = +piDpj(jj(2),jj(1))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(1),jj(3))*piDpj(jj(4),jj(4))
+ s( 3) = s(2)
+* s( 3) = +piDpj(jj(3),jj(1))*piDpj(jj(1),jj(2))*
+* + piDpj(jj(2),jj(3))*piDpj(jj(4),jj(4))
+ s( 4) = -piDpj(jj(1),jj(1))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(2),jj(3))*piDpj(jj(4),jj(4))
+ s( 5) = -piDpj(jj(3),jj(1))*piDpj(jj(2),jj(2))*
+ + piDpj(jj(1),jj(3))*piDpj(jj(4),jj(4))
+ s( 6) = -piDpj(jj(2),jj(1))*piDpj(jj(1),jj(2))*
+ + piDpj(jj(3),jj(3))*piDpj(jj(4),jj(4))
+
+ s( 7) = -piDpj(jj(1),jj(1))*piDpj(jj(2),jj(2))*
+ + piDpj(jj(4),jj(3))*piDpj(jj(3),jj(4))
+ s( 8) = -piDpj(jj(2),jj(1))*piDpj(jj(4),jj(2))*
+ + piDpj(jj(1),jj(3))*piDpj(jj(3),jj(4))
+ s( 9) = -piDpj(jj(4),jj(1))*piDpj(jj(1),jj(2))*
+ + piDpj(jj(2),jj(3))*piDpj(jj(3),jj(4))
+ s(10) = +piDpj(jj(1),jj(1))*piDpj(jj(4),jj(2))*
+ + piDpj(jj(2),jj(3))*piDpj(jj(3),jj(4))
+ s(11) = +piDpj(jj(4),jj(1))*piDpj(jj(2),jj(2))*
+ + piDpj(jj(1),jj(3))*piDpj(jj(3),jj(4))
+ s(12) = +piDpj(jj(2),jj(1))*piDpj(jj(1),jj(2))*
+ + piDpj(jj(4),jj(3))*piDpj(jj(3),jj(4))
+
+ s(13) = -piDpj(jj(1),jj(1))*piDpj(jj(4),jj(2))*
+ + piDpj(jj(3),jj(3))*piDpj(jj(2),jj(4))
+ s(14) = -piDpj(jj(4),jj(1))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(1),jj(3))*piDpj(jj(2),jj(4))
+ s(15) = s(8)
+* s(15) = -piDpj(jj(3),jj(1))*piDpj(jj(1),jj(2))*
+* + piDpj(jj(4),jj(3))*piDpj(jj(2),jj(4))
+ s(16) = s(10)
+* s(16) = +piDpj(jj(1),jj(1))*piDpj(jj(3),jj(2))*
+* + piDpj(jj(4),jj(3))*piDpj(jj(2),jj(4))
+ s(17) = +piDpj(jj(3),jj(1))*piDpj(jj(4),jj(2))*
+ + piDpj(jj(1),jj(3))*piDpj(jj(2),jj(4))
+ s(18) = +piDpj(jj(4),jj(1))*piDpj(jj(1),jj(2))*
+ + piDpj(jj(3),jj(3))*piDpj(jj(2),jj(4))
+
+ s(19) = -piDpj(jj(4),jj(1))*piDpj(jj(2),jj(2))*
+ + piDpj(jj(3),jj(3))*piDpj(jj(1),jj(4))
+ s(20) = s(9)
+* s(20) = -piDpj(jj(2),jj(1))*piDpj(jj(3),jj(2))*
+* + piDpj(jj(4),jj(3))*piDpj(jj(1),jj(4))
+ s(21) = s(14)
+* s(21) = -piDpj(jj(3),jj(1))*piDpj(jj(4),jj(2))*
+* + piDpj(jj(2),jj(3))*piDpj(jj(1),jj(4))
+ s(22) = +piDpj(jj(4),jj(1))*piDpj(jj(3),jj(2))*
+ + piDpj(jj(2),jj(3))*piDpj(jj(1),jj(4))
+ s(23) = s(11)
+* s(23) = +piDpj(jj(3),jj(1))*piDpj(jj(2),jj(2))*
+* + piDpj(jj(4),jj(3))*piDpj(jj(1),jj(4))
+ s(24) = s(18)
+* s(24) = +piDpj(jj(2),jj(1))*piDpj(jj(4),jj(2))*
+* + piDpj(jj(3),jj(3))*piDpj(jj(1),jj(4))
+
+ som = 0
+ smax = 0
+ do 80 k=1,24
+ som = som + s(k)
+ smax = max(smax,abs(som))
+ 80 continue
+ if ( i .eq. 1 .or. smax .lt. xmax ) then
+ dl4p = som
+ xmax = smax
+ endif
+ if ( lwrite ) then
+ print *,'dl4p = +',i-1,' = ',som,smax
+ endif
+ if ( abs(dl4p) .ge. xloss**2*smax ) goto 110
+ 100 continue
+ if ( lwarn ) call ffwarn(159,ier,dl4p,xmax)
+ 110 continue
+* #] calculations:
+* #[ debug output:
+ if ( lwrite ) then
+ print *,'ffdl4p: input: '
+ print *,' ii = ',ii
+ print *,' xpi= ',xpi
+ print *,'ffdl4p: output: ',dl4p,xmax
+ endif
+* #] debug output:
+*###] ffdl4p:
+ end
+*###[ ffdl4r:
+ subroutine ffdl4r(dl4r,xpi,piDpj,ns,miss,ier)
+***#[*comment:***********************************************************
+* calculate in a numerically stable way *
+* *
+* s1 s2 s3 s4 *
+* delta *
+* p1 p2 p3 p4 *
+* *
+* with s(miss) NOT included *
+* *
+* ier is the usual error flag. *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,miss,ier
+ DOUBLE PRECISION dl4r,xpi(ns),piDpj(ns,ns)
+*
+* local variables
+*
+ integer i,j,k,ii(4),jj(4),ipermp(4,125),iperms(4,125),
+ + iplace(11,5),minus(125),mem,msign
+ parameter(mem=45)
+ integer memarr(mem,4),inow,jnow,imem,jmem,memind
+ DOUBLE PRECISION s(24),som,xmax,smax,xnul
+ save ipermp,iperms,iplace,minus,memarr,inow,jnow,memind
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ data:
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1,mem*1/
+ data inow,jnow /1,1/
+*
+* data (see getpermp.for)
+*
+ data ipermp/
+ + 1,2,3,4,1,2,5,3,1,2,3,8,1,2,10,3,1,2,4,5,1,2,7,4,1,2,8,4,1,2,4,
+ + 9,1,2,4,10,1,2,5,7,1,2,9,5,1,2,7,8,1,2,10,7,1,2,8,9,1,2,9,10,1,
+ + 3,5,4,1,3,4,6,1,3,4,7,1,3,9,4,1,3,10,4,1,3,6,5,1,3,7,5,1,3,5,8,
+ + 1,3,5,9,1,3,8,6,1,3,6,10,1,3,8,7,1,3,7,10,1,3,9,8,1,3,10,8,1,3,
+ + 10,9,1,4,5,6,1,4,8,5,1,4,6,7,1,4,6,8,1,4,9,6,1,4,10,6,1,4,7,8,1,
+ + 4,8,9,1,4,8,10,1,5,7,6,1,5,6,9,1,5,8,7,1,5,9,8,1,6,7,8,1,6,10,7,
+ + 1,6,8,9,1,6,9,10,1,7,10,8,1,8,10,9,2,3,4,5,2,3,6,4,2,3,4,9,2,3,
+ + 5,6,2,3,8,5,2,3,9,5,2,3,5,10,2,3,6,8,2,3,10,6,2,3,8,9,2,3,9,10,
+ + 2,4,6,5,2,4,5,7,2,4,5,8,2,4,10,5,2,4,7,6,2,4,8,6,2,4,6,9,2,4,6,
+ + 10,2,4,9,7,2,4,9,8,2,4,10,9,2,5,6,7,2,5,9,6,2,5,7,8,2,5,7,9,2,5,
+ + 10,7,2,5,8,9,2,5,9,10,2,6,8,7,2,6,7,10,2,6,9,8,2,6,10,9,2,7,8,9,
+ + 2,7,9,10,3,4,7,5,3,4,5,10,3,4,6,7,3,4,10,6,3,4,7,9,3,4,9,10,3,5,
+ + 7,6,3,5,6,10,3,5,8,7,3,5,9,7,3,5,7,10,3,5,10,8,3,5,10,9,3,6,7,8,
+ + 3,6,10,7,3,6,8,10,3,7,9,8,3,7,10,9,3,8,9,10,4,5,6,7,4,5,10,6,4,
+ + 5,7,8,4,5,8,10,4,6,8,7,4,6,7,9,4,6,10,8,4,6,9,10,4,7,8,9,4,8,10,
+ + 9,5,6,9,7,5,6,7,10,5,6,10,9,5,7,9,8,5,7,8,10,5,8,9,10,6,7,8,9,6,
+ + 7,10,8,6,7,9,10,6,8,10,9,7,8,9,10/
+ data iperms/
+ + 1,2,3,4,1,2,3,7,1,2,8,3,1,2,3,10,1,2,6,4,1,2,4,7,1,2,4,9,1,2,6,7
+ + ,1,2,8,6,1,2,6,10,1,2,7,8,1,2,7,9,1,2,10,7,1,2,9,8,1,2,10,9,1,3,
+ + 4,5,1,3,6,4,1,3,10,4,1,3,7,5,1,3,5,8,1,3,10,5,1,3,6,7,1,3,8,6,1,
+ + 3,6,10,1,3,10,7,1,3,8,10,1,4,5,6,1,4,7,5,1,4,9,5,1,4,6,7,1,4,6,9
+ + ,1,4,6,10,1,4,10,7,1,4,10,9,1,5,6,7,1,5,8,6,1,5,6,10,1,5,7,8,1,5
+ + ,7,9,1,5,10,7,1,5,9,8,1,5,10,9,1,6,8,7,1,6,9,7,1,6,8,9,1,6,8,10,
+ + 1,6,9,10,1,7,10,8,1,7,10,9,1,8,9,10,2,3,4,5,2,3,8,4,2,3,9,4,2,3,
+ + 7,5,2,3,5,8,2,3,10,5,2,3,8,7,2,3,9,7,2,3,8,9,2,3,8,10,2,3,9,10,2
+ + ,4,5,6,2,4,7,5,2,4,9,5,2,4,6,8,2,4,6,9,2,4,8,7,2,4,9,7,2,4,8,9,2
+ + ,5,6,7,2,5,8,6,2,5,6,10,2,5,7,8,2,5,7,9,2,5,10,7,2,5,9,8,2,5,10,
+ + 9,2,6,8,7,2,6,9,7,2,6,8,9,2,6,8,10,2,6,9,10,2,7,10,8,2,7,10,9,2,
+ + 8,9,10,3,4,5,6,3,4,8,5,3,4,9,5,3,4,5,10,3,4,6,8,3,4,6,9,3,4,10,8
+ + ,3,4,10,9,3,5,6,7,3,5,8,6,3,5,6,10,3,5,7,8,3,5,7,9,3,5,10,7,3,5,
+ + 9,8,3,5,10,9,3,6,8,7,3,6,9,7,3,6,8,9,3,6,8,10,3,6,9,10,3,7,10,8,
+ + 3,7,10,9,3,8,9,10,4,5,6,7,4,5,8,6,4,5,6,10,4,5,7,8,4,5,7,9,4,5,1
+ + 0,7,4,5,9,8,4,5,10,9,4,6,8,7,4,6,9,7,4,6,8,9,4,6,8,10,4,6,9,10,4
+ + ,7,10,8,4,7,10,9,4,8,9,10/
+ data iplace /
+ + 2,3,4,5, 07,08,09,15, +12,+13, 17,
+ + 1,3,4,5, 11,08,09,10, -14,+13, 18,
+ + 1,2,4,5, 06,12,09,10, -14,-15, 19,
+ + 1,2,3,5, 06,07,13,10, +11,-15, 20,
+ + 1,2,3,4, 06,07,08,14, +11,+12, 16/
+ data minus /
+ + +1,+1,+1,+1,+1,+1,-1,+1,+1,+1,+1,-1,+1,-1,-1,+1,
+ + +1,+1,+1,+1,+1,+1,+1,+1,+1,+1,+1,+1,-1,+1,-1,+1,
+ + +1,-1,+1,+1,+1,+1,-1,+1,-1,-1,+1,-1,-1,+1,-1,+1,
+ + -1,-1,+1,+1,-1,+1,+1,+1,+1,-1,-1,+1,-1,+1,+1,-1,
+ + +1,-1,+1,-1,-1,+1,+1,+1,+1,-1,+1,-1,-1,+1,-1,-1,
+ + +1,-1,+1,-1,-1,+1,+1,-1,+1,+1,-1,+1,-1,+1,+1,+1,
+ + +1,-1,+1,-1,-1,+1,-1,-1,+1,-1,+1,-1,-1,+1,+1,+1,
+ + +1,-1,+1,-1,-1,+1,-1,-1,+1,-1,+1,-1,-1/
+* #] data:
+* #[ check input:
+ if ( ltest ) then
+ if ( miss.gt.5 .or. miss.lt.1 ) then
+ print *,'ffdl4r: error: miss < 1 or > 5: ',miss
+ stop
+ endif
+ do 4 i=1,15
+ xnul = 0
+ xmax = 0
+ do 1 j=6,10
+ xnul = xnul + piDpj(j,i)
+ xmax = max(xmax,abs(piDpj(j,i)))
+ 1 continue
+ if ( xloss*xnul .gt. precx*xmax ) print *,'ffdl4r: ',
+ + 'error: \sum p',i,'.p6-10 do not add up to 0: ',
+ + xnul,xmax
+ xnul = 0
+ xmax = 0
+ do 2 j=11,15
+ xnul = xnul + piDpj(j,i)
+ xmax = max(xmax,abs(piDpj(j,i)))
+ 2 continue
+ if ( xloss*xnul .gt. precx*xmax ) print *,'ffdl4r: ',
+ + 'error: \sum p',i,'.p11-15 do not add up to 0:',
+ + xnul,xmax
+* do 3 j=6,10
+* k = j+1
+* if ( k.eq.11 ) k=6
+* xnul = piDpj(i,j) + piDpj(i,k) - piDpj(i,j+5)
+* xmax = max(abs(piDpj(i,j)),abs(piDpj(i,k)))
+* if ( xloss*xnul .gt. precx*xmax ) print *,'ffdl4r:',
+* + ' error: \sum p',i,'.p',j,k,j+5,' do not add ',
+* + 'up to 0: ',xnul,xmax
+* 3 continue
+ 4 continue
+ endif
+* #] check input:
+* #[ out of memory:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
+ inow = memarr(i,3)
+ jnow = memarr(i,4)
+ if ( lwrite ) print *,'ffdel5: found in memory'
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] out of memory:
+* #[ calculations:
+*
+* loop over all permutations of the si and the pi -
+* we have 125*125 = a lot of possibilities before we give up ....
+* 15-feb-1993: well, let's only consider 25 at a time, otherwise
+* the time spent here becomes ludicrous
+*
+ imem = inow
+ jmem = jnow
+ dl4r = 0
+ xmax = 0
+*
+ do 110 i=1,5
+ ii(1) = abs(iplace((iperms(1,inow)),miss))
+ ii(2) = abs(iplace((iperms(2,inow)),miss))
+ ii(3) = abs(iplace((iperms(3,inow)),miss))
+ ii(4) = abs(iplace((iperms(4,inow)),miss))
+ msign = sign(1,iplace((iperms(1,inow)),miss))*
+ + sign(1,iplace((iperms(2,inow)),miss))*
+ + sign(1,iplace((iperms(3,inow)),miss))*
+ + sign(1,iplace((iperms(4,inow)),miss))
+ do 100 j=1,5
+ jj(1) = ipermp(1,jnow) + 5
+ jj(2) = ipermp(2,jnow) + 5
+ jj(3) = ipermp(3,jnow) + 5
+ jj(4) = ipermp(4,jnow) + 5
+*
+ s( 1) = +piDpj(ii(1),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(4),jj(4))
+ s( 2) = +piDpj(ii(2),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(4),jj(4))
+ s( 3) = +piDpj(ii(3),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(4),jj(4))
+ s( 4) = -piDpj(ii(1),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(4),jj(4))
+ s( 5) = -piDpj(ii(3),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(4),jj(4))
+ s( 6) = -piDpj(ii(2),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(4),jj(4))
+*
+ s( 7) = -piDpj(ii(1),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(3),jj(4))
+ s( 8) = -piDpj(ii(2),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(3),jj(4))
+ s( 9) = -piDpj(ii(4),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(3),jj(4))
+ s(10) = +piDpj(ii(1),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(3),jj(4))
+ s(11) = +piDpj(ii(4),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(3),jj(4))
+ s(12) = +piDpj(ii(2),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(3),jj(4))
+*
+ s(13) = -piDpj(ii(1),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(2),jj(4))
+ s(14) = -piDpj(ii(4),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(2),jj(4))
+ s(15) = -piDpj(ii(3),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(2),jj(4))
+ s(16) = +piDpj(ii(1),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(2),jj(4))
+ s(17) = +piDpj(ii(3),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(2),jj(4))
+ s(18) = +piDpj(ii(4),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(2),jj(4))
+*
+ s(19) = -piDpj(ii(4),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(1),jj(4))
+ s(20) = -piDpj(ii(2),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(1),jj(4))
+ s(21) = -piDpj(ii(3),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(1),jj(4))
+ s(22) = +piDpj(ii(4),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(1),jj(4))
+ s(23) = +piDpj(ii(3),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(1),jj(4))
+ s(24) = +piDpj(ii(2),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(1),jj(4))
+*
+ som = 0
+ smax = 0
+ do 80 k=1,24
+ som = som + s(k)
+ smax = max(smax,abs(som))
+ 80 continue
+ if ( ( inow .eq. imem .and. jnow .eq. jmem ) .or.
+ + smax .lt. xmax ) then
+ dl4r = msign*minus(inow)*som
+ xmax = smax
+ endif
+ if ( lwrite ) then
+ print *,'dl4r+',i-1,j-1,' = ',msign*minus(inow)*som,smax
+ print *,' inow,ii = ',inow,ii
+ print *,' jnow,jj = ',jnow,jj
+ endif
+ if ( abs(dl4r) .ge. xloss**2*smax ) goto 120
+* increase with something that is relative prime to 125 so that
+* eventually we cover all possibilities, but with a good
+* scatter.
+ jnow = jnow + 49
+ if ( jnow .gt. 125 ) jnow = jnow - 125
+ 100 continue
+* again, a number relative prime to 125 and a few times smaller
+ inow = inow + 49
+ if ( inow .gt. 125 ) inow = inow - 125
+ 110 continue
+ if ( lwarn ) call ffwarn(169,ier,dl4r,xmax)
+ 120 continue
+* #] calculations:
+* #[ into memory:
+ 800 continue
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+ memarr(memind,4) = jnow
+* #] into memory:
+*###] ffdl4r:
+ end
diff --git a/ff-2.0/ffdel6.f b/ff-2.0/ffdel6.f
new file mode 100644
index 0000000..1a773ed
--- /dev/null
+++ b/ff-2.0/ffdel6.f
@@ -0,0 +1,787 @@
+* $Id: ffdel6.f,v 1.4 1996/03/14 15:53:15 gj Exp $
+*###[ ffdel6:
+ subroutine ffdel6(del6s,xpi,piDpj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* compute the coefficient of the F0 in the decomposition in 5 E0s *
+* note that this is not a proper determinant as the s_i do not *
+* exist when the p_i live in 4-space. *
+* *
+* s1 p1 p2 p3 p4 p5 *
+* del6 = delta *
+* s1 p1 p2 p3 p4 p5 *
+* *
+* Input: xpi real(ns) 1-6: mi_2, 7-21: p_i^2 *
+* piDpj real(ns,ns) pi.pj *
+* ns integer assumed 21 for the time being *
+* ier integer usual error flag *
+* Output del6s real *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit logical (a-r,u-z)
+ implicit DOUBLE PRECISION (s,t)
+*
+* arguments
+*
+ integer ns,ier
+ DOUBLE PRECISION del6s,xpi(21),piDpj(21,21)
+*
+* local vars
+*
+ integer i,is,ip(5),ii(15)
+ DOUBLE PRECISION som(315),xmx,sum,xmax
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( ns.ne.21 ) then
+ print *,'ffdel6: only for ns=21 for the time being'
+ stop
+ endif
+ endif
+ if ( lwrite ) then
+ print *,'ffdel6: input '
+ print *,'xpi = ',xpi
+ endif
+* #] check input:
+* #[ work:
+ do 100 is=1,6
+*
+* find a linearly independent set ipi such that s.pi minimal
+*
+ do 5 i=1,15
+ som(i) = abs(piDpj(6+i,is))
+ 5 continue
+ call ffsort(som,ii,15)
+ do 6 i=1,15
+ ii(i) = ii(i)+6
+ 6 continue
+ call ff5ind(ip,ii,0,ier)
+*
+* not so straight from Maple
+*
+ t1 = piDpj(is,ip(3))
+ t2 = t1**2
+ t3 = piDpj(ip(1),ip(4))
+ t4 = t3**2
+ t5 = piDpj(ip(2),ip(5))
+ t6 = t5**2
+ t10 = piDpj(is,ip(2))
+ t11 = t10**2
+ t12 = piDpj(ip(1),ip(5))
+ t13 = t12**2
+ t14 = piDpj(ip(3),ip(4))
+ t15 = t14**2
+ t19 = piDpj(is,ip(5))
+ t20 = t19**2
+ t21 = piDpj(ip(2),ip(3))
+ t22 = t21**2
+ t26 = piDpj(ip(1),ip(3))
+ t27 = t26**2
+ t28 = piDpj(ip(2),ip(4))
+ t29 = t28**2
+ t33 = piDpj(ip(4),ip(5))
+ t34 = t33**2
+ t38 = piDpj(ip(1),ip(2))
+ t39 = t38**2
+ t43 = xpi(ip(1))
+ t44 = xpi(ip(2))
+ t45 = xpi(ip(3))
+ t46 = xpi(ip(4))
+ t52 = xpi(ip(5))
+ t53 = piDpj(is,ip(4))
+ t54 = t53**2
+ t66 = piDpj(ip(3),ip(5))
+ t67 = t66**2
+ t77 = piDpj(is,ip(1))
+ t78 = t77**2
+ t222 = t66*t33
+ t228 = t14*t33
+ t234 = t14*t66
+ t254 = t5*t33
+ t260 = t28*t33
+ t266 = t28*t5
+ t278 = t5*t66
+ t284 = t21*t33
+ t285 = t12*t284
+ t290 = t21*t66
+ t296 = t21*t5
+ t302 = t28*t14
+ t308 = t21*t14
+ t315 = t21*t28
+ t321 = t14*t222
+ t325 = t21*t34
+ t330 = t28*t222
+ t335 = t5*t228
+ t340 = t21*t222
+ t345 = t28*t67
+ t350 = t5*t234
+ t355 = t21*t228
+ t360 = t28*t234
+ t369 = t5*t15
+ t374 = t28*t254
+ t378 = t21*t254
+ t383 = t28*t278
+ t388 = t6*t14
+ t393 = t21*t260
+ t398 = t29*t66
+ t403 = t5*t14
+ t404 = t28*t403
+ t409 = t21*t278
+ t414 = t22*t33
+ t419 = t28*t66
+ t420 = t21*t419
+ t425 = t21*t403
+ t430 = t21*t302
+ t446 = t12*t33
+ t452 = t3*t33
+ t472 = t12*t66
+ t478 = t26*t66
+ t494 = t3*t14
+ t500 = t26*t14
+ t515 = t26*t34
+ t520 = t3*t222
+ t526 = t12*t228
+ t531 = t26*t222
+ t536 = t3*t67
+ t541 = t12*t234
+ t546 = t26*t228
+ t551 = t3*t234
+ t556 = t12*t15
+ t561 = t3*t446
+ t593 = t12*t14
+ t599 = t26*t472
+ t619 = t26*t494
+ t630 = t12*t5
+ t648 = t3*t28
+ t674 = t3*t254
+ t679 = t12*t260
+ t691 = t3*t6
+ t696 = t12*t266
+ t706 = t3*t266
+ t711 = t12*t29
+ t745 = t12*t28
+ t751 = t38*t630
+ t771 = t38*t648
+ t775 = t26*t21
+ t806 = t26*t278
+ t811 = t12*t290
+ t826 = t12*t296
+ t842 = t12*t22
+ t879 = t12*t21
+ t906 = t38*t775
+ t918 = t26*t302
+ t923 = t3*t308
+ t939 = t3*t315
+ t990 = t3*t21
+ t1231 = t12*t419
+ t1236 = t12*t403
+ t1261 = t3*t278
+ t1303 = t3*t284
+ t1308 = t3*t419
+ t1313 = t3*t403
+ t1321 = t12*t302
+ t1330 = t12*t308
+ t1417 = t12*t315
+ som(1) = +t45*t52*t78*t29
+ som(2) = +t44*t52*t2*t4
+ som(3) = +t44*t52*t78*t15
+ som(4) = +t44*t46*t2*t13
+ som(5) = +t44*t46*t20*t27
+ som(6) = +t43*t46*t20*t22
+ som(7) = -2*t45*t46*t77*t10*t630
+ som(8) = -t2*t39*t34
+ som(9) = +t44*t46*t78*t67
+ som(10) = -2*t45*t54*t751
+ som(11) = +t44*t45*t20*t4
+ som(12) = +t44*t45*t54*t13
+ som(13) = +t44*t45*t78*t34
+ som(14) = -t44*t45*t46*t52*t78
+ som(15) = +t44*t52*t54*t27
+ som(16) = +t43*t45*t20*t29
+ som(17) = +t43*t52*t11*t15
+ som(18) = +t43*t45*t54*t6
+ som(19) = +2*t52*t77*t53*t26*t315
+ som(20) = -t20*t4*t22
+ som(21) = +2*t45*t46*t52*t77*t10*t38
+ som(22) = -t11*t4*t67
+ som(23) = -t78*t22*t34
+ som(24) = -t2*t13*t29
+ som(25) = +2*t78*t28*t350
+ som(26) = +2*t78*t21*t335
+ som(27) = +2*t78*t21*t330
+ som(28) = -2*t52*t54*t906
+ som(29) = -2*t52*t2*t771
+ som(30) = -t11*t13*t15
+ som(31) = +2*t52*t77*t53*t38*t308
+ som(32) = +2*t44*t53*t19*t26*t593
+ som(33) = +2*t52*t77*t1*t939
+ som(34) = -2*t52*t11*t619
+ som(35) = -2*t52*t77*t1*t26*t29
+ som(36) = +2*t44*t53*t19*t26*t3*t66
+ som(37) = -t20*t39*t15
+ som(38) = +2*t52*t77*t1*t38*t302
+ som(39) = -2*t52*t78*t430
+ som(40) = -2*t46*t20*t906
+ som(41) = -2*t44*t53*t19*t27*t33
+ som(42) = -2*t46*t2*t751
+ som(43) = +2*t52*t77*t10*t923
+ som(44) = +2*t44*t1*t19*t3*t593
+ som(45) = +2*t52*t77*t10*t918
+ som(46) = -2*t52*t77*t10*t38*t15
+ som(47) = -2*t44*t1*t19*t4*t66
+ som(48) = +t43*t52*t54*t22
+ som(49) = +2*t44*t1*t19*t26*t452
+ som(50) = -2*t44*t1*t53*t13*t14
+ som(51) = -2*t46*t11*t599
+ som(52) = +2*t44*t1*t53*t3*t472
+ som(53) = +2*t46*t1*t19*t38*t879
+ som(54) = +2*t44*t1*t53*t26*t446
+ som(55) = +2*t46*t1*t19*t38*t26*t5
+ som(56) = -2*t44*t77*t19*t556
+ som(57) = +2*t44*t77*t19*t551
+ som(58) = -2*t46*t1*t19*t39*t66
+ som(59) = +t43*t46*t11*t67
+ som(60) = +2*t44*t77*t19*t546
+ som(61) = +2*t46*t10*t19*t26*t879
+ som(62) = +2*t44*t77*t53*t541
+ som(63) = -2*t44*t77*t53*t536
+ som(64) = +2*t44*t77*t53*t531
+ som(65) = -2*t46*t10*t19*t27*t5
+ som(66) = +2*t44*t77*t1*t526
+ som(67) = -2*t46*t78*t409
+ som(68) = +2*t46*t10*t19*t38*t478
+ som(69) = +2*t44*t77*t1*t520
+ som(70) = -2*t46*t10*t1*t13*t21
+ som(71) = -t54*t27*t6
+ som(72) = -2*t44*t77*t1*t515
+ som(73) = -2*t45*t20*t771
+ som(74) = -2*t44*t52*t1*t53*t26*t3
+ som(75) = +2*t46*t10*t1*t26*t630
+ som(76) = +2*t46*t10*t1*t38*t472
+ som(77) = -2*t44*t52*t77*t53*t500
+ som(78) = -2*t44*t46*t1*t19*t26*t12
+ som(79) = -2*t44*t52*t77*t1*t494
+ som(80) = -2*t1*t19*t26*t706
+ som(81) = -2*t45*t11*t561
+ som(82) = -2*t46*t77*t19*t842
+ som(83) = +2*t46*t77*t19*t26*t296
+ som(84) = +4*t77*t10*t38*t321
+ som(85) = -2*t44*t46*t77*t19*t478
+ som(86) = +2*t46*t77*t19*t38*t290
+ som(87) = -2*t44*t46*t77*t1*t472
+ som(88) = +2*t46*t77*t1*t826
+ som(89) = -t54*t13*t22
+ som(90) = -2*t45*t78*t374
+ som(91) = +2*t44*t46*t52*t77*t1*t26
+ som(92) = -2*t46*t77*t1*t26*t6
+ som(93) = -2*t44*t20*t619
+ som(94) = -2*t44*t45*t53*t19*t3*t12
+ som(95) = -t54*t39*t67
+ som(96) = -2*t44*t54*t599
+ som(97) = +2*t46*t77*t1*t38*t278
+ som(98) = -t2*t4*t6
+ som(99) = +2*t20*t26*t939
+ som(100) = -2*t44*t45*t77*t19*t452
+ som(101) = -2*t44*t78*t321
+ som(102) = -2*t44*t2*t561
+ som(103) = +2*t46*t77*t10*t811
+ som(104) = -2*t44*t45*t77*t53*t446
+ som(105) = +2*t46*t77*t10*t806
+ som(106) = +2*t53*t19*t3*t842
+ som(107) = +2*t44*t45*t52*t77*t53*t3
+ som(108) = +2*t44*t45*t46*t77*t19*t12
+ som(109) = -2*t43*t20*t430
+ som(110) = -t78*t6*t15
+ som(111) = -2*t46*t77*t10*t38*t67
+ som(112) = +2*t43*t53*t19*t425
+ som(113) = -2*t53*t19*t26*t1417
+ som(114) = -2*t46*t52*t10*t1*t38*t26
+ som(115) = -2*t53*t19*t26*t3*t296
+ som(116) = +2*t53*t19*t27*t266
+ som(117) = +2*t43*t53*t19*t420
+ som(118) = -2*t77*t10*t26*t335
+ som(119) = -2*t53*t19*t38*t1330
+ som(120) = -2*t43*t53*t19*t414
+ som(121) = -2*t46*t52*t77*t1*t38*t21
+ som(122) = -2*t43*t2*t374
+ som(123) = +2*t43*t1*t19*t404
+ som(124) = -2*t43*t54*t409
+ som(125) = -2*t53*t19*t38*t3*t290
+ som(126) = -2*t43*t1*t19*t398
+ som(127) = +2*t43*t1*t19*t393
+ som(128) = -2*t43*t1*t53*t388
+ som(129) = +2*t43*t1*t53*t383
+ som(130) = -2*t46*t52*t77*t10*t775
+ som(131) = +2*t43*t1*t53*t378
+ som(132) = +2*t20*t38*t918
+ som(133) = +2*t20*t38*t923
+ som(134) = -2*t53*t19*t38*t26*t403
+ som(135) = -2*t43*t10*t19*t369
+ som(136) = -2*t53*t19*t38*t26*t419
+ som(137) = +2*t43*t10*t19*t360
+ som(138) = +2*t45*t53*t19*t38*t745
+ som(139) = +4*t53*t19*t38*t26*t284
+ som(140) = -2*t43*t11*t321
+ som(141) = +2*t53*t19*t39*t234
+ som(142) = +2*t43*t10*t19*t355
+ som(143) = +2*t45*t53*t19*t38*t3*t5
+ som(144) = +2*t43*t10*t53*t350
+ som(145) = -2*t43*t10*t53*t345
+ som(146) = +2*t43*t10*t53*t340
+ som(147) = +2*t43*t10*t1*t335
+ som(148) = +2*t54*t38*t806
+ som(149) = +2*t54*t38*t811
+ som(150) = +2*t54*t26*t826
+ som(151) = -t20*t27*t29
+ som(152) = -2*t43*t10*t1*t325
+ som(153) = +2*t43*t10*t1*t330
+ som(154) = -2*t1*t19*t3*t1417
+ som(155) = -t78*t29*t67
+ som(156) = +2*t1*t19*t4*t296
+ som(157) = -2*t45*t53*t19*t39*t33
+ som(158) = -2*t43*t52*t1*t53*t315
+ som(159) = +2*t1*t19*t26*t711
+ som(160) = -2*t43*t52*t10*t53*t308
+ som(161) = +2*t45*t10*t19*t3*t745
+ som(162) = -2*t43*t52*t10*t1*t302
+ som(163) = -2*t43*t46*t1*t19*t296
+ som(164) = -2*t1*t19*t38*t1321
+ som(165) = -2*t45*t10*t19*t4*t5
+ som(166) = -2*t43*t46*t10*t19*t290
+ som(167) = +4*t1*t19*t38*t1308
+ som(168) = -2*t1*t19*t38*t1313
+ som(169) = +2*t45*t10*t19*t38*t452
+ som(170) = -2*t1*t53*t38*t285
+ som(171) = -2*t1*t19*t38*t1303
+ som(172) = -2*t1*t19*t38*t26*t260
+ som(173) = -2*t43*t46*t10*t1*t278
+ som(174) = +2*t43*t46*t52*t10*t1*t21
+ som(175) = -2*t45*t10*t53*t13*t28
+ som(176) = +2*t1*t19*t39*t228
+ som(177) = +2*t1*t53*t13*t315
+ som(178) = +2*t45*t10*t53*t3*t630
+ som(179) = -2*t43*t45*t53*t19*t266
+ som(180) = -2*t1*t53*t3*t826
+ som(181) = -2*t1*t53*t26*t696
+ som(182) = +2*t45*t10*t53*t38*t446
+ som(183) = +2*t1*t53*t26*t691
+ som(184) = -2*t43*t45*t10*t19*t260
+ som(185) = +4*t1*t53*t38*t1236
+ som(186) = -2*t1*t53*t38*t1231
+ som(187) = +2*t43*t45*t52*t10*t53*t28
+ som(188) = -2*t45*t77*t19*t711
+ som(189) = -2*t1*t53*t38*t1261
+ som(190) = +2*t43*t45*t46*t10*t19*t5
+ som(191) = -2*t1*t53*t38*t26*t254
+ som(192) = +2*t45*t77*t19*t706
+ som(193) = +2*t1*t53*t39*t222
+ som(194) = -2*t43*t44*t53*t19*t234
+ som(195) = -2*t43*t44*t1*t19*t228
+ som(196) = +2*t2*t38*t674
+ som(197) = +2*t2*t38*t679
+ som(198) = +2*t2*t3*t696
+ som(199) = -2*t10*t19*t3*t1330
+ som(200) = +2*t10*t19*t4*t290
+ som(201) = +2*t45*t77*t19*t38*t260
+ som(202) = +2*t43*t44*t52*t1*t53*t14
+ som(203) = -2*t10*t19*t26*t1321
+ som(204) = -2*t43*t44*t1*t53*t222
+ som(205) = -t11*t27*t34
+ som(206) = +t43*t52*t2*t29
+ som(207) = +4*t10*t19*t26*t1313
+ som(208) = +2*t43*t44*t46*t1*t19*t66
+ som(209) = +2*t43*t44*t45*t53*t19*t33
+ som(210) = +2*t45*t77*t53*t696
+ som(211) = -2*t10*t19*t26*t1308
+ som(212) = -t43*t44*t45*t52*t54
+ som(213) = -2*t45*t77*t53*t691
+ som(214) = -2*t10*t19*t26*t1303
+ som(215) = -2*t43*t45*t10*t53*t254
+ som(216) = +t45*t46*t78*t6
+ som(217) = +2*t45*t77*t53*t38*t254
+ som(218) = +2*t10*t19*t27*t260
+ som(219) = +2*t10*t19*t38*t556
+ som(220) = -2*t10*t19*t38*t551
+ som(221) = +t43*t46*t2*t6
+ som(222) = -2*t10*t19*t38*t546
+ som(223) = +2*t10*t53*t13*t308
+ som(224) = -2*t10*t53*t3*t811
+ som(225) = -2*t10*t53*t26*t1236
+ som(226) = +4*t10*t53*t26*t1231
+ som(227) = +t43*t45*t11*t34
+ som(228) = +2*t45*t77*t10*t679
+ som(229) = -2*t10*t53*t26*t285
+ som(230) = -2*t10*t53*t26*t1261
+ som(231) = +2*t10*t53*t27*t254
+ som(232) = +2*t45*t77*t10*t674
+ som(233) = -2*t10*t53*t38*t541
+ som(234) = +2*t10*t53*t38*t536
+ som(235) = -2*t10*t53*t38*t531
+ som(236) = +2*t10*t1*t13*t302
+ som(237) = +t46*t52*t2*t39
+ som(238) = -2*t45*t77*t10*t38*t34
+ som(239) = -2*t10*t1*t3*t1231
+ som(240) = -2*t10*t1*t3*t1236
+ som(241) = +4*t10*t1*t3*t285
+ som(242) = +t46*t52*t11*t27
+ som(243) = +2*t10*t1*t4*t278
+ som(244) = -2*t45*t52*t10*t53*t38*t3
+ som(245) = -2*t10*t1*t26*t679
+ som(246) = -2*t10*t1*t26*t674
+ som(247) = +t46*t52*t78*t22
+ som(248) = -2*t10*t1*t38*t526
+ som(249) = -2*t10*t1*t38*t520
+ som(250) = +2*t10*t1*t38*t515
+ som(251) = +4*t77*t19*t12*t430
+ som(252) = -2*t77*t19*t3*t425
+ som(253) = -2*t77*t19*t3*t420
+ som(254) = +2*t77*t19*t3*t414
+ som(255) = -2*t77*t19*t26*t404
+ som(256) = +t45*t52*t54*t39
+ som(257) = +2*t77*t19*t26*t398
+ som(258) = -2*t45*t52*t77*t53*t38*t28
+ som(259) = -2*t77*t19*t26*t393
+ som(260) = +2*t77*t19*t38*t369
+ som(261) = -2*t77*t19*t38*t360
+ som(262) = -2*t45*t52*t77*t10*t648
+ som(263) = -2*t77*t19*t38*t355
+ som(264) = -2*t77*t53*t12*t425
+ som(265) = -2*t77*t53*t12*t420
+ som(266) = +2*t11*t26*t520
+ som(267) = +2*t11*t26*t526
+ som(268) = +2*t11*t3*t541
+ som(269) = +t45*t46*t20*t39
+ som(270) = +2*t77*t53*t12*t414
+ som(271) = +4*t77*t53*t3*t409
+ som(272) = +2*t77*t53*t26*t388
+ som(273) = -2*t77*t53*t26*t383
+ som(274) = -2*t77*t53*t26*t378
+ som(275) = -2*t77*t53*t38*t350
+ som(276) = +2*t77*t53*t38*t345
+ som(277) = -2*t77*t53*t38*t340
+ som(278) = -2*t77*t1*t12*t404
+ som(279) = +2*t77*t1*t12*t398
+ som(280) = -2*t77*t1*t12*t393
+ som(281) = +2*t77*t1*t3*t388
+ som(282) = -2*t45*t46*t10*t19*t38*t12
+ som(283) = -2*t77*t1*t3*t383
+ som(284) = -2*t77*t1*t3*t378
+ som(285) = +4*t77*t1*t26*t374
+ som(286) = -2*t77*t1*t38*t335
+ som(287) = -2*t77*t1*t38*t330
+ som(288) = +t43*t44*t2*t34
+ som(289) = +2*t77*t1*t38*t325
+ som(290) = +2*t77*t10*t12*t369
+ som(291) = -2*t77*t10*t12*t360
+ som(292) = -2*t77*t10*t12*t355
+ som(293) = -2*t77*t10*t3*t350
+ som(294) = +2*t77*t10*t3*t345
+ som(295) = -2*t77*t10*t3*t340
+ som(296) = +t45*t46*t11*t13
+ som(297) = -t43*t45*t46*t52*t11
+ som(298) = -2*t77*t10*t26*t330
+ som(299) = +2*t77*t10*t26*t325
+ som(300) = +2*t52*t1*t53*t38*t990
+ som(301) = +2*t52*t1*t53*t38*t26*t28
+ som(302) = -2*t52*t1*t53*t39*t14
+ som(303) = +t43*t44*t54*t67
+ som(304) = +2*t52*t10*t53*t26*t990
+ som(305) = +t45*t52*t11*t4
+ som(306) = -2*t52*t10*t53*t27*t28
+ som(307) = +2*t52*t10*t53*t38*t500
+ som(308) = -2*t52*t10*t1*t4*t21
+ som(309) = -2*t45*t46*t77*t19*t38*t5
+ som(310) = +2*t52*t10*t1*t26*t648
+ som(311) = +2*t52*t10*t1*t38*t494
+ som(312) = -t43*t44*t45*t46*t20
+ som(313) = -2*t52*t77*t53*t3*t22
+ som(314) = -t43*t44*t46*t52*t2
+ som(315) = +t43*t44*t20*t15
+
+ sum = 0
+ xmx = 0
+ do 10 i=1,315
+ sum = sum + som(i)
+ xmx = max(xmx,abs(som(i)))
+ 10 continue
+ if ( lwrite ) then
+ print *,'ffdel6s: del6s',is,' = ',sum,xmx
+ endif
+ if ( is.eq.1 ) then
+ del6s = sum
+ xmax = xmx
+ endif
+ if ( xmx.lt.xmax ) then
+ del6s = sum
+ xmax = xmx
+ endif
+ if ( abs(del6s) .gt. xloss**2*xmax ) goto 110
+ 100 continue
+ if ( lwarn ) call ffwarn(187,ier,sum,xmx)
+ 110 continue
+*
+* #] work:
+*###] ffdel6:
+ end
+*###[ ffsort:
+ subroutine ffsort(a,ii,nn)
+***#[*comment:***********************************************************
+* *
+* Sort the array a(nn): give the position of the smallest element *
+* in ii(1), ..., largest in ii(nn). I use a fancy merge-sort *
+* algorithm which is probably not the samrtest thing to do with *
+* the small arrays for which it is used, but it was fun to program*
+* To extend to larger arrays: just change 1024 to some power of 2 *
+* *
+* Input: a real(nn) array *
+* nn integer *
+* Output: ii integer(nn) a(ii(1))<=a(ii(2))<=.<=a(ii(nn))*
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer nn,ii(nn)
+ DOUBLE PRECISION a(nn)
+*
+* local variables
+*
+ integer i,j,k,jj(1024,2),h,j12,j21,l,m,n,o
+*
+* common
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ work:
+ if ( nn.gt.1024 ) then
+ print *,'ffsort: can only sort up to 1024 elments, not ',nn
+ stop
+ endif
+ do 10 i=1,nn
+ jj(i,1) = i
+ 10 continue
+ j12 = 1
+ j21 = 2
+*
+* do the first sweep faster
+*
+ do 15 i=1,nn-1,2
+ if ( a(jj(i,j12)) .le. a(jj(i+1,j12)) ) then
+ jj(i,j21) = jj(i,j12)
+ jj(i+1,j21) = jj(i+1,j12)
+ else
+ jj(i,j21) = jj(i+1,j12)
+ jj(i+1,j21) = jj(i,j12)
+ endif
+ 15 continue
+ if ( mod(nn,2).ne.0 ) jj(nn,j21) = jj(nn,j12)
+ o = j12
+ j12 = j21
+ j21 = o
+*
+* and do the other sweeps (works also for k=1,10)
+*
+ do 100 k=2,nint(log(dble(1024))/log(dble(2)))
+ h = 2**k
+ do 90 j=1,nn,h
+ l = j
+ n = j
+ m = j+h/2
+ if ( m.gt.nn ) then
+ do 17 o=j,nn
+ jj(o,j21) = jj(o,j12)
+ 17 continue
+ goto 90
+ endif
+ do 20 i=1,2*1024
+ if ( a(jj(l,j12)) .le. a(jj(m,j12)) ) then
+ jj(n,j21) = jj(l,j12)
+ l = l+1
+ n = n+1
+ if ( l.ge.j+h/2 ) then
+ do 18 o=m,min(j+h-1,nn)
+ jj(n,j21) = jj(o,j12)
+ n = n+1
+ 18 continue
+ goto 21
+ endif
+ else
+ jj(n,j21) = jj(m,j12)
+ m = m+1
+ n = n+1
+ if ( m.ge.j+h .or. m.gt.nn ) then
+ do 19 o=l,j+h/2-1
+ jj(n,j21) = jj(o,j12)
+ n = n+1
+ 19 continue
+ goto 21
+ endif
+ endif
+ 20 continue
+ 21 continue
+ if ( n.ne.j+h .and. n.ne.nn+1 ) print *,'n wrong: ',n
+ 90 continue
+ o = j12
+ j12 = j21
+ j21 = o
+ if ( h.ge.nn ) goto 900
+ 100 continue
+ 900 continue
+ do 901 i=1,nn
+ ii(i) = jj(i,j12)
+ 901 continue
+* #] work:
+* #[ debug output:
+* if ( lwrite ) then
+* print *,'This should be sorted:'
+* do 910 i=1,nn
+* print '(i5,f20.8)',ii(i),a(ii(i))
+* 910 continue
+* endif
+* #] debug output:
+*###] ffsort:
+ end
+*###[ ff5ind:
+ subroutine ff5ind(ip,ii,ngiven,ier)
+***#[*comment:***********************************************************
+* *
+* Find a set of 5 independent external momenta (disregarding the *
+* fact that we live in 4-dim space), preferring low indices in ii *
+* the first ngiven are already given in ip. *
+* *
+* Input: ii integer(15) some ordered set of 7-21 *
+* ngiven integer the first ngiven ip(i) are input*
+* Output: ip integer(5) p(ip(i)) are independent momenta*
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ii(15),ip(5),ngiven,ier
+*
+* local variables
+*
+ integer i,j,k,oldk,t,in,third(7:21,7:21),idep(7:21),depi(15),i1
+ save third
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+* the array which gives the third vector which forms a dependent
+* set of 3
+* 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
+ data third/
+ + 0,13, 0, 0, 0,18, 8,19, 0, 0,20,12, 14,17, 0,
+ + 13, 0,14, 0, 0, 0, 7, 9,20, 0, 0,21, 0,15,18,
+ + 0,14, 0,15, 0, 0, 19, 8,10,21, 0, 0, 13, 0,16,
+ + 0, 0,15, 0,16, 0, 0,20, 9,11,19, 0, 17,14, 0,
+ + 0, 0, 0,16, 0,17, 0, 0,21,10,12,20, 0,18,15,
+ + 18, 0, 0, 0,17, 0, 21, 0, 0,19,11, 7, 16, 0,13,
+
+ + 8, 7,19, 0, 0,21, 0, 0,17, 0,15, 0, 9, 0,12,
+ + 19, 9, 8,20, 0, 0, 0, 0, 0,18, 0,16, 7,10, 0,
+ + 0,20,10, 9,21, 0, 17, 0, 0, 0,13, 0, 0, 8,11,
+ + 0, 0,21,11,10,19, 0,18, 0, 0, 0,14, 12, 0, 9,
+ + 20, 0, 0,19,12,11, 15, 0,13, 0, 0, 0, 10, 7, 0,
+ + 12,21, 0, 0,20, 7, 0,16, 0,14, 0, 0, 0,11, 8,
+
+ + 14, 0,13,17, 0,16, 9, 7, 0,12,10, 0, 0, 0, 0,
+ + 17,15, 0,14,18, 0, 0,10, 8, 0, 7,11, 0, 0, 0,
+ + 0,18,16, 0,15,13, 12, 0,11, 9, 0, 8, 0, 0, 0/
+*
+* #] declarations:
+* #[ work:
+ if ( lwrite ) then
+ print *,'ff5ind: input: ',ii
+ print *,' ngiven: ',ngiven,': ',(ip(i),i=1,ngiven)
+ endif
+*
+ do 15 i=7,21
+ idep(i) = 0
+ 15 continue
+*
+ in = 1
+ k = 0
+ i = 1
+ do 100 i1=1,1024
+*
+* dependent?
+*
+ if ( in.gt.1 ) then
+ if ( in.le.ngiven ) then
+ if ( idep(ip(in)) .ne. 0 ) then
+ print *,'ff5ind: error: given vectors already ',
+ + 'dependent ',(ip(j),j=1,ngiven)
+ goto 101
+ endif
+ else
+ if ( idep(ii(i)) .ne. 0 ) then
+** if ( lwrite ) print *,'Rejected: ',ii(i)
+ i = i+1
+ if ( i.gt. 15 ) goto 101
+ goto 100
+ endif
+ endif
+ endif
+*
+* Found one!
+*
+ if ( in.gt.ngiven ) then
+ ip(in) = ii(i)
+ i = i+1
+ endif
+** if ( lwrite ) print *,'Found: ',ip(in)
+ if ( in.eq.5 ) goto 120
+*
+* paint this one and all other dependent vectors black
+* (recursively)
+*
+ idep(ip(in)) = 1
+ k = k+1
+ depi(k) = ip(in)
+ in = in+1
+ oldk = k
+ 80 continue
+ do 90 j=1,oldk-1
+ t = third(depi(j),depi(oldk))
+ if ( t.ne.0 ) then
+ if ( idep(t).eq.0 ) then
+** if ( lwrite ) print *,'Vectors ',depi(j),
+** + depi(oldk),' give ',t
+ idep(t) = 1
+ k = k+1
+ depi(k) = t
+ endif
+ endif
+ 90 continue
+ if ( k.gt.oldk ) then
+ oldk = oldk+1
+ goto 80
+ endif
+ 100 continue
+ 101 continue
+ call fferr(69,ier)
+ do 110 i=1,5
+ ip(i) = i+6
+ 110 continue
+ 120 continue
+ if ( lwrite ) then
+ print *,'ff5ind: found lin. independent combination ',ip
+ endif
+* #] work:
+*###] ff5ind:
+ end
diff --git a/ff-2.0/ffdl2i.f b/ff-2.0/ffdl2i.f
new file mode 100644
index 0000000..b72e5cb
--- /dev/null
+++ b/ff-2.0/ffdl2i.f
@@ -0,0 +1,342 @@
+* $Id: ffdl2i.f,v 1.4 1996/01/10 15:36:43 gj Exp $
+*###[ ffdl2i:
+ subroutine ffdl2i(dl2i,piDpj,ns,i1,i2,i3,isn,j1,j2,j3,jsn,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* *
+* p(i1) p(i2) with p(i3) = isn*(p(i1)+p(i2) *
+* del p(j3) = jsn*(p(j1)+p(j2) *
+* p(j1) p(j2) *
+* *
+* ier is the usual error flag. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,i1,i2,i3,isn,j1,j2,j3,jsn,ier
+ DOUBLE PRECISION dl2i,piDpj(ns,ns)
+*
+* local variables
+*
+ integer i
+ DOUBLE PRECISION s1,s2,del2,xmax,xnul,xlosn
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffdl2i: arbitrary 2x2 p-like determinant, ier ',ier
+ print *,'i1,i2,i3,isn = ',i1,i2,i3,isn
+ print *,'j1,j2,j3,jsn = ',j1,j2,j3,jsn
+ endif
+ if ( .TRUE. .or. ltest ) then
+ xlosn = max(sqrt(precx),xloss*DBLE(10)**(-2-mod(ier,50)))
+ if ( abs(isn) .ne. 1 )
+ + print *,'ffdl2i: error: |isn| != 1 ',isn
+ if ( abs(jsn) .ne. 1 )
+ + print *,'ffdl2i: error: |jsn| != 1 ',jsn
+ do 10 i=1,ns
+ xnul = piDpj(i1,i) + piDpj(i2,i) - isn*piDpj(i3,i)
+ xmax = max(abs(piDpj(i1,i)),abs(piDpj(i2,i)))
+ if ( xlosn*abs(xnul) .gt. precx*xmax ) print *,
+ + 'ffdl2i: error: dotproducts ',i1,i2,i3,' with ',i,
+ + ' do not add to 0',piDpj(i1,i),piDpj(i2,i),
+ + isn*piDpj(i3,i),xnul,ier
+ xnul = piDpj(j1,i) + piDpj(j2,i) - jsn*piDpj(j3,i)
+ xmax = max(abs(piDpj(j1,i)),abs(piDpj(j2,i)))
+ if ( xlosn*abs(xnul) .gt. precx*xmax ) print *,
+ + 'ffdl2i: error: dotproducts ',j1,j2,j3,' with ',i,
+ + ' do not add to 0',piDpj(j1,i),piDpj(j2,i),
+ + jsn*piDpj(j3,i),xnul,ier
+ 10 continue
+ endif
+* #] check input:
+* #[ stupid tree:
+*
+* calculations
+*
+ idsub = idsub + 1
+*
+* stupid tree
+*
+ s1 = +piDpj(i1,j1)*piDpj(i2,j2)
+ s2 = -piDpj(i1,j2)*piDpj(i2,j1)
+ dl2i = s1 + s2
+ xmax = abs(s1)
+ if ( abs(dl2i) .ge. xloss*xmax ) goto 100
+ if ( lwrite ) print *,'dl2i+1= ',dl2i,xmax
+*
+ s1 = +piDpj(i1,j1)*piDpj(i3,j2)
+ s2 = -piDpj(i1,j2)*piDpj(i3,j1)
+ del2 = s1 + s2
+ if ( lwrite ) print *,'dl2i+2= ',del2*isn,abs(s1)
+ if ( abs(s1) .lt. xmax ) then
+ dl2i = del2*isn
+ xmax = abs(s1)
+ if ( abs(dl2i) .ge. xloss*xmax ) goto 100
+ endif
+*
+ s1 = +piDpj(i3,j1)*piDpj(i2,j2)
+ s2 = -piDpj(i3,j2)*piDpj(i2,j1)
+ del2 = s1 + s2
+ if ( lwrite ) print *,'dl2i+3= ',del2*isn,abs(s1)
+ if ( abs(s1) .lt. xmax ) then
+ dl2i = del2*isn
+ xmax = abs(s1)
+ if ( abs(dl2i) .ge. xloss*xmax ) goto 100
+ endif
+*
+ s1 = +piDpj(i1,j1)*piDpj(i2,j3)
+ s2 = -piDpj(i1,j3)*piDpj(i2,j1)
+ del2 = s1 + s2
+ if ( lwrite ) print *,'dl2i+4= ',del2*jsn,abs(s1)
+ if ( abs(s1) .lt. xmax ) then
+ dl2i = del2*jsn
+ xmax = abs(s1)
+ if ( abs(dl2i) .ge. xloss*xmax ) goto 100
+ endif
+*
+ s1 = +piDpj(i1,j1)*piDpj(i3,j3)
+ s2 = -piDpj(i1,j3)*piDpj(i3,j1)
+ del2 = s1 + s2
+ if ( lwrite ) print *,'dl2i+5= ',del2*isn*jsn,abs(s1)
+ if ( abs(s1) .lt. xmax ) then
+ dl2i = del2*isn*jsn
+ xmax = abs(s1)
+ if ( abs(dl2i) .ge. xloss*xmax ) goto 100
+ endif
+*
+ s1 = +piDpj(i3,j1)*piDpj(i2,j3)
+ s2 = -piDpj(i3,j3)*piDpj(i2,j1)
+ del2 = s1 + s2
+ if ( lwrite ) print *,'dl2i+6= ',del2*isn*jsn,abs(s1)
+ if ( abs(s1) .lt. xmax ) then
+ dl2i = del2*isn*jsn
+ xmax = abs(s1)
+ if ( abs(dl2i) .ge. xloss*xmax ) goto 100
+ endif
+*
+ s1 = +piDpj(i1,j3)*piDpj(i2,j2)
+ s2 = -piDpj(i1,j2)*piDpj(i2,j3)
+ del2 = s1 + s2
+ if ( lwrite ) print *,'dl2i+7= ',del2*jsn,abs(s1)
+ if ( abs(s1) .lt. xmax ) then
+ dl2i = del2*jsn
+ xmax = abs(s1)
+ if ( abs(dl2i) .ge. xloss*xmax ) goto 100
+ endif
+*
+ s1 = +piDpj(i1,j3)*piDpj(i3,j2)
+ s2 = -piDpj(i1,j2)*piDpj(i3,j3)
+ del2 = s1 + s2
+ if ( lwrite ) print *,'dl2i+8= ',del2*isn*jsn,abs(s1)
+ if ( abs(s1) .lt. xmax ) then
+ dl2i = del2*isn*jsn
+ xmax = abs(s1)
+ if ( abs(dl2i) .ge. xloss*xmax ) goto 100
+ endif
+*
+ s1 = +piDpj(i3,j3)*piDpj(i2,j2)
+ s2 = -piDpj(i3,j2)*piDpj(i2,j3)
+ del2 = s1 + s2
+ if ( lwrite ) print *,'dl2i+9= ',del2*isn*jsn,abs(s1)
+ if ( abs(s1) .lt. xmax ) then
+ dl2i = del2*isn*jsn
+ xmax = abs(s1)
+ if ( abs(dl2i) .ge. xloss*xmax ) goto 100
+ endif
+*
+ if ( lwarn ) call ffwarn(165,ier,dl2i,xmax)
+*
+ 100 continue
+* #] stupid tree:
+*###] ffdl2i:
+ end
+*###[ ffdl3q:
+ subroutine ffdl3q(dl3q,piDpj,i1,i2,i3,j1,j2,j3,
+ + isn1,isn2,isn3,jsn1,jsn2,jsn3,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the 3x3 determinant *
+* *
+* p(i1) p(i2) p(i3) / p(j1) = jsn1*(p(i1)-isn1*p(i2)) *
+* delta with | p(j2) = jsn2*(p(i2)-isn2*p(i3)) *
+* p5 p6 p7 \ p(j3) = jsn3*(p(i3)-isn3*p(i1)) *
+* *
+* and piDpj(10,10) in standard four-point notation. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer i1,i2,i3,j1,j2,j3,isn1,isn2,isn3,jsn1,jsn2,jsn3,ier
+ DOUBLE PRECISION dl3q,piDpj(10,10)
+*
+* local variables
+*
+ logical lset
+ integer ier0,ier1,i
+ DOUBLE PRECISION del2i(3),s(23),xmax,xmaxp,som
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ debug input:
+ if ( lwrite ) then
+ print *,'ffdl3q: determinant delta(',i1,i2,i3,';5,6,7)'
+ print *,'input: i1,i2,i3 = ',i1,i2,i3
+ print *,'input: j1,j2,j3 = ',j1,j2,j3
+ print *,'input: isigns = ',isn1,isn2,isn3
+ print *,'input: jsigns = ',jsn1,jsn2,jsn3
+ print *,'(p(j1) = jsn1*(p(i1)-isn1*p(i2) etc.)'
+ endif
+* #] debug input:
+* #[ first try:
+*
+ lset = .FALSE.
+ if ( isn1 .eq. -1 ) then
+ ier1 = ier
+ if ( lwrite ) print *,'ffdl2i #1'
+ call ffdl2i(del2i(1),piDpj,10, i1,i2,j1,jsn1,6,7,10,+1,ier1)
+ if ( lwrite ) print *,'ffdl2t #2'
+ ier0 = ier
+ call ffdl2t(del2i(2),piDpj,7,5, i1,i2,j1,-jsn1,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'ffdl2i #3'
+ ier0 = ier
+ call ffdl2i(del2i(3),piDpj,10, i1,i2,j1,jsn1,5,6,9,-1,ier0)
+ ier1 = max(ier1,ier0)
+ s(1) = piDpj(i3,5)*del2i(1)
+ s(2) = piDpj(i3,6)*del2i(2)
+ s(3) = piDpj(i3,7)*del2i(3)
+ som = s(1) + s(2) + s(3)
+ xmax = DBLE(10)**(ier1-ier)*max(abs(s(1)),abs(s(2)),
+ + abs(s(3)))
+ dl3q = som
+ xmaxp = xmax
+ lset = .TRUE.
+ if ( lwrite ) then
+ print *,'dl3q 1 = ',dl3q,xmax
+ print *,'(s = ',s(1),s(2),s(3),')'
+ endif
+ if ( abs(dl3q) .ge. xloss*xmax ) goto 900
+ endif
+ if ( isn2 .eq. -1 ) then
+ ier1 = ier
+ if ( lwrite ) print *,'ffdl2i #1'
+ call ffdl2i(del2i(1),piDpj,10, i2,i3,j2,jsn2,6,7,10,+1,ier1)
+ if ( lwrite ) print *,'ffdl2t #2'
+ ier0 = ier
+ call ffdl2t(del2i(2),piDpj,7,5, i2,i3,j2,-jsn2,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'ffdl2i #3'
+ ier0 = ier
+ call ffdl2i(del2i(3),piDpj,10, i2,i3,j2,jsn2,5,6,9,-1,ier0)
+ ier1 = max(ier1,ier0)
+ s(1) = piDpj(i1,5)*del2i(1)
+ s(2) = piDpj(i1,6)*del2i(2)
+ s(3) = piDpj(i1,7)*del2i(3)
+ som = s(1) + s(2) + s(3)
+ xmax = DBLE(10)**(ier1-ier)*max(abs(s(1)),abs(s(2)),
+ + abs(s(3)))
+ if ( .not.lset ) then
+ dl3q = som
+ xmaxp = xmax
+ lset = .TRUE.
+ elseif ( xmax .lt. xmaxp ) then
+ dl3q = som
+ xmaxp = xmax
+ endif
+ if ( lwrite ) then
+ print *,'dl3q 2 = ',som,xmax
+ print *,'(s = ',s(1),s(2),s(3),')'
+ endif
+ if ( abs(dl3q) .ge. xloss*xmax ) goto 900
+ endif
+ if ( isn3 .eq. -1 ) then
+ if ( lwrite ) print *,'ffdl2i #1'
+ ier1 = ier
+ call ffdl2i(del2i(1),piDpj,10, i3,i1,j3,jsn3,6,7,10,+1,ier1)
+ if ( lwrite ) print *,'ffdl2t #2'
+ ier0 = ier
+ call ffdl2t(del2i(2),piDpj,7,5, i3,i1,j3,-jsn3,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'ffdl2i #3'
+ ier0 = ier
+ call ffdl2i(del2i(3),piDpj,10, i3,i1,j3,jsn3,5,6,9,-1,ier0)
+ ier1 = max(ier1,ier0)
+ s(1) = piDpj(i2,5)*del2i(1)
+ s(2) = piDpj(i2,6)*del2i(2)
+ s(3) = piDpj(i2,7)*del2i(3)
+ som = s(1) + s(2) + s(3)
+ xmax = DBLE(10)**(ier1-ier)*max(abs(s(1)),abs(s(2)),
+ + abs(s(3)))
+ if ( .not.lset ) then
+ dl3q = som
+ xmaxp = xmax
+ lset = .TRUE.
+ elseif ( xmax .lt. xmaxp ) then
+ dl3q = som
+ xmaxp = xmax
+ endif
+ if ( lwrite ) then
+ print *,'dl3q 3 = ',som,xmax
+ print *,'(s = ',s(1),s(2),s(3),')'
+ endif
+ if ( abs(dl3q) .ge. xloss*xmax ) goto 900
+ endif
+* #] first try:
+* #[ last try:
+ if ( .not. lset ) then
+ s(1) = + piDpj(i1,5)*piDpj(i2,6)*piDpj(i3,7)
+ s(2) = - piDpj(i1,5)*piDpj(i2,7)*piDpj(i3,6)
+ s(3) = - piDpj(i1,6)*piDpj(i2,5)*piDpj(i3,7)
+ s(4) = + piDpj(i1,6)*piDpj(i2,7)*piDpj(i3,5)
+ s(5) = + piDpj(i1,7)*piDpj(i2,5)*piDpj(i3,6)
+ s(6) = - piDpj(i1,7)*piDpj(i2,6)*piDpj(i3,5)
+ dl3q = s(1) + s(2) + s(3) + s(4) + s(5) + s(6)
+ xmax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)),
+ + abs(s(5)),abs(s(6)))
+ if ( lwrite ) then
+ print *,'dl3q 0 = ',dl3q,xmax
+ print *,'(s = ',s(1),s(2),s(3),s(4),s(5),s(6),')'
+ endif
+ if ( abs(dl3q) .ge. xloss*xmax ) goto 900
+ endif
+* #] last try:
+* #[ final:
+ if ( lwarn ) call ffwarn(166,ier,dl3q,xmax)
+ 900 continue
+* #] final:
+* #[ check output:
+ if ( ltest ) then
+ s(1) = + piDpj(i1,5)*piDpj(i2,6)*piDpj(i3,7)
+ s(2) = - piDpj(i1,5)*piDpj(i2,7)*piDpj(i3,6)
+ s(3) = - piDpj(i1,6)*piDpj(i2,5)*piDpj(i3,7)
+ s(4) = + piDpj(i1,6)*piDpj(i2,7)*piDpj(i3,5)
+ s(5) = + piDpj(i1,7)*piDpj(i2,5)*piDpj(i3,6)
+ s(6) = - piDpj(i1,7)*piDpj(i2,6)*piDpj(i3,5)
+ som = s(1) + s(2) + s(3) + s(4) + s(5) + s(6)
+ xmaxp = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)),
+ + abs(s(5)),abs(s(6)))
+ if ( lwrite ) then
+ print *,'dl3q = ',som,xmaxp
+ endif
+ if ( xloss*abs(som-dl3q) .gt. precx*max(xmax,xmaxp) ) then
+ print *,'ffdl3q: error: answer does not agree with ',
+ + 'normal case: ',dl3q,som,max(xmax,xmaxp),dl3q-som
+ endif
+ endif
+* #] check output:
+*###] ffdl3q:
+ end
+
diff --git a/ff-2.0/ffdl5p.f b/ff-2.0/ffdl5p.f
new file mode 100644
index 0000000..091ca37
--- /dev/null
+++ b/ff-2.0/ffdl5p.f
@@ -0,0 +1,444 @@
+*--#[ log:
+* $Id: ffdl5p.f,v 1.3 1996/02/12 21:06:19 gj Exp $
+* $Log: ffdl5p.f,v $
+c Revision 1.3 1996/02/12 21:06:19 gj
+c Added safety check on ns in ffdl5r, updated comment
+c
+c Revision 1.2 1995/12/08 10:44:14 gj
+c Added forgotten 'abs' in error calculation.
+c
+*--#] log:
+*###[ ffdl5p:
+ subroutine ffdl5p(xpi,pDp,ns,ii,ier)
+***#[*comment:***********************************************************
+* check that *
+* *
+* p1 p2 p3 p4 p5 s1 p1 p2 p3 p4 *
+* delta = 0, delta = 0 *
+* p1 p2 p3 p4 p5 p1 p2 p3 p4 p5 *
+* *
+* with pn = xpi(ii(n)), n=1,5 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,ii(5),ier
+ DOUBLE PRECISION xpi(ns),pDp(ns,ns)
+*
+* local variables
+*
+ integer i,j1,j2,j3,j4,j5
+ DOUBLE PRECISION s(109),som,xmax,xlosn
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ del5(p):
+ j1 = ii(1)
+ j2 = ii(2)
+ j3 = ii(3)
+ j4 = ii(4)
+ j5 = ii(5)
+ s(1)=+ xpi(j1)*xpi(j2)*xpi(j3)*xpi(j4)*xpi(j5)
+ s(2)=- xpi(j1)*xpi(j2)*xpi(j3)*pDp(j4,j5)**2
+ s(3)=- xpi(j1)*xpi(j2)*pDp(j3,j4)**2*xpi(j5)
+ s(4)=+2*xpi(j1)*xpi(j2)*pDp(j3,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(5)=- xpi(j1)*xpi(j2)*pDp(j3,j5)**2*xpi(j4)
+ s(6)=- xpi(j1)*pDp(j2,j3)**2*xpi(j4)*xpi(j5)
+ s(7)=+ xpi(j1)*pDp(j2,j3)**2*pDp(j4,j5)**2
+ s(8)=+2*xpi(j1)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j4)*xpi(j5)
+ s(9)=-2*xpi(j1)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(10)=-2*xpi(j1)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j4)*pDp(j4,j5)
+ s(11)=+2*xpi(j1)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j5)*xpi(j4)
+ s(12)=- xpi(j1)*pDp(j2,j4)**2*xpi(j3)*xpi(j5)
+ s(13)=+ xpi(j1)*pDp(j2,j4)**2*pDp(j3,j5)**2
+ s(14)=+2*xpi(j1)*pDp(j2,j4)*pDp(j2,j5)*xpi(j3)*pDp(j4,j5)
+ s(15)=-2*xpi(j1)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j4)*pDp(j3,j5)
+ s(16)=- xpi(j1)*pDp(j2,j5)**2*xpi(j3)*xpi(j4)
+ s(17)=+ xpi(j1)*pDp(j2,j5)**2*pDp(j3,j4)**2
+ s(18)=- pDp(j1,j2)**2*xpi(j3)*xpi(j4)*xpi(j5)
+ s(19)=+ pDp(j1,j2)**2*xpi(j3)*pDp(j4,j5)**2
+ s(20)=+ pDp(j1,j2)**2*pDp(j3,j4)**2*xpi(j5)
+ s(21)=-2*pDp(j1,j2)**2*pDp(j3,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(22)=+ pDp(j1,j2)**2*pDp(j3,j5)**2*xpi(j4)
+ s(23)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j3)*xpi(j4)*xpi(j5)
+ s(24)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j3)*pDp(j4,j5)**2
+ s(25)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j4)*pDp(j3,j4)*xpi(j5)
+ s(26)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j4)*pDp(j3,j5)*pDp(j4,j5)
+ s(27)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j5)*pDp(j3,j4)*pDp(j4,j5)
+ s(28)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j5)*pDp(j3,j5)*xpi(j4)
+ s(29)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j3)*pDp(j3,j4)*xpi(j5)
+ s(30)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j3)*pDp(j3,j5)*pDp(j4,j5)
+ s(31)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j4)*xpi(j3)*xpi(j5)
+ s(32)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j4)*pDp(j3,j5)**2
+ s(33)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j5)*xpi(j3)*pDp(j4,j5)
+ s(34)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j5)*pDp(j3,j4)*pDp(j3,j5)
+ s(35)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j3)*pDp(j3,j4)*pDp(j4,j5)
+ s(36)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j3)*pDp(j3,j5)*xpi(j4)
+ s(37)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j4)*xpi(j3)*pDp(j4,j5)
+ s(38)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j4)*pDp(j3,j4)*pDp(j3,j5)
+ s(39)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j5)*xpi(j3)*xpi(j4)
+ s(40)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j5)*pDp(j3,j4)**2
+ s(41)=- pDp(j1,j3)**2*xpi(j2)*xpi(j4)*xpi(j5)
+ s(42)=+ pDp(j1,j3)**2*xpi(j2)*pDp(j4,j5)**2
+ s(43)=+ pDp(j1,j3)**2*pDp(j2,j4)**2*xpi(j5)
+ s(44)=-2*pDp(j1,j3)**2*pDp(j2,j4)*pDp(j2,j5)*pDp(j4,j5)
+ s(45)=+ pDp(j1,j3)**2*pDp(j2,j5)**2*xpi(j4)
+ s(46)=+2*pDp(j1,j3)*pDp(j1,j4)*xpi(j2)*pDp(j3,j4)*xpi(j5)
+ s(47)=-2*pDp(j1,j3)*pDp(j1,j4)*xpi(j2)*pDp(j3,j5)*pDp(j4,j5)
+ s(48)=-2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j3)*pDp(j2,j4)*xpi(j5)
+ s(49)=+2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j3)*pDp(j2,j5)*pDp(j4,j5)
+ s(50)=+2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j5)
+ s(51)=-2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j5)**2*pDp(j3,j4)
+ s(52)=-2*pDp(j1,j3)*pDp(j1,j5)*xpi(j2)*pDp(j3,j4)*pDp(j4,j5)
+ s(53)=+2*pDp(j1,j3)*pDp(j1,j5)*xpi(j2)*pDp(j3,j5)*xpi(j4)
+ s(54)=+2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j4)*pDp(j4,j5)
+ s(55)=-2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j5)*xpi(j4)
+ s(56)=-2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j4)**2*pDp(j3,j5)
+ s(57)=+2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j4)
+ s(58)=- pDp(j1,j4)**2*xpi(j2)*xpi(j3)*xpi(j5)
+ s(59)=+ pDp(j1,j4)**2*xpi(j2)*pDp(j3,j5)**2
+ s(60)=+ pDp(j1,j4)**2*pDp(j2,j3)**2*xpi(j5)
+ s(61)=-2*pDp(j1,j4)**2*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j5)
+ s(62)=+ pDp(j1,j4)**2*pDp(j2,j5)**2*xpi(j3)
+ s(63)=+2*pDp(j1,j4)*pDp(j1,j5)*xpi(j2)*xpi(j3)*pDp(j4,j5)
+ s(64)=-2*pDp(j1,j4)*pDp(j1,j5)*xpi(j2)*pDp(j3,j4)*pDp(j3,j5)
+ s(65)=-2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)**2*pDp(j4,j5)
+ s(66)=+2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j5)
+ s(67)=+2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j4)
+ s(68)=-2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j4)*pDp(j2,j5)*xpi(j3)
+ s(69)=- pDp(j1,j5)**2*xpi(j2)*xpi(j3)*xpi(j4)
+ s(70)=+ pDp(j1,j5)**2*xpi(j2)*pDp(j3,j4)**2
+ s(71)=+ pDp(j1,j5)**2*pDp(j2,j3)**2*xpi(j4)
+ s(72)=-2*pDp(j1,j5)**2*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j4)
+ s(73)=+ pDp(j1,j5)**2*pDp(j2,j4)**2*xpi(j3)
+*
+ som = 0
+ xmax = 0
+ do 80 i=1,73
+ som = som + s(i)
+ xmax = max(xmax,abs(som))
+ 80 continue
+ xlosn = xloss*DBLE(10)**(-1-mod(ier,50))
+ if ( xlosn*abs(som) .gt. precx*xmax )
+ + print *,'ffdl5p: error: dl5p != 0: ',som,xmax
+ if ( lwrite ) print *,'ffdl5p: dl5p = ',som,xmax
+*
+* #] del5(p):
+*###] ffdl5p:
+ end
+*###[ ffdl5r:
+ subroutine ffdl5r(dl5r,xpi,piDpj,ns,inum,ier)
+***#[*comment:***********************************************************
+* calculate in a numerically stable way *
+* *
+* s1 pi+1 pi+2 pi+3 pi+4 *
+* delta *
+* pi pi+1 pi+2 pi+3 pi+4 *
+* *
+* ier is the usual error flag. *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ns,inum,ier
+ DOUBLE PRECISION dl5r,xpi(ns),piDpj(ns,ns)
+*
+* local variables
+*
+ integer i,j,k,is,ip(5),ii(10),jj(15),i54(10,6)
+ logical lagain
+ DOUBLE PRECISION s(109),som,xmax,smax
+ DOUBLE PRECISION t10,t101,t104,t105,t108,t109,t112,t116,
+ + t120,t121,t128,t129,t13,t132,t135,t139,t14,t143,t146,
+ + t147,t148,t15,t16,t182,t185,t19,t190,t194,t2,t20,t202,
+ + t203,t206,t21,t210,t214,t218,t22,t222,t230,t234,t235,
+ + t25,t26,t27,t275,t28,t282,t285,t289,t29,t295,t298,t30,
+ + t302,t33,t367,t37,t42,t49,t5,t53,t54,t58,t6,t68,t69,t74,
+ + t75,t79,t80,t81,t85,t86,t89,t9,t92,t97
+ save i54
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ data:
+*
+* data
+*
+ data i54/
+ + 8, 9,10,11, 18, 14,15,16, 20,21,
+ + 9,10,11,12, 13, 15,16,17, 19,21,
+ + 10,11,12, 7, 14, 16,17,18, 19,20,
+ + 11,12, 7, 8, 15, 17,18,13, 20,21,
+ + 12, 7, 8, 9, 16, 18,13,14, 19,21,
+ + 7, 8, 9,10, 17, 13,14,15, 19,20/
+*
+* #] data:
+* #[ check input:
+ if ( ltest ) then
+ if ( inum.gt.6 .or. inum.lt.1 ) then
+ print *,'ffdl5r: error: inum < 1 or > 6: ',inum
+ stop
+ endif
+ endif
+ if ( ns.ne.21 ) then
+ print *,'ffdl5r: only for 6point pi, ns should be 21, not ',
+ + ns
+ stop
+ endif
+* #] check input:
+* #[ calculations:
+*
+ is = 1
+ do 10 i=1,10
+ s(i) = abs(piDpj(i54(i,inum),is))
+ 10 continue
+ call ffsort(s,ii,10)
+ do 20 i=1,10
+ jj(i) = i54(ii(i),inum)
+ 20 continue
+* just for safety...
+ jj(11) = -99999
+ ip(1) = inum + 6
+ call ff5ind(ip,jj,1,ier)
+ lagain = .FALSE.
+*
+* we compute \delta^{pi pa pb pc pd pe}_{s1 pa pb pc pd pe}
+* with {pi,pa-pe} lin.independent, pa-pe arbitrary. This way we
+* never need to determine the sign of (pa-pe) w.r.t. (pi+1 - pi+4)
+* see dl5r.frm -> dl5r.map
+*
+ 30 continue
+ if ( lwrite ) print *,'ip = ',ip
+*
+* #[ define t's:
+ t2 = piDpj(is,ip(1))
+ t5 = piDpj(ip(2),ip(5))
+ t6 = t5**2
+ t9 = piDpj(ip(3),ip(4))
+ t10 = t9**2
+ t13 = piDpj(ip(2),ip(3))
+ t14 = t13**2
+ t15 = piDpj(ip(4),ip(5))
+ t16 = t15**2
+ t19 = piDpj(ip(2),ip(4))
+ t20 = t19**2
+ t21 = piDpj(ip(3),ip(5))
+ t22 = t21**2
+ t25 = piDpj(ip(2),ip(2))
+ t26 = piDpj(ip(3),ip(3))
+ t27 = piDpj(ip(4),ip(4))
+ t28 = piDpj(ip(5),ip(5))
+ t29 = t27*t28
+ t30 = t26*t29
+ t33 = t26*t16
+ t37 = t10*t28
+ t42 = t22*t27
+ t49 = t26*t27
+ t53 = piDpj(is,ip(2))
+ t54 = piDpj(ip(1),ip(2))
+ t58 = t26*t28
+ t68 = piDpj(ip(1),ip(3))
+ t69 = t13*t29
+ t74 = t21*t27
+ t75 = t5*t74
+ t79 = piDpj(ip(1),ip(4))
+ t80 = t9*t28
+ t81 = t13*t80
+ t85 = t21*t15
+ t86 = t13*t85
+ t89 = t19*t58
+ t92 = t13*t16
+ t97 = t19*t80
+ t101 = t19*t85
+ t104 = t9*t15
+ t105 = t5*t104
+ t108 = piDpj(ip(1),ip(5))
+ t109 = t5*t49
+ t112 = t5*t10
+ t116 = t19*t22
+ t120 = t26*t15
+ t121 = t5*t120
+ t128 = t9*t21
+ t129 = t5*t128
+ t132 = t13*t104
+ t135 = t13*t74
+ t139 = t19*t120
+ t143 = t19*t128
+ t146 = piDpj(is,ip(3))
+ t147 = t5*t15
+ t148 = t13*t147
+ t182 = t25*t80
+ t185 = t25*t85
+ t190 = t13*t19*t28
+ t194 = piDpj(is,ip(4))
+ t202 = t5*t21
+ t203 = t19*t202
+ t206 = t6*t9
+ t210 = t25*t104
+ t214 = t25*t74
+ t218 = t13*t19*t15
+ t222 = t13*t5*t27
+ t230 = t20*t21
+ t234 = t5*t9
+ t235 = t19*t234
+ t275 = piDpj(is,ip(5))
+ t282 = t25*t120
+ t285 = t25*t128
+ t289 = t14*t15
+ t295 = t13*t19*t21
+ t298 = t13*t234
+ t302 = t19*t5*t26
+ t367 = t9*t85
+* #] define t's:
+* #[ fill s-array:
+ s(1) = +t2*t20*t22
+ s(2) = -t146*t79*t206
+ s(3) = +t275*t108*t20*t26
+ s(4) = +t146*t108*t235
+ s(5) = -t146*t54*t75
+ s(6) = -t146*t79*t190
+ s(7) = -2*t53*t54*t367
+ s(8) = -2*t2*t19*t129
+ s(9) = +2*t2*t19*t121
+ s(10) = -2*t2*t13*t105
+ s(11) = -2*t2*t13*t101
+ s(12) = +2*t2*t13*t97
+ s(13) = +2*t2*t25*t367
+ s(14) = -t2*t25*t33
+ s(15) = -t275*t79*t302
+ s(16) = +t275*t79*t298
+ s(17) = +t275*t79*t295
+ s(18) = -t275*t79*t289
+ s(19) = -t275*t79*t285
+ s(20) = +t275*t79*t282
+ s(21) = -t194*t79*t25*t58
+ s(22) = +t275*t68*t235
+ s(23) = -t275*t68*t222
+ s(24) = +t275*t68*t218
+ s(25) = +t275*t68*t214
+ s(26) = -t275*t68*t210
+ s(27) = -t275*t54*t112
+ s(28) = +t146*t79*t148
+ s(29) = +t275*t54*t109
+ s(30) = +t275*t54*t143
+ s(31) = -t275*t54*t139
+ s(32) = -t275*t54*t135
+ s(33) = -t194*t108*t302
+ s(34) = -t2*t14*t29
+ s(35) = +t194*t108*t298
+ s(36) = -t2*t20*t58
+ s(37) = +t194*t108*t295
+ s(38) = +t146*t54*t105
+ s(39) = -t194*t108*t289
+ s(40) = +t53*t68*t101
+ s(41) = -t194*t68*t206
+ s(42) = +t2*t25*t30
+ s(43) = +t194*t68*t203
+ s(44) = +t2*t6*t10
+ s(45) = +t53*t54*t33
+ s(46) = +t194*t68*t148
+ s(47) = +t53*t79*t86
+ s(48) = -t194*t68*t185
+ s(49) = +t194*t68*t182
+ s(50) = +t194*t54*t129
+ s(51) = -t194*t54*t121
+ s(52) = -t194*t54*t116
+ s(53) = +t194*t54*t89
+ s(54) = -t53*t108*t139
+ s(55) = -t194*t54*t81
+ s(56) = -t53*t79*t116
+ s(57) = -t194*t108*t285
+ s(58) = +t146*t54*t69
+ s(59) = -t146*t108*t222
+ s(60) = -t53*t68*t92
+ s(61) = -t146*t108*t230
+ s(62) = -t2*t25*t42
+ s(63) = +t53*t54*t37
+ s(64) = +t275*t54*t132
+ s(65) = +t194*t54*t86
+ s(66) = +t53*t108*t109
+ s(67) = +t2*t14*t16
+ s(68) = +t146*t108*t218
+ s(69) = -t2*t25*t37
+ s(70) = -t53*t68*t75
+ s(71) = +t53*t54*t42
+ s(72) = -t2*t6*t49
+ s(73) = +t53*t68*t105
+ s(74) = +2*t2*t13*t75
+ s(75) = -t194*t68*t190
+ s(76) = +t146*t54*t101
+ s(77) = +t53*t108*t132
+ s(78) = -t53*t108*t135
+ s(79) = -t53*t68*t97
+ s(80) = -t53*t54*t30
+ s(81) = -t146*t54*t92
+ s(82) = -t146*t79*t185
+ s(83) = +t146*t79*t203
+ s(84) = -t146*t54*t97
+ s(85) = -t275*t68*t230
+ s(86) = -t146*t108*t210
+ s(87) = +t53*t79*t129
+ s(88) = +t53*t108*t143
+ s(89) = -t53*t108*t112
+ s(90) = +t53*t79*t89
+ s(91) = +t194*t108*t282
+ s(92) = -2*t275*t108*t13*t19*t9
+ s(93) = +t146*t79*t182
+ s(94) = -2*t194*t79*t13*t202
+ s(95) = -2*t146*t68*t19*t147
+ s(96) = +t146*t108*t214
+ s(97) = -t53*t79*t81
+ s(98) = -t53*t79*t121
+ s(99) = +t275*t108*t14*t27
+ s(100) = +t275*t108*t25*t10
+ s(101) = -t275*t108*t25*t49
+ s(102) = +t194*t79*t25*t22
+ s(103) = +t146*t68*t20*t28
+ s(104) = +t194*t79*t14*t28
+ s(105) = -t146*t68*t25*t29
+ s(106) = +t146*t68*t25*t16
+ s(107) = +t53*t68*t69
+ s(108) = +t194*t79*t6*t26
+ s(109) = +t146*t68*t6*t27
+* #] fill s-array:
+*
+ som = 0
+ xmax = 0
+ do 100 i=1,109
+ som = som + s(i)
+ xmax = max(xmax,abs(s(i)))
+ 100 continue
+*
+ if ( .not.lagain ) then
+ dl5r = som
+ smax = xmax
+ if ( lwrite ) print *,'dl5r = ',dl5r,xmax
+ if ( lwarn ) call ffwarn(188,ier,dl5r,xmax)
+ if ( ltest ) then
+ do 900 i=2,5
+ k = inum + i - 1 + 6
+ if ( k.gt.12 ) k = k-6
+ ip(i) = k
+ 900 continue
+ lagain = .TRUE.
+ goto 30
+ endif
+ else
+ if ( xloss*abs(som-dl5r) .gt. precx*max(smax,xmax) ) then
+ print *,'ffdl5r: error: is not what it should be: ',
+ + dl5r,som,dl5r-som,max(smax,xmax)
+ endif
+ endif
+*
+* #] calculations:
+*###] ffdl5r:
+ end
diff --git a/ff-2.0/ffdxc0.f b/ff-2.0/ffdxc0.f
new file mode 100644
index 0000000..f143fc7
--- /dev/null
+++ b/ff-2.0/ffdxc0.f
@@ -0,0 +1,1029 @@
+*###[ ffdxc0:
+ subroutine ffdxc0(cs3,ipi12,isoort,clogi,ilogi,xpi,dpipj,piDpj,
+ + xqi,dqiqj,qiDqj,sdel2,del2s,etalam,etami,delpsi,alph,
+ + ddel2s,ldel2s,npoin,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the difference of two threepoint functions *
+* C(3,...a) - C(4,...b) *
+* For this we not only calculate the roots of the three-point *
+* function y,z(1-4,3-4,1-3) but also the combinations *
+* *
+* yzzy = y(,4,)*z(,3,) - z(,4,)*y(,3,) *
+* and *
+* yyzz = y(,4,) - z(,4,) - y(,3,) + z(,3,) *
+* *
+* This is done explicitly for most special cases, so a lot of *
+* lines of code result. This may be shortened with a smart use *
+* of indices, however, it is readable now. *
+* *
+* Input: xpi(6,3:4) (real) transformed mi,pi squared in Ci *
+* dpipj(6,6,3:4) (real) xpi(i)-xpi(j) *
+* piDpj(6,6,3:4) (real) pi(i).pi(j) *
+* xqi(10,10) (real) transformed mi,pi squared in D *
+* dqiqj(10,10) (real) xqi(i)-xqi(j) *
+* qiDqj(10,10) (real) qi(i).qi(j) *
+* sdel2 (real) sqrt(delta_{p_1 p_2}^{p_1 p_2}) *
+* del2s(3,3:4) (real) delta_{p_i s_i}^{p_i s_i} *
+* etalam(3:4) (real) delta_{s_1 s_2 s_3}^{s_1 s_2 s_3}
+* /delta_{p_1 p_2}^{p_1 p_2} *
+* etami(6,3:4) (real) m_i^2 - etalam *
+* ddel2s(2:3) (real) del2s(i,3) - del2s(i,4) *
+* alph(3) (real) alph(1)=alpha, alph(3)=1-alpha *
+* ldel2s (logical) indicates yes/no limit del2s->0 *
+* *
+* Output: cs3 (complex)(160) C0(3)-C0(4), not yet summed. *
+* ipi12 (integer)(6) factors pi^2/12, not yet summed *
+* slam (complex) lambda(p1,p2,p3). *
+* isoort (integer)(16) indication of he method used *
+* clogi (complex)(6) log(-dyz(2,1,i)/dyz(2,2,i)) *
+* ilogi (integer)(6) factors i*pi in this *
+* ier (integer) 0=ok, 1=inaccurate, 2=error *
+* *
+* Calls: ... *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(16),isoort(16),ilogi(6),npoin,ier
+ logical ldel2s
+ DOUBLE COMPLEX cs3(160),clogi(6)
+ DOUBLE PRECISION xqi(10),dqiqj(10,10),qiDqj(10,10),
+ + xpi(6,3:4),dpipj(6,6,3:4),piDpj(6,6,3:4),
+ + sdel2,del2s(3,3:4),etalam(3:4),etami(6,3:4),alph(3),
+ + ddel2s(2:3),delpsi(3,3:4)
+*
+* local variables:
+*
+ integer i,j,k,l,ip,ier0,ii,ifirst,ieri(12),idone(6)
+ logical lcompl
+ DOUBLE COMPLEX c,csom,chck,cs(5),csdeli(3,3:4),csdel2,
+ + cy(4,3:4,3),cz(4,3:4,3),cdyz(2,2,3:4,3),cd2yzz(3:4,3),
+ + cpi(6,3:4),cpiDpj(6,6,3:4),cdyzzy(4,3),cdyyzz(2,3)
+ DOUBLE PRECISION sdel2i(3,3:4),s(5),som,smax,absc,dfflo1,xhck,
+ + rloss,y(4,3:4,3),z(4,3:4,3),dyz(2,2,3:4,3),d2yzz(3:4,3),
+ + dy2z(4,3:4,3),dyzzy(4,3),dsdel2,xmax
+ DOUBLE COMPLEX zxfflg,zfflog,zfflo1
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+* call ffxhck(xpi(1,3),dpipj(1,1,3),6,ier)
+* call ffxhck(xpi(1,4),dpipj(1,1,4),6,ier)
+ call ffxhck(xqi,dqiqj,10,ier)
+ endif
+* #] check input:
+* #[ get y,z-roots:
+ lcompl = .FALSE.
+ if ( lwrite ) print '(a)',' ##[ get roots:'
+ do 20 k=3,4
+ do 10 i=1,3
+*
+* get roots (y,z) and flag what to do: 0=nothing, 1=normal,
+* -1=complex
+*
+ ip = i+3
+* first get the roots
+ if ( del2s(i,k) .le. 0 ) then
+* real case
+ sdel2i(i,k) = sqrt(-del2s(i,k))
+* then handle the special case Si = 0
+ if ( xpi(ip,k) .eq. 0 ) then
+ if ( i .eq. 1 .and. alph(3) .eq. 0 .or.
+ + i .eq. 3 .and. alph(1) .eq. 0 ) then
+ isoort(2*i-1+8*(k-3)) = 0
+ isoort(2*i+8*(k-3)) = 0
+ goto 10
+ endif
+ endif
+ call ffxxyz(y(1,k,i),z(1,k,i),dyz(1,1,k,i),d2yzz(k,i),
+ + dy2z(1,k,i),i,sdel2,sdel2i(i,k),etalam(k),etami(1,k),
+ + delpsi(i,k),xpi(1,k),dpipj(1,1,k),piDpj(1,1,k),
+ + isoort(2*i-1+8*(k-3)),ldel2s,6,ier)
+ else
+* complex case
+ sdel2i(i,k) = sqrt(del2s(i,k))
+ csdeli(i,k) = DCMPLX(x0,sdel2i(i,k))
+ lcompl = .TRUE.
+ call ffcxyz(cy(1,k,i),cz(1,k,i),cdyz(1,1,k,i),cd2yzz(k,i),i,
+ + sdel2,sdel2i(i,k),etalam(k),etami(1,k),delpsi(i,k),xpi(
+ + 1,k),piDpj(1,1,k),isoort(2*i-1+8*(k-3)),ldel2s,6,ier)
+ endif
+ 10 continue
+ 20 continue
+* #] get y,z-roots:
+* #[ convert to complex if necessary:
+ do 60 i=2,3
+ l = 2*i-1
+ if ( isoort(l).gt.0 .and. isoort(l+8).lt.0 ) then
+ k = 3
+* we get -5, -105 if they have equal roots, isoort=+2
+* -6, -106 if they have unequal roots, isoort=+1
+ if ( .not.ldel2s ) then
+ isoort(l) = isoort(l)-7
+ isoort(l+1) = isoort(l+1)-7
+ else
+ isoort(l) = isoort(l)-207
+ isoort(l+1) = isoort(l+1)-207
+ endif
+ elseif ( isoort(l).lt.0 .and. isoort(l+8).gt.0 ) then
+ k = 4
+ if ( .not.ldel2s ) then
+ isoort(l+8) = isoort(l+8)-7
+ isoort(l+9) = isoort(l+9)-7
+ else
+ isoort(l+8) = isoort(l+8)-207
+ isoort(l+9) = isoort(l+9)-207
+ endif
+ else
+ k = 0
+ endif
+ if ( k .ne. 0 ) then
+ if ( lwrite ) print *,'ffdxc0: converting i,k=',i,k,
+ + ' to complex'
+ do 30 j=1,4
+ cy(j,k,i) = y(j,k,i)
+ cz(j,k,i) = z(j,k,i)
+ 30 continue
+ do 50 j=1,2
+ do 40 l=1,2
+ cdyz(l,j,k,i) = dyz(l,j,k,i)
+ 40 continue
+ 50 continue
+ cd2yzz(k,i) = d2yzz(k,i)
+ csdeli(i,k) = sdel2i(i,k)
+ endif
+ 60 continue
+* #] convert to complex if necessary:
+* #[ get differences:
+*
+* the only important differences are y4z3-z3y4 and (1-y4)(1-z3)-
+* (1-y3)(1-z4)
+*
+ do 100 i=1,12
+ ieri(i) = 0
+ 100 continue
+* #[ vertices (1):
+ som = qiDqj(7,2)/sdel2
+ if ( isoort(1) .ge. 0 ) then
+* Note that the isoorts are equal as the vertex is equal.
+*
+* flag if we have a cancellation
+*
+ if ( abs(som) .lt. xloss ) then
+ isoort(1) = isoort(1) + 10
+ isoort(9) = isoort(9) + 10
+ endif
+ do 110 k=1,4
+ dyzzy(k,1) = som*z(k,3,1)
+ if ( k .gt. 2 ) dyzzy(k,1) = -dyzzy(k,1)
+ 110 continue
+ else
+ if ( abs(som) .lt. xloss ) then
+ isoort(1) = isoort(1) - 10
+ isoort(9) = isoort(9) - 10
+ endif
+ do 120 k=1,4
+ cdyzzy(k,1) = DBLE(som)*cz(k,3,1)
+ if ( k .gt. 2 ) cdyzzy(k,1) = -cdyzzy(k,1)
+ 120 continue
+ cdyyzz(1,1) = som
+ cdyyzz(2,1) = som
+ if ( lwrite ) then
+ print *,'cdyyzz(11) =',cy(2,4,1)-cy(2,3,1),
+ + absc(cy(2,4,1))
+ print *,'cdyyzz(11)+=',cdyyzz(1,1)
+ endif
+ endif
+* #] vertices (1):
+* #[ vertices (2):
+ if ( isoort(3) .ge. 0 ) then
+* #[ real case: (note that this implies isoort(11)>0)
+ ifirst = 0
+ do 150 j=1,2
+ do 140 k=1,2
+ ii = 2*(j-1) + k
+ dyzzy(ii,2) = y(2*j,4,2)*z(ii,3,2)-y(2*j,3,2)*z(ii,4,2)
+ xmax = abs(y(2*j,4,2)*z(ii,3,2))
+ if ( abs(dyzzy(ii,2)) .ge. xmax ) goto 140
+ isoort(3) = isoort(3) + 10
+ isoort(11) = isoort(11) + 10
+ 1000 format(a,i1,a,g22.14,g12.4)
+ if ( lwrite ) print 1000,'dyzzy(',ii,'2) = ',
+ + dyzzy(ii,2),xmax
+ if ( ldel2s ) then
+ print *,'ffdxc0: not ready for del2s=0, real case'
+ goto 130
+ endif
+ if ( ifirst .le. 0 ) then
+ if ( ddel2s(2) .eq. 0 ) then
+ dsdel2 = 0
+ else
+ dsdel2 = ddel2s(2)/(sdel2i(2,3)+sdel2i(2,4))
+ endif
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 ) then
+ s(1) = xqi(6)*qiDqj(7,4)*qiDqj(5,4)/sdel2
+ s(2) = -qiDqj(7,4)*sdel2i(2,3)
+ s(3) = +qiDqj(6,4)*dsdel2
+ else
+ s(1) = xqi(6)*qiDqj(7,2)*qiDqj(5,2)/sdel2
+ s(2) = -qiDqj(7,2)*sdel2i(2,3)
+ s(3) = +qiDqj(6,2)*dsdel2
+ endif
+ endif
+ if ( ifirst .le. 0 ) then
+ ifirst = 2
+ s(4) = -qiDqj(5,10)*qiDqj(7,4)*sdel2i(2,3)/sdel2
+ s(5) = delpsi(2,3)*dsdel2/sdel2
+ endif
+ if ( k .eq. 1 ) then
+ som = s(1) + s(2) + s(3) + s(4) + s(5)
+ else
+ som = s(1) - s(2) - s(3) - s(4) - s(5)
+ endif
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)),
+ + abs(s(5)))/xqi(6)**2
+ if ( lwrite ) then
+ print 1000,'dyzzy(',ii,'2)+ = ',som/xqi(6)**2,smax
+* print *,(s(i)/xqi(6)**2,i=1,5)
+ endif
+ if ( smax .lt. xmax ) then
+ dyzzy(ii,2) = som/xqi(6)**2
+ xmax = smax
+ endif
+ 130 continue
+ if ( lwarn .and. abs(dyzzy(ii,2)) .lt. xloss*xmax ) then
+ call ffwarn(140,ieri(2*k+j-2),dyzzy(ii,2),xmax)
+ endif
+ 140 continue
+ ifirst = ifirst - 1
+ 150 continue
+* #] real case:
+ else
+* #[ complex case:
+ ifirst = 0
+ do 180 j=1,2
+ do 170 k=1,2
+ ii = 2*(j-1) + k
+ cdyzzy(ii,2) = cy(2*j,4,2)*cz(ii,3,2)-cy(2*j,3,2)*
+ + cz(ii,4,2)
+ xmax = absc(cy(2*j,4,2)*cz(ii,3,2))
+ if ( absc(cdyzzy(ii,2)) .ge. xmax ) goto 170
+ isoort(3) = isoort(3) - 10
+ isoort(11) = isoort(11) - 10
+ 1002 format(a,i1,a,2g22.14,g12.4)
+ if ( lwrite ) print 1002,'cdyzzy(',ii,'2) =',
+ + cdyzzy(ii,2),xmax
+ if ( ldel2s ) then
+ ip = 3
+ else
+ ip = 6
+ endif
+ if ( mod(isoort(3),10).ne.0 .or. mod(isoort(11),10).ne.0
+ + ) then
+*
+* one of the roots is really real
+*
+ if ( ifirst .le. 0 ) then
+ csdel2=DBLE(ddel2s(2))/(csdeli(2,3)+csdeli(2,4))
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 .neqv. ldel2s ) then
+ if ( .not.ldel2s ) then
+ cs(1)=xqi(6)*qiDqj(7,4)*qiDqj(5,4)/sdel2
+ cs(2) = -DBLE(qiDqj(7,4))*csdeli(2,3)
+ cs(3) = +DBLE(qiDqj(6,4))*csdel2
+ else
+ cs(1)=-xqi(3)*qiDqj(5,10)*qiDqj(7,2)/
+ + sdel2
+ cs(2) = -DBLE(qiDqj(7,2))*csdeli(2,3)
+ cs(3) = -DBLE(qiDqj(6,3))*csdel2
+ endif
+ else
+ cs(1) = xqi(ip)*qiDqj(7,2)*qiDqj(5,2)/sdel2
+ cs(2) = -DBLE(qiDqj(7,2))*csdeli(2,3)
+ cs(3) = +DBLE(qiDqj(ip,2))*csdel2
+ endif
+ endif
+ if ( ifirst .le. 0 ) then
+ ifirst = 2
+ if ( .not.ldel2s ) then
+ cs(4) = -DBLE(qiDqj(5,10)*qiDqj(7,4)/sdel2)*
+ + csdeli(2,3)
+ else
+ cs(4) = -DBLE(qiDqj(5,3)*qiDqj(7,2)/sdel2)*
+ + csdeli(2,3)
+ endif
+ cs(5) = DBLE(delpsi(2,3)/sdel2)*csdel2
+ endif
+ else
+*
+* both roots are complex
+*
+ if ( ifirst .eq. 0 ) then
+ dsdel2 = -ddel2s(2)/(sdel2i(2,3)+sdel2i(2,4))
+ csdel2 = DCMPLX(x0,dsdel2)
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 .neqv. ldel2s ) then
+ if ( .not.ldel2s ) then
+ cs(1)=xqi(6)*qiDqj(7,4)*qiDqj(5,4)/sdel2
+ cs(2)=-DCMPLX(x0,qiDqj(7,4)*sdel2i(2,3))
+ cs(3)=+DCMPLX(x0,qiDqj(6,3)*dsdel2)
+ else
+ cs(1)=-xqi(3)*qiDqj(5,10)*qiDqj(7,2)/
+ + sdel2
+ cs(2)=-DCMPLX(x0,qiDqj(7,2)*sdel2i(2,3))
+ cs(3)=-DCMPLX(x0,qiDqj(6,3)*dsdel2)
+ endif
+ else
+ cs(1) = xqi(ip)*qiDqj(7,2)*qiDqj(5,2)/sdel2
+ cs(2) = -DCMPLX(x0,qiDqj(7,2)*sdel2i(2,3))
+ cs(3) = +DCMPLX(x0,qiDqj(ip,2)*dsdel2)
+ endif
+ endif
+ if ( ifirst .eq. 0 ) then
+ ifirst = 2
+ if ( .not.ldel2s ) then
+ cs(4) = -DCMPLX(x0,qiDqj(5,10)*qiDqj(7,4)*
+ + sdel2i(2,3)/sdel2)
+ else
+ cs(4) = -DCMPLX(x0,qiDqj(5,3)*qiDqj(7,2)*
+ + sdel2i(2,3)/sdel2)
+ endif
+ cs(5) = DCMPLX(x0,delpsi(2,3)*dsdel2/sdel2)
+ endif
+ endif
+ if ( k .eq. 1 ) then
+ csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
+ else
+ csom = cs(1) - cs(2) - cs(3) - cs(4) - cs(5)
+ endif
+ smax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)),
+ + absc(cs(4)),absc(cs(5)))/xqi(ip)**2
+ if ( lwrite ) then
+ print 1002,'cdyzzy(',ii,'2)+ =',csom/DBLE(xqi(ip))**
+ + 2,smax
+*** print *,(cs(i)/DBLE(xqi(ip))**2,i=1,5)
+ endif
+ if ( smax .lt. xmax ) then
+ cdyzzy(ii,2) = csom/DBLE(xqi(ip))**2
+ xmax = smax
+ endif
+ if ( lwarn .and. absc(cdyzzy(ii,2)).lt.xloss*xmax ) then
+ call ffwarn(140,ieri(2*k+j-2),absc(cdyzzy(ii,2)),xmax)
+ endif
+ 170 continue
+*
+* get cdyyzz
+*
+ if ( ldel2s ) then
+ cdyyzz(j,2) = cdyz(2,j,4,2) - cdyz(2,j,3,2)
+ xmax = absc(cdyz(2,j,4,2))
+ if ( absc(cdyyzz(j,2)) .ge. xloss*xmax ) goto 175
+ if ( lwrite ) print 1002,'cdyyzz(',j,'2) =',cdyyzz(j,2),
+ + xmax
+ if ( ifirst .le. 0 ) then
+ if ( mod(isoort( 3),10).ne.0 .or.
+ + mod(isoort(11),10).ne.0 ) then
+ csdel2=DBLE(ddel2s(2))/(csdeli(2,3)+csdeli(2,4))
+ else
+ dsdel2 = -ddel2s(2)/(sdel2i(2,3)+sdel2i(2,4))
+ csdel2 = DCMPLX(x0,dsdel2)
+ endif
+ endif
+ cs(2) = csdel2/DBLE(xqi(3))
+ cs(1) = qiDqj(5,3)*qiDqj(7,2)/(sdel2*xqi(3))
+ if ( j .eq. 1 ) then
+ csom = cs(1) + cs(2)
+ else
+ csom = cs(1) - cs(2)
+ endif
+ smax = absc(cs(1))
+ if ( lwrite ) print 1002,'cdyyzz(',j,'2)+=',csom,smax
+ if ( smax .lt. xmax ) then
+ cdyyzz(j,2) = csom
+ xmax = smax
+ endif
+ if ( lwarn .and. absc(cdyyzz(j,2)).lt.xloss*xmax ) then
+ call ffwarn(147,ieri(7+j),absc(cdyyzz(j,2)),xmax)
+ endif
+ endif
+*
+* bookkeeping
+*
+ 175 continue
+ ifirst = ifirst - 1
+ 180 continue
+* #] complex case:
+ endif
+* #] vertices (2):
+* #[ vertices (3):
+ if ( isoort(5) .ge. 0 ) then
+* #[ real case: (note that this implies isoort(15)>0)
+ ifirst = 0
+ do 210 j=1,2
+ do 200 k=1,2
+ ii = 2*(j-1) + k
+ dyzzy(ii,3) = y(2*j,4,3)*z(ii,3,3)-y(2*j,3,3)*z(ii,4,3)
+ xmax = abs(y(2*j,4,3)*z(ii,3,3))
+ if ( abs(dyzzy(ii,3)) .ge. xmax ) goto 200
+ isoort(5) = isoort(5) + 10
+ isoort(13) = isoort(13) + 10
+ if ( lwrite ) print 1000,'dyzzy(',ii,'3) = ',
+ + dyzzy(ii,3),xmax
+ if ( ldel2s ) then
+ print *,'ffdxc0: not ready for del2s=0, real case'
+ goto 190
+ endif
+ if ( ifirst .le. 0 ) then
+ if ( ddel2s(2) .eq. 0 ) then
+ dsdel2 = 0
+ else
+ dsdel2 = ddel2s(3)/(sdel2i(3,3)+sdel2i(3,4))
+ endif
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 ) then
+ s(1) = xqi(8)*qiDqj(7,1)*qiDqj(5,1)/sdel2
+ s(2) = +qiDqj(7,1)*sdel2i(3,3)
+ s(3) = +qiDqj(9,1)*dsdel2
+ else
+ s(1) = xqi(8)*qiDqj(7,4)*qiDqj(5,4)/sdel2
+ s(2) = +qiDqj(7,4)*sdel2i(3,3)
+ s(3) = +qiDqj(9,4)*dsdel2
+ endif
+ endif
+ if ( ifirst .le. 0 ) then
+ ifirst = 2
+ s(4) = -qiDqj(5,9)*qiDqj(7,1)*sdel2i(3,3)/sdel2
+ s(5) = delpsi(3,3)*dsdel2/sdel2
+ endif
+ if ( k .eq. 1 ) then
+ som = s(1) + s(2) + s(3) + s(4) + s(5)
+ else
+ som = s(1) - s(2) - s(3) - s(4) - s(5)
+ endif
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)),
+ + abs(s(5)))/xqi(8)**2
+ if ( lwrite ) then
+ print 1000,'dyzzy(',ii,'3)+ = ',som/xqi(8)**2,smax
+*** print *,(s(i)/xqi(8)**2,i=1,5)
+ endif
+ if ( smax .lt. xmax ) then
+ dyzzy(ii,3) = som/xqi(8)**2
+ xmax = smax
+ endif
+ 190 continue
+ if ( lwarn .and. abs(dyzzy(ii,3)) .lt. xloss*xmax ) then
+ call ffwarn(140,ieri(2*k+j+2),dyzzy(ii,3),xmax)
+ endif
+ 200 continue
+ ifirst = ifirst - 1
+ 210 continue
+* #] real case:
+ else
+* #[ complex case:
+ ifirst = 0
+ do 240 j=1,2
+ do 230 k=1,2
+ ii = 2*(j-1) + k
+ cdyzzy(ii,3) = cy(2*j,4,3)*cz(ii,3,3)-cy(2*j,3,3)*
+ + cz(ii,4,3)
+ xmax = absc(cy(2*j,4,3)*cz(ii,3,3))
+ if ( absc(cdyzzy(ii,3)) .ge. xmax ) goto 230
+ isoort(5) = isoort(5) - 10
+ isoort(13) = isoort(13) - 10
+ if ( lwrite ) print 1002,'cdyzzy(',ii,'3) =',
+ + cdyzzy(ii,3),xmax
+ if ( ldel2s ) then
+ ip = 3
+ else
+ ip = 8
+ endif
+ if ( mod(isoort(3),10).ne.0 .or. mod(isoort(11),10).ne.0
+ + ) then
+*
+* one of the roots is really real
+*
+ if ( ifirst .le. 0 ) then
+ csdel2=DBLE(ddel2s(3))/(csdeli(3,3)+csdeli(3,4))
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 ) then
+ cs(1) = xqi(ip)*qiDqj(7,1)*qiDqj(5,1)/sdel2
+ cs(2) = +DBLE(qiDqj(7,1))*csdeli(3,3)
+ if ( .not.ldel2s ) then
+ cs(3) = +DBLE(qiDqj(9,1))*csdel2
+ else
+ cs(3) = +DBLE(qiDqj(3,1))*csdel2
+ endif
+ else
+ if ( .not.ldel2s ) then
+ cs(1) = xqi(ip)*qiDqj(7,4)*qiDqj(5,4)/
+ + sdel2
+ cs(2) = DBLE(qiDqj(7,4))*csdeli(3,3)
+ else
+ cs(1) = xqi(ip)*qiDqj(7,1)*qiDqj(5,9)/
+ + sdel2
+ cs(2) = DBLE(qiDqj(7,1))*csdeli(3,3)
+ endif
+ cs(3) = +DBLE(qiDqj(9,3))*csdel2
+ endif
+ if ( ldel2s ) cs(3) = -cs(3)
+ endif
+ if ( ifirst .le. 0 ) then
+ ifirst = 2
+ if ( .not.ldel2s ) then
+ cs(4) = -DBLE(qiDqj(5,9)*qiDqj(7,1)/sdel2)*
+ + csdeli(3,3)
+ else
+ cs(4) = DBLE(qiDqj(5,4)*qiDqj(7,1)/sdel2)*
+ + csdeli(3,3)
+ endif
+ cs(5) = DBLE(delpsi(3,3)/sdel2)*csdel2
+ endif
+ else
+*
+* both roots are complex
+*
+ if ( ifirst .eq. 0 ) then
+ dsdel2 = -ddel2s(3)/(sdel2i(3,3)+sdel2i(3,4))
+ csdel2 = DCMPLX(x0,dsdel2)
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 ) then
+ cs(1) = xqi(ip)*qiDqj(7,1)*qiDqj(5,1)/sdel2
+ cs(2) = +DCMPLX(x0,qiDqj(7,1)*sdel2i(3,3))
+ if ( .not.ldel2s ) then
+ cs(3) = +DCMPLX(x0,qiDqj(9,1)*dsdel2)
+ else
+ cs(3) = +DCMPLX(x0,qiDqj(3,1)*dsdel2)
+ endif
+ else
+ if ( .not.ldel2s ) then
+ cs(1) = xqi(ip)*qiDqj(7,4)*qiDqj(5,4)/
+ + sdel2
+ cs(2) =DCMPLX(x0,qiDqj(7,4)*sdel2i(3,3))
+ else
+ cs(1) = xqi(ip)*qiDqj(7,1)*qiDqj(5,9)/
+ + sdel2
+ cs(2) =DCMPLX(x0,qiDqj(7,1)*sdel2i(3,3))
+ endif
+ cs(3) = +DCMPLX(x0,qiDqj(9,3)*dsdel2)
+ endif
+ if ( ldel2s ) cs(3) = -cs(3)
+ endif
+ if ( ifirst .le. 0 ) then
+ ifirst = 2
+ if ( .not.ldel2s ) then
+ cs(4) = -DCMPLX(x0,qiDqj(5,9)*qiDqj(7,1)*
+ + sdel2i(3,3)/sdel2)
+ else
+ cs(4) = DCMPLX(x0,qiDqj(5,4)*qiDqj(7,1)*
+ + sdel2i(3,3)/sdel2)
+ endif
+ cs(5) = DCMPLX(x0,delpsi(3,3)*dsdel2/sdel2)
+ endif
+ endif
+ if ( k .eq. 1 ) then
+ csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
+ else
+ csom = cs(1) - cs(2) - cs(3) - cs(4) - cs(5)
+ endif
+ smax =max(absc(cs(1)),absc(cs(2)),absc(cs(3)),
+ + absc(cs(4)),absc(cs(5)))/xqi(ip)**2
+ if ( lwrite ) then
+ print 1002,'cdyzzy(',ii,'3)+ =',csom/DBLE(xqi(ip))**
+ + 2,smax
+*** print *,(cs(i)/DBLE(xqi(ip))**2,i=1,5)
+ endif
+ if ( smax .lt. xmax ) then
+ cdyzzy(ii,3) = csom/DBLE(xqi(ip))**2
+ xmax = smax
+ endif
+ if ( lwarn .and. absc(cdyzzy(ii,3)).lt.xloss*xmax ) then
+ call ffwarn(140,ieri(2*k+j+2),absc(cdyzzy(ii,3)),xmax)
+ endif
+ 230 continue
+*
+* get cdyyzz
+*
+ if ( ldel2s ) then
+ cdyyzz(j,3) = cdyz(2,j,4,3) - cdyz(2,j,3,3)
+ xmax = absc(cdyz(2,j,4,3))
+ if ( absc(cdyyzz(j,3)) .ge. xloss*xmax ) goto 235
+ if ( lwrite ) print 1002,'cdyyzz(',j,'3) =',cdyyzz(j,3),
+ + xmax
+ if ( ifirst .le. 0 ) then
+ if ( mod(isoort( 5),10).ne.0 .or.
+ + mod(isoort(13),10).ne.0 ) then
+ csdel2=DBLE(ddel2s(3))/(csdeli(3,3)+csdeli(3,4))
+ else
+ dsdel2 = -ddel2s(3)/(sdel2i(3,3)+sdel2i(3,4))
+ csdel2 = DCMPLX(x0,dsdel2)
+ endif
+ endif
+ cs(2) = -csdel2/DBLE(xqi(3))
+ cs(1) = qiDqj(5,3)*qiDqj(7,1)/(sdel2*xqi(3))
+ if ( j .eq. 1 ) then
+ csom = cs(1) + cs(2)
+ else
+ csom = cs(1) - cs(2)
+ endif
+ smax = absc(cs(1))
+ if ( lwrite ) print 1002,'cdyyzz(',j,'3)+=',csom,smax
+ if ( smax .lt. xmax ) then
+ cdyyzz(j,3) = csom
+ xmax = smax
+ endif
+ if ( lwarn .and. absc(cdyyzz(j,3)).lt.xloss*xmax ) then
+ call ffwarn(147,ieri(9+j),absc(cdyyzz(j,3)),xmax)
+ endif
+ endif
+*
+* bookkeeping
+*
+ 235 continue
+ ifirst = ifirst - 1
+ 240 continue
+* #] complex case:
+ endif
+* #] vertices (3):
+ ier0 = 0
+ do 250 i = 1,12
+ ier0 = max(ier0,ieri(i))
+ 250 continue
+ ier = ier + ier0
+* #] get differences:
+* #[ check differences:
+ if ( ltest ) then
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ do 300 i=1,3
+ if ( isoort(2*i-1) .ne. isoort(2*i+7) ) goto 300
+ do 290 j=1,2
+ if ( isoort(2*i-1) .ge. 0 ) then
+ xhck = dyzzy(j,i) - y(2,4,i)*z(j,3,i)
+ + + z(j,4,i)*y(2,3,i)
+ if ( rloss*abs(xhck) .gt. precx*max(
+ + abs(y(2,4,i)*z(j,3,i)),
+ + abs(z(j,4,i)*y(2,3,i))) ) print *,
+ + 'ffdxc0: error: ','dyzzy(',j,i,') <> terms, ',
+ + dyzzy(j,i),y(2,4,i)*z(j,3,i),
+ + z(j,4,i)*y(2,3,i),xhck
+ xhck = dyzzy(j+2,i) - y(4,4,i)*z(j+2,3,i)
+ + + z(j+2,4,i)*y(4,3,i)
+ if ( rloss*abs(xhck) .gt. precx*max(
+ + abs(y(4,4,i)*z(j+2,3,i)),
+ + abs(z(j+2,4,i)*y(4,3,i))) ) print *,
+ + 'ffdxc0: error: ','dyzzy(',j+2,i,') <> terms, ',
+ + dyzzy(j+2,i),y(4,4,i)*z(j+2,3,i),
+ + z(j+2,4,i)*y(4,3,i),xhck
+ else
+ chck = cdyzzy(j,i) - cy(2,4,i)*cz(j,3,i)
+ + + cz(j,4,i)*cy(2,3,i)
+ if ( rloss*absc(chck) .gt. precc*max(
+ + abs(cy(2,4,i)*cz(j,3,i)),
+ + abs(cz(j,4,i)*cy(2,3,i))) ) print *,
+ + 'ffdxc0: error: ','cdyzzy(',j,i,') <> terms, ',
+ + cdyzzy(j,i),cy(2,4,i)*cz(j,3,i),
+ + cz(j,4,i)*cy(2,3,i),chck
+ chck = cdyzzy(j+2,i) - cy(4,4,i)*cz(j+2,3,i)
+ + + cz(j+2,4,i)*cy(4,3,i)
+ if ( rloss*absc(chck) .gt. precc*max(
+ + abs(cy(4,4,i)*cz(j+2,3,i)),
+ + abs(cz(j+2,4,i)*cy(4,3,i))) ) print *,
+ + 'ffdxc0: error: ','cdyzzy(',j+2,i,') <> terms,',
+ + cdyzzy(j+2,i),cy(4,4,i)*cz(j+2,3,i),
+ + cz(j+2,4,i)*cy(4,3,i),chck
+ endif
+ 290 continue
+ 300 continue
+ endif
+* #] check differences:
+* #[ write output:
+ if ( lwrite ) then
+ print *,'ffdxc0: found roots:'
+ do 320 k=3,4
+ do 310 i=1,3
+ print *,' k = ',i
+ if ( isoort(2*i+8*(k-3)) .gt. 0 ) then
+ print *,' ym,ym1 = ',y(1,k,i),y(3,k,i),
+ + ' (not used)'
+ print *,' yp,yp1 = ',y(2,k,i),y(4,k,i)
+ print *,' zm,zm1 = ',z(1,k,i),z(3,k,i)
+ print *,' zp,zp1 = ',z(2,k,i),z(4,k,i)
+ elseif ( isoort(2*i+8*(k-3)) .eq. 0 ) then
+ if ( isoort(2*i-1+8*(k-3)) .eq. 0 ) then
+ print *,' no roots, all is zero'
+ else
+ print *,' yp,yp1 = ',y(2,k,i),y(4,k,i)
+ print *,' zp,zp1 = ',z(2,k,i),z(4,k,i)
+ endif
+ else
+ print *,' cym,cym1 = ',cy(1,k,i),cy(3,k,i),
+ + '(not used)'
+ print *,' cyp,cyp1 = ',cy(2,k,i),cy(4,k,i)
+ print *,' czm,czm1 = ',cz(1,k,i),cz(3,k,i)
+ print *,' czp,czp1 = ',cz(2,k,i),cz(4,k,i)
+ endif
+ 310 continue
+ 320 continue
+ endif
+ if ( lwrite ) print '(a)',' ##] get roots:'
+* #] write output:
+* #[ logarithms for 4point function:
+*
+* Not yet made stable ...
+*
+ if ( npoin .eq. 4 ) then
+ if ( lwrite ) print '(a)',' ##[ logarithms for Ai<0:'
+ do 420 i = 1,3
+ do 410 k = 3,4
+ ii = i+3*(k-3)
+ if ( ilogi(ii) .ne. -999 ) then
+ idone(ii) = 0
+ goto 410
+ endif
+ l = 2*i+8*(k-3)-1
+ if ((isoort(l).gt.0 .or. mod(isoort(l),10).le.-5) .and.
+ + (isoort(l+1).ge.0 .or. mod(isoort(l+1),10).le.-5)) then
+* #[ real case:
+*
+* the real case (isoort=-5,-6: really real but complex for ffdcs)
+*
+ s(1) = -dyz(2,1,k,i)/dyz(2,2,k,i)
+ if ( lwrite ) then
+* fantasize imag part, but suppress error message
+ clogi(ii) = zxfflg(s(1),1,x1,ier0)
+ print *,'clogi = ',clogi(ii)
+ endif
+ if ( abs(s(1)-1) .lt. xloss ) then
+ clogi(ii) = dfflo1(d2yzz(k,i)/dyz(2,2,k,i),ier)
+ ilogi(ii) = 0
+ else
+ if ( abs(s(1)+1) .lt. xloss ) then
+ clogi(ii) = dfflo1(-2*sdel2i(i,k)/(xpi(i+3,k)*
+ + dyz(2,2,k,i)),ier)
+ else
+ clogi(ii) = zxfflg(abs(s(1)),0,x0,ier)
+ endif
+ if ( dyz(2,2,k,i).gt.0 .and. dyz(2,1,k,i).gt.0 )
+ + then
+ ilogi(ii) = -1
+ elseif ( dyz(2,1,k,i).lt.0 .and. dyz(2,2,k,i).lt.0)
+ + then
+ ilogi(ii) = +1
+ else
+ ilogi(ii) = 0
+ endif
+* in case del2s=0 and i=3 we pick up a minus sign, I think
+ if ( ldel2s .and. i .eq. 3 ) ilogi(ii) = -ilogi(ii)
+ endif
+ if ( lwrite ) print *,'clogi+ = ',clogi(ii)+
+ + DCMPLX(x0,pi)*ilogi(ii)
+ idone(ii) = 1
+* #] real case:
+ elseif ( isoort(l) .lt. 0 ) then
+* #[ complex case:
+* for stability split the unit circle up in 4*pi/2
+* (this may have to be improved to 8*pi/4...)
+*
+ ier0 = 0
+ if ( lwrite ) then
+ if ( abs(DBLE(cdyz(2,1,k,i))) .lt. xalog2 .or.
+ + abs(DIMAG(cdyz(2,2,k,i))) .lt. xalog2 ) then
+ csom = -DCMPLX(DBLE(cdyz(2,1,k,i))/xalog2,DIMAG(
+ + cdyz(2,1,k,i))/xalog2) /DCMPLX(DBLE(cdyz
+ + (2,2,k,i))/xalog2,DIMAG(cdyz(2,2,k,i))/
+ + xalog2)
+ else
+ csom = -cdyz(2,1,k,i)/cdyz(2,2,k,i)
+ endif
+ clogi(ii)=zfflog(csom,0,c0,ier0)
+ print *,'isoort = ',isoort(2*i-1)
+ print *,'cdyz(2,1) = ',cdyz(2,1,k,i)
+ print *,'cdyz(2,2) = ',cdyz(2,2,k,i)
+ print *,'clogi = ',clogi(ii)
+ endif
+ if ( DBLE(cdyz(2,1,k,i)) .gt. abs(DIMAG(cdyz(2,1,k,i))))
+ + then
+ som =2*atan2(DIMAG(cdyz(2,1,k,i)),DBLE(
+ + cdyz(2,1,k,i)))
+ clogi(ii) = DCMPLX(x0,som)
+ if ( DIMAG(cdyz(2,1,k,i)) .gt. 0 ) then
+ ilogi(ii) = -1
+ else
+ ilogi(ii) = +1
+ endif
+
+ elseif ( DBLE(cdyz(2,1,k,i)) .lt.
+ + -abs(DIMAG(cdyz(2,1,k,i))) ) then
+ if ( DIMAG(cdyz(2,1,k,i)) .eq. 0 ) then
+ call fferr(82,ier)
+ print *,'isoort = ',isoort(l),isoort(l+1)
+ endif
+ som = 2*atan2(-DIMAG(cdyz(2,1,k,i)),-DBLE(
+ + cdyz(2,1,k,i)))
+ clogi(ii) = DCMPLX(x0,som)
+ if ( DIMAG(cdyz(2,1,k,i)) .gt. 0 ) then
+ ilogi(ii) = +1
+ else
+ ilogi(ii) = -1
+ endif
+ else
+ s(1) = -DBLE(cdyz(2,1,k,i))
+ s(2) = DIMAG(cdyz(2,1,k,i))
+ som = 2*atan2(s(1),s(2))
+ clogi(ii) = DCMPLX(x0,som)
+ ilogi(ii) = 0
+ endif
+ if ( lwrite ) print *,'clogi+= ',clogi(ii)+
+ + DCMPLX(x0,pi)*ilogi(ii)
+ idone(ii) = 1
+* #] complex case:
+ endif
+* Note that we generate an error if isoort(l)=0
+ if ( lwrite ) then
+ print *,'ffdxc0: ',ii,': ',clogi(ii),' + ',ilogi(ii),
+ + '*i*pi'
+ endif
+ 410 continue
+ if ( idone(ii) .ne. 0 .and. idone(ii-3) .ne. 0 .and.
+ + absc(clogi(ii)-clogi(ii-3)).lt.xloss*absc(clogi(ii)) .and.
+ + ilogi(ii).eq.ilogi(ii-3) ) then
+* #[ subtract more smartly:
+ if ( isoort(l).gt.0 .and. isoort(l+1).ge.0 ) then
+ if ( lwrite ) print *,'ffdxc0: extra logs not ready ',
+ + 'in the real case'
+ goto 420
+ else
+ cs(1) = cdyzzy(1,i)
+ cs(2) = cdyzzy(2,i)
+ if ( i .eq. 1 ) then
+ cs(3) = 0
+ else
+ if ( lwrite ) print *,'ffdxc0: extra logs not ',
+ + 'ready for i <>1'
+ goto 420
+ endif
+ csom = cs(1) - cs(2) + cs(3)
+ xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)))
+* change this to "no warning and quit" later
+ if ( lwarn .and. absc(csom) .lt. xmax ) then
+ goto 420
+*** call ffwarn(148,ier,absc(csom),xmax)
+ endif
+ if ( lwrite ) print *,'som was : ',clogi(ii-3)-clogi(ii)
+ c = csom/(cdyz(2,2,3,i)*cdyz(2,1,4,i))
+ c = zfflo1(c,ier)
+ if ( lwrite ) print *,'som is : ',c
+*
+* the log is never much bigger than 1, so demand at least
+* accuracy to 0.1; this will catch all i*pi errors
+*
+ if ( abs(clogi(ii-3)-clogi(ii)-c).gt.0.1 ) then
+ print *,'ffdxc0: error in smart logs: ',clogi(ii-3)-
+ + clogi(ii),c,' not used'
+ goto 420
+ endif
+ clogi(ii-3) = c
+ clogi(ii) = 0
+ endif
+* #] subtract more smartly:
+ endif
+ 420 continue
+* An algorithm to obtain the sum of two small logarithms more
+* accurately has been put in ffcc0p, not yet here
+ if ( lwrite ) print '(a)',' ##] logarithms for Ai<0:'
+ endif
+* #] logarithms for 4point function:
+* #[ real case integrals:
+ if ( .not. lcompl ) then
+* normal case
+ do 510 i=1,3
+ if ( lwrite ) print '(a,i1,a)',' ##[ dxs nr ',i,':'
+ j = 2*i-1
+ if ( isoort(j) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdxc0: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j),isoort(j+1)
+ endif
+ if ( isoort(j+8) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdxc0: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j+8),isoort(j+9)
+ endif
+ else
+ call ffcxs3(cs3(20*i+61),ipi12(j+8),y(1,4,i),
+ + z(1,4,i),dyz(1,1,4,i),d2yzz(4,i),dy2z(1,4,i),
+ + xpi(1,4),piDpj(1,1,4),i,6,isoort(j+8),ier)
+ endif
+ elseif ( isoort(j+8) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdxc0: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j),isoort(j+1)
+ endif
+ call ffcxs3(cs3(20*i-19),ipi12(j),y(1,3,i),
+ + z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),
+ + xpi(1,3),piDpj(1,1,3),i,6,isoort(j),ier)
+ else
+ call ffdcxs(cs3(20*i-19),ipi12(j),y(1,3,i),z(1,3,i),
+ + dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),dyzzy(1,i),
+ + xpi,piDpj,i,6,isoort(j),ier)
+ endif
+ if ( lwrite ) print '(a,i1,a)',' ##] dxs nr ',i,':'
+ 510 continue
+ isoort(7) = 0
+ isoort(8) = 0
+* #] real case integrals:
+* #[ complex case integrals:
+ else
+* convert xpi
+ do 540 k=3,4
+*not cetami(1,k) = etami(1,k)
+*used cetami(3,k) = etami(3,k)
+ do 530 i=1,6
+ cpi(i,k) = xpi(i,k)
+ do 520 j=1,6
+ cpiDpj(j,i,k) = piDpj(j,i,k)
+ 520 continue
+ 530 continue
+ 540 continue
+ do 550 i=1,3
+ if ( lwrite ) print '(a,i1,a)',' ##[ dcs nr ',i,':'
+ j = 2*i-1
+ if ( isoort(j) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdxc0: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j),isoort(j+1)
+ endif
+ if ( isoort(j+8) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdxc0: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j+8),isoort(j+9)
+ endif
+ else
+ call ffcxs3(cs3(20*i+61),ipi12(j+8),y(1,4,i),
+ + z(1,4,i),dyz(1,1,4,i),d2yzz(4,i),dy2z(1,4,i),
+ + xpi(1,4),piDpj(1,1,4),i,6,isoort(j+8),ier)
+ endif
+ elseif ( isoort(j+8) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffdxc0: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j),isoort(j+1)
+ endif
+ call ffcxs3(cs3(20*i-19),ipi12(j),y(1,3,i),
+ + z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),
+ + xpi(1,3),piDpj(1,1,3),i,6,isoort(j),ier)
+ elseif ( isoort(j) .gt. 0 ) then
+ if ( isoort(j+8) .gt. 0 ) then
+ call ffdcxs(cs3(20*i-19),ipi12(j),y(1,3,i),
+ + z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),
+ + dyzzy(1,i),xpi,piDpj,i,6,isoort(j),ier)
+ else
+ print *,'ffdxc0: error: should not occur!'
+ call ffcxs3(cs3(20*i-19),ipi12(j),y(1,3,i),
+ + z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),
+ + xpi(1,3),piDpj(1,1,3),i,6,isoort(j),ier)
+ call ffcs3(cs3(20*i+61),ipi12(j+8),cy(1,4,i),
+ + cz(1,4,i),cdyz(1,1,4,i),cd2yzz(4,i),
+ + cpi(1,4),cpiDpj(1,1,4),i,6,isoort(j+8),ier)
+ endif
+ else
+ if ( isoort(j+8) .lt. 0 ) then
+ call ffdcs(cs3(20*i-19),ipi12(j),cy(1,3,i),
+ + cz(1,3,i),cdyz(1,1,3,i),cd2yzz(3,i),
+ + cdyzzy(1,i),cdyyzz(1,i),cpi,cpiDpj,
+ + i,6,isoort(j),ier)
+ else
+ print *,'ffdxc0: error: should not occur!'
+ call ffcs3(cs3(20*i-19),ipi12(j),cy(1,3,i),
+ + cz(1,3,i),cdyz(1,1,3,i),cd2yzz(3,i),
+ + cpi(1,3),cpiDpj(1,1,3),i,6,isoort(j),ier)
+ call ffcxs3(cs3(20*i+61),ipi12(j+8),y(1,4,i),
+ + z(1,4,i),dyz(1,1,4,i),d2yzz(4,i),dy2z(1,4,i),
+ + xpi(1,4),piDpj(1,1,4),i,6,isoort(j+8),ier)
+ endif
+ endif
+ if ( lwrite ) print '(a,i1,a)',' ##] dcs nr ',i,':'
+ 550 continue
+ isoort(7) = 0
+ isoort(8) = 0
+ endif
+ return
+* #] complex case integrals:
+*###] ffdxc0:
+ end
diff --git a/ff-2.0/fferr.dat b/ff-2.0/fferr.dat
new file mode 100644
index 0000000..ca18e83
--- /dev/null
+++ b/ff-2.0/fferr.dat
@@ -0,0 +1,101 @@
+This file is called fferr.dat and contains (i4) err number
+and (a80) error message. The first two lines are skipped.
+ 1 ffca0: error: minimum value complex logarithm gives problem, change mu.
+ 2 ffxa0: error: minimum value real logarithm gives problem, change mu.
+ 3 ffcb0: error: minimum value complex logarithm gives problem, change mu.
+ 4 ffxb0: error: minimum value real logarithm gives problem, change mu.
+ 5 ffcb0p: error: cannot handle complex k^2 yet
+ 6 ffcb0p: error: minimum value complex log gives problem in unequal masses.
+ 7 ffxb0p: error: divergence for k->0, m1=m2=0.
+ 8 ffxb0p: error: minimum value real log gives problem in equal masses.
+ 9 ffxb0p: error: minimum value real log gives problem in unequal masses.
+ 10 ffcc0p: error: cannot handle two spacelike momenta and one zero.
+ 11 ffxc0p: error: cannot handle two spacelike momenta and one zero.
+ 12 ffcs3: error: illegal code for isoort(1) (should not occur)
+ 13 ffcs3: error: illegal code for isoort(2) (should not occur)
+ 14 ffcs3: error: imaginary part wrong, will be improved later
+ 15 ffcs3: error: isoort = -1,0 not yet ready
+ 16 ffcs3: error: illegal combination in isoort (should not occur)
+ 17 ffcxs3: error: illegal code for isoort(1) (should not occur)
+ 18 ffcxs3: error: illegal code for isoort(2) (should not occur)
+ 19 ffcs4: error: imaginary part is wrong (should be updated)
+ 20 ffdcrr: error: Taylor expansion in 1/x not yet ready
+ 21 ffdcxr: error: imaginary part is wrong
+ 22 ffdcxr: error: Taylor expansion in 1/x not yet ready
+ 23 ffcrr: error: minimum value complex log causes correction term to be wrong.
+ 24 ffcxr: error: minimum value real log causes correction term to be wrong.
+ 25 ffcrr: error: illegal code for iclas1 (should not occur)
+ 26 ffcxr: error: illegal code for iclas1 (should not occur)
+ 27 ffcrr: error: illegal code for iclas2 (should not occur)
+ 28 ffcxr: error: illegal code for iclas2 (should not occur)
+ 29 ffxli2: error: argument too large (should not occur)
+ 30 ffzli2: error: argument too large (should not occur)
+ 31 ffzzdl: error: imaginary part dilog is undefined for real x > 1.
+ 32 nffeta: error: eta is not defined for real negative numbers a,b, ab.
+ 33 nffet1: error: eta is not defined for real negative numbers a,b, ab.
+ 34 ffcota: error: illegal flag (should not occur)
+ 35 ffrota: error: illegal flag (should not occur)
+ 36 ffccyz: error: I took the wrong value for calpha... (should not occur)
+ 37 ffxxyz: error: I took the wrong value for alpha... (should not occur)
+ 38 ffcoot: error: a=0, trying to find two roots of a linear equation ...
+ 39 ffroot: error: a=0, trying to find two roots of a linear equation ...
+ 40 ffrot3: error: all three external masses zero !
+ 41 ffxc0: error: lambda(p1,p2,p3) < 0, unphysical configuration
+ 42 ffxc0: error: cannot handle this case (p1,p2,p3 dependent, on threshold)
+ 43 ffcxs3: error: illegal code for isoort(1) (should not occur)
+ 44 ffxd0: error: lambda(p1,p2,p3,p4) < 0, unphysical configuration
+ 45 ffxd0: error: cannot handle this case (p1,p2,p3 dependent, on threshold)
+ 46 ffxd0p: error: correction terms for Ai <0 infinite (mass zero?)
+ 47 ffcxyz: error: p_i^2 = 0 (should not occur)
+ 48 ffeta: error: answer not consistent with normal result (old)
+ 49 ffcc0: error: cannot handle complex external momenta or im > 0
+ 50 ffcd0: error: cannot handle complex external momenta.
+ 51 zfflog: error: imaginary part undefined for real z < 0.
+ 52 zxfflg: error: imaginary part undefined for x < 0.
+ 53 ffcs3: error: eta changes within (0,1), add sophisticated terms...
+ 54 ffrot4: error: cannot find any physical vertex to apply transformation.
+ 55 fftra0: error: too many vectors parallel, p_1.p_7 or p_2.p_7 is zero.
+ 56 zfflog: error: tiny imaginary part in conflict with ieps prescription.
+ 57 ffxe0: error: lambda(p1,p2,p3,p4,p5) < 0, unphysical
+ 58 ffxc0j: error: IR divergent C0 with lambda(p1,p2,p3)=0.
+ 59 ffxc0i: error: IR divergent C0 with delta=0. specify cutoff delta in /ffcut/
+ 60 ffxc0j: error: IR divergent C0 obtained from D0 is singular. Contact author.
+ 61 ffxd0p: error: IR divergent D0 with delta=0. specify cutoff delta in /ffcut/
+ 62 ffxc0p: error: I never expected complex roots in an IR divergent diagram.
+ 63 ffxd0p: error: can only handle one IR divergence per 3point function
+ 64 ffxd0p: error: can not handle a threshold in (3,4), rotated wrongly.
+ 65 ffcxr: error: IR divergence but iclass!=3. should not occur.
+ 66 ffcxs3: error: different imaginary signs should not occur for ipole=3.
+ 67 ffxdbd: error: I cannot use this algorithm for a linear IR divergence
+ 68 ffxd0: error: cannot find a proj. transformation; try another permutation.
+ 69 ff5ind: error: could not find independent momenta (should not occur).
+ 70 ffxdna: error: lambda(pi,pj,pk) < 0, unphysical configuration
+ 71 ffxdna: error: cannot handle lambda(pi,pj,pk) = 0, dependent momenta.
+ 72 ffxd0e: error: could not find a stable root; please try another permutation
+ 73 ffxdir: error: cannot handle a linearly divergent four point function (yet)
+ 74 ffxdbd: error: IR divergent B0' without cutoff delta in /ffcut/
+ 75 ffdcxr: error: dyz=0, should not occur
+ 76 ffdcrr: error: cdwz=0, but iepsz!=iepsz and significant
+ 77 ffdcrr: error: cdyz=0, should not occur
+ 78 ffdcc0: error: imaginary part wrong
+ 79 ffdcs: error: error: cannot handle isoort=0
+ 80 ffdcs: error: mixed up iep's, 2*pi^2 wrong somewhere
+ 81 ffdcs: error: wrong value for isoort
+ 82 ffdxc0: error: imaginary part Ai<0 terms uncertain
+ 83 ffxc0j: error: sorry, complex roots not yet supported here
+ 84 ffxc0p: error: imaginary part Ai<0 terms uncertain
+ 85 ffxd0a: error: t3=t4, donot know what to do
+ 86 ffxdbp: error: cannot compute derivative, lam=0
+ 87 ffxdi: error: dependent momenta not yet supported (boundary of phase space)
+ 88 ffxxyz: error: xk = 0 not yet implemented
+ 89 aaxi3: error: cannot invert matrix with zero determinant.
+ 90 aaxi4: error: cannot invert matrix with zero determinant.
+ 91 aaxi5: error: cannot invert matrix with zero determinant.
+ 92 ffxc1: error: cannot invert matrix with zero determinant.
+ 93 ffze0: error: Im(m^2) > 0
+ 94 ffze0: error: Im(p^2) != 0
+ 95 ffzf0: error: Im(m^2) > 0
+ 96 ffzf0: error: Im(p^2) != 0
+ 97 ffxc0j: error: ill-defined IR-divergent C0 for massless charged particles.
+ 98 ffxdbd: error: ill-defined IR-divergent D0 for massless charged particles.
+ 100 ffrcvr: math error: probably underflow, I do not know where or how severe..
diff --git a/ff-2.0/ffinit.f.in b/ff-2.0/ffinit.f.in
new file mode 100644
index 0000000..3515f49
--- /dev/null
+++ b/ff-2.0/ffinit.f.in
@@ -0,0 +1,1272 @@
+* $Id: ffinit.f,v 1.9 1996/04/26 10:39:03 gj Exp $
+*###[ ffini:
+ subroutine ffini
+***#[*comment:***********************************************************
+* calculate a lot of commonly-used constants in the common block *
+* /ffcnst/. also set the precision, maximum loss of digits and *
+* the minimum value the logarithm accepts in /prec/. *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer i,j,init,ioldp(13,12),isgrop(10,12),ji
+ save init
+ DOUBLE PRECISION s,sold
+ DOUBLE COMPLEX cs
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+ data init /0/
+ data ioldp/1,2,3,4, 5,6,7,8,9,10, 11,12,13,
+ + 4,1,2,3, 8,5,6,7,10,9, 11,13,12,
+ + 3,4,1,2, 7,8,5,6,9,10, 11,12,13,
+ + 2,3,4,1, 6,7,8,5,10,9, 11,13,12,
+ + 4,2,3,1, 10,6,9,8,7,5, 12,11,13,
+ + 1,3,2,4, 9,6,10,8,5,7, 12,11,13,
+ + 1,2,4,3, 5,10,7,9,8,6, 13,12,11,
+ + 1,4,3,2, 8,7,6,5,9,10, 11,13,12,
+ + 3,4,2,1, 7,10,5,9,6,8, 13,12,11,
+ + 2,3,1,4, 6,9,8,10,5,7, 12,13,11,
+ + 4,2,1,3, 10,5,9,7,8,6, 13,11,12,
+ + 1,3,4,2, 9,7,10,5,8,6, 13,11,12/
+ data isgrop/
+ + +1,+1,+1,+1, +1,+1,+1,+1, +1,+1,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,-1,
+ + +1,+1,+1,+1, +1,+1,+1,+1, +1,-1,
+ + +1,+1,+1,+1, -1,+1,+1,-1, +1,-1,
+ + +1,+1,+1,+1, -1,-1,+1,+1, -1,+1,
+ + +1,+1,+1,+1, +1,+1,-1,+1, +1,+1,
+ + +1,+1,+1,+1, -1,-1,-1,-1, +1,-1,
+ + +1,+1,+1,+1, -1,+1,+1,+1, -1,-1,
+ + +1,+1,+1,+1, +1,+1,+1,-1, +1,-1,
+ + +1,+1,+1,+1, -1,+1,+1,-1, -1,-1,
+ + +1,+1,+1,+1, -1,-1,+1,+1, -1,-1/
+* #] declarations:
+* #[ check:
+* check whether tehre is anything to do
+ if ( init .ne. 0 ) return
+ init = 1
+ print *,'===================================================='
+ print *,' FF 2.0, a package to evaluate one-loop integrals'
+ print *,'written by G. J. van Oldenborgh, NIKHEF-H, Amsterdam'
+ print *,'===================================================='
+ print *,'for the algorithms used see preprint NIKHEF-H 89/17,'
+ print *,'''New Algorithms for One-loop Integrals'', by G.J. van'
+ print *,'Oldenborgh and J.A.M. Vermaseren, published in '
+ print *,'Zeitschrift fuer Physik C46(1990)425.'
+ print *,'===================================================='
+* #] check:
+* #[ precision etc:
+ lwrite = .TRUE.
+ nevent = -1
+*
+* the loss of accuracy in any single subtraction at which
+* (timeconsuming) corrective action is to be taken is
+*
+ xloss = 0.125
+*
+* the precision to which real calculations are done is
+*
+ precx = 1
+ sold = 0
+ do 1 i=1,1000
+ precx = precx/2
+ s = exp(log(1+precx))
+ if ( s .eq. sold ) goto 2
+ sold = s
+ 1 continue
+ 2 continue
+ precx = precx*8
+* (take three bits for safety)
+ if ( lwrite ) print *,'ffini: precx = ',precx
+*
+* the precision to which complex calculations are done is
+*
+ precc = 1
+ sold = 0
+ do 3 i=1,1000
+ precc = precc/2
+ cs = exp(log(DCMPLX(1+precc,x0)))
+ if ( DBLE(cs) .eq. sold ) goto 4
+ sold = DBLE(cs)
+ 3 continue
+ 4 continue
+ precc = precc*8
+* (take three bits for safety)
+ if ( lwrite ) print *,'ffini: precc = ',precc
+*
+* for efficiency tke them equal if they are not too different
+*
+ if ( precx/precc .lt. 4 .and. precx/precc .gt. .25 ) then
+ precx = max(precc,precx)
+ precc = max(precc,precx)
+ endif
+*
+* and the minimum value the logarithm accepts without complaining
+* about arguments zero is (DOUBLE PRECISION cq DOUBLE COMPLEX)
+*
+ s = 1
+ xalogm = 1
+ do 5 i=1,10000
+ s = s/2
+ if ( 2*abs(s) .ne. xalogm ) goto 6
+ xalogm = abs(s)
+ 5 continue
+ 6 continue
+ if ( xalogm.eq.0 ) xalogm = 1d-308
+ if ( lwrite ) print *,'ffini: xalogm = ',xalogm
+ s = 1
+ xclogm = abs(DCMPLX(s))
+ do 7 i=1,10000
+ s = s/2
+ if ( 2*abs(DCMPLX(s)) .ne. xclogm ) goto 8
+ xclogm = abs(DCMPLX(s))
+ 7 continue
+ 8 continue
+ if ( xclogm.eq.0 ) xclogm = 1d-308
+ if ( lwrite ) print *,'ffini: xclogm = ',xclogm
+*
+* These values are for Absoft, Apollo fortran (68000):
+* xalogm = 1.D-308
+* xclogm = 1.D-18
+* These values are for VAX g_float
+* xalogm = 1.D-308
+* xclogm = 1.D-308
+* These values are for Gould fort (because of div_zz)
+* xalogm = 1.D-75
+* xclogm = 1.D-36
+ xalog2 = sqrt(xalogm)
+ xclog2 = sqrt(xclogm)
+* #] precision etc:
+* #[ constants:
+*
+* calculate the coefficients of the series expansion
+* li2(x) = sum bn*z^n/(n+1)!, z = -log(1-x), bn are the
+* bernouilli numbers (zero for odd n>1).
+*
+ bf(1) = - 1.D+0/4.D+0
+ bf(2) = + 1.D+0/36.D+0
+ bf(3) = - 1.D+0/36.D+2
+ bf(4) = + 1.D+0/21168.D+1
+ bf(5) = - 1.D+0/108864.D+2
+ bf(6) = + 1.D+0/52690176.D+1
+ bf(7) = - 691.D+0/16999766784.D+3
+ bf(8) = + 1.D+0/1120863744.D+3
+ bf(9) = - 3617.D+0/18140058832896.D+4
+ bf(10) = + 43867.D+0/97072790126247936.D+3
+ bf(11) = - 174611.D+0/168600109166641152.D+5
+ bf(12) = + 77683.D+0/32432530090601152512.D+4
+ bf(13) = - 236364091.D+0/4234560341829359173632.D+7
+ bf(14) = + 657931.D+0/5025632054039239458816.D+6
+ bf(15) = - 3392780147.D+0/109890470493622010006470656.D+7
+ bf(16)=+172.3168255201D+0/2355349904102724211909.3102313472D+6
+ bf(17)=-770.9321041217D+0/4428491985594062112714.2791446528D+8
+ bf(18)=( 0.4157635644614046176D-28)
+ bf(19)=(-0.9962148488284986022D-30)
+ bf(20)=( 0.2394034424896265390D-31)
+*
+* inverses of integers:
+*
+ do 10 i=1,30
+ xninv(i) = x1/i
+ xn2inv(i) = x1/(i*i)
+ 10 continue
+*
+* inverses of faculties of integers:
+*
+ xinfac(1) = x1
+ do 20 i=2,30
+ xinfac(i) = xinfac(i-1)/i
+ 20 continue
+*
+* inx: p(inx(i,j)) = isgn(i,j)*(s(i)-s(j))
+*
+ inx(1,1) = -9999
+ inx(2,1) = 5
+ inx(3,1) = 9
+ inx(4,1) = 8
+ inx(1,2) = 5
+ inx(2,2) = -9999
+ inx(3,2) = 6
+ inx(4,2) = 10
+ inx(1,3) = 9
+ inx(2,3) = 6
+ inx(3,3) = -9999
+ inx(4,3) = 7
+ inx(1,4) = 8
+ inx(2,4) = 10
+ inx(3,4) = 7
+ inx(4,4) = -9999
+ isgn(1,1) = -9999
+ isgn(2,1) = +1
+ isgn(3,1) = -1
+ isgn(4,1) = -1
+ isgn(1,2) = -1
+ isgn(2,2) = -9999
+ isgn(3,2) = +1
+ isgn(4,2) = +1
+ isgn(1,3) = +1
+ isgn(2,3) = -1
+ isgn(3,3) = -9999
+ isgn(4,3) = +1
+ isgn(1,4) = +1
+ isgn(2,4) = -1
+ isgn(3,4) = -1
+ isgn(4,4) = -9999
+ do 40 i=1,12
+ do 30 j=1,13
+ iold(j,i) = ioldp(j,i)
+ 30 continue
+ do 35 j=1,10
+ isgrot(j,i) = isgrop(j,i)
+ 35 continue
+ 40 continue
+ inx5(1,1) = -9999
+ inx5(1,2) = 6
+ inx5(1,3) = 11
+ inx5(1,4) = 14
+ inx5(1,5) = 10
+ inx5(2,1) = 6
+ inx5(2,2) = -9999
+ inx5(2,3) = 7
+ inx5(2,4) = 12
+ inx5(2,5) = 15
+ inx5(3,1) = 11
+ inx5(3,2) = 7
+ inx5(3,3) = -9999
+ inx5(3,4) = 8
+ inx5(3,5) = 13
+ inx5(4,1) = 14
+ inx5(4,2) = 12
+ inx5(4,3) = 8
+ inx5(4,4) = -9999
+ inx5(4,5) = 9
+ inx5(5,1) = 10
+ inx5(5,2) = 15
+ inx5(5,3) = 13
+ inx5(5,4) = 9
+ inx5(5,5) = -9999
+* isgn5 is not yet used.
+ do i=1,5
+ do j=1,5
+ isgn5(i,j) = -9999
+ enddo
+ enddo
+*
+ inx6(1,1) = -9999
+ inx6(1,2) = 7
+ inx6(1,3) = 13
+ inx6(1,4) = 19
+ inx6(1,5) = 17
+ inx6(1,6) = 12
+ inx6(2,1) = 7
+ inx6(2,2) = -9999
+ inx6(2,3) = 8
+ inx6(2,4) = 14
+ inx6(2,5) = 20
+ inx6(2,6) = 18
+ inx6(3,1) = 13
+ inx6(3,2) = 8
+ inx6(3,3) = -9999
+ inx6(3,4) = 9
+ inx6(3,5) = 15
+ inx6(3,6) = 21
+ inx6(4,1) = 19
+ inx6(4,2) = 14
+ inx6(4,3) = 9
+ inx6(4,4) = -9999
+ inx6(4,5) = 10
+ inx6(4,6) = 16
+ inx6(5,1) = 17
+ inx6(5,2) = 20
+ inx6(5,3) = 15
+ inx6(5,4) = 10
+ inx6(5,5) = -9999
+ inx6(5,6) = 11
+ inx6(6,1) = 12
+ inx6(6,2) = 18
+ inx6(6,3) = 21
+ inx6(6,4) = 16
+ inx6(6,5) = 11
+ inx6(6,6) = -9999
+* isgn6 is used.
+ do i=1,6
+ do j=1,6
+ ji = j-i
+ if ( ji.gt.+3 ) ji = ji - 6
+ if ( ji.lt.-3 ) ji = ji + 6
+ if ( ji.eq.0 ) then
+ isgn6(j,i) = -9999
+ elseif ( abs(ji).eq.3 ) then
+ if ( i.lt.0 ) then
+ isgn6(j,i) = -1
+ else
+ isgn6(j,i) = +1
+ endif
+ elseif ( ji.gt.0 ) then
+ isgn6(j,i) = +1
+ elseif ( ji.lt.0 ) then
+ isgn6(j,i) = -1
+ else
+ print *,'ffini: internal error in isgn6'
+ stop
+ endif
+ enddo
+ enddo
+*
+* #] constants:
+* #[ defaults for flags:
+ nevent = 0
+*
+* the debugging flags.
+*
+ lwrite = .FALSE.
+ ltest = .FALSE.
+ lwarn = .TRUE.
+ ldc3c4 = .FALSE.
+ l4also = .FALSE.
+ lmem = .FALSE.
+ ldot = .FALSE.
+ idot = 0
+*
+* Specify which root to take in cases were two are possible
+* it may be advantageous to change this to -1 (debugging hook)
+*
+ isgn34 = 1
+ isgnal = 1
+*
+* the cutoff has to be initialized because of the memory mechansim
+*
+ delta = 0
+*
+* the scheme used for the complex scalar functions:
+*
+* nschem = 1: do not use the complex mass at all
+* 2: only use the complex mass in linearly divergent terms
+* 3: also use the complex mass in divergent logs UNDEFINED
+* 4: use the complex mass in the C0 if there are
+* divergent logs
+* 5: include the almost-divergent threshold terms from
+* (m,m,0) vertices
+* 6: include the (s-m^2)*log(s-m^2) threshold terms from
+* (m1+m2),m1,m2) vertices
+* 7: full complex computation
+* (only in the ffz... functions):
+* onshel = .FALSE.: use the offshell p^2 everywhere
+* .TRUE.: use the onshell p^2 except in complex parts
+*
+ nschem = 7
+ onshel = .TRUE.
+*
+* the precision wanted in the complex D0 (and hence E0) when
+* nschem=7, these are calculated via Taylor exoansion in the real
+* one and hence expensive.
+*
+ reqprc = 1.e-8
+*
+* in some schemes, for onshel=.FALSE.,
+* when |p^2-Re(m^2)| < nwidth*|Im(m^2)| special action is taken
+*
+ nwidth = 5
+*
+* a flag to indicate the validity of differences smuggled to the
+* IR routines in the C0 (ff internal only)
+*
+ lsmug = .FALSE.
+*
+* #] defaults for flags:
+*###] ffini:
+ end
+*###[ ffexi:
+ subroutine ffexi
+***#[*comment:***********************************************************
+* check a lot of commonly-used constants in the common block *
+* /ffcnst/. *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer i,ier
+ include 'ff.h'
+* #] declarations:
+* #[ checks:
+*
+* calculate the coefficients of the series expansion
+* li2(x) = sum bn*z^n/(n+1)!, z = -log(1-x), bn are the
+* bernouilli numbers (zero for odd n>1).
+*
+ if ( bf(1) .ne. - 1.D+0/4.D+0 )
+ + print *,'ffexi: error: bf(1) is corrupted'
+ if ( bf(2) .ne. + 1.D+0/36.D+0 )
+ + print *,'ffexi: error: bf(2) is corrupted'
+ if ( bf(3) .ne. - 1.D+0/36.D+2 )
+ + print *,'ffexi: error: bf(3) is corrupted'
+ if ( bf(4) .ne. + 1.D+0/21168.D+1 )
+ + print *,'ffexi: error: bf(4) is corrupted'
+ if ( bf(5) .ne. - 1.D+0/108864.D+2 )
+ + print *,'ffexi: error: bf(5) is corrupted'
+ if ( bf(6) .ne. + 1.D+0/52690176.D+1 )
+ + print *,'ffexi: error: bf(6) is corrupted'
+ if ( bf(7) .ne. - 691.D+0/16999766784.D+3 )
+ + print *,'ffexi: error: bf(7) is corrupted'
+ if ( bf(8) .ne. + 1.D+0/1120863744.D+3 )
+ + print *,'ffexi: error: bf(8) is corrupted'
+ if ( bf(9) .ne. - 3617.D+0/18140058832896.D+4 )
+ + print *,'ffexi: error: bf(9) is corrupted'
+ if ( bf(10) .ne. + 43867.D+0/97072790126247936.D+3 )
+ + print *,'ffexi: error: bf(10) is corrupted'
+ if ( bf(11) .ne. - 174611.D+0/168600109166641152.D+5 )
+ + print *,'ffexi: error: bf(11) is corrupted'
+ if ( bf(12) .ne. + 77683.D+0/32432530090601152512.D+4 )
+ + print *,'ffexi: error: bf(12) is corrupted'
+ if ( bf(13) .ne. - 236364091.D+0/4234560341829359173632.D+7 )
+ + print *,'ffexi: error: bf(13) is corrupted'
+ if ( bf(14) .ne. + 657931.D+0/5025632054039239458816.D+6 )
+ + print *,'ffexi: error: bf(14) is corrupted'
+ if ( bf(15) .ne. -3392780147.D+0/109890470493622010006470656.D+7
+ + ) print *,'ffexi: error: bf(15) is corrupted'
+ if ( bf(16).ne.+172.3168255201D+0/2355349904102724211909.3102313
+ + 472D+6 )
+ + print *,'ffexi: error: bf(16) is corrupted'
+ if ( bf(17).ne.-770.9321041217D+0/4428491985594062112714.2791446
+ + 528D+8 )
+ + print *,'ffexi: error: bf(17) is corrupted'
+ if ( bf(18).ne.( 0.4157635644614046176D-28) )
+ + print *,'ffexi: error: bf(18) is corrupted'
+ if ( bf(19).ne.(-0.9962148488284986022D-30) )
+ + print *,'ffexi: error: bf(19) is corrupted'
+ if ( bf(20).ne.( 0.2394034424896265390D-31) )
+ + print *,'ffexi: error: bf(20) is corrupted'
+*
+* inverses of integers:
+*
+ do 10 i=1,20
+ if ( abs(xninv(i)-x1/i) .gt. precx*xninv(i) ) print *,
+ + 'ffexi: error: xninv(',i,') is not 1/',i,': ',
+ + xninv(i),xninv(i)-x1/i
+ 10 continue
+*
+* #] checks:
+* #[ print summary of errors and warning:
+ ier = 0
+ call fferr(999,ier)
+* #] print summary of errors and warning:
+*###] ffexi:
+ end
+*###[ fferr:
+ subroutine fferr(nerr,ierr)
+***#[*comment:***********************************************************
+* *
+* generates an errormessage #nerr with severity 2 *
+* nerr=999 gives a frequency listing of all errors *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer nmax
+ parameter (nmax=100)
+ integer nerr,ierr,ifile
+ character*80 error(nmax),error1
+ logical locwrt
+ integer noccur(nmax),init,i,ier,inone,nnerr,nomore
+ save error,noccur,init,locwrt,nomore
+ include 'ff.h'
+* #] declarations:
+* #[ data:
+ data locwrt /.TRUE./
+ data nomore /-1/
+ data noccur /nmax*0/
+ data init /0/
+ if ( init.eq.0 ) then
+ init = 1
+ do 1 i=1,nmax
+ error(i) =
+ + 'fferr: error: illegal value for ierr'
+ 1 continue
+ call ffopen(ifile,'fferr.dat',ier)
+ if ( ier .ne. 0 ) goto 100
+ rewind(ifile)
+ read(ifile,'(a)')error1
+ read(ifile,'(a)')error1
+ do 90 i=1,10000
+ read(ifile,'(i4,a80)',end=110,err=110)ier,error1
+ if ( ier .lt. 1 .or. ier .gt. nmax ) then
+ print '(a,i3)','fferr: error: wild error number ',
+ + ier
+ print '(a,a)','>>> ',error1
+ goto 90
+ endif
+ error(ier) = error1
+ 90 continue
+ goto 110
+ 100 continue
+ print '(a)',
+ + 'fferr: warning cannot open fferr.dat with error texts'
+ 110 continue
+ close(ifile)
+ endif
+* #] data:
+* #[ nerr=999:
+ if ( nerr .eq. 999 ) then
+* print out total numbers...
+ print '(a)',' '
+ print '(a)','total number of errors and warnings'
+ print '(a)','==================================='
+ inone = 1
+ do 10 i=1,nmax
+ if ( noccur(i) .gt. 0 ) then
+ print '(a,i8,a,i3,a,a)','fferr: ',noccur(i),
+ + ' times ',i,': ',error(i)
+ noccur(i) = 0
+ inone = 0
+ endif
+ 10 continue
+ if ( inone.eq.1 ) print '(a)','fferr: no errors'
+ if ( lwarn ) then
+ call ffwarn(999,ierr,x1,x1)
+ else
+ print '(a)','the warning system has been disabled'
+ endif
+ print '(a)',' '
+ return
+ endif
+* #] nerr=999:
+* #[ print error:
+ if ( nerr .lt. 1 .or. nerr .gt. nmax ) then
+ nnerr = nmax
+ else
+ nnerr = nerr
+ endif
+ noccur(nnerr) = noccur(nnerr) + 1
+ ierr = ierr + 100
+
+ if ( nevent .eq. nomore ) return
+
+ if ( locwrt ) then
+ print '(a,i6,a,i6,a,i8)','fferr: id nr ',id,'/',idsub,
+ + ', event nr ',nevent
+ print '(a,i6,a,a)','error nr',nerr,': ',error(nnerr)
+ endif
+
+ if ( nerr .eq. 100 ) then
+* we found a matherror - discard all errors from now till next
+* event
+ nomore = nevent
+ endif
+
+* #] print error:
+*###] fferr:
+ end
+*###[ ffwarn:
+ subroutine ffwarn(nerr,ierr,som,xmax)
+***#[*comment:***********************************************************
+* *
+* The warning routine. A warning is aloss of precision greater *
+* than xloss (which is default set in ffini), whenever in a *
+* subtraction the result is smaller than xloss*max(operands) this *
+* routine is called. Now the strategy is to remember these *
+* warnings until a 998 message is obtained; then all warnings of *
+* the previous event are printed. The rationale is that one *
+* makes this call if too much preciasion is lost only. *
+* nerr=999 gives a frequency listing of all warnings *
+* *
+* Input: nerr integer the id of the warning message, see the *
+* file ffwarn.dat or 998 or 999 *
+* ierr integer the usual error flag: number of digits *
+* lost so far *
+* som real the result of the addition *
+* xmax real the largest operand *
+* *
+* Output: ierr integer is raised by the number of digits lost *
+* the tolerated loss of xloss *
+* *
+* NOTE: This routine needs a file ffwarn.dat with the warning *
+* texts, it is very system dependent where to pick it up *
+* set the PATH variable to your own taste. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer nmax
+ parameter (nmax=300)
+*
+* arguments
+*
+ integer nerr,ierr
+ DOUBLE PRECISION som,xmax
+*
+* local variables
+*
+ integer memmax
+ parameter (memmax = 1000)
+ character*80 warn(nmax),warn1
+ integer noccur(nmax),init,i,ier,inone,nnerr,ilost,
+ + nermem(memmax),losmem(memmax),idmem(memmax),
+ + idsmem(memmax),laseve,imem,ifile
+ DOUBLE PRECISION xlosti(nmax),xlost
+ save warn,noccur,init,xlosti,nermem,losmem,idmem,idsmem,
+ + laseve,imem
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+* #] declarations:
+* #[ data:
+ data noccur /nmax*0/
+ data init /0/
+ if ( init.eq.0 .and. nerr.ne.999 ) then
+ init = 1
+ do 1 i=1,nmax
+ warn(i) =
+ + 'ffwarn: warning: illegal value for ierr'
+ xlosti(i) = 0
+ 1 continue
+ call ffopen(ifile,'ffwarn.dat',ier)
+ if ( ier.ne.0 ) goto 100
+ rewind(ifile)
+ read(ifile,'(a)')warn1
+ read(ifile,'(a)')warn1
+ do 90 i=1,10000
+ read(ifile,'(i4,a80)',end=110,err=110)ier,warn1
+ if ( warn1.eq.' ' ) goto 90
+ if ( ier.lt.1 .or. ier.gt.nmax ) then
+ print '(a,i3)','ffwarn: error: wild warning number '
+ + ,ier
+ print '(a,a)','>>> ',warn1
+ goto 90
+ endif
+ warn(ier) = warn1
+ 90 continue
+ goto 110
+ 100 continue
+ print '(a)',
+ + 'ffwarn: warning cannot open ffwarn.dat with warning texts'
+ 110 continue
+ close(ifile)
+ laseve = -1
+ imem = 1
+ endif
+* #] data:
+* #[ nerr=999:
+ if ( nerr.eq.999 ) then
+* print out total numbers...
+ inone = 1
+ do 10 i=1,nmax
+ if ( noccur(i) .gt. 0 ) then
+ print '(a,i8,a,i3,a,a)','ffwarn: ',noccur(i),
+ + ' times ',i,': ',warn(i)
+ print '(a,g12.3,a)',
+ + ' (lost at most a factor ',xlosti(i),')'
+ noccur(i) = 0
+ xlosti(i) = 0
+ inone = 0
+ endif
+ 10 continue
+ if ( inone.eq.1 ) print '(a)','ffwarn: no warnings'
+ return
+ endif
+* #] nerr=999:
+* #[ print warning:
+ if ( nerr .eq. 998 ) then
+ if ( nevent .ne. laseve ) return
+ do 20 i=1,imem-1
+ if ( nermem(i).ne.0 ) then
+ print '(a,i6,a,i6,a,i8)','ffwarn: id nr ',idmem(i),
+ + '/',idsmem(i),', event nr ',nevent
+ print '(a,i6,a,a)','warning nr ',nermem(i),': ',
+ + warn(nermem(i))
+ print '(a,i3,a)',' (lost ',losmem(i),' digits)'
+ endif
+ 20 continue
+ imem = 1
+ return
+ endif
+* #] print warning:
+* #[ collect warnings:
+*
+* bring in range
+*
+ if ( nerr .lt. 1 .or. nerr .gt. nmax ) then
+ nnerr = nmax
+ else
+ nnerr = nerr
+ endif
+*
+* bookkeeping
+*
+ noccur(nnerr) = noccur(nnerr) + 1
+ if ( som .ne. 0 ) then
+ xlost = abs(xmax/som)
+ elseif ( xmax .ne. 0 ) then
+ xlost = 1/precx
+ else
+ xlost = 1
+ endif
+ xlosti(nnerr) = max(xlosti(nnerr),xlost)
+ if ( xlost*xloss .gt. xalogm ) then
+ ilost = 1 + int(abs(log10(xlost*xloss)))
+ else
+ ilost = 0
+ endif
+ ierr = ierr + ilost
+*
+* nice place to stop when debugging
+*
+ if ( ilost.ge.10 ) then
+ ilost = ilost + 1 - init
+ endif
+*
+* add to memory
+*
+ if ( laseve .ne. nevent ) then
+ imem = 1
+ laseve = nevent
+ endif
+ if ( imem .le. memmax ) then
+ idmem(imem) = id
+ idsmem(imem) = idsub
+ nermem(imem) = nerr
+ losmem(imem) = ilost
+ imem = imem + 1
+ endif
+*
+* print directly if lwrite TRUE
+*
+ if ( awrite .or. lwrite ) then
+ imem = imem - 1
+ print '(a,i6,a,i6,a,i8)','ffwarn: id nr ',idmem(imem),'/',
+ + idsmem(imem),', event nr ',nevent
+ print '(a,i6,a,a)','warning nr ',nermem(imem),': ',
+ + warn(nnerr)
+ print '(a,i3,a)',' (lost ',losmem(imem),' digits)'
+ endif
+* #] collect warnings:
+*###] ffwarn:
+ end
+*###[ ffopen:
+ subroutine ffopen(ifile,name,ier)
+*
+* opens a data file and returns the unit number.
+*
+ implicit none
+*
+* arguments
+*
+ integer ifile,ier
+ character*(*) name
+*
+ logical lopen
+ character*128 path,fullname
+*
+ include 'ff.h'
+*
+ ier = 0
+ do 10 ifile = 10,100
+ inquire(ifile,opened=lopen)
+ if ( .not.lopen ) goto 20
+ 10 continue
+ 20 continue
+*
+* Adjust PATH to suit your own directory structure
+* I could use a getenv() here, but that may not work
+* on PC/Mac/...
+* VMS users: use something like the following lines instead
+* fullname = 'USR$LOCAL[GEERT]'//name
+* open(ifile,file=fullname,status='OLD',READONLY,err=100)
+*
+* This has been modified to work with autoconf
+ path='@DATADIR@'
+ fullname = path(1:index(path,' ')-1)
+ + //'/@PACKAGE@/'
+ + //name
+ open(ifile,file=fullname,status='OLD',err=40)
+ return
+* file could not be found
+ 40 continue
+ print *,'ffopen: error: could not open ',fullname
+ print *,' adjust path in ffopen (ffinit.f)'
+ ier = -1
+*###] ffopen:
+ end
+*###[ ffbnd:
+ DOUBLE PRECISION function ffbnd(n1,n2,array)
+*************************************************************************
+* *
+* calculate bound = (precx*|a(n1)/a(n1+n2)|^(1/n2) which is the *
+* maximum value of x in a series expansion sum_(i=n1)^(n1+n2) *
+* a(i)*x(i) to give a result of accuracy precx (actually of |next *
+* term| < prec *
+* *
+*************************************************************************
+ implicit none
+ integer n1,n2
+ DOUBLE PRECISION array(n1+n2)
+ include 'ff.h'
+ if ( array(n1+n2) .eq. 0 ) then
+ print *,'ffbnd: fatal: array not intialized; did you call ',
+ + 'ffini?'
+ stop
+ endif
+ ffbnd = (precx*abs(array(n1)/array(n1+n2)))**(1/DBLE(n2))
+*###] ffbnd:
+ end
+*###[ ffbndc:
+ DOUBLE PRECISION function ffbndc(n1,n2,carray)
+*************************************************************************
+* *
+* calculate bound = (precc*|a(n1)/a(n1+n2)|^(1/n2) which is the *
+* maximum value of x in a series expansion sum_(i=n1)^(n1+n2) *
+* a(i)*x(i) to give a result of accuracy precc (actually of |next *
+* term| < prec *
+* *
+*************************************************************************
+ implicit none
+ integer n1,n2
+ DOUBLE COMPLEX carray(n1+n2)
+ include 'ff.h'
+ if ( carray(n1+n2) .eq. 0 ) then
+ print *,'ffbnd: fatal: array not intialized; did you call ',
+ + 'ffini?'
+ stop
+ endif
+ ffbndc = (precc*abs(carray(n1)/carray(n1+n2)))**(1/DBLE(n2))
+*###] ffbndc:
+ end
+*###[ ffroot:
+ subroutine ffroot(xm,xp,a,b,c,d,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the roots of the equation *
+* a*x^2 - 2*b*x + c = 0 *
+* given by *
+* x = (b +/- d )/a xp*xm = c/a *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ier
+ DOUBLE PRECISION xm,xp,a,b,c,d
+*
+* local variables:
+*
+ DOUBLE PRECISION s1,s2,s3,rloss
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( a .eq. 0 ) then
+ call fferr(39,ier)
+ if ( b.gt.0 .eqv. d.gt.0 ) then
+ xp = 1/xalogm
+ xm = c/(b+d)
+ else
+ xp = c/(b-d)
+ xm = 1/xalogm
+ endif
+ return
+ endif
+* if ( lwrite ) print *,'ffroot: a,b,c,d = ',a,b,c,d
+* #] check input:
+* #[ calculations:
+ if ( d .eq. 0 ) then
+ xm = b / a
+ xp = xm
+ elseif ( b .gt. 0 .eqv. d .gt. 0 ) then
+ xp = ( b + d ) / a
+ xm = c / (a*xp)
+ else
+ xm = ( b - d ) / a
+ xp = c / (a*xm)
+ endif
+* #] calculations:
+* #[ test output:
+ if ( ltest ) then
+ rloss = xloss*DBLE(10)**(-2-mod(ier,50))
+ if ( xm .ne. 0 ) then
+ s1 = a*xm
+ s2 = 2*b
+ s3 = c/xm
+ if ( rloss*abs(s1-s2+s3) .gt. precx*max(abs(s1),abs(s2),
+ + abs(s3)) ) then
+ print *,'ffroot: error: xm not root! ',s1,s2,s3,
+ + s1-s2+s3,ier
+ endif
+ endif
+ if ( xp .ne. 0 ) then
+ s1 = a*xp
+ s2 = 2*b
+ s3 = c/xp
+ if ( rloss*abs(s1-s2+s3) .gt. precx*max(abs(s1),abs(s2),
+ + abs(s3)) ) then
+ print *,'ffroot: error: xp not root! ',s1,s2,s3,
+ + s1-s2+s3,ier
+ endif
+ endif
+ endif
+* #] test output:
+*###] ffroot:
+ end
+*###[ ffcoot:
+ subroutine ffcoot(xm,xp,a,b,c,d,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the roots of the equation *
+* a*x^2 - 2*b*x + c = 0 *
+* given by *
+* x = (b +/- d )/a xp*xm = c/a *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ier
+ DOUBLE COMPLEX xm,xp,a,b,c,d
+*
+* local variables:
+*
+ DOUBLE COMPLEX s1,s2,s3,cc
+ DOUBLE PRECISION absc,rloss
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+* #] declarations:
+* #[ check input:
+ if ( a .eq. 0 ) then
+ call fferr(38,ier)
+ if ( DBLE(b).gt.0 .eqv. DBLE(d).gt.0 ) then
+ xp = 1/xclogm
+ xm = c/(b+d)
+ else
+ xp = c/(b-d)
+ xm = 1/xclogm
+ endif
+ return
+ endif
+* if ( lwrite ) print *,'ffroot: a,b,c,d = ',a,b,c,d
+* #] check input:
+* #[ calculations:
+ cc = b+d
+ if ( d .eq. 0 ) then
+ xm = b / a
+ xp = xm
+ elseif ( absc(cc) .gt. xloss*absc(d) ) then
+ xp = ( b + d ) / a
+ xm = c / (a*xp)
+ else
+ xm = ( b - d ) / a
+ xp = c / (a*xm)
+ endif
+* #] calculations:
+* #[ test output:
+ if ( ltest ) then
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ if ( absc(xm) .gt. xclogm ) then
+ s1 = a*xm
+ s2 = 2*b
+ s3 = c/xm
+ cc = s1-s2+s3
+ if ( rloss*absc(cc).gt.precc*max(absc(s1),absc(
+ + s2),absc(s3)) ) print *,
+ + 'ffcoot: error: xm not root! ',s1,s2,s3,s1-s2+s3
+ endif
+ if ( absc(xp) .gt. xclogm ) then
+ s1 = a*xp
+ s2 = 2*b
+ s3 = c/xp
+ cc = s1-s2+s3
+ if ( rloss*absc(cc).gt.precc*max(absc(s1),absc(
+ + s2),absc(s3)) ) print *,
+ + 'ffcoot: error: xp not root! ',s1,s2,s3,s1-s2+s3
+ endif
+ endif
+* #] test output:
+*###] ffcoot:
+ end
+*###[ ffxhck:
+ subroutine ffxhck(xpi,dpipj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* check whether the differences dpipj are compatible with xpi *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ns,ier
+ DOUBLE PRECISION xpi(ns),dpipj(ns,ns)
+ integer i,j
+ DOUBLE PRECISION xheck,rloss
+ include 'ff.h'
+* #] declarations:
+* #[ calculations:
+ if ( ier.lt.0 ) then
+ print *,'ffxhck: error: ier < 0 ',ier
+ ier=0
+ endif
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ do 20 i=1,ns
+ do 10 j=1,ns
+ xheck = dpipj(j,i) - xpi(j) + xpi(i)
+ if ( rloss*abs(xheck) .gt. precx*max(abs(dpipj(j,i)),
+ + abs(xpi(j)),abs(xpi(i))) ) then
+ print *,'ffxhck: error: dpipj(',j,i,') <> xpi(',j,
+ + ') - xpi(',i,'):',dpipj(j,i),xpi(j),xpi(i),
+ + xheck,ier
+ if ( lwrite ) ier = ier + 100
+ endif
+ 10 continue
+ 20 continue
+* #] calculations:
+*###] ffxhck:
+ end
+*###[ ffchck:
+ subroutine ffchck(cpi,cdpipj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* check whether the differences cdpipj are compatible with cpi *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ns,ier
+ DOUBLE COMPLEX cpi(ns),cdpipj(ns,ns),c
+ integer i,j
+ DOUBLE COMPLEX check
+ DOUBLE PRECISION absc,rloss
+ include 'ff.h'
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ calculations:
+ if ( ier.lt.0 ) then
+ print *,'ffchck: error: ier < 0 ',ier
+ ier=0
+ endif
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ do 20 i=1,ns
+ do 10 j=1,ns
+ check = cdpipj(j,i) - cpi(j) + cpi(i)
+ if ( rloss*absc(check) .gt. precc*max(absc(
+ + cdpipj(j,i)),absc(cpi(j)),absc(cpi(i))) ) then
+ print *,'ffchck: error: cdpipj(',j,i,') <> cpi(',j,
+ + ') - cpi(',i,'):',cdpipj(j,i),cpi(j),cpi(i),
+ + check,ier
+ if ( lwrite ) ier = ier + 100
+ endif
+ 10 continue
+ 20 continue
+* #] calculations:
+*###] ffchck:
+ end
+*###[ nffeta:
+ integer function nffeta(ca,cb,ier)
+***#[*comment:***********************************************************
+* calculates *
+* *
+* eta(a,b)/(2*i*pi) = ( thIm(-a)*thIm(-b)*thIm(a*b) *
+* - thIm(a)*thIm(b)*thIm(-a*b) ) *
+* *
+* with thIm(a) = theta(Im(a)) *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ier
+ DOUBLE COMPLEX ca,cb
+ DOUBLE PRECISION a,b,ab,rab
+ include 'ff.h'
+* #] declarations:
+* #[ calculations:
+ a = DIMAG(ca)
+ b = DIMAG(cb)
+ if ( a*b .lt. 0 ) then
+ nffeta = 0
+ return
+ endif
+ rab = DBLE(ca)*DBLE(cb) - a*b
+ ab = DBLE(ca)*b + a*DBLE(cb)
+ if ( abs(ab) .lt. precc*abs(DBLE(ca)*b) ) then
+ call fferr(32,ier)
+ if ( lwrite ) print *,'a,b = ',ca,cb,
+ + ' (no precision left in DIMAG(ab)=',ab,')'
+ endif
+ if ( a .lt. 0 .and. b .lt. 0 .and. ab .gt. 0 ) then
+ nffeta = 1
+ elseif ( a .gt. 0 .and. b .gt. 0 .and. ab .lt. 0 ) then
+ nffeta = -1
+ elseif ( a .eq. 0 .and. DBLE(ca) .le. 0 .or.
+ + b .eq. 0 .and. DBLE(cb) .le. 0 .or.
+ + ab .eq. 0 .and. rab .le. 0 ) then
+ call fferr(32,ier)
+ if ( ltest .or. lwrite ) print *,'a,b = ',ca,cb
+ nffeta = 0
+ else
+ nffeta = 0
+ endif
+* #] calculations:
+*###] nffeta:
+ end
+*###[ nffet1:
+ integer function nffet1(ca,cb,cc,ier)
+***#[*comment:***********************************************************
+* calculates the same eta with three input variables *
+* *
+* et1(a,b)/(2*i*pi) = ( thIm(-a)*thIm(-b)*thIm(c) *
+* - thIm(a)*thIm(b)*thIm(-c) ) *
+* *
+* with thIm(a) = theta(Im(a)) *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ier
+ DOUBLE COMPLEX ca,cb,cc,c
+ DOUBLE PRECISION a,b,ab,abp,absc
+ include 'ff.h'
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if ( ltest .and. DIMAG(ca)*DIMAG(cb) .gt. 0 .and. DBLE(ca)*DBLE(
+ + cb) .ne. 0 ) then
+ ab = DIMAG(cc)
+ abp = DIMAG(ca*cb)
+ if ( xloss*abs(abp) .lt. precc*absc(ca)*absc(cb) )
+ + abp = 0
+ if ( ab .gt. 0 .and. abp .lt. 0 .or. ab .lt. 0 .and. abp
+ + .gt. 0 ) then
+ print *,'nffet1: error: sgn im(ca*cb) != sgn im(cc): ',
+ + ab,abp
+ endif
+ endif
+* #] check input:
+* #[ calculations:
+ a = DIMAG(ca)
+ b = DIMAG(cb)
+ if ( a .gt. 0 .neqv. b .gt. 0 ) then
+ nffet1 = 0
+ return
+ endif
+ ab = DIMAG(cc)
+ if ( a .lt. 0 .and. b .lt. 0 .and. ab .gt. 0 ) then
+ nffet1 = 1
+ elseif ( a .gt. 0 .and. b .gt. 0 .and. ab .lt. 0 ) then
+ nffet1 = -1
+ elseif ( a .eq. 0 .and. DBLE(ca) .le. 0 .or.
+ + b .eq. 0 .and. DBLE(cb) .le. 0 .or.
+ + ab .eq. 0 .and. DBLE(cc) .le. 0 ) then
+ call fferr(33,ier)
+ if ( ltest.or.lwrite ) print *,'a,b,ab = ',ca,cb,cc
+ nffet1 = 1
+ else
+ nffet1 = 0
+ endif
+* #] calculations:
+*###] nffet1:
+ end
+*###[ ffcayl:
+ subroutine ffcayl(cs,z,coeff,n,ier)
+***#[*comment:***********************************************************
+* *
+* Do a Taylor expansion in z with real coefficients coeff(i) *
+* *
+* Input: z complex *
+* coeff(n) real *
+* n integer *
+* *
+* Output cs complex \sum_{i=1} z^i coeff(i) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer n,ier
+ DOUBLE PRECISION coeff(n)
+ DOUBLE COMPLEX z,cs
+*
+* local variables
+*
+ integer i
+ DOUBLE PRECISION absc
+ DOUBLE COMPLEX c,zi,csi
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ work:
+ cs = z*DBLE(coeff(1))
+ if ( absc(z) .lt. precc ) return
+ zi = z
+ do 10 i=2,n
+ zi = zi*z
+ csi = zi*DBLE(coeff(i))
+ cs = cs + csi
+ if ( absc(csi) .lt. precc*absc(cs) ) goto 20
+ 10 continue
+ call ffwarn(9,ier,precc,absc(csi))
+ 20 continue
+* #] work:
+*###] ffcayl:
+ end
+*###[ fftayl:
+ subroutine fftayl(s,z,coeff,n,ier)
+***#[*comment:***********************************************************
+* *
+* Do a Taylor expansion in z with real coefficients coeff(i) *
+* *
+* Input: z real *
+* coeff(n) real *
+* n integer *
+* *
+* Output cs real \sum_{i=1} z^i coeff(i) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer n,ier
+ DOUBLE PRECISION coeff(n),z,s
+*
+* local variables
+*
+ integer i
+ DOUBLE PRECISION zi,si
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ work:
+ s = coeff(1)*z
+ if ( abs(z) .lt. precx ) return
+ zi = z
+ do 10 i=2,n
+ zi = zi*z
+ si = coeff(i)*zi
+ s = s + si
+ if ( abs(si) .lt. precx*abs(s) ) goto 20
+ 10 continue
+ call ffwarn(9,ier,precx,si)
+ 20 continue
+* #] work:
+*###] fftayl:
+ end
+
diff --git a/ff-2.0/ffperm5.dat b/ff-2.0/ffperm5.dat
new file mode 100644
index 0000000..942bf3a
--- /dev/null
+++ b/ff-2.0/ffperm5.dat
@@ -0,0 +1,327 @@
+* This is file ffperm5.dat and it contains the permutations for the determinant
+* \delta^{s1 s2 s3 s4 s5}_{s1 s2 s3 s4 s5} (327 lines). The first two lines are skipped.
+ 1, 2, 3, 4, 5, 1, 2, 3, 4, 9, 1, 2, 3,10, 4, 1, 2, 3, 4,13,
+ 1, 2, 3,15, 4, 1, 2, 3, 8, 5, 1, 2, 3, 5, 9, 1, 2, 3,12, 5,
+ 1, 2, 3, 5,14, 1, 2, 3, 8, 9, 1, 2, 3,10, 8, 1, 2, 3, 8,13,
+ 1, 2, 3,15, 8, 1, 2, 3, 9,10, 1, 2, 3,12, 9, 1, 2, 3,13, 9,
+ 1, 2, 3, 9,14, 1, 2, 3, 9,15, 1, 2, 3,10,12, 1, 2, 3,14,10,
+ 1, 2, 3,12,13, 1, 2, 3,15,12, 1, 2, 3,13,14, 1, 2, 3,14,15,
+ 1, 2, 4, 5, 7, 1, 2, 4, 8, 5, 1, 2, 4, 5,11, 1, 2, 4,13, 5,
+ 1, 2, 4, 9, 7, 1, 2, 4, 7,10, 1, 2, 4,13, 7, 1, 2, 4, 7,15,
+ 1, 2, 4, 8, 9, 1, 2, 4,10, 8, 1, 2, 4, 8,13, 1, 2, 4,15, 8,
+ 1, 2, 4, 9,11, 1, 2, 4,13, 9, 1, 2, 4,11,10, 1, 2, 4,10,13,
+ 1, 2, 4,13,11, 1, 2, 4,11,15, 1, 2, 4,15,13, 1, 2, 5, 7, 8,
+ 1, 2, 5, 9, 7, 1, 2, 5, 7,12, 1, 2, 5,14, 7, 1, 2, 5, 8, 9,
+ 1, 2, 5,11, 8, 1, 2, 5,12, 8, 1, 2, 5, 8,13, 1, 2, 5, 8,14,
+ 1, 2, 5, 9,11, 1, 2, 5,13, 9, 1, 2, 5,11,12, 1, 2, 5,14,11,
+ 1, 2, 5,12,13, 1, 2, 5,13,14, 1, 2, 7, 8, 9, 1, 2, 7,10, 8,
+ 1, 2, 7, 8,13, 1, 2, 7,15, 8, 1, 2, 7, 9,10, 1, 2, 7,12, 9,
+ 1, 2, 7,13, 9, 1, 2, 7, 9,14, 1, 2, 7, 9,15, 1, 2, 7,10,12,
+ 1, 2, 7,14,10, 1, 2, 7,12,13, 1, 2, 7,15,12, 1, 2, 7,13,14,
+ 1, 2, 7,14,15, 1, 2, 8,10, 9, 1, 2, 8, 9,11, 1, 2, 8, 9,12,
+ 1, 2, 8,14, 9, 1, 2, 8,15, 9, 1, 2, 8,11,10, 1, 2, 8,12,10,
+ 1, 2, 8,10,13, 1, 2, 8,10,14, 1, 2, 8,13,11, 1, 2, 8,11,15,
+ 1, 2, 8,13,12, 1, 2, 8,12,15, 1, 2, 8,14,13, 1, 2, 8,15,13,
+ 1, 2, 8,15,14, 1, 2, 9,10,11, 1, 2, 9,13,10, 1, 2, 9,11,12,
+ 1, 2, 9,11,13, 1, 2, 9,14,11, 1, 2, 9,15,11, 1, 2, 9,12,13,
+ 1, 2, 9,13,14, 1, 2, 9,13,15, 1, 2,10,12,11, 1, 2,10,11,14,
+ 1, 2,10,13,12, 1, 2,10,14,13, 1, 2,11,12,13, 1, 2,11,15,12,
+ 1, 2,11,13,14, 1, 2,11,14,15, 1, 2,12,15,13, 1, 2,13,15,14,
+ 1, 3, 4, 6, 5, 1, 3, 4, 5, 7, 1, 3, 4, 5,12, 1, 3, 4,15, 5,
+ 1, 3, 4, 6, 9, 1, 3, 4,10, 6, 1, 3, 4, 6,13, 1, 3, 4,15, 6,
+ 1, 3, 4, 9, 7, 1, 3, 4, 7,10, 1, 3, 4,13, 7, 1, 3, 4, 7,15,
+ 1, 3, 4, 9,12, 1, 3, 4,15, 9, 1, 3, 4,12,10, 1, 3, 4,10,15,
+ 1, 3, 4,13,12, 1, 3, 4,12,15, 1, 3, 4,15,13, 1, 3, 5, 8, 6,
+ 1, 3, 5, 6, 9, 1, 3, 5,12, 6, 1, 3, 5, 6,14, 1, 3, 5, 7, 8,
+ 1, 3, 5, 9, 7, 1, 3, 5, 7,12, 1, 3, 5,14, 7, 1, 3, 5,12, 8,
+ 1, 3, 5, 8,15, 1, 3, 5, 9,12, 1, 3, 5,15, 9, 1, 3, 5,14,12,
+ 1, 3, 5,12,15, 1, 3, 5,15,14, 1, 3, 6, 9, 8, 1, 3, 6, 8,10,
+ 1, 3, 6,13, 8, 1, 3, 6, 8,15, 1, 3, 6,10, 9, 1, 3, 6, 9,12,
+ 1, 3, 6, 9,13, 1, 3, 6,14, 9, 1, 3, 6,15, 9, 1, 3, 6,12,10,
+ 1, 3, 6,10,14, 1, 3, 6,13,12, 1, 3, 6,12,15, 1, 3, 6,14,13,
+ 1, 3, 6,15,14, 1, 3, 7, 8, 9, 1, 3, 7,10, 8, 1, 3, 7, 8,13,
+ 1, 3, 7,15, 8, 1, 3, 7, 9,10, 1, 3, 7,12, 9, 1, 3, 7,13, 9,
+ 1, 3, 7, 9,14, 1, 3, 7, 9,15, 1, 3, 7,10,12, 1, 3, 7,14,10,
+ 1, 3, 7,12,13, 1, 3, 7,15,12, 1, 3, 7,13,14, 1, 3, 7,14,15,
+ 1, 3, 8, 9,12, 1, 3, 8,15, 9, 1, 3, 8,12,10, 1, 3, 8,10,15,
+ 1, 3, 8,13,12, 1, 3, 8,12,15, 1, 3, 8,15,13, 1, 3, 9,10,12,
+ 1, 3, 9,15,10, 1, 3, 9,12,13, 1, 3, 9,14,12, 1, 3, 9,13,15,
+ 1, 3, 9,15,14, 1, 3,10,12,14, 1, 3,10,15,12, 1, 3,10,14,15,
+ 1, 3,12,13,14, 1, 3,12,15,13, 1, 3,12,14,15, 1, 3,13,15,14,
+ 1, 4, 5, 6, 7, 1, 4, 5, 8, 6, 1, 4, 5, 6,11, 1, 4, 5,13, 6,
+ 1, 4, 5, 7, 8, 1, 4, 5,11, 7, 1, 4, 5, 7,12, 1, 4, 5, 7,13,
+ 1, 4, 5,15, 7, 1, 4, 5,12, 8, 1, 4, 5, 8,15, 1, 4, 5,11,12,
+ 1, 4, 5,15,11, 1, 4, 5,12,13, 1, 4, 5,13,15, 1, 4, 6, 7, 9,
+ 1, 4, 6,10, 7, 1, 4, 6, 7,13, 1, 4, 6,15, 7, 1, 4, 6, 9, 8,
+ 1, 4, 6, 8,10, 1, 4, 6,13, 8, 1, 4, 6, 8,15, 1, 4, 6,11, 9,
+ 1, 4, 6, 9,13, 1, 4, 6,10,11, 1, 4, 6,13,10, 1, 4, 6,11,13,
+ 1, 4, 6,15,11, 1, 4, 6,13,15, 1, 4, 7, 8, 9, 1, 4, 7,10, 8,
+ 1, 4, 7, 8,13, 1, 4, 7,15, 8, 1, 4, 7, 9,11, 1, 4, 7,12, 9,
+ 1, 4, 7,13, 9, 1, 4, 7, 9,15, 1, 4, 7,11,10, 1, 4, 7,10,12,
+ 1, 4, 7,10,13, 1, 4, 7,15,10, 1, 4, 7,13,11, 1, 4, 7,11,15,
+ 1, 4, 7,12,13, 1, 4, 7,15,12, 1, 4, 8, 9,12, 1, 4, 8,15, 9,
+ 1, 4, 8,12,10, 1, 4, 8,10,15, 1, 4, 8,13,12, 1, 4, 8,12,15,
+ 1, 4, 8,15,13, 1, 4, 9,11,12, 1, 4, 9,15,11, 1, 4, 9,12,13,
+ 1, 4, 9,13,15, 1, 4,10,12,11, 1, 4,10,11,15, 1, 4,10,13,12,
+ 1, 4,10,15,13, 1, 4,11,12,13, 1, 4,11,15,12, 1, 4,11,13,15,
+ 1, 4,12,15,13, 1, 5, 6, 8, 7, 1, 5, 6, 7, 9, 1, 5, 6,12, 7,
+ 1, 5, 6, 7,14, 1, 5, 6, 9, 8, 1, 5, 6, 8,11, 1, 5, 6, 8,12,
+ 1, 5, 6,13, 8, 1, 5, 6,14, 8, 1, 5, 6,11, 9, 1, 5, 6, 9,13,
+ 1, 5, 6,12,11, 1, 5, 6,11,14, 1, 5, 6,13,12, 1, 5, 6,14,13,
+ 1, 5, 7, 8, 9, 1, 5, 7,11, 8, 1, 5, 7, 8,13, 1, 5, 7, 8,14,
+ 1, 5, 7,15, 8, 1, 5, 7, 9,11, 1, 5, 7,12, 9, 1, 5, 7,13, 9,
+ 1, 5, 7, 9,15, 1, 5, 7,11,12, 1, 5, 7,14,11, 1, 5, 7,12,13,
+ 1, 5, 7,12,14, 1, 5, 7,15,12, 1, 5, 7,13,14, 1, 5, 7,14,15,
+ 1, 5, 8, 9,12, 1, 5, 8,15, 9, 1, 5, 8,12,11, 1, 5, 8,11,15,
+ 1, 5, 8,13,12, 1, 5, 8,14,12, 1, 5, 8,12,15, 1, 5, 8,15,13,
+ 1, 5, 8,15,14, 1, 5, 9,11,12, 1, 5, 9,15,11, 1, 5, 9,12,13,
+ 1, 5, 9,13,15, 1, 5,11,12,14, 1, 5,11,15,12, 1, 5,11,14,15,
+ 1, 5,12,13,14, 1, 5,12,15,13, 1, 5,13,15,14, 1, 6, 7, 8, 9,
+ 1, 6, 7,10, 8, 1, 6, 7, 8,13, 1, 6, 7,15, 8, 1, 6, 7, 9,10,
+ 1, 6, 7,12, 9, 1, 6, 7,13, 9, 1, 6, 7, 9,14, 1, 6, 7, 9,15,
+ 1, 6, 7,10,12, 1, 6, 7,14,10, 1, 6, 7,12,13, 1, 6, 7,15,12,
+ 1, 6, 7,13,14, 1, 6, 7,14,15, 1, 6, 8,10, 9, 1, 6, 8, 9,11,
+ 1, 6, 8, 9,12, 1, 6, 8,14, 9, 1, 6, 8,15, 9, 1, 6, 8,11,10,
+ 1, 6, 8,12,10, 1, 6, 8,10,13, 1, 6, 8,10,14, 1, 6, 8,13,11,
+ 1, 6, 8,11,15, 1, 6, 8,13,12, 1, 6, 8,12,15, 1, 6, 8,14,13,
+ 1, 6, 8,15,13, 1, 6, 8,15,14, 1, 6, 9,10,11, 1, 6, 9,13,10,
+ 1, 6, 9,11,12, 1, 6, 9,11,13, 1, 6, 9,14,11, 1, 6, 9,15,11,
+ 1, 6, 9,12,13, 1, 6, 9,13,14, 1, 6, 9,13,15, 1, 6,10,12,11,
+ 1, 6,10,11,14, 1, 6,10,13,12, 1, 6,10,14,13, 1, 6,11,12,13,
+ 1, 6,11,15,12, 1, 6,11,13,14, 1, 6,11,14,15, 1, 6,12,15,13,
+ 1, 6,13,15,14, 1, 7, 8, 9,10, 1, 7, 8,11, 9, 1, 7, 8, 9,14,
+ 1, 7, 8,10,11, 1, 7, 8,13,10, 1, 7, 8,14,10, 1, 7, 8,10,15,
+ 1, 7, 8,11,13, 1, 7, 8,15,11, 1, 7, 8,13,14, 1, 7, 8,14,15,
+ 1, 7, 9,11,10, 1, 7, 9,10,12, 1, 7, 9,10,13, 1, 7, 9,15,10,
+ 1, 7, 9,12,11, 1, 7, 9,13,11, 1, 7, 9,11,14, 1, 7, 9,11,15,
+ 1, 7, 9,14,12, 1, 7, 9,14,13, 1, 7, 9,15,14, 1, 7,10,11,12,
+ 1, 7,10,14,11, 1, 7,10,12,13, 1, 7,10,12,14, 1, 7,10,15,12,
+ 1, 7,10,13,14, 1, 7,10,14,15, 1, 7,11,13,12, 1, 7,11,12,15,
+ 1, 7,11,14,13, 1, 7,11,15,14, 1, 7,12,13,14, 1, 7,12,14,15,
+ 1, 8, 9,12,10, 1, 8, 9,10,15, 1, 8, 9,11,12, 1, 8, 9,15,11,
+ 1, 8, 9,12,14, 1, 8, 9,14,15, 1, 8,10,12,11, 1, 8,10,11,15,
+ 1, 8,10,13,12, 1, 8,10,14,12, 1, 8,10,12,15, 1, 8,10,15,13,
+ 1, 8,10,15,14, 1, 8,11,12,13, 1, 8,11,15,12, 1, 8,11,13,15,
+ 1, 8,12,14,13, 1, 8,12,15,14, 1, 8,13,14,15, 1, 9,10,11,12,
+ 1, 9,10,15,11, 1, 9,10,12,13, 1, 9,10,13,15, 1, 9,11,13,12,
+ 1, 9,11,12,14, 1, 9,11,15,13, 1, 9,11,14,15, 1, 9,12,13,14,
+ 1, 9,13,15,14, 1,10,11,14,12, 1,10,11,12,15, 1,10,11,15,14,
+ 1,10,12,14,13, 1,10,12,13,15, 1,10,13,14,15, 1,11,12,13,14,
+ 1,11,12,15,13, 1,11,12,14,15, 1,11,13,15,14, 1,12,13,14,15,
+ 2, 3, 4, 6, 5, 2, 3, 4, 5,10, 2, 3, 4,11, 5, 2, 3, 4, 5,14,
+ 2, 3, 4, 6, 9, 2, 3, 4,10, 6, 2, 3, 4, 6,13, 2, 3, 4,15, 6,
+ 2, 3, 4, 9,10, 2, 3, 4,11, 9, 2, 3, 4, 9,14, 2, 3, 4,10,11,
+ 2, 3, 4,13,10, 2, 3, 4,14,10, 2, 3, 4,10,15, 2, 3, 4,11,13,
+ 2, 3, 4,15,11, 2, 3, 4,13,14, 2, 3, 4,14,15, 2, 3, 5, 8, 6,
+ 2, 3, 5, 6, 9, 2, 3, 5,12, 6, 2, 3, 5, 6,14, 2, 3, 5,10, 8,
+ 2, 3, 5, 8,11, 2, 3, 5,14, 8, 2, 3, 5, 9,10, 2, 3, 5,11, 9,
+ 2, 3, 5, 9,14, 2, 3, 5,10,12, 2, 3, 5,14,10, 2, 3, 5,12,11,
+ 2, 3, 5,11,14, 2, 3, 5,14,12, 2, 3, 6, 9, 8, 2, 3, 6, 8,10,
+ 2, 3, 6,13, 8, 2, 3, 6, 8,15, 2, 3, 6,10, 9, 2, 3, 6, 9,12,
+ 2, 3, 6, 9,13, 2, 3, 6,14, 9, 2, 3, 6,15, 9, 2, 3, 6,12,10,
+ 2, 3, 6,10,14, 2, 3, 6,13,12, 2, 3, 6,12,15, 2, 3, 6,14,13,
+ 2, 3, 6,15,14, 2, 3, 8, 9,10, 2, 3, 8,11, 9, 2, 3, 8, 9,14,
+ 2, 3, 8,10,11, 2, 3, 8,13,10, 2, 3, 8,14,10, 2, 3, 8,10,15,
+ 2, 3, 8,11,13, 2, 3, 8,15,11, 2, 3, 8,13,14, 2, 3, 8,14,15,
+ 2, 3, 9,11,10, 2, 3, 9,10,12, 2, 3, 9,10,13, 2, 3, 9,15,10,
+ 2, 3, 9,12,11, 2, 3, 9,13,11, 2, 3, 9,11,14, 2, 3, 9,11,15,
+ 2, 3, 9,14,12, 2, 3, 9,14,13, 2, 3, 9,15,14, 2, 3,10,11,12,
+ 2, 3,10,14,11, 2, 3,10,12,13, 2, 3,10,12,14, 2, 3,10,15,12,
+ 2, 3,10,13,14, 2, 3,10,14,15, 2, 3,11,13,12, 2, 3,11,12,15,
+ 2, 3,11,14,13, 2, 3,11,15,14, 2, 3,12,13,14, 2, 3,12,14,15,
+ 2, 4, 5, 6, 7, 2, 4, 5, 8, 6, 2, 4, 5, 6,11, 2, 4, 5,13, 6,
+ 2, 4, 5, 7,10, 2, 4, 5,11, 7, 2, 4, 5, 7,14, 2, 4, 5,10, 8,
+ 2, 4, 5, 8,11, 2, 4, 5,14, 8, 2, 4, 5,11,10, 2, 4, 5,10,13,
+ 2, 4, 5,13,11, 2, 4, 5,11,14, 2, 4, 5,14,13, 2, 4, 6, 7, 9,
+ 2, 4, 6,10, 7, 2, 4, 6, 7,13, 2, 4, 6,15, 7, 2, 4, 6, 9, 8,
+ 2, 4, 6, 8,10, 2, 4, 6,13, 8, 2, 4, 6, 8,15, 2, 4, 6,11, 9,
+ 2, 4, 6, 9,13, 2, 4, 6,10,11, 2, 4, 6,13,10, 2, 4, 6,11,13,
+ 2, 4, 6,15,11, 2, 4, 6,13,15, 2, 4, 7,10, 9, 2, 4, 7, 9,11,
+ 2, 4, 7,14, 9, 2, 4, 7,11,10, 2, 4, 7,10,13, 2, 4, 7,10,14,
+ 2, 4, 7,15,10, 2, 4, 7,13,11, 2, 4, 7,11,15, 2, 4, 7,14,13,
+ 2, 4, 7,15,14, 2, 4, 8, 9,10, 2, 4, 8,11, 9, 2, 4, 8, 9,14,
+ 2, 4, 8,10,11, 2, 4, 8,13,10, 2, 4, 8,14,10, 2, 4, 8,10,15,
+ 2, 4, 8,11,13, 2, 4, 8,15,11, 2, 4, 8,13,14, 2, 4, 8,14,15,
+ 2, 4, 9,11,10, 2, 4, 9,10,13, 2, 4, 9,13,11, 2, 4, 9,11,14,
+ 2, 4, 9,14,13, 2, 4,10,14,11, 2, 4,10,11,15, 2, 4,10,13,14,
+ 2, 4,10,15,13, 2, 4,11,14,13, 2, 4,11,13,15, 2, 4,11,15,14,
+ 2, 4,13,14,15, 2, 5, 6, 8, 7, 2, 5, 6, 7, 9, 2, 5, 6,12, 7,
+ 2, 5, 6, 7,14, 2, 5, 6, 9, 8, 2, 5, 6, 8,11, 2, 5, 6, 8,12,
+ 2, 5, 6,13, 8, 2, 5, 6,14, 8, 2, 5, 6,11, 9, 2, 5, 6, 9,13,
+ 2, 5, 6,12,11, 2, 5, 6,11,14, 2, 5, 6,13,12, 2, 5, 6,14,13,
+ 2, 5, 7, 8,10, 2, 5, 7,11, 8, 2, 5, 7, 8,14, 2, 5, 7,10, 9,
+ 2, 5, 7, 9,11, 2, 5, 7,14, 9, 2, 5, 7,12,10, 2, 5, 7,10,14,
+ 2, 5, 7,11,12, 2, 5, 7,14,11, 2, 5, 7,12,14, 2, 5, 8, 9,10,
+ 2, 5, 8,11, 9, 2, 5, 8, 9,14, 2, 5, 8,10,11, 2, 5, 8,10,12,
+ 2, 5, 8,13,10, 2, 5, 8,14,10, 2, 5, 8,12,11, 2, 5, 8,11,13,
+ 2, 5, 8,14,12, 2, 5, 8,13,14, 2, 5, 9,11,10, 2, 5, 9,10,13,
+ 2, 5, 9,13,11, 2, 5, 9,11,14, 2, 5, 9,14,13, 2, 5,10,11,12,
+ 2, 5,10,14,11, 2, 5,10,12,13, 2, 5,10,13,14, 2, 5,11,13,12,
+ 2, 5,11,12,14, 2, 5,11,14,13, 2, 5,12,13,14, 2, 6, 7, 8, 9,
+ 2, 6, 7,10, 8, 2, 6, 7, 8,13, 2, 6, 7,15, 8, 2, 6, 7, 9,10,
+ 2, 6, 7,12, 9, 2, 6, 7,13, 9, 2, 6, 7, 9,14, 2, 6, 7, 9,15,
+ 2, 6, 7,10,12, 2, 6, 7,14,10, 2, 6, 7,12,13, 2, 6, 7,15,12,
+ 2, 6, 7,13,14, 2, 6, 7,14,15, 2, 6, 8,10, 9, 2, 6, 8, 9,11,
+ 2, 6, 8, 9,12, 2, 6, 8,14, 9, 2, 6, 8,15, 9, 2, 6, 8,11,10,
+ 2, 6, 8,12,10, 2, 6, 8,10,13, 2, 6, 8,10,14, 2, 6, 8,13,11,
+ 2, 6, 8,11,15, 2, 6, 8,13,12, 2, 6, 8,12,15, 2, 6, 8,14,13,
+ 2, 6, 8,15,13, 2, 6, 8,15,14, 2, 6, 9,10,11, 2, 6, 9,13,10,
+ 2, 6, 9,11,12, 2, 6, 9,11,13, 2, 6, 9,14,11, 2, 6, 9,15,11,
+ 2, 6, 9,12,13, 2, 6, 9,13,14, 2, 6, 9,13,15, 2, 6,10,12,11,
+ 2, 6,10,11,14, 2, 6,10,13,12, 2, 6,10,14,13, 2, 6,11,12,13,
+ 2, 6,11,15,12, 2, 6,11,13,14, 2, 6,11,14,15, 2, 6,12,15,13,
+ 2, 6,13,15,14, 2, 7, 8, 9,10, 2, 7, 8,11, 9, 2, 7, 8, 9,14,
+ 2, 7, 8,10,11, 2, 7, 8,13,10, 2, 7, 8,14,10, 2, 7, 8,10,15,
+ 2, 7, 8,11,13, 2, 7, 8,15,11, 2, 7, 8,13,14, 2, 7, 8,14,15,
+ 2, 7, 9,11,10, 2, 7, 9,10,12, 2, 7, 9,10,13, 2, 7, 9,15,10,
+ 2, 7, 9,12,11, 2, 7, 9,13,11, 2, 7, 9,11,14, 2, 7, 9,11,15,
+ 2, 7, 9,14,12, 2, 7, 9,14,13, 2, 7, 9,15,14, 2, 7,10,11,12,
+ 2, 7,10,14,11, 2, 7,10,12,13, 2, 7,10,12,14, 2, 7,10,15,12,
+ 2, 7,10,13,14, 2, 7,10,14,15, 2, 7,11,13,12, 2, 7,11,12,15,
+ 2, 7,11,14,13, 2, 7,11,15,14, 2, 7,12,13,14, 2, 7,12,14,15,
+ 2, 8, 9,12,10, 2, 8, 9,10,15, 2, 8, 9,11,12, 2, 8, 9,15,11,
+ 2, 8, 9,12,14, 2, 8, 9,14,15, 2, 8,10,12,11, 2, 8,10,11,15,
+ 2, 8,10,13,12, 2, 8,10,14,12, 2, 8,10,12,15, 2, 8,10,15,13,
+ 2, 8,10,15,14, 2, 8,11,12,13, 2, 8,11,15,12, 2, 8,11,13,15,
+ 2, 8,12,14,13, 2, 8,12,15,14, 2, 8,13,14,15, 2, 9,10,11,12,
+ 2, 9,10,15,11, 2, 9,10,12,13, 2, 9,10,13,15, 2, 9,11,13,12,
+ 2, 9,11,12,14, 2, 9,11,15,13, 2, 9,11,14,15, 2, 9,12,13,14,
+ 2, 9,13,15,14, 2,10,11,14,12, 2,10,11,12,15, 2,10,11,15,14,
+ 2,10,12,14,13, 2,10,12,13,15, 2,10,13,14,15, 2,11,12,13,14,
+ 2,11,12,15,13, 2,11,12,14,15, 2,11,13,15,14, 2,12,13,14,15,
+ 3, 4, 5, 6, 7, 3, 4, 5,10, 6, 3, 4, 5, 6,11, 3, 4, 5, 6,12,
+ 3, 4, 5,14, 6, 3, 4, 5,15, 6, 3, 4, 5, 7,10, 3, 4, 5,11, 7,
+ 3, 4, 5, 7,14, 3, 4, 5,12,10, 3, 4, 5,10,15, 3, 4, 5,11,12,
+ 3, 4, 5,15,11, 3, 4, 5,12,14, 3, 4, 5,14,15, 3, 4, 6, 7, 9,
+ 3, 4, 6,10, 7, 3, 4, 6, 7,13, 3, 4, 6,15, 7, 3, 4, 6, 9,10,
+ 3, 4, 6,11, 9, 3, 4, 6,12, 9, 3, 4, 6, 9,14, 3, 4, 6, 9,15,
+ 3, 4, 6,10,11, 3, 4, 6,10,12, 3, 4, 6,13,10, 3, 4, 6,14,10,
+ 3, 4, 6,11,13, 3, 4, 6,15,11, 3, 4, 6,12,13, 3, 4, 6,15,12,
+ 3, 4, 6,13,14, 3, 4, 6,13,15, 3, 4, 6,14,15, 3, 4, 7,10, 9,
+ 3, 4, 7, 9,11, 3, 4, 7,14, 9, 3, 4, 7,11,10, 3, 4, 7,10,13,
+ 3, 4, 7,10,14, 3, 4, 7,15,10, 3, 4, 7,13,11, 3, 4, 7,11,15,
+ 3, 4, 7,14,13, 3, 4, 7,15,14, 3, 4, 9,12,10, 3, 4, 9,10,15,
+ 3, 4, 9,11,12, 3, 4, 9,15,11, 3, 4, 9,12,14, 3, 4, 9,14,15,
+ 3, 4,10,12,11, 3, 4,10,11,15, 3, 4,10,13,12, 3, 4,10,14,12,
+ 3, 4,10,12,15, 3, 4,10,15,13, 3, 4,10,15,14, 3, 4,11,12,13,
+ 3, 4,11,15,12, 3, 4,11,13,15, 3, 4,12,14,13, 3, 4,12,15,14,
+ 3, 4,13,14,15, 3, 5, 6, 8, 7, 3, 5, 6, 7, 9, 3, 5, 6,12, 7,
+ 3, 5, 6, 7,14, 3, 5, 6,10, 8, 3, 5, 6, 8,11, 3, 5, 6, 8,12,
+ 3, 5, 6,14, 8, 3, 5, 6,15, 8, 3, 5, 6, 9,10, 3, 5, 6,11, 9,
+ 3, 5, 6,12, 9, 3, 5, 6, 9,14, 3, 5, 6, 9,15, 3, 5, 6,10,12,
+ 3, 5, 6,14,10, 3, 5, 6,12,11, 3, 5, 6,11,14, 3, 5, 6,15,12,
+ 3, 5, 6,14,15, 3, 5, 7, 8,10, 3, 5, 7,11, 8, 3, 5, 7, 8,14,
+ 3, 5, 7,10, 9, 3, 5, 7, 9,11, 3, 5, 7,14, 9, 3, 5, 7,12,10,
+ 3, 5, 7,10,14, 3, 5, 7,11,12, 3, 5, 7,14,11, 3, 5, 7,12,14,
+ 3, 5, 8,10,12, 3, 5, 8,15,10, 3, 5, 8,12,11, 3, 5, 8,11,15,
+ 3, 5, 8,14,12, 3, 5, 8,15,14, 3, 5, 9,12,10, 3, 5, 9,10,15,
+ 3, 5, 9,11,12, 3, 5, 9,15,11, 3, 5, 9,12,14, 3, 5, 9,14,15,
+ 3, 5,10,14,12, 3, 5,10,12,15, 3, 5,10,15,14, 3, 5,11,12,14,
+ 3, 5,11,15,12, 3, 5,11,14,15, 3, 5,12,15,14, 3, 6, 7, 8, 9,
+ 3, 6, 7,10, 8, 3, 6, 7, 8,13, 3, 6, 7,15, 8, 3, 6, 7, 9,10,
+ 3, 6, 7,12, 9, 3, 6, 7,13, 9, 3, 6, 7, 9,14, 3, 6, 7, 9,15,
+ 3, 6, 7,10,12, 3, 6, 7,14,10, 3, 6, 7,12,13, 3, 6, 7,15,12,
+ 3, 6, 7,13,14, 3, 6, 7,14,15, 3, 6, 8,10, 9, 3, 6, 8, 9,11,
+ 3, 6, 8, 9,12, 3, 6, 8,14, 9, 3, 6, 8,15, 9, 3, 6, 8,11,10,
+ 3, 6, 8,12,10, 3, 6, 8,10,13, 3, 6, 8,10,14, 3, 6, 8,13,11,
+ 3, 6, 8,11,15, 3, 6, 8,13,12, 3, 6, 8,12,15, 3, 6, 8,14,13,
+ 3, 6, 8,15,13, 3, 6, 8,15,14, 3, 6, 9,10,11, 3, 6, 9,13,10,
+ 3, 6, 9,11,12, 3, 6, 9,11,13, 3, 6, 9,14,11, 3, 6, 9,15,11,
+ 3, 6, 9,12,13, 3, 6, 9,13,14, 3, 6, 9,13,15, 3, 6,10,12,11,
+ 3, 6,10,11,14, 3, 6,10,13,12, 3, 6,10,14,13, 3, 6,11,12,13,
+ 3, 6,11,15,12, 3, 6,11,13,14, 3, 6,11,14,15, 3, 6,12,15,13,
+ 3, 6,13,15,14, 3, 7, 8, 9,10, 3, 7, 8,11, 9, 3, 7, 8, 9,14,
+ 3, 7, 8,10,11, 3, 7, 8,13,10, 3, 7, 8,14,10, 3, 7, 8,10,15,
+ 3, 7, 8,11,13, 3, 7, 8,15,11, 3, 7, 8,13,14, 3, 7, 8,14,15,
+ 3, 7, 9,11,10, 3, 7, 9,10,12, 3, 7, 9,10,13, 3, 7, 9,15,10,
+ 3, 7, 9,12,11, 3, 7, 9,13,11, 3, 7, 9,11,14, 3, 7, 9,11,15,
+ 3, 7, 9,14,12, 3, 7, 9,14,13, 3, 7, 9,15,14, 3, 7,10,11,12,
+ 3, 7,10,14,11, 3, 7,10,12,13, 3, 7,10,12,14, 3, 7,10,15,12,
+ 3, 7,10,13,14, 3, 7,10,14,15, 3, 7,11,13,12, 3, 7,11,12,15,
+ 3, 7,11,14,13, 3, 7,11,15,14, 3, 7,12,13,14, 3, 7,12,14,15,
+ 3, 8, 9,12,10, 3, 8, 9,10,15, 3, 8, 9,11,12, 3, 8, 9,15,11,
+ 3, 8, 9,12,14, 3, 8, 9,14,15, 3, 8,10,12,11, 3, 8,10,11,15,
+ 3, 8,10,13,12, 3, 8,10,14,12, 3, 8,10,12,15, 3, 8,10,15,13,
+ 3, 8,10,15,14, 3, 8,11,12,13, 3, 8,11,15,12, 3, 8,11,13,15,
+ 3, 8,12,14,13, 3, 8,12,15,14, 3, 8,13,14,15, 3, 9,10,11,12,
+ 3, 9,10,15,11, 3, 9,10,12,13, 3, 9,10,13,15, 3, 9,11,13,12,
+ 3, 9,11,12,14, 3, 9,11,15,13, 3, 9,11,14,15, 3, 9,12,13,14,
+ 3, 9,13,15,14, 3,10,11,14,12, 3,10,11,12,15, 3,10,11,15,14,
+ 3,10,12,14,13, 3,10,12,13,15, 3,10,13,14,15, 3,11,12,13,14,
+ 3,11,12,15,13, 3,11,12,14,15, 3,11,13,15,14, 3,12,13,14,15,
+ 4, 5, 6, 8, 7, 4, 5, 6, 7,10, 4, 5, 6,12, 7, 4, 5, 6,13, 7,
+ 4, 5, 6, 7,14, 4, 5, 6, 7,15, 4, 5, 6,10, 8, 4, 5, 6, 8,11,
+ 4, 5, 6, 8,12, 4, 5, 6,14, 8, 4, 5, 6,15, 8, 4, 5, 6,11,10,
+ 4, 5, 6,10,13, 4, 5, 6,12,11, 4, 5, 6,13,11, 4, 5, 6,11,14,
+ 4, 5, 6,11,15, 4, 5, 6,13,12, 4, 5, 6,14,13, 4, 5, 6,15,13,
+ 4, 5, 7, 8,10, 4, 5, 7,11, 8, 4, 5, 7, 8,14, 4, 5, 7,10,11,
+ 4, 5, 7,12,10, 4, 5, 7,13,10, 4, 5, 7,10,15, 4, 5, 7,11,12,
+ 4, 5, 7,11,13, 4, 5, 7,14,11, 4, 5, 7,15,11, 4, 5, 7,12,14,
+ 4, 5, 7,13,14, 4, 5, 7,14,15, 4, 5, 8,10,12, 4, 5, 8,15,10,
+ 4, 5, 8,12,11, 4, 5, 8,11,15, 4, 5, 8,14,12, 4, 5, 8,15,14,
+ 4, 5,10,11,12, 4, 5,10,15,11, 4, 5,10,12,13, 4, 5,10,13,15,
+ 4, 5,11,13,12, 4, 5,11,12,14, 4, 5,11,15,13, 4, 5,11,14,15,
+ 4, 5,12,13,14, 4, 5,13,15,14, 4, 6, 7, 8, 9, 4, 6, 7,10, 8,
+ 4, 6, 7, 8,13, 4, 6, 7,15, 8, 4, 6, 7, 9,10, 4, 6, 7,12, 9,
+ 4, 6, 7,13, 9, 4, 6, 7, 9,14, 4, 6, 7, 9,15, 4, 6, 7,10,12,
+ 4, 6, 7,14,10, 4, 6, 7,12,13, 4, 6, 7,15,12, 4, 6, 7,13,14,
+ 4, 6, 7,14,15, 4, 6, 8,10, 9, 4, 6, 8, 9,11, 4, 6, 8, 9,12,
+ 4, 6, 8,14, 9, 4, 6, 8,15, 9, 4, 6, 8,11,10, 4, 6, 8,12,10,
+ 4, 6, 8,10,13, 4, 6, 8,10,14, 4, 6, 8,13,11, 4, 6, 8,11,15,
+ 4, 6, 8,13,12, 4, 6, 8,12,15, 4, 6, 8,14,13, 4, 6, 8,15,13,
+ 4, 6, 8,15,14, 4, 6, 9,10,11, 4, 6, 9,13,10, 4, 6, 9,11,12,
+ 4, 6, 9,11,13, 4, 6, 9,14,11, 4, 6, 9,15,11, 4, 6, 9,12,13,
+ 4, 6, 9,13,14, 4, 6, 9,13,15, 4, 6,10,12,11, 4, 6,10,11,14,
+ 4, 6,10,13,12, 4, 6,10,14,13, 4, 6,11,12,13, 4, 6,11,15,12,
+ 4, 6,11,13,14, 4, 6,11,14,15, 4, 6,12,15,13, 4, 6,13,15,14,
+ 4, 7, 8, 9,10, 4, 7, 8,11, 9, 4, 7, 8, 9,14, 4, 7, 8,10,11,
+ 4, 7, 8,13,10, 4, 7, 8,14,10, 4, 7, 8,10,15, 4, 7, 8,11,13,
+ 4, 7, 8,15,11, 4, 7, 8,13,14, 4, 7, 8,14,15, 4, 7, 9,11,10,
+ 4, 7, 9,10,12, 4, 7, 9,10,13, 4, 7, 9,15,10, 4, 7, 9,12,11,
+ 4, 7, 9,13,11, 4, 7, 9,11,14, 4, 7, 9,11,15, 4, 7, 9,14,12,
+ 4, 7, 9,14,13, 4, 7, 9,15,14, 4, 7,10,11,12, 4, 7,10,14,11,
+ 4, 7,10,12,13, 4, 7,10,12,14, 4, 7,10,15,12, 4, 7,10,13,14,
+ 4, 7,10,14,15, 4, 7,11,13,12, 4, 7,11,12,15, 4, 7,11,14,13,
+ 4, 7,11,15,14, 4, 7,12,13,14, 4, 7,12,14,15, 4, 8, 9,12,10,
+ 4, 8, 9,10,15, 4, 8, 9,11,12, 4, 8, 9,15,11, 4, 8, 9,12,14,
+ 4, 8, 9,14,15, 4, 8,10,12,11, 4, 8,10,11,15, 4, 8,10,13,12,
+ 4, 8,10,14,12, 4, 8,10,12,15, 4, 8,10,15,13, 4, 8,10,15,14,
+ 4, 8,11,12,13, 4, 8,11,15,12, 4, 8,11,13,15, 4, 8,12,14,13,
+ 4, 8,12,15,14, 4, 8,13,14,15, 4, 9,10,11,12, 4, 9,10,15,11,
+ 4, 9,10,12,13, 4, 9,10,13,15, 4, 9,11,13,12, 4, 9,11,12,14,
+ 4, 9,11,15,13, 4, 9,11,14,15, 4, 9,12,13,14, 4, 9,13,15,14,
+ 4,10,11,14,12, 4,10,11,12,15, 4,10,11,15,14, 4,10,12,14,13,
+ 4,10,12,13,15, 4,10,13,14,15, 4,11,12,13,14, 4,11,12,15,13,
+ 4,11,12,14,15, 4,11,13,15,14, 4,12,13,14,15, 5, 6, 7, 8, 9,
+ 5, 6, 7,10, 8, 5, 6, 7, 8,13, 5, 6, 7,15, 8, 5, 6, 7, 9,10,
+ 5, 6, 7,12, 9, 5, 6, 7,13, 9, 5, 6, 7, 9,14, 5, 6, 7, 9,15,
+ 5, 6, 7,10,12, 5, 6, 7,14,10, 5, 6, 7,12,13, 5, 6, 7,15,12,
+ 5, 6, 7,13,14, 5, 6, 7,14,15, 5, 6, 8,10, 9, 5, 6, 8, 9,11,
+ 5, 6, 8, 9,12, 5, 6, 8,14, 9, 5, 6, 8,15, 9, 5, 6, 8,11,10,
+ 5, 6, 8,12,10, 5, 6, 8,10,13, 5, 6, 8,10,14, 5, 6, 8,13,11,
+ 5, 6, 8,11,15, 5, 6, 8,13,12, 5, 6, 8,12,15, 5, 6, 8,14,13,
+ 5, 6, 8,15,13, 5, 6, 8,15,14, 5, 6, 9,10,11, 5, 6, 9,13,10,
+ 5, 6, 9,11,12, 5, 6, 9,11,13, 5, 6, 9,14,11, 5, 6, 9,15,11,
+ 5, 6, 9,12,13, 5, 6, 9,13,14, 5, 6, 9,13,15, 5, 6,10,12,11,
+ 5, 6,10,11,14, 5, 6,10,13,12, 5, 6,10,14,13, 5, 6,11,12,13,
+ 5, 6,11,15,12, 5, 6,11,13,14, 5, 6,11,14,15, 5, 6,12,15,13,
+ 5, 6,13,15,14, 5, 7, 8, 9,10, 5, 7, 8,11, 9, 5, 7, 8, 9,14,
+ 5, 7, 8,10,11, 5, 7, 8,13,10, 5, 7, 8,14,10, 5, 7, 8,10,15,
+ 5, 7, 8,11,13, 5, 7, 8,15,11, 5, 7, 8,13,14, 5, 7, 8,14,15,
+ 5, 7, 9,11,10, 5, 7, 9,10,12, 5, 7, 9,10,13, 5, 7, 9,15,10,
+ 5, 7, 9,12,11, 5, 7, 9,13,11, 5, 7, 9,11,14, 5, 7, 9,11,15,
+ 5, 7, 9,14,12, 5, 7, 9,14,13, 5, 7, 9,15,14, 5, 7,10,11,12,
+ 5, 7,10,14,11, 5, 7,10,12,13, 5, 7,10,12,14, 5, 7,10,15,12,
+ 5, 7,10,13,14, 5, 7,10,14,15, 5, 7,11,13,12, 5, 7,11,12,15,
+ 5, 7,11,14,13, 5, 7,11,15,14, 5, 7,12,13,14, 5, 7,12,14,15,
+ 5, 8, 9,12,10, 5, 8, 9,10,15, 5, 8, 9,11,12, 5, 8, 9,15,11,
+ 5, 8, 9,12,14, 5, 8, 9,14,15, 5, 8,10,12,11, 5, 8,10,11,15,
+ 5, 8,10,13,12, 5, 8,10,14,12, 5, 8,10,12,15, 5, 8,10,15,13,
+ 5, 8,10,15,14, 5, 8,11,12,13, 5, 8,11,15,12, 5, 8,11,13,15,
+ 5, 8,12,14,13, 5, 8,12,15,14, 5, 8,13,14,15, 5, 9,10,11,12,
+ 5, 9,10,15,11, 5, 9,10,12,13, 5, 9,10,13,15, 5, 9,11,13,12,
+ 5, 9,11,12,14, 5, 9,11,15,13, 5, 9,11,14,15, 5, 9,12,13,14,
+ 5, 9,13,15,14, 5,10,11,14,12, 5,10,11,12,15, 5,10,11,15,14,
+ 5,10,12,14,13, 5,10,12,13,15, 5,10,13,14,15, 5,11,12,13,14,
+ 5,11,12,15,13, 5,11,12,14,15, 5,11,13,15,14, 5,12,13,14,15,
+ * last line
diff --git a/ff-2.0/ffrcvr.f b/ff-2.0/ffrcvr.f
new file mode 100644
index 0000000..23a34dc
--- /dev/null
+++ b/ff-2.0/ffrcvr.f
@@ -0,0 +1,29 @@
+*###[ ffrcvr:
+ subroutine ffrcvr(isig)
+ integer isig,ier,nold,ncall
+ save nold
+ include 'ff.h'
+ data nold /0/
+ data ncall /0/
+ if ( isig .ne. 8 ) then
+ print *,'ffrcvr: Somebody shot a signal ',isig,' at me'
+ stop
+ endif
+* Only give the message once per event
+ if ( nevent .eq. nold ) then
+ ncall = ncall + 1
+ if ( ncall .lt. 100 ) then
+* return
+ else
+ print *,'ffrcvr: error: more than 100 calls'
+ stop
+ endif
+ else
+ nold = nevent
+ ncall = 0
+ endif
+ ner = ner + 100
+ ier = 0
+ call fferr(100,ier)
+*###] ffrcvr:
+ end
diff --git a/ff-2.0/ffs.h b/ff-2.0/ffs.h
new file mode 100644
index 0000000..4960abf
--- /dev/null
+++ b/ff-2.0/ffs.h
@@ -0,0 +1,39 @@
+ integer memory
+ parameter(memory=12)
+ logical lwrite,ltest,l4also,ldc3c4,lmem,lwarn,ldot,onshel,lsmug,
+ + lnasty
+ integer nwidth,nschem,idot
+ DOUBLE PRECISION xloss,precx,precc,xalogm,xclogm,xalog2,xclog2,
+ + reqprc,x0,x05,x1,x2,x4,pi,pi6,pi12,xlg2,bf(20),
+ + xninv(30),xn2inv(30),xinfac(30),
+ + fpij2(3,3),fpij3(6,6),fpij4(10,10),fpij5(15,15),
+ + fpij6(21,21),fdel2,fdel3,fdel4s,fdel4,fdl3i(5),
+ + fdl3ij(6,6),fdl4i(6)
+ COMPLEX c0,c05,c1,c2,c4,c2ipi,cipi2,
+ + cfpij2(3,3),cfpij3(6,6),cfpij4(10,10),cfpij5(15,15),
+ + cfpij6(21,21),cmipj(3,3),c2sisj(4,4),cfdl4s,ca1
+ integer nevent,ner,id,idsub,inx(4,4),isgn(4,4),isgn34,isgnal,
+ + iold(13,12),isgrot(10,12),irota3,irota4,irota5,irota6
+ integer idum93(2)
+ parameter(x0 = 0.d0,x1 = 1.d0,x05 = .5d0,x2 = 2.d0,x4 = 4.d0,
+ + c0 = (0.E0,0.E0),c05 = (.5D0,0.E0),c1 = (1.E0,0.E0),
+ + c2 = (2.E0,0.E0),c4 = (4.E0,0.E0))
+ parameter(
+ + c2ipi = (0.E+0,6.28318530717958647692528676655896D+0),
+ + cipi2 = (0.E+0,9.869604401089358618834490999876D+0),
+ + pi = 3.14159265358979323846264338327948D+0,
+ + pi6 = 1.644934066848226436472415166646D+0,
+ + pi12 = .822467033424113218236207583323D+0,
+ + xlg2 = .6931471805599453094172321214581D+0)
+ common /ffsign/isgn34,isgnal
+ common /ffprec/ xloss,precx,precc,xalogm,xclogm,xalog2,xclog2,
+ + reqprc
+ common /ffflag/ lwrite,ltest,l4also,ldc3c4,lmem,lwarn,ldot,
+ + nevent,ner,id,idsub,nwidth,nschem,onshel,idot
+ common /ffcnst/ bf,xninv,xn2inv,xinfac,inx,isgn,iold,isgrot
+ common /ffrota/ irota3,irota4,irota5,irota6
+ common /ffdot/ fpij2,fpij3,fpij4,fpij5,fpij6
+ common /ffdel/ fdel2,fdel3,fdel4s,fdel4,fdl3i,fdl3ij,fdl4i
+ common /ffcdot/ cfpij2,cfpij3,cfpij4,cfpij5,cfpij6
+ common /ffcdel/ cfdl4s
+ common /ffsmug/ lsmug,lnasty,idum93,cmipj,c2sisj,ca1
diff --git a/ff-2.0/fftran.f b/ff-2.0/fftran.f
new file mode 100644
index 0000000..07a3bf8
--- /dev/null
+++ b/ff-2.0/fftran.f
@@ -0,0 +1,944 @@
+*###[ ffai:
+ subroutine ffai(ai,daiaj,aai,laai,del2s,sdel2s,xpi,dpipj,piDpj,
+ + ier)
+***#[*comment:***********************************************************
+* *
+* calculates the coefficients of the projective transformation *
+* *
+* xi = ai*ui / (som aj*uj ) *
+* *
+* such that the coefficients of z^2, z*x and z*y vanish: *
+* *
+* a2/a1 = ( lij +/- lam1/2(xp1,xm1,xm2) ) / (2*xm2) *
+* a3 = ( xm2*a2 - xm1*a1 ) / ( xl23*a2 - xl13*a1 ) *
+* a4 = ( xm2*a2 - xm1*a1 ) / ( xl24*a2 - xl14*a1 ) *
+* *
+* the differences ai-aj = daiaj(i,j) are also evaluated. *
+* *
+* Input: del2s real delta(s3,s4,s3,s4) *
+* sdel2s real sqrt(-del2s) *
+* xpi(10) real masses, momenta^2 *
+* dpipj(10,10 real xpi(i) - xpi(j) *
+* piDpj(10,10) real dotproducts *
+* *
+* Output: ai(4) real Ai of the transformation *
+* daiaj(4,4) real Ai-Aj *
+* aai(4) real the other roots *
+* laai logical if .TRUE. aai are defined *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ logical laai
+ DOUBLE PRECISION ai(4),daiaj(4,4),aai(4),del2s,sdel2s,xpi(10),
+ + dpipj(10,10),piDpj(10,10)
+*
+* local variables
+*
+ integer i,j,ier0,ier1,ier2
+ DOUBLE PRECISION del2sa,del2sb,del3mi(2),aim(4),aaim(4),delps,
+ + del3m(1),dum,da2a1m,da1a3m,da1a4m,da2a3m,da2a4m,da3a4m
+* for debugging purposes
+ DOUBLE COMPLEX ca1m
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ get ai:
+ if ( lwrite ) print *,'ffai: xpi = ',(xpi(i),i=1,10),ier
+*
+* A4: some arbitrary normalisation ...
+*
+ ai(4) = 1
+ aai(4) = 1
+ ier2 = ier
+ if ( del2s .ne. 0 ) then
+*
+* A3: simple solution of quadratic equation
+*
+ ier0 = ier
+ call ffroot(aaim(3),aim(3),xpi(4),piDpj(4,3),xpi(3),
+ + sdel2s,ier0)
+ ier2 = max(ier2,ier0)
+ if ( aim(3) .eq. 0 ) then
+* choose the other root
+ if ( lwrite ) print *,'ffai: 1/A_3 = 0'
+ ier = ier + 100
+ return
+ endif
+ ai(3) = ai(4)/aim(3)
+ if ( aaim(3) .ne. 0 ) then
+ laai = .TRUE.
+ aai(3) = aai(4)/aaim(3)
+ else
+ laai = .FALSE.
+ endif
+*
+* A2: a bit more complicated quadratic equation
+*
+ ier1 = ier
+ ier0 = ier
+ call ffdl2s(del2sa,xpi,piDpj, 2,4,10,1, 3,4,7,1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ffdl3m(del3mi(2),.FALSE.,x0,x0,xpi,dpipj,piDpj,10,
+ + 3,4,7, 2,1,ier0)
+ ier1 = max(ier1,ier0)
+ call ffroot(aim(2),aaim(2),xpi(4),piDpj(4,2),del3mi(2)/del2s
+ + ,del2sa/sdel2s,ier1)
+ ier2 = max(ier2,ier1)
+ if ( aim(2) .eq. 0 ) then
+ if ( lwrite ) print *,'ffai: 1/A_2 = 0'
+ ier = ier + 100
+ return
+ endif
+ ai(2) = ai(4)/aim(2)
+ if ( laai ) then
+ if ( aaim(2) .eq. 0 ) then
+ laai = .FALSE.
+ else
+ aai(2) = aai(4)/aaim(2)
+ endif
+ endif
+*
+* A1: same as A2, except for the special nasty case.
+*
+ if ( .not.lnasty ) then
+ ier0 = ier
+ ier1 = ier
+ call ffdl2s(del2sb,xpi,piDpj, 1,4,8,-1, 3,4,7,1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ffdl3m(del3mi(1),.FALSE.,x0,x0,xpi,dpipj,piDpj,10,
+ + 3,4,7, 1,1,ier0)
+ ier1 = max(ier1,ier0)
+ call ffroot(aim(1),aaim(1),xpi(4),piDpj(4,1),del3mi(1)/del2s
+ + ,del2sb/sdel2s,ier1)
+ ier2 = max(ier2,ier1)
+ if ( aim(1) .eq. 0 ) then
+ if ( lwrite ) print *,'ffai: 1/A_1 = 0'
+ ier = ier + 100
+ return
+ endif
+ ai(1) = ai(4)/aim(1)
+ if ( laai ) then
+ if ( aaim(1) .eq. 0 ) then
+ laai = .FALSE.
+ else
+ aai(1) = aai(4)/aaim(1)
+ endif
+ endif
+ else
+ laai = .FALSE.
+ ca1m = (c2sisj(1,4) - (c2sisj(1,3)*DBLE(xpi(4)) -
+ + c2sisj(1,4)*DBLE(piDpj(3,4)))/DBLE(sdel2s))/
+ + DBLE(2*xpi(4))
+ ca1 = DBLE(ai(4))/ca1m
+ if ( lwrite ) print *,'ffai: A1 = ',ca1
+ ai(1) = ai(4)/DBLE(ca1m)
+ endif
+ else
+*
+* the special case del2s=0 with xpi(3)=xpi(4),xpi(7)=0
+*
+ laai = .FALSE.
+ ai(3) = ai(4)
+ if ( piDpj(7,2) .eq. 0 .or. piDpj(7,1) .eq. 0 ) then
+ call fferr(55,ier)
+ return
+ endif
+ ai(2) = ai(4)*xpi(3)/piDpj(7,2)
+ ai(1) = ai(4)*xpi(3)/piDpj(7,1)
+ endif
+ ier = ier2
+* #] get ai:
+* #[ get daiaj:
+ ier2 = ier
+ do 120 i=1,4
+ daiaj(i,i) = 0
+ do 110 j=i+1,4
+ daiaj(j,i) = ai(j) - ai(i)
+ if ( abs(daiaj(j,i)) .ge. xloss*abs(ai(i)) ) goto 105
+ if ( lwrite ) print *,'daiaj(',j,i,') = ',daiaj(j,i),
+ + ai(j),-ai(i),ier
+ if ( del2s .eq. 0 ) then
+* #[ del2s=0:
+ if ( i .eq. 1 .and. j .eq. 2 ) then
+ daiaj(2,1) = -ai(1)*ai(2)*piDpj(5,7)/xpi(3)
+ goto 104
+ elseif ( i .eq. 3 .and. j .eq. 4 ) then
+ daiaj(4,3) = 0
+ goto 104
+ endif
+ ier1 = ier
+ call ffwarn(146,ier1,daiaj(j,i),ai(i))
+ goto 105
+* #] del2s=0:
+ elseif ( lnasty .and. i.eq.1 ) then
+ ier1 = ier
+ call ffwarn(146,ier1,daiaj(j,i),ai(i))
+ goto 105
+ endif
+ ier0 = ier
+ if ( i .eq. 1 .and. j .eq. 2 ) then
+* #[ daiaj(2,1):
+*
+* some determinants (as usual)
+*
+* as the vertex p1,s4,? does not exist we use ffdl2t
+*
+ call ffdl2t(delps,piDpj, 5,4, 3,4,7,1,+1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ffdl3m(del3m,.FALSE.,x0,x0,xpi,dpipj,piDpj,
+ + 10, 3,4,7, 5,1, ier0)
+ ier1 = max(ier1,ier0)
+ call ffroot(dum,da2a1m,xpi(4),piDpj(4,5),
+ + del3m(1)/del2s,-delps/sdel2s,ier1)
+ daiaj(2,1) = -ai(1)*ai(2)*da2a1m
+ goto 104
+* #] daiaj(2,1):
+ elseif ( i .eq. 1 .and. j .eq. 3 ) then
+* #[ daiaj(3,1):
+*
+* Again, the solution of a simple quadratic equation
+*
+ call ffdl2t(delps,piDpj, 9,4, 3,4,7,1,+1, 10,ier0)
+ ier1 = ier0
+ ier0 = ier
+ call ffdl3m(del3m,.FALSE.,x0,x0,xpi,dpipj,piDpj,
+ + 10, 3,4,7, 9,1, ier0)
+ ier1 = max(ier1,ier0)
+ call ffroot(dum,da1a3m,xpi(4),-piDpj(4,9),
+ + del3m(1)/del2s,delps/sdel2s,ier1)
+ daiaj(3,1) = -ai(1)*ai(3)*da1a3m
+ goto 104
+* #] daiaj(3,1):
+ elseif ( i .eq. 1 .and. j .eq. 4 ) then
+* #[ daiaj(4,1):
+*
+* Again, the solution of a simple quadratic equation
+*
+ call ffdl2s(delps,xpi,piDpj,4,1,8,1,3,4,7,1,10,ier0)
+ ier1 = ier0
+ ier0 = ier
+ call ffdl3m(del3m,.FALSE.,x0,x0,xpi,dpipj,piDpj,
+ + 10, 3,4,7, 8,1, ier0)
+ ier1 = max(ier0,ier1)
+ call ffroot(dum,da1a4m,xpi(4),piDpj(4,8),del3m(1)/
+ + del2s,delps/sdel2s,ier1)
+ daiaj(4,1) = ai(1)*ai(4)*da1a4m
+ goto 104
+* #] daiaj(4,1):
+ elseif ( i .eq. 2 .and. j .eq. 3 ) then
+* #[ daiaj(3,2):
+*
+* Again, the solution of a simple quadratic equation
+*
+ call ffdl2t(delps,piDpj, 6,4, 3,4,7,1,+1, 10,ier0)
+ ier1 = ier0
+ ier0 = ier
+ call ffdl3m(del3m,.FALSE.,x0,x0,xpi,dpipj,piDpj,
+ + 10, 3,4,7, 6,1, ier0)
+ ier1 = max(ier1,ier0)
+ call ffroot(dum,da2a3m,xpi(4),-piDpj(4,6),
+ + del3m(1)/del2s,delps/sdel2s,ier1)
+ daiaj(3,2) = ai(2)*ai(3)*da2a3m
+ goto 104
+* #] daiaj(3,2):
+ elseif ( i .eq. 2 .and. j .eq. 4 ) then
+* #[ daiaj(4,2):
+*
+* Again, the solution of a simple quadratic equation
+*
+ call ffdl2s(delps,xpi,piDpj,2,4,10,1,3,4,7,1,10,
+ + ier0)
+ ier1 = ier0
+ ier0 = ier
+ call ffdl3m(del3m,.FALSE.,x0,x0,xpi,dpipj,piDpj,
+ + 10, 3,4,7, 10,1, ier0)
+ ier1 = max(ier0,ier1)
+ call ffroot(dum,da2a4m,xpi(4),piDpj(4,10),del3m(1)/
+ + del2s,delps/sdel2s,ier1)
+ daiaj(4,2) = -ai(2)*ai(4)*da2a4m
+ goto 104
+* #] daiaj(4,2):
+ elseif ( i .eq. 3 .and. j .eq. 4 ) then
+* #[ daiaj(4,3):
+*
+* Again, the solution of a very simple quadratic equation
+*
+ ier1 = ier
+ call ffroot(dum,da3a4m,xpi(4),-piDpj(4,7),
+ + xpi(7),sdel2s,ier1)
+ daiaj(4,3) = ai(3)*ai(4)*da3a4m
+ goto 104
+* #] daiaj(4,3):
+ endif
+ 104 continue
+ if ( lwrite ) print *,'daiaj(',j,i,')+= ',daiaj(j,i),ier
+ 105 continue
+ daiaj(i,j) = -daiaj(j,i)
+ ier2 = max(ier2,ier1)
+ 110 continue
+ 120 continue
+ ier = ier2
+* #] get daiaj:
+* #[ debug output:
+ if ( lwrite ) then
+ print *,'ffai: Found Ai: ',ai
+ print *,' Ai-Aj: ',daiaj
+ print *,' ier ',ier
+ endif
+* #] debug output:
+*###] ffai:
+ end
+*###[ fftran:
+ subroutine fftran(ai,daiaj,aai,laai,xqi,dqiqj,qiDqj,
+ + del2s,sdel2s,xpi,dpipj,piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* Transform the impulses according to *
+* *
+* ti = Ai*si *
+* qij = (Ai*si - Aj*sj) *
+* *
+* In case del2s=0 it calculates the same coefficients but for *
+* for A1,A2 leave out the delta with 2*delta = 1-xpi(4)/xpi(3) *
+* infinitesimal. *
+* *
+* Input: ai(4) ai *
+* daiaj(4,4) ai-aj *
+* del2s \delta^{s(3) s4}_{s(3) s4} *
+* sdel2s sqrt(del2s) *
+* xpi(10) masses = s1-s2-s(3)-s4 *
+* dpipj(10,10) differences *
+* piDpj(10,10) dotproducts *
+* *
+* Output: xqi(10) transformed momenta *
+* dqiqj(10,10) differences *
+* qiDqj(10,10) dotproducts *
+* ier (integer) 0=ok,1=inaccurate,2=error *
+* *
+* Calls: ffxlmb,... *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ logical laai
+ DOUBLE PRECISION ai(4),daiaj(4,4),aai(4),xqi(10),dqiqj(10,10),
+ + qiDqj(10,10),del2s,sdel2s,xpi(10),dpipj(10,10),
+ + piDpj(10,10)
+*
+* local variables
+*
+ integer i,j,ji,k,kj,l,lk,is,isgnji,isgnlk,
+ + ifirst,i1,j1,k1,j2,kk,kkj,ier0,ier1,ier2
+ logical lgo
+ DOUBLE PRECISION xmax,dum,delps,del2d2,dl2d22,aijk,aijkl,
+ + xheck,smax,s(3),rloss,som
+*
+* common blocks
+*
+ include 'ff.h'
+*
+ ifirst = 0
+* #] declarations:
+* #[ si.sj -> ti.tj:
+*
+* calculate the dotproducts of ti(i) = ai*si(i): no problems.
+*
+ do 20 i=1,4
+ xqi(i) = ai(i)**2 * xpi(i)
+ qiDqj(i,i) = xqi(i)
+ do 10 j=i+1,4
+ qiDqj(j,i) = ai(j)*ai(i)*piDpj(j,i)
+ qiDqj(i,j) = qiDqj(j,i)
+ 10 continue
+ 20 continue
+*
+* and the smuggled ones for the onshell complex D0
+*
+ if ( lsmug ) then
+ do 40 j=1,3
+ do 30 i=i+1,4
+ c2sisj(i,j) = DBLE(ai(j)*ai(i))*c2sisj(i,j)
+ c2sisj(j,i) = c2sisj(i,j)
+ 30 continue
+ 40 continue
+ endif
+ if ( lnasty ) then
+ do 60 j=3,4
+*
+* we also hide in this array the corresponding real value
+* in (j,2) and (2,j), and the untransformed in (j,j).
+* Not beuatiful, but we need these to get the correct
+* Riemann sheets.
+*
+ c2sisj(j,j) = c2sisj(j,1)
+ c2sisj(j,2) = ai(j)*ai(1)*DBLE(c2sisj(j,1))
+ c2sisj(2,j) = c2sisj(j,2)
+ c2sisj(j,1) = DBLE(ai(j))*ca1*c2sisj(j,1)
+ c2sisj(1,j) = c2sisj(j,1)
+*
+ 60 continue
+ if ( lwrite ) then
+ print *,'c2sisj(1,3-4) = ',c2sisj(1,3),c2sisj(1,4)
+ print *,'c2sisj(2,3-4) = ',c2sisj(2,3),c2sisj(2,4)
+ endif
+ endif
+*
+* #] si.sj -> ti.tj:
+* #[ si.pj -> ti.qj:
+*
+* The dotproducts ti.qjk are still not too bad
+* Notice that t3.p = t4.p, so qiDqj(3,5-10) = qiDqj(4,5-10)
+*
+ ier2 = ier
+ do 90 i=1,4
+ do 80 j=1,3
+ do 70 k=j+1,4
+ ier1 = ier
+ kj = inx(k,j)
+ is = isgn(k,j)
+ if ( .not. ltest .and. i.eq.4 .and.
+ + (del2s.ne.0 .or. kj.eq.5 .or. kj.eq.7 )) then
+ qiDqj(kj,4) = qiDqj(kj,3)
+ goto 65
+ endif
+ s(1) = qiDqj(k,i)
+ s(2) = qiDqj(j,i)
+ qiDqj(kj,i) = is*(s(1) - s(2))
+ if ( abs(qiDqj(kj,i)).ge.xloss*abs(s(1)) ) goto 65
+ if ( lwrite ) print *,'qiDqj(',kj,i,') =',
+ + qiDqj(kj,i),is,s(1),s(2),ier
+ ier0 = ier
+ if ( del2s .eq. 0 ) then
+*
+* the special cases for del2s-0
+*
+ if ( kj .eq. 5 ) then
+ call ffdl2t(delps,piDpj, 7,i, 1,2,5,
+ + 1,1,10,ier0)
+ qiDqj(5,i) = ai(1)*ai(2)*ai(i)*delps/xpi(3)
+ elseif ( kj .eq. 7 ) then
+ qiDqj(kj,i) = ai(i)*ai(4)**2*piDpj(kj,i)
+ else
+*
+* the pi has a mixed delta/no delta behaviour
+*
+ call ffwarn(144,ier1,qiDqj(kj,i),s(1))
+ if ( lwrite ) print *,'in qiDqj(',kj,i,')'
+ goto 65
+ endif
+ if ( lwrite ) print *,'qiDqj(',kj,i,')+ =',
+ + qiDqj(kj,i),max(ier2,ier1)
+ goto 65
+ endif
+*
+* Normal case, from the quadratic equation ...
+*
+ ier1 = ier0
+ ier0 = ier
+ call ff2dl2(del2d2,delps,xpi,dpipj,piDpj, i,
+ + j,k,kj,is, 4, 3,4,7,+1, 10, ier0)
+ ier1 = max(ier1,ier0)
+ ier0 = ier
+ call ff2d22(dl2d22,xpi,dpipj,piDpj, i, j,k,kj,is,
+ + 3,4,7,+1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ call ffroot(dum,aijk,xpi(4),delps,dl2d22/del2s,
+ + -del2d2/sdel2s,ier1)
+* the minus sign is because we have aijk, not aikj.
+ qiDqj(kj,i) = -is*aijk*ai(i)*ai(j)*ai(k)
+ if ( lwrite ) print *,'qiDqj(',kj,i,')+ =',
+ + qiDqj(kj,i),max(ier2,ier1)
+ 65 continue
+ qiDqj(i,kj) = qiDqj(kj,i)
+ ier2 = max(ier2,ier1)
+ 70 continue
+ 80 continue
+ 90 continue
+ if ( ltest ) then
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ do 100 i=5,10
+ if ( del2s.eq.0 .and. (i.ne.5 .and. i.ne.7) ) goto 100
+ if ( lnasty .and. (i.eq.5.or.i.eq.8.or.i.eq.9)) goto 100
+ if ( rloss*abs(qiDqj(i,3)-qiDqj(i,4)) .gt. precx*
+ + abs(qiDqj(i,3)))print *,'fftran: error: t3.q',i,
+ + ' /= t4.q',i,': ',qiDqj(i,3),qiDqj(i,4),
+ + qiDqj(i,3)-qiDqj(i,4),ier
+ 100 continue
+ endif
+* #] si.pj -> ti.qj:
+* #[ pi.pj -> qi.qj:
+ do 180 i=1,3
+ do 170 j=i+1,4
+ ji = inx(j,i)
+ isgnji = isgn(j,i)
+ do 160 k=i,3
+ do 150 l=k+1,4
+ if ( k .eq. i .and. l .lt. j ) goto 150
+ ier1 = ier
+ lk = inx(l,k)
+ isgnlk = isgn(l,k)
+*
+* Some are zero by definition, or equal to others
+*
+ if ( del2s .ne. 0 .and. (ji.eq.7 .or. lk.eq.7)
+ + .or.
+ + del2s .eq. 0 .and. (ji.eq.7 .and. (lk.eq.7
+ + .or. lk.eq.5) .or. ji.eq.5 .and. lk.eq.7
+ + ) ) then
+ qiDqj(lk,ji) = 0
+ goto 145
+ endif
+ if ( j.eq.4 .and. (del2s.ne.0 .or. lk.eq.5) )
+ + then
+ qiDqj(lk,ji) = isgnji*isgn(3,i)*
+ + qiDqj(lk,inx(3,i))
+ goto 145
+ endif
+ if ( l.eq.4 .and. (del2s.ne.0 .or. ji.eq.5) )
+ + then
+ qiDqj(lk,ji) = isgnlk*isgn(3,k)*
+ + qiDqj(inx(3,k),ji)
+ goto 145
+ endif
+*
+* First normal try
+*
+ if ( abs(qiDqj(k,ji)).le.abs(qiDqj(i,lk)) ) then
+ s(1) = qiDqj(k,ji)
+ s(2) = qiDqj(l,ji)
+ is = isgnlk
+ else
+ s(1) = qiDqj(i,lk)
+ s(2) = qiDqj(j,lk)
+ is = isgnji
+ endif
+ qiDqj(lk,ji) = is*(s(2) - s(1))
+ if ( abs(qiDqj(lk,ji)) .ge. xloss**2*abs(s(1)) )
+ + goto 145
+ if ( lwrite ) print *,'qiDqj(',lk,ji,') = ',
+ + qiDqj(lk,ji),isgnji,isgnlk,s(1),s(2),ier2
+*
+* First the special case del2s=0
+*
+ if ( del2s .eq. 0 ) then
+ if ( ji .eq. 5 .and. lk .eq. 5 ) then
+ call ffdl3m(s(1),.FALSE.,x0,x0,xpi,dpipj
+ + ,piDpj, 10, 1,2,5, 7, 1,ier1)
+ qiDqj(5,5) =ai(1)**2*ai(2)**2*s(1)/xpi(3
+ + )**2
+ if ( lwrite ) print *,'qiDqj(',lk,ji,
+ + ')+ =',qiDqj(lk,ji),max(ier2,ier1)
+ else
+ call ffwarn(145,ier1,qiDqj(lk,ji),s(1))
+ endif
+ goto 145
+ endif
+*
+* Otherwise use determinants
+*
+ call ffabcd(aijkl,xpi,dpipj,piDpj,del2s,
+ + sdel2s, i,j,ji,isgnji, k,l,lk,isgnlk, 10,
+ + ifirst, ier1)
+ qiDqj(lk,ji) = (isgnji*isgnlk)*
+ + aijkl*ai(i)*ai(j)*ai(k)*ai(l)
+ if ( lwrite ) print *,'qiDqj(',lk,ji,')+ = ',
+ + qiDqj(lk,ji),max(ier2,ier1)
+ goto 145
+* print *,'fftran: warning: numerical problems ',
+* + 'in qiDqj(',lk,ji,')'
+ 145 continue
+ if ( lk .ne. ji ) then
+ qiDqj(ji,lk) = qiDqj(lk,ji)
+ else
+ xqi(ji) = qiDqj(lk,ji)
+ endif
+ ier2 = max(ier2,ier1)
+ 150 continue
+ 160 continue
+ 170 continue
+ 180 continue
+ ier = ier2
+ if ( ltest ) then
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ if ( del2s .ne. 0 ) then
+ do 810 i=1,2
+ do 800 j=i,2
+ s(1) = isgn(i,3)*isgn(j,3)*qiDqj(inx(i,3),inx(j,3))
+ s(2) = isgn(i,4)*isgn(j,4)*qiDqj(inx(i,4),inx(j,4))
+ if ( rloss*abs(s(1)-s(2)).gt.precx*max(abs(
+ + s(1)),abs(s(2))) ) print *,'fftran: error: q',i,
+ + '3.q',j,'3 /= q',i,'4.q',j,'4 : ',s(1),s(2),
+ + s(1)-s(2),ier
+ 800 continue
+ 810 continue
+ endif
+ do 830 i=1,10
+ do 820 j=i+1,10
+ if ( qiDqj(i,j) .ne. qiDqj(j,i) ) print *,
+ + 'fftran: error: qiDqj(',i,j,')/= qiDqj(',j,i,')'
+ 820 continue
+ 830 continue
+ do 840 i=1,10
+ xheck = qiDqj(i,5)+qiDqj(i,6)+qiDqj(i,7)+qiDqj(i,8)
+ smax = max(abs(qiDqj(i,5)),abs(qiDqj(i,6)),
+ + abs(qiDqj(i,7)),abs(qiDqj(i,8)))
+ if ( rloss*abs(xheck) .gt. precx*smax ) print *,
+ + 'fftran: error: No momentum conservation in ',
+ + 'qiDqj, i=',i,' j=5678 ',xheck,smax,ier
+ xheck = qiDqj(i,5)+qiDqj(i,6)+qiDqj(i,9)
+ smax = max(abs(qiDqj(i,5)),abs(qiDqj(i,6)),
+ + abs(qiDqj(i,9)))
+ if ( rloss*abs(xheck) .gt. precx*smax ) print *,
+ + 'fftran: error: No momentum conservation in ',
+ + 'qiDqj, i=',i,' j=569 ',xheck,smax,ier
+ xheck = qiDqj(i,5)+qiDqj(i,10)+qiDqj(i,8)
+ smax = max(abs(qiDqj(i,5)),abs(qiDqj(i,10)),
+ + abs(qiDqj(i,8)))
+ if ( rloss*abs(xheck) .gt. precx*smax ) print *,
+ + 'fftran: error: No momentum conservation in ',
+ + 'qiDqj, i=',i,' j=5810 ',xheck,smax,ier
+ 840 continue
+ endif
+* #] pi.pj -> qi.qj:
+* #[ si^2 - sj^2:
+*
+* the differences may be awkward
+*
+ ier2 = ier
+ do 140 i=1,4
+ dqiqj(i,i) = 0
+ do 130 j=i+1,4
+ ier0 = ier
+ dqiqj(j,i) = xqi(j) - xqi(i)
+ smax = abs(xqi(i))
+ if ( abs(dqiqj(j,i)) .ge. xloss*smax ) goto 125
+ if ( lwrite ) print *,'dqiqj(',j,i,') = ',
+ + dqiqj(j,i),xqi(j),-xqi(i),ier2
+ if ( abs(daiaj(j,i)) .le. xloss*abs(ai(i)) )
+ + then
+ s(1) = daiaj(j,i)*(ai(i)+ai(j))*xpi(j)
+ s(2) = ai(i)**2*dpipj(j,i)
+ som = s(1) + s(2)
+ xmax = abs(s(1))
+ if ( lwrite ) print *,'dqiqj(',j,i,')+ = ',
+ + som,s(1),s(2),ier2
+ if ( xmax.lt.smax ) then
+ dqiqj(j,i) = som
+ smax = xmax
+ endif
+ if ( abs(dqiqj(j,i)) .ge. xloss*smax ) goto 125
+ endif
+*
+* give up
+*
+ if ( lwarn ) call ffwarn(125,ier0,dqiqj(j,i),smax)
+ if ( lwrite ) print *,' (between qi(',i,') and qi(',j,
+ + '))'
+ 125 continue
+ dqiqj(i,j) = -dqiqj(j,i)
+ ier2 = max(ier2,ier0)
+ 130 continue
+ 140 continue
+* #] si^2 - sj^2:
+* #[ si^2 - pj^2:
+ do 210 i=1,4
+ do 200 j=1,4
+ do 190 kk=j+1,4
+ ier0 = ier
+ k = kk
+ kj = inx(k,j)
+ kkj = kj
+*
+* Use that q_(i4)^2 = q_(i3)^2
+*
+ if ( del2s.ne.0 .and. k.eq.4 ) then
+ if ( j .eq. 3 ) then
+ dqiqj(7,i) = -xqi(i)
+ else
+ dqiqj(kj,i) = dqiqj(inx(j,3),i)
+ endif
+ goto 185
+ elseif ( kj .eq. 7 ) then
+ dqiqj(7,i) = -xqi(i)
+ goto 185
+ endif
+ xmax = 0
+ 181 continue
+ som = xqi(kj) - xqi(i)
+ if ( lwrite .and. kk .ne. k ) print *,'dqiqj(',kj,i,
+ + ')4+= ',som,xqi(kj),xqi(i),ier2
+ if ( k.eq.kk .or. abs(xqi(i)).lt.xmax ) then
+ dqiqj(kj,i) = som
+ xmax = abs(xqi(i))
+ if ( abs(dqiqj(kj,i)) .ge. xloss*xmax ) goto 185
+ endif
+ if ( lwrite .and. kk .eq. k ) print *,'dqiqj(',kj,i,
+ + ') = ',dqiqj(kj,i),xqi(kj),xqi(i),ier2
+*
+* second try
+* we assume that qi.qj, i,j<=3 are known
+*
+ if ( abs(dqiqj(k,i)) .lt. abs(dqiqj(j,i)) ) then
+ j1 = k
+ j2 = j
+ else
+ j2 = k
+ j1 = j
+ endif
+ s(1) = dqiqj(j1,i)
+ s(2) = xqi(j2)
+ s(3) = -2*qiDqj(j1,j2)
+ som = s(1) + s(2) + s(3)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( lwrite ) print *,'dqiqj(',kj,i,')+ = ',
+ + som,s(1),s(2),s(3),ier2
+ if ( smax.lt.xmax ) then
+ dqiqj(kj,i) = som
+ xmax = smax
+ if ( abs(dqiqj(kj,i)) .ge. xloss*xmax ) goto 185
+ endif
+*
+* third try: rearrange s(2),s(3)
+* this works if ai(j1)~ai(j2)
+*
+ if ( abs(daiaj(j2,j1)) .lt. xloss*abs(ai(j1)) ) then
+ s(2) = ai(j2)*daiaj(j2,j1)*xpi(j2)
+ s(3) = ai(j2)*ai(j1)*dpipj(kj,j1)
+ som = s(1) + s(2) + s(3)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( lwrite ) print *,'dqiqj(',kj,i,')++= ',
+ + som,s(1),s(2),s(3),ier2
+ if ( smax.lt.xmax ) then
+ dqiqj(kj,i) = som
+ xmax = smax
+ if ( abs(dqiqj(kj,i)) .ge. xloss*xmax )
+ + goto 185
+ endif
+ endif
+*
+* There is a trick involving the other root for j2=4
+* Of course it also works for j2=3.
+*
+ if ( laai .and. j2 .ge. 3 ) then
+ s(2) = -ai(4)**2*(ai(j1)/aai(j1))*xpi(4)
+ som = s(1) + s(2)
+ smax = abs(s(1))
+ if ( lwrite ) print *,'dqiqj(',kj,i,')3+= ',
+ + som,s(1),s(2),ier2
+ if ( smax.lt.xmax ) then
+ dqiqj(kj,i) = som
+ xmax = smax
+ if ( abs(dqiqj(kj,i)) .ge. xloss*xmax )
+ + goto 185
+ endif
+ endif
+*
+* If k = 3 we can also try with k = 4 -- should give
+* the same
+*
+ if ( del2s.ne.0 .and. kk.eq.3 .and. k.eq.3 ) then
+ k = 4
+ kj = inx(k,j)
+ dqiqj(kj,i) = dqiqj(kkj,i)
+ if ( lwrite ) print *,'trying with ',kj,
+ + ' instead of ',kkj
+ goto 181
+ endif
+ if ( del2s.ne.0 .and. kk.eq.4 .and. k.eq.4 ) then
+ k = 3
+ kj = inx(k,j)
+ dqiqj(kj,i) = dqiqj(kkj,i)
+ if ( lwrite ) print *,'trying with ',kj,
+ + ' instead of ',kkj
+ goto 181
+ endif
+*
+* give up
+*
+ if ( lwarn ) call ffwarn(126,ier0,dqiqj(kj,i),xmax)
+ if ( lwrite ) print *,' (between qi(',kj,') and qi('
+ + ,i,'))'
+
+ 185 continue
+ if ( k .ne. kk ) then
+ dqiqj(kkj,i) = dqiqj(kj,i)
+ dqiqj(i,kkj) = -dqiqj(kj,i)
+ else
+ dqiqj(i,kj) = -dqiqj(kj,i)
+ endif
+ ier2 = max(ier2,ier0)
+ 190 continue
+ 200 continue
+ 210 continue
+* #] si^2 - pj^2:
+* #[ pi^2 - pj^2:
+ do 280 i=1,4
+ do 270 j=i+1,4
+ ji = inx(j,i)
+ dqiqj(ji,ji) = 0
+ do 260 k=i,4
+ do 250 l=k+1,4
+ ier0 = ier
+ if ( k .eq. i .and. l .le. j ) goto 250
+ lk = inx(l,k)
+ if ( del2s .eq. 0 ) then
+*
+* special case:
+*
+ if ( j.eq.4 .and. i.eq.3 ) then
+ dqiqj(lk,7) = xqi(lk)
+ goto 245
+ endif
+ if ( l.eq.4 .and. k.eq.3 ) then
+ dqiqj(7,ji) = -xqi(ji)
+ goto 245
+ endif
+ else
+*
+* Use that t_3.p_i = t_4.p_i
+*
+ if ( k.eq.i .and. j.eq.3 .and. l.eq.4 ) then
+ dqiqj(lk,ji) = 0
+ goto 245
+ endif
+ if ( j.eq.4 ) then
+ if ( i .eq. 3 ) then
+ dqiqj(lk,7) = xqi(lk)
+ else
+ dqiqj(lk,ji) = dqiqj(lk,inx(i,3))
+ endif
+ goto 245
+ endif
+ if ( l.eq.4 ) then
+ if ( k .eq. 3 ) then
+ dqiqj(7,ji) = -xqi(ji)
+ else
+ dqiqj(lk,ji) = dqiqj(inx(k,3),ji)
+ endif
+ goto 245
+ endif
+ endif
+*
+* We really have to calculate something
+*
+ dqiqj(lk,ji) = xqi(lk) - xqi(ji)
+ smax = abs(xqi(lk))
+ if ( abs(dqiqj(lk,ji)).ge.xloss*smax ) goto 245
+ if ( lwrite ) print *,'dqiqj(',lk,ji,') =',
+ + dqiqj(lk,ji),xqi(lk),xqi(ji),ier2
+*
+* First the special case j=k,l
+*
+ i1 = i
+ j1 = j
+ k1 = k
+ lgo = .FALSE.
+ if ( j .eq. k ) then
+ k1 = l
+ lgo = .TRUE.
+ elseif ( j .eq. l ) then
+ lgo = .TRUE.
+ elseif ( i .eq. k ) then
+ i1 = j
+ j1 = i
+ k1 = l
+ lgo = .TRUE.
+ endif
+ if ( lgo ) then
+ s(1) = dqiqj(k1,i1)
+ s(2) = 2*isgn(i1,k1)*qiDqj(j1,inx(i1,k1))
+ xmax = abs(s(1))
+ if ( xmax .lt. smax ) then
+ smax = xmax
+ dqiqj(lk,ji) = s(1) + s(2)
+ if ( lwrite ) print *,'dqiqj(',lk,ji,
+ + ')+ =',dqiqj(lk,ji),s(1),s(2),ier2
+ if ( abs(dqiqj(lk,ji)).ge.xloss*smax )
+ + goto 245
+ endif
+ endif
+*
+* Just some recombinations
+*
+ if ( abs(dqiqj(l,ji)).lt.abs(dqiqj(k,ji)) ) then
+ j1 = l
+ j2 = k
+ else
+ j2 = l
+ j1 = k
+ endif
+ s(1) = dqiqj(j1,ji)
+ s(2) = xqi(j2)
+ s(3) = -2*qiDqj(j1,j2)
+* only if this is an improvement
+ xmax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( xmax .lt. smax ) then
+ smax = xmax
+ dqiqj(lk,ji) = s(1) + s(2) + s(3)
+ if ( lwrite ) print *,'dqiqj(',lk,ji,')+1=',
+ + dqiqj(lk,ji),s(1),s(2),s(3),ier2
+ if ( abs(dqiqj(lk,ji)) .ge. xloss*smax )
+ + goto 245
+ endif
+ if ( abs(dqiqj(j,lk)).lt.abs(dqiqj(i,lk)) ) then
+ j1 = j
+ j2 = i
+ else
+ j2 = j
+ j1 = i
+ endif
+ s(1) = -dqiqj(j1,lk)
+ s(2) = -xqi(j2)
+ s(3) = 2*qiDqj(j1,j2)
+* only if this is an improvement
+ xmax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+ if ( xmax .lt. smax ) then
+ dqiqj(lk,ji) = s(1) + s(2) + s(3)
+ smax = xmax
+ if ( lwrite ) print *,'dqiqj(',lk,ji,')+2=',
+ + dqiqj(lk,ji),s(1),s(2),s(3),ier2
+ if ( abs(dqiqj(lk,ji)) .ge. xloss*smax )
+ + goto 245
+ endif
+*
+* give up
+*
+ if ( lwarn ) call ffwarn(127,ier0,dqiqj(lk,ji),
+ + smax)
+ if ( lwrite ) print *,' (between qi(',lk,
+ + ') and qi(',ji,'))'
+
+ 245 continue
+ dqiqj(ji,lk) = -dqiqj(lk,ji)
+ ier2 = max(ier2,ier0)
+ 250 continue
+ 260 continue
+ 270 continue
+ 280 continue
+ ier = ier2
+* #] pi^2 - pj^2:
+* #[ debug:
+ if ( lwrite ) then
+ print *,'fftran: transformed momenta'
+ print *,xqi
+ print '(10e16.8)',qiDqj
+ print *,'ier = ',ier
+ endif
+* #] debug:
+*###] fftran:
+ end
diff --git a/ff-2.0/ffwarn.dat b/ff-2.0/ffwarn.dat
new file mode 100644
index 0000000..0406692
--- /dev/null
+++ b/ff-2.0/ffwarn.dat
@@ -0,0 +1,294 @@
+This file is called ffwarn.dat and contains (i4) err number
+and (a80) error message. The first two lines are skipped.
+ 1 ffcb0p: warning: instability in case one mass zero, may be solved later.
+ 2 ffcb0p: warning: not enough terms in Taylor expansion ma=mb. May be serious!
+ 3 ffcb0p: warning: minimum value complex logarithm gives problem in equal masses.
+ 4 ffcb0p: warning: cancellations in equal masses (should not occur).
+ 5 ffcb0p: warning: not enough terms in expansion1 k2 zero. May be serious!
+ 6 ffcb0p: warning: not enough terms in expansion2 k2 zero, May be serious!
+ 7 ffcb0p: warning: cancellations in final adding up, contact author if serious.
+ 8 ffc1lg: warning: the combination 1-z*log(1-1/z) id unstable.
+ 9 ffcayl: warning: not enough terms in Taylor expansion, may be serious.
+ 10 ffcb0p: warning: cancellation in dotproduct s1.s2
+ 11 ffcot2: warning: cancellation in dotproduct p.si
+ 12 ffcdbp: warning: not enough terms in Taylor expansion, may be serious
+ 13 ffcdbp: warning: cancellations in case one mass equal to zero
+ 14 ffxb0p: warning: instability in case one mass zero, may be solved later.
+ 15 ffxb0p: warning: not enough terms in Taylor expansion ma=mb. May be serious!
+ 16 ffxb0p: warning: minimum value real logarithm gives problem in equal masses.
+ 17 ffxb0p: warning: cancellations in equal masses (should not occur).
+ 18 ffxb0p: warning: cancellations in equal masses, complex roots, can be avoided.
+ 19 ffxb0p: warning: not enough terms in expansion1 k2 zero, may be serious!
+ 20 ffxb0p: warning: not enough terms in expansion2 k2 zero, may be serious!
+ 21 ffxb0p: warning: cancellations between s2 and alpha, should not be serious
+ 22 ffd1lg: warning: the combination 1-z*log(1-1/z) id unstable.
+ 23 ffxb0p: warning: cancellations in lambda equal masses.
+ 24 ffxb0p: warning: cancellation in dotproduct s1.s2
+ 25 ffdot2: warning: cancellation in dotproduct p.si
+ 26 ffcc0: warning: cancellation between the two twopoint functions.
+ 27 ffcc0: warning: cancellation in final summing up.
+ 28 ffxc0: warning: cancellation between the two twopoint functions.
+ 29 ffxc0: warning: cancellation in final summing up.
+ 30 ffcc0p: warning: numerical problems in cw(j+2,1), not used
+ 31 ffcc0p: warning: cancellations in cdwz(j,i,1), not used
+ 32 ffcc0p: warning: numerical problems in cw(j+2,3), not used
+ 33 ffcc0p: warning: cancellations in cdwz(j,i,3), not used
+ 34 ffxc0p: warning: numerical problems in w(j+2,1), not used
+ 35 ffxc0p: warning: cancellations in dwz(j,i,1), not used
+ 36 ffxc0p: warning: numerical problems in cw(j+2,1), not used
+ 37 ffxc0p: warning: cancellations in cdwz(j,i,1), not used
+ 38 ffxc0p: warning: numerical problems in w(j+2,3), not used
+ 39 ffxc0p: warning: cancellations in dwz(j,i,3), not used
+ 40 ffxc0p: warning: numerical problems in cw(j+2,3), not used
+ 41 ffxc0p: warning: cancellations in cdwz(j,i,3), not used
+ 42 ffcs3: warning: problems with range complex numbers
+ 43 ffcs3: warning: cancellations in czz1 in special case
+ 44 ffcxs3: warning: cancellations in zz1 in special case
+ 45 ffdcrr: warning: not enough terms in Taylor series (may be serious)
+ 46 ffdcxr: warning: not enough terms in Taylor series (may be serious)
+ 47 ffcrr: warning: problems with dynamical range complex numbers
+ 48 ffcrr: warning: y0 = y1, so R has been taken zero
+ 49 ffcrr: warning: very large correction terms.
+ 50 ffcrr: warning: minimum value complex log causes loss of precision.
+ 51 ffcxr: warning: y0 = y1, so R has been taken zero
+ 52 ffcxr: warning: very large correction terms.
+ 53 ffcxr: warning: minimum value real log causes loss of precision.
+ 54 ffcrr: warning: not enough terms in Taylor series (may be serious)
+ 55 ffcxr: warning: not enough terms in Taylor series (may be serious)
+ 56 ffcrr: warning: cancellations in cd2yzz + czz
+ 57 ffcrr: warning: cancellations in cd2yzz - czz1
+ 58 ffcxr: warning: cancellations in d2yzz + zz
+ 59 ffcxr: warning: cancellations in d2yzz - zz1
+ 60 ffxli2: warning: not enough terms in expansion (may be serious)
+ 61 ffzli2: warning: not enough terms in expansion (may be serious)
+ 62 dfflo1: warning: not enough terms in expansion. calling log.
+ 63 zfflo1: warning: not enough terms in expansion. calling log.
+ 64 ffzxdl: warning: minimum value real log gives problems.
+ 65 ffzzdl: warning: minimum value complex log gives problems.
+ 66 ffzxdl: warning: not enough terms in expansion (may be serious)
+ 67 ffzzdl: warning: not enough terms in expansion (may be serious)
+ 68 ffclmb: warning: cancellation in calculation lambda.
+ 69 ffxlmb: warning: cancellation in calculation lambda.
+ 70 ffcel2: warning: cancellation in calculation \delta_{pi pj}^{pi pj}
+ 71 ffdel2: warning: cancellation in calculation \delta_{pi pj}^{pi pj}
+ 72 ffcel3: warning: cancellation in calculation \delta_{s1 s2 s3}^{s1 s2 s3}
+ 73 ffdel3: warning: cancellation in calculation \delta_{s1 s2 s3}^{s1 s2 s3}
+ 74 ffcl3m: warning: cancellation in (\delta_{sj sk}^{si \mu})^2
+ 75 ffdl3m: warning: cancellation in (\delta_{sj sk}^{si \mu})^2
+ 76 ffeta: warning: still cancellations. (not used)
+ 77 ffceta: warning: still cancellations. (not used)
+ 78 ffcdwz: warning: still cancelations in cw3pm - cz3mp (not used)
+ 79 ffdwz: warning: still cancelations in w3pm - z3mp (not used)
+ 80 ffdcxr: warning: minimum value real log causes problems.
+ 81 ffdcxr: warning: ieps <> iepsz, imaginary part will be wrong
+ 82 ffdcrr: warning: minimum value complex log causes problems.
+ 83 ffdl2s: warning: cancellations in delta_{s1's2'}^{s1 s2}
+ 84 ffxd0: warning: cancellation in final summing up.
+ 85 ffdl3s: warning: cancellation in calculation \delta^(si sj sk)_(sl sm sn)
+ 86 ffcc0: warning: cancellations among input parameters
+ 87 ffxc0: warning: cancellations among input parameters (import difference)
+ 88 ffabcd: warning: cancellations in (2*s3.s4^2 - s3^2*s4^2), try with del2
+ 89 ffabcd: warning: cancellations in somb
+ 90 ffabcd: warning: cancellations in d
+ 91 ffabcd: warning: xc not yet accurate (can be improved)
+ 92 ffdl2p: warning: cancellations in \delta_{p1 s2}^{p1 p2}
+ 93 ffdl2t: warning: cancellations in \delta_{p1 s4}^{s3 s4}
+ 94 ffcb0: warning: cancellations between cma and cmb (add input parameters)
+ 95 ffcb0: warning: cancellations between ck and cma (add input parameters)
+ 96 ffcb0: warning: cancellations between ck and cmb (add input parameters)
+ 97 ffxb0: warning: cancellations between xma and xmb (add input parameters)
+ 98 ffxb0: warning: cancellations between xk and xma (add input parameters)
+ 99 ffxb0: warning: cancellations between xk and xmb (add input parameters)
+100 ffdot3: warning: cancellations in dotproduct s_i.s_{i+1}
+101 ffdot3: warning: cancellations in dotproduct p_i.s_i
+102 ffdot3: warning: cancellations in dotproduct p_i.s_{i+1}
+103 ffdot3: warning: cancellations in dotproduct p_i.s_{i+2}
+104 ffdot3: warning: cancellations in dotproduct p_i.p_{i+1}
+105 ffdot4: warning: cancellations in dotproduct s_i.s_{i+1}
+106 ffdot4: warning: cancellations in dotproduct s_i.s_{i-1}
+107 ffdot4: warning: cancellations in dotproduct p_i.s_i
+108 ffdot4: warning: cancellations in dotproduct p_i.s_{i+1}
+109 ffdot4: warning: cancellations in dotproduct p_{i-1}.s_i
+110 ffdot4: warning: cancellations in dotproduct p_i.s_{i+2}
+111 ffdot4: warning: cancellations in dotproduct p_{i+1}.s_i
+112 ffdot4: warning: cancellations in dotproduct p_{i+2}.s_{i+1}
+113 ffdot4: warning: cancellations in dotproduct p_i.p_{i+1}
+114 ffdot4: warning: cancellations in dotproduct p_{i+1}.p_{i+2}
+115 ffdot4: warning: cancellations in dotproduct p_{i+2}.p_i
+116 ffdot4: warning: cancellations in dotproduct p_5.p_7
+117 ffdot4: warning: cancellations in dotproduct p_6.p_8
+118 ffdot4: warning: cancellations in dotproduct p_9.p_10
+119 ffxd0: warning: sum is close to the minimum of the range.
+120 ffxc0: warning: sum is close to the minimum of the range.
+121 ffxd0: warning: cancellations among input parameters (import difference)
+122 ff2d22: warning: cancellations (\delta_{sjsk}_{si\mu} \delta_{smsn}^{\mu\nu})^2
+123 ff2dl2: warning: cancellations \delta^{si\mu}_{sj sk} \delta^{\mu sl}_{sm sn}
+124 ff3dl2: warning: cancellations \d^{i\mu}_{jl} \d^{\mu\nu}_{lm} \d^{\nu n}_{op}
+125 fftran: warning: cancellations in s'_i^2 - s'_j^2
+126 fftran: warning: cancellations in p'_i^2 - s'_j^2
+127 fftran: warning: cancellations in p'_i^2 - p'_j^2
+128 zfflog: warning: taking log of number close to 1, must be cured.
+129 zxfflg: warning: taking log of number close to 1, must be cured.
+130 ffcrr: warning: cancellations in calculating 2y-1-z...
+131 ffxtra: warning: cancellations in extra terms, working on it
+132 dfflo1: warning: cancellations because of wrong call, should not occur
+133 zfflo1: warning: cancellations because of wrong call, should not occur
+134 ffcs4: warning: cancellations in cd2yzz + czz
+135 ffcd0: warning: cancellations among input parameters (import difference)
+136 ffcd0: warning: cancellation in final summing up.
+137 ffcd0: warning: sum is close to the minimum of the range.
+138 ffdl3p: warning: cancellations in \delta_{p1 p2 p3}^{p1 p2 p3}
+139 ffxd0p: warning: problems calculating sqrt(delta(si,s3)) - sqrt(delta(si,s4))
+140 ffdxc0: warning: problems calculating yzzy = y(4)z(3) - y(3)z(4)
+141 ffcd0p: warning: problems calculating sqrt(delta(si,s3)) - sqrt(delta(si,s4))
+142 ffdcc0: warning: problems calculating yzzy = y(4)z(3) - y(3)z(4)
+143 ffdel4: warning: cancellation in calculation \delta_{s1 s2 s3 s4}^{s1 s2 s3 s4}
+144 fftran: warning: cancellation in calculation s_i'.p_{jk}'
+145 fftran: warning: cancellation in calculation p_{ji}'.p_{lk}'
+146 fftran: warning: cancellation in calculation Ai - Aj
+147 ffdxc0: warning: problems calculating yyzz = y(4) - y(3) - z(3) + z(4)
+148 ffdxc0: warning: problems calculating cancellations extra terms
+149 ffcb0: warning: cancellations between Delta, B0' and log(m1*m2/mu^2)/2
+150 ffxb0: warning: cancellations between Delta, B0' and log(m1*m2/mu^2)/2
+151 ffzli2: warning: real part complex dilog very small and not stable
+152 ffxxyz: warning: cancellations in y - 2*z (will be solved)
+153 ffxd0: warning: cancellation in u=+p5^2+p6^2+p7^2+p8^2-p9^2-p10^2, import it!
+154 ffxd0: warning: cancellation in v=-p5^2+p6^2-p7^2+p8^2+p9^2+p10^2, import it!
+155 ffxd0: warning: cancellation in w=+p5^2-p6^2+p7^2-p8^2+p9^2+p10^2, import it!
+156 ffxc0i: warning: cancellations in dotproduct p_i.s_j
+157 ffxc0i: warning: cancellations in final summing up
+158 ffxe0: warning: cancellations among input parameters (import difference)
+159 ffdl4p: warning: cancellations in \delta_{p1 p2 p3 p4}^{p1 p2 p3 p4}
+160 ffdel5: warning: cancellation in calculation \delta_{s1s2s3s4s5}^{s1s2s3s4s5}
+161 ffxe0a: warning: cancellation in final summing up.
+162 ffxe0a: warning: sum is close to the minimum of the range.
+163 ffxc1: warning: cancellations in cc1.
+164 ffxd1: warning: cancellations in cd1.
+165 ffdl2i: warning: cancellations in \delta_{p1 p2}^{p3 p4}
+166 ffdl3q: warning: cancellations in \delta_{p5 p6 p7}^{p(i1) p(i2) p(i3)}
+167 ffxb1: warning: cancellations in cb1.
+168 ffxe0: warning: cancellations in (p_i+p_{i+2})^2, import it (may not be serious)
+169 ffdl4r: warning: cancellations in \delta_{p1 p2 p3 p4}^{s1 s2 s3 s4}
+170 ffdl4s: warning: cancellations in \delta_{p1p2p3p4}^{si pj pk pl}, to be improved
+171 ffxe1: warning: cancellations in ce1
+172 ffceta: warning: cancellations in extra terms for 4point function
+173 ffceta: warning: cancellations between alpha and w-
+174 ffceta: warning: cancellations between alpha and w+
+175 ffceta: warning: cancellations between a and z
+176 ffceta: warning: cancellations between a and y
+177 ffcdbd: warning: cancellations in summing up
+178 ffkfun: warning: cancellations between z and (m-mp)^2
+179 ffkfun: warning: 4*m*mp/(z-(m-mp)^2) ~ 1, can be solved
+180 ffxc0p: warning: \delta^{s1,s2,s3}_{s1,s2,s3} not stable, can be solved.
+181 ffxc0p: warning: cancellations in complex discriminant, can be solved
+182 ffcd0e: warning: still cancellations in del4 with only complex in poles
+183 ffcc0a: warning: cannot deal properly with threshold of this type
+184 ffcran: warning: cancellations in s'(i).p'(kj)
+185 ffcran: warning: cancellations in p'(ji).p'(lk)
+186 ffcd0p: warning: cancellations in cel2
+187 ffdel6: warning: cancellations in coefficient F0, can be improved
+188 ffdl5r: warning: cancellations in coefficient E0, can be improved
+189 ffxdi: warning: cancellations in cd2del
+190 ffxdi: warning: cancellations in cd2pp
+191 ffxf0a: warning: cancellations in F0 as sum of 6 E0's - near threshold?
+192 ffxf0a: warning: sum is close to minimum of range
+193 ffxf0: warning: cancellations among input parameters (import difference)
+194 ffxdbd: warning: cancellations in summing up
+195 ffdot6: warning: cancellations in dotproduct s_i.s_{i+1}
+196 ffdot6: warning: cancellations in dotproduct s_i.s_{i-1}
+197 ffdot6: warning: cancellations in dotproduct p_i.s_i
+198 ffdot6: warning: cancellations in dotproduct p_i.s_{i+1}
+199 ffdot6: warning: cancellations in dotproduct p_{i-1}.s_i
+200 ffdot6: warning: cancellations in dotproduct p_i.s_{i+2}
+201 ffdot6: warning: cancellations in dotproduct p_{i+1}.s_i
+202 ffdot6: warning: cancellations in dotproduct p_{i+2}.s_{i+1}
+203 ffdot6: warning: cancellations in dotproduct p_i.p_{i+1}
+204 ffdot6: warning: cancellations in dotproduct p_{i+1}.p_{i+2}
+205 ffdot6: warning: cancellations in dotproduct p_{i+2}.p_i
+206 ffdot6: warning: cancellations in dotproduct p_{i+2}.s_{i+2}
+207 ffdot6: warning: cancellations in dotproduct s_i.s{i+3}
+208 ffdot6: warning: cancellations in dotproduct pi.pj
+209 ffxdna: warning: cancellations in 1+/-a, unexpected...
+210 ffxdna: warning: cancellations in b-a, unexpected...
+211 ffcd0c: warning: cancellations in subtraction of IR pole (to be expected)
+212 ffcd0c: warning: cancellations in computation prop1 for threshold
+213 ffcd0c: warning: cancellations in computation prop2 for threshold
+214 ffxb2a: warning: cancellations in B2d
+215 ffxd0p: warning: cancellations in complex del3mi
+216 ffzcnp: warning: cancellations in y (can be fixed, contact author)
+217 ffzdnp: warning: cancellations in delta^(pi si+1)_(pi pi+1)
+218 ffzdnp: warning: cancellations in (delta^(\mu si+1)_(pi pi+1))^2
+219 ffzcnp: warning: cancellations in z (can be fixed, contact author)
+220 ffxb1: warning: not enough terms in Taylor expansion, may be serious
+221 ffxdb0: warning: cancellations in computation "diff"
+222 ffxdb0: warning: still cancellations is split-up 1
+223 ffxdb0: warning: still cancellations is s1
+224 ffxdb0: warning: cancellations in B0', complex args (can be improved)
+225 ffxb2p: warning: cancellations in B21 (after a lot of effort)
+226 ffxb2p: warning: cancellations in B22
+227 ffxb2a: warning: cancellations in B21
+228 ffxbdp: warning: cancellations in case p^2=0
+229 ffxdpv: warning: cancellations in going from delta- to PV-scheme
+230 ffxl22: warning: not enough terms in Taylor expansion Li2(2-x)
+231 dfflo2: warning: not enough terms in taylor expansion, using log(1-x)+x
+232 dfflo3: warning: not enough terms in taylor expansion, using log(1-x)+x+x^2/2
+231 zfflo2: warning: not enough terms in taylor expansion, using log(1-x)+x
+232 zfflo3: warning: not enough terms in taylor expansion, using log(1-x)+x+x^2/2
+233 ffcdbp: warning: cancellations in equal masses case
+234 ffcbdp: warning: cancellations in case p^2=0
+235 ffcbdp: warning: cancellations in small diff.
+236 ffcbdp: warning: cancellations in 1-alpha
+237 ffcbdp: warning: cancellations in s2-alpha, may not be serious
+238 ffcbdp: warning: not enough terms in Taylor expansion, may be serious
+239 ffcbdp: warning: cancellations in s1-(1-alpha), may not be serious
+240 ffcbdp: warning: cancellations in final result
+241 ffxe2: warning: cancellations in E2 (can maybe be done better)
+242 ffxe3: warning: cancellations in E3 (can maybe be done better)
+243 ffxe3: warning: cancellations in adding determinants (may not be serious)
+244 ffcdna: warning: cancellations in del45
+245 ffcdna: warning: cancellations in del543m
+246 ffcdna: warning: cancellations in B
+247 ffcdna: warning: cancellations in C
+248 ffcdna: warning: cancellations between z1 and alpha
+249 ffcdna: warning: cancellations between z2 and alpha
+250 ffcdna: warning: cancellations in 1 + r*x1
+251 ffcdna: warning: cancellations in 1 + r*x2
+252 ffcdna: warning: cancellations between r*x1 and r*x2
+263 aaxix4: warning: cancellations in inverse matrix del3; can be cured
+264 aaxdx: warning: cancellations in D310= cdxi(21)
+265 aaxdx: warning: cancellations in D39 = cdxi(20)
+266 aaxdx: warning: cancellations in D38 = cdxi(19)
+267 aaxdx: warning: cancellations in D37 = cdxi(18)
+268 aaxdx: warning: cancellations in D36 = cdxi(17)
+269 aaxdx: warning: cancellations in D35 = cdxi(16)
+270 aaxdx: warning: cancellations in D34 = cdxi(15)
+271 aaxdx: warning: cancellations in D33 = cdxi(14)
+272 aaxdx: warning: cancellations in D32 = cdxi(13)
+273 aaxdx: warning: cancellations in D31 = cdxi(12)
+274 aaxdx: warning: cancellations in D313= cdxi(24)
+275 aaxdx: warning: cancellations in D312= cdxi(23)
+276 aaxdx: warning: cancellations in D311= cdxi(22)
+277 aaxdx: warning: cancellations in D26 = cdxi(10)
+278 aaxdx: warning: cancellations in D25 = cdxi(9)
+279 aaxdx: warning: cancellations in D24 = cdxi(8)
+280 aaxdx: warning: cancellations in D23 = cdxi(7)
+281 aaxdx: warning: cancellations in D22 = cdxi(6)
+282 aaxdx: warning: cancellations in D21 = cdxi(5)
+283 aaxdx: warning: cancellations in D27 = cdxi(11)
+284 aaxcx: warning: cancellations in C34 = ccxi(11)
+285 aaxcx: warning: cancellations in C33 = ccxi(10)
+286 aaxcx: warning: cancellations in C32 = ccxi(9)
+287 aaxcx: warning: cancellations in C31 = ccxi(8)
+288 aaxcx: warning: cancellations in C36 = ccxi(13)
+289 aaxcx: warning: cancellations in C35 = ccxi(12)
+290 aaxcx: warning: cancellations in C23 = ccxi(6)
+291 aaxcx: warning: cancellations in C22 = ccxi(5)
+292 aaxcx: warning: cancellations in C21 = ccxi(4)
+293 aaxcx: warning: cancellations in C24 = ccxi(7)
+294 aabrem: warning: result is not accurate for an almost stationary particle.
+295 aabrem: warning: omega ~ lambda
+296 aabrem: warning: cancellations in vl (whatever that may be)
+297 aabrem: warning: cancellations in del2
+298 aaxbx: warning: cancellations in B2
+299 aaxbx: warning: cancellations in B1
+
diff --git a/ff-2.0/ffxb0.f b/ff-2.0/ffxb0.f
new file mode 100644
index 0000000..31bdf24
--- /dev/null
+++ b/ff-2.0/ffxb0.f
@@ -0,0 +1,1171 @@
+*###[ ffxb0:
+ subroutine ffxb0(cb0,d0,xmu,xp,xma,xmb,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the the two-point function (cf 't Hooft and Veltman) *
+* we include an overall factor 1/(i*pi^2) relative to FormF *
+* *
+* Input: d0 (real) infinity arising from renormalization *
+* xmu (real) renormalization mass *
+* xp (real) k2, in B&D metric *
+* xma (real) mass2 *
+* xmb (real) mass2 *
+* *
+* Output: cb0 (complex) B0, the two-point function, *
+* ier (integer) # of digits lost, if >=100: error *
+* *
+* Calls: ffxb0p *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cb0
+ DOUBLE PRECISION d0,xmu,xp,xma,xmb
+*
+* local variables
+*
+ integer ier0
+ DOUBLE COMPLEX cb0p,c
+ DOUBLE PRECISION dmamb,dmap,dmbp,xm,absc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffxb0: nevent,id = ',nevent,id,' input:'
+ print *,'xma,xmb,xp,ier = ',xma,xmb,xp,ier
+ endif
+ if ( ltest ) then
+ if ( xma .lt. 0 .or. xmb .lt. 0 ) then
+ print *,'ffxb0: error: xma,b < 0: ',xma,xmb
+ stop
+ endif
+ endif
+* #] check input:
+* #[ get differences:
+ ier0 = 0
+ dmamb = xma - xmb
+ dmap = xma - xp
+ dmbp = xmb - xp
+ if ( lwarn ) then
+ if ( abs(dmamb) .lt. xloss*abs(xma) .and. xma .ne. xmb )
+ + call ffwarn(97,ier0,dmamb,xma)
+ if ( abs(dmap) .lt. xloss*abs(xp) .and. xp .ne. xma )
+ + call ffwarn(98,ier0,dmap,xp)
+ if ( abs(dmbp) .lt. xloss*abs(xp) .and. xp .ne. xmb )
+ + call ffwarn(99,ier0,dmbp,xp)
+ endif
+* #] get differences:
+* #[ calculations:
+ call ffxb0p(cb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
+ if ( xma .eq. 0 ) then
+ if ( xmb .eq. 0 ) then
+ xm = x1
+ else
+ xm = xmb**2
+ endif
+ elseif ( xmb .eq. 0 ) then
+ xm = xma**2
+ else
+ xm = xma*xmb
+ endif
+ if ( xmu .ne. 0 ) xm = xm/xmu**2
+ if ( abs(xm) .gt. xalogm ) then
+ cb0 = DBLE(d0 - log(xm)/2) - cb0p
+ if ( lwarn .and. absc(cb0).lt.xloss*max(abs(d0),absc(cb0p)))
+ + call ffwarn(150,ier,absc(cb0),max(abs(d0),absc(cb0p)))
+ else
+ call fferr(4,ier)
+ cb0 = DBLE(d0) - cb0p
+ endif
+ if ( lwrite ) print *,'B0 = ',cb0,ier
+* #] calculations:
+*###] ffxb0:
+ end
+*###[ ffxb0p:
+ subroutine ffxb0p(cb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the two-point function (see 't Hooft and *
+* Veltman) for all possible cases: masses equal, unequal, *
+* equal to zero. *
+* *
+* Input: xp (real) p.p, in B&D metric *
+* xma (real) mass2, *
+* xmb (real) mass2, *
+* dm[ab]p (real) xm[ab] - xp *
+* dmamb (real) xma - xmb *
+* *
+* Output: cb0p (complex) B0, the two-point function, minus *
+* log(xm1*xm2)/2, delta and ipi^2 *
+* ier (integer) 0=ok, 1=numerical problems, 2=error *
+* *
+* Calls: ffxb0q. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cb0p
+ DOUBLE PRECISION xp,xma,xmb,dmap,dmbp,dmamb
+*
+* local variables
+*
+ integer i,initeq,initn1,iflag,jsign,init
+ DOUBLE PRECISION ax,ay,ffbnd,
+ + xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ + xprcn1,bdn101,bdn105,bdn110,bdn115,bdn120,
+ + xprnn2,bdn201,bdn205,bdn210,bdn215,bdn220,
+ + xprcn3,bdn301,bdn305,bdn310,bdn315,
+ + xprcn5,bdn501,bdn505,bdn510,bdn515,
+ + absc
+ DOUBLE PRECISION xcheck,xm,dmp,xm1,xm2,dm1m2,dm1p,
+ + dm2p,s,s1,s1a,s1b,s1p,s2,s2a,s2b,s2p,x,y,som,
+ + xlam,slam,xlogmm,alpha,alph1,xnoe,xpneq(30),
+ + xpnn1(30),xx,xtel,dfflo1
+ DOUBLE COMPLEX cs2a,cs2b,cs2p,c,cx
+ save initeq,initn1,init,xpneq,xpnn1,
+ + xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ + xprcn1,bdn101,bdn105,bdn110,bdn115,bdn120,
+ + xprnn2,bdn201,bdn205,bdn210,bdn215,bdn220,
+ + xprcn3,bdn301,bdn305,bdn310,bdn315,
+ + xprcn5,bdn501,bdn505,bdn510,bdn515
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data xprceq /-1./
+ data xprcn1 /-1./
+ data xprnn2 /-1./
+ data xprcn3 /-1./
+ data xprcn5 /-1./
+ data initeq /0/
+ data initn1 /0/
+ data init /0/
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if (ltest) then
+ xcheck = xma - xmb - dmamb
+ if ( abs(xcheck) .gt. precx*max(abs(xma),abs(xmb),abs(
+ + dmamb))/xloss ) then
+ print *,'ffxb0q: input not OK, dmamb <> xma-xmb',xcheck
+ endif
+ xcheck = -xp + xma - dmap
+ if ( abs(xcheck) .gt. precx*max(abs(xp),abs(xma),abs(
+ + dmap))/xloss ) then
+ print *,'ffxb0q: input not OK, dmap <> xma - xp',xcheck
+ endif
+ xcheck = -xp + xmb - dmbp
+ if ( abs(xcheck) .gt. precx*max(abs(xp),abs(xmb),abs(
+ + dmbp))/xloss ) then
+ print *,'ffxb0q: input not OK, dmbp <> xmb - xp',xcheck
+ endif
+ endif
+* #] check input:
+* #[ fill some dotproducts:
+ if ( ldot ) then
+ call ffdot2(fpij2,xp,xma,xmb,dmap,dmbp,dmamb,ier)
+ endif
+* #] fill some dotproducts:
+* #[ which case:
+*
+* sort according to the type of masscombination encountered:
+* 100: both masses zero, 200: one equal to zero, 300: both equal
+* 400: rest.
+*
+ if ( xma .eq. 0 ) then
+ if ( xmb .eq. 0 ) then
+ goto 100
+ endif
+ xm = xmb
+ dmp = dmbp
+ goto 200
+ endif
+ if ( xmb .eq. 0 ) then
+ xm = xma
+ dmp = dmap
+ goto 200
+ elseif ( dmamb .eq. 0 ) then
+ xm = xma
+ dmp = dmap
+ goto 300
+ elseif ( xma .gt. xmb ) then
+ xm2 = xma
+ xm1 = xmb
+ dm1m2 = -dmamb
+ dm1p = dmbp
+ dm2p = dmap
+ else
+ xm1 = xma
+ xm2 = xmb
+ dm1m2 = dmamb
+ dm1p = dmap
+ dm2p = dmbp
+ endif
+ goto 400
+* #] which case:
+* #[ both masses equal to zero:
+ 100 continue
+ if ( xp .lt. -xalogm ) then
+ cb0p = log(-xp) - 2
+ elseif ( xp .gt. xalogm ) then
+ cb0p = DCMPLX( DBLE(log(xp) - 2), DBLE(-pi) )
+ else
+ cb0p = 0
+ call fferr(7,ier)
+ endif
+ return
+* #] both masses equal to zero:
+* #[ one mass equal to zero:
+ 200 continue
+*
+* special case xp = 0
+*
+ if ( xp .eq. 0 ) then
+ cb0p = -1
+ goto 990
+*
+* special case xp = xm
+*
+ elseif ( dmp.eq.0 ) then
+ cb0p = -2
+ goto 990
+ endif
+*
+* Normal case:
+*
+ s1 = xp/xm
+ if ( abs(s1) .lt. xloss ) then
+ s = dfflo1(s1,ier)
+ else
+ s = log(abs(dmp/xm))
+ endif
+ s = -s*dmp/xp
+ cb0p = s - 2
+ if ( xp .gt. xm )
+ + cb0p = cb0p - DCMPLX(DBLE(x0),DBLE(-(dmp/xp)*pi))
+ if ( lwarn .and. absc(cb0p) .lt. xloss*x2 )
+ + call ffwarn(14,ier,absc(cb0p),x2)
+ goto 990
+* #] one mass equal to zero:
+* #[ both masses equal:
+ 300 continue
+*
+* Both masses are equal. Not only this speeds up things, some
+* cancellations have to be avoided as well.
+*
+* first a special case
+*
+ if ( abs(xp) .lt. 8*xloss*xm ) then
+* -#[ taylor expansion:
+*
+* a Taylor expansion seems appropriate as the result will go
+* as k^2 but seems to go as 1/k !!
+*
+*--#[ data and bounds:
+ if ( initeq .eq. 0 ) then
+ initeq = 1
+ xpneq(1) = x1/6
+ do 1 i=2,30
+ xpneq(i) = - xpneq(i-1)*DBLE(i-1)/DBLE(2*(2*i+1))
+ 1 continue
+ endif
+ if (xprceq .ne. precx ) then
+*
+* calculate the boundaries for the number of terms to be
+* included in the taylorexpansion
+*
+ xprceq = precx
+ bdeq01 = ffbnd(1,1,xpneq)
+ bdeq05 = ffbnd(1,5,xpneq)
+ bdeq11 = ffbnd(1,11,xpneq)
+ bdeq17 = ffbnd(1,17,xpneq)
+ bdeq25 = ffbnd(1,25,xpneq)
+ endif
+*--#] data and bounds:
+ x = -xp/xm
+ ax = abs(x)
+ if ( lwarn .and. ax .gt. bdeq25 ) then
+ call ffwarn(15,ier,precx,abs(xpneq(25))*ax**25)
+ endif
+ if ( ax .gt. bdeq17 ) then
+ som = x*(xpneq(18) + x*(xpneq(19) + x*(xpneq(20) +
+ + x*(xpneq(21) + x*(xpneq(22) + x*(xpneq(23) +
+ + x*(xpneq(24) + x*(xpneq(25) ))))))))
+ else
+ som = 0
+ endif
+ if ( ax .gt. bdeq11 ) then
+ som = x*(xpneq(12) + x*(xpneq(13) + x*(xpneq(14) +
+ + x*(xpneq(15) + x*(xpneq(16) + x*(xpneq(17) + som ))))
+ + ))
+ endif
+ if ( ax .gt. bdeq05 ) then
+ som = x*(xpneq(6) + x*(xpneq(7) + x*(xpneq(8) + x*(
+ + xpneq(9) + x*(xpneq(10) + x*(xpneq(11) + som ))))))
+ endif
+ if ( ax .gt. bdeq01 ) then
+ som = x*(xpneq(2) + x*(xpneq(3) + x*(xpneq(4) + x*(
+ + xpneq(5) + som ))))
+ endif
+ cb0p = x*(xpneq(1)+som)
+ if (lwrite) then
+ print *,'ffxb0q: m1 = m2, Taylor expansion in ',x
+ endif
+ goto 990
+* -#] taylor expansion:
+ endif
+* -#[ normal case:
+*
+* normal case
+*
+ call ffxlmb(xlam,-xp,-xm,-xm,dmp,dmp,x0,ier)
+ if ( xlam .ge. 0 ) then
+* cases 1,2 and 4
+ slam = sqrt(xlam)
+ s2a = dmp + xm
+ s2 = s2a + slam
+ if ( abs(s2) .gt. xloss*slam ) then
+* looks fine
+ jsign = 1
+ else
+ s2 = s2a - slam
+ jsign = -1
+ endif
+ ax = abs(s2/(2*xm))
+ if ( ax .lt. xalogm ) then
+ if ( lwarn ) call ffwarn(16,ier,ax,xalogm)
+ s = 0
+ elseif( ax-1 .lt. .1 .and. s2 .gt. 0 ) then
+* In this case a quicker and more accurate way is to
+* calculate log(1-x).
+ s2 = (xp - slam)
+* the following line is superfluous.
+ if ( lwarn .and. abs(s2) .lt. xloss*slam )
+ + call ffwarn(17,ier,s2,slam)
+ s = -slam/xp*dfflo1(s2/(2*xm),ier)
+ else
+* finally the normal case
+ s = -slam/xp*log(ax)
+ if ( jsign .eq. -1 ) s = -s
+ endif
+ if ( xp .gt. 2*xm ) then
+* in this case ( xlam>0, so xp>(2*m)^2) ) there also
+* is an imaginary part
+ y = -pi*slam/xp
+ else
+ y = 0
+ endif
+ else
+* the root is complex (k^2 between 0 and (2*m1)^2)
+ slam = sqrt(-xlam)
+ s = 2*slam/xp*atan2(xp,slam)
+ y = 0
+ endif
+ if (lwrite) print *,'s = ',s
+ xx = s - 2
+ if ( lwarn .and. abs(xx).lt.xloss*2 ) call ffwarn(18,ier,xx,x2)
+ cb0p = DCMPLX(DBLE(xx),DBLE(y))
+ goto 990
+* -#] normal case:
+*
+* #] both masses equal:
+* #[ unequal nonzero masses:
+* -#[ get log(xm2/xm1):
+ 400 continue
+ x = xm2/xm1
+ if ( 1 .lt. xalogm*x ) then
+ call fferr(8,ier)
+ xlogmm = 0
+ elseif ( abs(x-1) .lt. xloss ) then
+ xlogmm = dfflo1(dm1m2/xm1,ier)
+ else
+ xlogmm = log(x)
+ endif
+* -#] get log(xm2/xm1):
+* -#[ xp = 0:
+*
+* first a special case
+*
+ if ( xp .eq. 0 ) then
+ s2 = ((xm2+xm1) / dm1m2)*xlogmm
+ s = - s2 - 2
+* save the factor 1/2 for the end
+ if (lwrite) print *,'s = ',s/2
+* save the factor 1/2 for the end
+ if ( abs(s) .lt. xloss*2 ) then
+* Taylor expansions: choose which one
+ x = dm1m2/xm1
+ ax = abs(x)
+ if ( ax .lt. .15 .or. precx .gt. 1.E-8 .and. ax
+ + .lt. .3 ) then
+*
+* This is the simple Taylor expansion 'n1'
+*
+*--#[ data and bounds:
+* get the coefficients of the taylor expansion
+ if ( initn1 .eq. 0 ) then
+ initn1 = 1
+ do 410 i = 1,30
+ 410 xpnn1(i) = DBLE(i)/DBLE((i+1)*(i+2))
+ endif
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn1 .ne. precx ) then
+ xprcn1 = precx
+ bdn101 = ffbnd(1,1,xpnn1)
+ bdn105 = ffbnd(1,5,xpnn1)
+ bdn110 = ffbnd(1,10,xpnn1)
+ bdn115 = ffbnd(1,15,xpnn1)
+ bdn120 = ffbnd(1,20,xpnn1)
+ endif
+*--#] data and bounds:
+* calculate:
+ if ( lwarn .and. ax .gt. bdn120 )
+ + call ffwarn(19,ier,precx,abs(xpnn1(20))*ax**19)
+ if ( ax .gt. bdn115 ) then
+ s = x*(xpnn1(16) + x*(xpnn1(17) + x*(xpnn1(18) +
+ + x*(xpnn1(19) + x*(xpnn1(20)) ))))
+ else
+ s = 0
+ endif
+ if ( ax .gt. bdn110 ) then
+ s = x*(xpnn1(11) + x*(xpnn1(12) + x*(xpnn1(13) +
+ + x*(xpnn1(14) + x*(xpnn1(15)) + s))))
+ endif
+ if ( ax .gt. bdn105 ) then
+ s = x*(xpnn1(6) + x*(xpnn1(7) + x*(xpnn1(8) + x*
+ + (xpnn1(9) + x*(xpnn1(10) + s)))))
+ endif
+ if ( ax .gt. bdn101 ) then
+ s = x*(xpnn1(2) + x*(xpnn1(3) + x*(xpnn1(4) + x*
+ + (xpnn1(5) +s))))
+ endif
+ s = x*x*(xpnn1(1) + s)
+ if (lwrite) then
+ print *,'ffxb0q: xp = 0, simple Taylor exp'
+ print *,' in ',x
+ print *,' gives s ',s/2
+ endif
+ else
+*
+* This is the more complicated Taylor expansion 'fc'
+*
+* #[ bounds:
+* determine the boundaries for 1,5,10,15 terms for
+* the exponential taylor expansion, assuming it
+* starts at n=2.
+*
+ if ( xprnn2 .ne. precx ) then
+ xprnn2 = precx
+ bdn201 = ffbnd(4,1,xinfac)
+ bdn205 = ffbnd(4,5,xinfac)
+ bdn210 = ffbnd(4,10,xinfac)
+ bdn215 = ffbnd(4,15,xinfac)
+ bdn220 = ffbnd(4,20,xinfac)
+ endif
+* #] bounds:
+* calculate:
+ y = 2*x/(2-x)
+ ay = abs(y)
+ if ( lwarn .and. ay .gt. bdn220 )
+ + call ffwarn(20,ier,precx,xinfac(23)*ay**23)
+ if ( ay .gt. bdn220 ) then
+ s = y*(xinfac(19) + y*(xinfac(20) + y*(xinfac(
+ + 21) + y*(xinfac(22) + y*(xinfac(
+ + 23) )))))
+ else
+ s = 0
+ endif
+ if ( ay .gt. bdn215 ) then
+ s = y*(xinfac(14) + y*(xinfac(15) + y*(xinfac(
+ + 16) + y*(xinfac(17) + y*(xinfac(
+ + 18) + s)))))
+ endif
+ if ( ay .gt. bdn210 ) then
+ s = y*(xinfac(9) + y*(xinfac(10) + y*(xinfac(11)
+ + + y*(xinfac(12) + y*(xinfac(13) + s)))))
+ endif
+ if ( ay .gt. bdn205 ) then
+ s = y*(xinfac(5) + y*(xinfac(6) + y*(xinfac(7) +
+ + y*(xinfac(8) + s))))
+ endif
+ s = (1-x)*y**4*(xinfac(4)+s)
+ s = x*y**2*(1+y)/12 - s
+ s = - 2*dfflo1(s,ier)/y
+ if (lwrite) then
+ print *,'ffxb0q: xp = 0, other Taylor expansion'
+ print *,' in ',y
+ print *,' s = ',s/2
+ endif
+ endif
+ endif
+ cb0p = s/2
+ goto 990
+ endif
+* -#] xp = 0:
+* -#[ normal case:
+*
+* proceeding with the normal case
+*
+ call ffxlmb(xlam,-xp,-xm2,-xm1,dm2p,dm1p,dm1m2,ier)
+ if ( xlam .gt. 0 ) then
+* cases k^2 < -(m2+m1)^2 or k^2 > -(m2-m1)^2:
+*--#[ first try:
+* first try the normal way
+ iflag = 0
+ slam = sqrt(xlam)
+ s2a = dm2p + xm1
+ s2 = s2a + slam
+ if ( abs(s2) .gt. xloss*slam ) then
+* looks fine
+ jsign = 1
+ else
+ s2 = s2a - slam
+ jsign = -1
+ endif
+ s2 = s2**2/(4*xm1*xm2)
+ if ( abs(s2) .lt. xalogm ) then
+ call fferr(9,ier)
+ s2 = 0
+ elseif ( abs(s2-1) .lt. xloss ) then
+ if ( jsign.eq.1 ) then
+ if ( lwrite ) print *,'s2 was ',-slam/(2*xp)*log(s2)
+ s2 = -slam*(s2a+slam)/(2*xm1*xm2)
+ s2 = -slam/(2*xp)*dfflo1(s2,ier)
+ else
+ if ( lwrite ) print *,'s2 was ',+slam/(2*xp)*log(s2)
+ s2 = +slam*(s2a-slam)/(2*xm1*xm2)
+ s2 = +slam/(2*xp)*dfflo1(s2,ier)
+ endif
+ if ( lwrite ) print *,'s2 is ',s2,jsign
+ else
+ s2 = -slam/(2*xp)*log(s2)
+ if ( jsign .eq. -1 ) s2 = -s2
+ endif
+ s1 = -dm1m2*xlogmm/(2*xp)
+ xx = s1+s2-2
+ if (lwrite) then
+ print *,'ffxb0q: lam>0, first try, xx = ',xx,s1,s2,-2
+ endif
+*--#] first try:
+ if ( abs(xx) .lt. xloss*max(abs(s1),abs(s2)) ) then
+*--#[ second try:
+* this is unacceptable, try a better solution
+ s1a = dm1m2 + slam
+ if (lwrite) print *,'s1 = ',-s1a/(2*xp),slam/(2*xp)
+ if ( abs(s1a) .gt. xloss*slam ) then
+* (strangely) this works
+ s1 = -s1a/(2*xp)
+ else
+* by division a more accurate form can be found
+ s1 = ( -xp/2 + xm1 + xm2 ) / ( slam - dm1m2 )
+ if (lwrite) print *,'s1+= ',s1
+ endif
+ s1 = s1*xlogmm
+ if ( abs(xp) .lt. xm2 ) then
+ s2a = xp - dm1m2
+ else
+ s2a = xm2 - dm1p
+ endif
+ s2 = s2a - slam
+ if (lwrite) print *,'s2 = ',s2/(2*xm2),slam/(2*xm2)
+ if ( abs(s2) .gt. xloss*slam ) then
+* at least reasonable
+ s2 = s2 / (2*xm2)
+ else
+* division again
+ s2 = (2*xp) / (s2a+slam)
+ if (lwrite) print *,'s2+= ',s2
+ endif
+ if ( abs(s2) .lt. .1 ) then
+* choose a quick way to get the logarithm
+ s2 = dfflo1(s2,ier)
+ else
+ s2a = abs(1-s2)
+ s2 = log(s2a)
+ endif
+ s2 = -(slam/xp)*s2
+ xx = s1 + s2 - 2
+ if (lwrite) then
+ print *,'ffxb0q: lam>0, second try, xx = ',xx
+ alpha = slam/(slam-dm1m2)
+ alph1 = -dm1m2/(slam-dm1m2)
+ print *,' alpha = ',alpha
+ print *,' s1 = ',s1,',- 2alph1 = ',s1-2*alph1
+ print *,' s2 = ',s2,',- 2alpha = ',s2-2*alpha
+ endif
+*--#] second try:
+ if ( abs(xx) .lt. xloss**2*max(abs(s1),abs(s2)) ) then
+*--#[ third try:
+* (we accept two times xloss because that's the same
+* as in this try)
+* A Taylor expansion might work. We expand
+* inside the logs. Only do the necessary work.
+*
+ alpha = slam/(slam-dm1m2)
+ alph1 = -dm1m2/(slam-dm1m2)
+*
+* First s1:
+*
+ s1p = s1 - 2*alph1
+ if ( abs(s1p) .lt. xloss*abs(s1) ) then
+* -#[ bounds:
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn3 .ne. precx ) then
+ xprcn3 = precx
+ bdn301 = ffbnd(3,1,xinfac)
+ bdn305 = ffbnd(3,5,xinfac)
+ bdn310 = ffbnd(3,10,xinfac)
+ bdn315 = ffbnd(3,15,xinfac)
+ endif
+* -#] bounds:
+ xnoe = -xp + 2*xm1 + 2*xm2
+ x = 4*dm1m2/xnoe
+ ax = abs(x)
+ if ( lwarn .and. ax .gt. bdn315 ) then
+ call ffwarn(21,ier,precx,xinfac(17)*ax**14)
+ endif
+ if ( ax .gt. bdn310 ) then
+ s1a = x*(xinfac(13) + x*(xinfac(14) + x*(
+ + xinfac(15) + x*(xinfac(16) + x*(
+ + xinfac(17))))))
+ else
+ s1a = 0
+ endif
+ if ( ax .gt. bdn305 ) then
+ s1a = x*(xinfac(8) + x*(xinfac(9) + x*(
+ + xinfac(10) + x*(xinfac(11) + x*(
+ + xinfac(12) + s1a)))))
+ endif
+ if ( ax .gt. bdn301 ) then
+ s1a = x*(xinfac(4) + x*(xinfac(5) + x*(
+ + xinfac(6) + x*(xinfac(7) + s1a))))
+ endif
+ s1a = x**3 *(xinfac(3) + s1a) *xm2/xm1
+ s1b = dm1m2*(4*dm1m2**2 - xp*(4*xm1-xp))/
+ + (xm1*xnoe**2)
+ s1p = s1b - s1a
+ if ( lwarn .and. abs(s1p).lt.xloss*abs(s1a) )
+ + call ffwarn(22,ier,s1p,s1a)
+ s1p = xnoe*dfflo1(s1p,ier)/(slam - dm1m2)/2
+ if (lwrite) then
+ print *,'ffxb0q: Taylor exp. of s1-2(1-a)'
+ print *,' in x = ',x
+ print *,' gives s1p = ',s1p
+ endif
+ endif
+*
+* next s2:
+*
+ 490 s2p = s2 - 2*alpha
+ if ( abs(s2p) .lt. xloss*abs(s2) ) then
+* -#[ bounds:
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn5 .ne. precx ) then
+ xprcn5 = precx
+ bdn501 = ffbnd(4,1,xinfac)
+ bdn505 = ffbnd(4,5,xinfac)
+ bdn510 = ffbnd(4,10,xinfac)
+ bdn515 = ffbnd(4,15,xinfac)
+ endif
+* -#] bounds:
+ xnoe = slam - dm1m2
+ x = 2*xp/xnoe
+ ax = abs(x)
+ if ( ax .gt. bdn515 ) then
+* do not do the Taylor expansion
+ if ( lwarn ) call ffwarn(23,ier,s2p,s2)
+ goto 495
+ endif
+ if ( ax .gt. bdn510 ) then
+ s2a = x*(xinfac(14) + x*(xinfac(15) + x*(
+ + xinfac(16) + x*(xinfac(17) + x*(
+ + xinfac(18))))))
+ else
+ s2a = 0
+ endif
+ if ( ax .gt. bdn505 ) then
+ s2a = x*(xinfac(9) + x*(xinfac(10) + x*(
+ + xinfac(11) + x*(xinfac(12) + x*(
+ + xinfac(13) + s2a)))))
+ endif
+ if ( ax .gt. bdn501 ) then
+ s2a = x*(xinfac(5) + x*(xinfac(6) + x*(
+ + xinfac(7) + x*(xinfac(8) + s2a))))
+ endif
+ s2a = x**4*(xinfac(4)+s2a)*(1-2*xp/(xnoe+xp))
+ s2b = -2*xp**3 *(-2*xp - xnoe)/(3*(xnoe+xp)*
+ + xnoe**3)
+ s2p = s2b - s2a
+ if ( lwarn .and. abs(s2p).lt.xloss*abs(s2a) )
+ + call ffwarn(24,ier,s2p,s2a)
+ s2p = -slam/xp*dfflo1(s2p,ier)
+ if (lwrite) then
+ print *,'ffxb0q: Taylor expansion of s2-2a'
+ print *,' in x = ',x
+ print *,' gives s2p = ',s2p
+ endif
+ endif
+*
+* finally ...
+*
+ 495 xx = s1p + s2p
+ if ( lwarn .and. abs(xx) .lt. xloss*abs(s1p) ) then
+ call ffwarn(25,ier,xx,s1p)
+ endif
+*--#] third try:
+ endif
+ endif
+ if ( xp .gt. xm1+xm2 ) then
+*--#[ imaginary part:
+* in this case ( xlam>0, so xp>(m1+m2)^2) ) there also
+* is an imaginary part
+ y = -pi*slam/xp
+ else
+ y = 0
+*--#] imaginary part:
+ endif
+ else
+* the root is complex (k^2 between -(m1+m2)^2 and -(m2-m1)^2)
+*--#[ first try:
+ slam = sqrt(-xlam)
+ xnoe = dm2p + xm1
+ s1 = -(dm1m2/(2*xp))*xlogmm
+ s2 = (slam/xp)*atan2(slam,xnoe)
+ xx = s1 + s2 - 2
+ if (lwrite) then
+ print *,'ffxb0q: lam<0, first try, xx = ',xx
+ alpha = -xlam/(2*xp*xnoe)
+ alph1 = -(xp**2-dm1m2**2)/(2*xp*xnoe)
+ print *,' alpha = ',alpha
+ print *,' s1 = ',s1,' - 2alph1 = ',s1-2*alph1
+ print *,' s2 = ',s2,' - 2alpha = ',s2-2*alpha
+ endif
+*--#] first try:
+ if ( abs(xx) .lt. xloss**2*max(abs(s1),abs(s2)) ) then
+*--#[ second try:
+* Again two times xloss as we'll accept that in the next
+* step as well.
+*
+ xtel = dm1m2**2 - xp**2
+ alpha = -xlam/(2*xp*xnoe)
+ alph1 = xtel/(2*xp*xnoe)
+*
+* try a taylor expansion on the terms. First s1:
+*
+ s1p = s1 - 2*alph1
+ if ( abs(s1p) .lt. xloss*abs(s1) ) then
+* -#[ bounds:
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn3 .ne. precx ) then
+ xprcn3 = precx
+ bdn301 = ffbnd(3,1,xinfac)
+ bdn305 = ffbnd(3,5,xinfac)
+ bdn310 = ffbnd(3,10,xinfac)
+ bdn315 = ffbnd(3,15,xinfac)
+ endif
+* -#] bounds:
+ x = 2*xtel/(dm1m2*xnoe)
+ ax = abs(x)
+ if ( ax .gt. bdn315 ) then
+* do not do the Taylor expansion
+ if ( lwarn ) call ffwarn(21,ier,s1p,s1)
+ goto 590
+ endif
+ if ( ax .gt. bdn310 ) then
+ s1a = x*(xinfac(13) + x*(xinfac(14) + x*(
+ + xinfac(15) + x*(xinfac(16) + x*(
+ + xinfac(17))))))
+ else
+ s1a = 0
+ endif
+ if ( ax .gt. bdn305 ) then
+ s1a = x*(xinfac(8) + x*(xinfac(9) + x*(
+ + xinfac(10) + x*(xinfac(11) + x*(
+ + xinfac(12) + s1a)))))
+ endif
+ if ( ax .gt. bdn301 ) then
+ s1a = x*(xinfac(4) + x*(xinfac(5) + x*(
+ + xinfac(6) + x*(xinfac(7) + s1a))))
+ endif
+ s1a = x**3 *(xinfac(3) + s1a) *xm2/xm1
+ s1b = (dm1m2**3*(dm1m2**2-2*xp*xm1) + xp**2*(4*
+ + dm1m2*xm1**2-dm1m2**2*(dm1m2+2*xm1))-2*xm2*
+ + xp**3*(dm1m2+xp))/(xm1*dm1m2**2*xnoe**2)
+ s1p = s1b - s1a
+ if ( lwarn .and. abs(s1p) .lt. xloss*abs(s1a) )
+ + call ffwarn(22,ier,s1p,s1a)
+ s1p = -dm1m2*dfflo1(s1p,ier)/(2*xp)
+ if (lwrite) then
+ print *,'ffxb0q: Taylor expansion of s1-2(1-a)'
+ print *,' in x = ',x
+ print *,' gives s1p = ',s1p
+ endif
+ endif
+*
+* next s2:
+*
+ 590 continue
+ s2p = s2 - 2*alpha
+ if ( abs(s2p) .lt. xloss*abs(s2) ) then
+* -#[ bounds:
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn3 .ne. precx ) then
+ xprcn3 = precx
+ bdn301 = ffbnd(3,1,xinfac)
+ bdn305 = ffbnd(3,5,xinfac)
+ bdn310 = ffbnd(3,10,xinfac)
+ bdn315 = ffbnd(3,15,xinfac)
+ endif
+* -#] bounds:
+ cx = DCMPLX(DBLE(x0),DBLE(-slam/xnoe))
+ ax = absc(cx)
+ if ( ax .gt. bdn315 ) then
+ if ( lwarn ) call ffwarn(23,ier,s2p,s2)
+ goto 600
+ endif
+ if ( ax .gt. bdn310 ) then
+ cs2a = cx*(DBLE(xinfac(13)) + cx*(DBLE(xinfac(14
+ + )) + cx*(DBLE(xinfac(15)) + cx*(DBLE(xinfac(16
+ + )) + cx*(DBLE(xinfac(17)))))))
+ else
+ cs2a = 0
+ endif
+ if ( ax .gt. bdn305 ) then
+ cs2a = cx*(DBLE(xinfac(8)) + cx*(DBLE(xinfac(9))
+ + + cx*(DBLE(xinfac(10)) + cx*(DBLE(xinfac(11))
+ + + cx*(DBLE(xinfac(12)) + cs2a)))))
+ endif
+ if ( ax .gt. bdn301 ) then
+ cs2a = cx*(DBLE(xinfac(4)) + cx*(DBLE(xinfac(5))
+ + + cx*(DBLE(xinfac(6)) + cx*(DBLE(xinfac(7))
+ + + cs2a))))
+ endif
+ cs2a = cx**3*(DBLE(xinfac(3))+cs2a)*
+ + DCMPLX(DBLE(xnoe),DBLE(slam))
+ cs2b = DCMPLX(DBLE(xnoe-xlam/xnoe/2),
+ + -DBLE(slam**3/xnoe**2/2))
+ cs2p = cs2b + cs2a
+ if ( lwarn .and. absc(cs2p) .lt. xloss*absc(cs2a) )
+ + call ffwarn(24,ier,absc(cs2p),absc(cs2b))
+ s2p = slam*atan2(DIMAG(cs2p),DBLE(cs2p))/xp
+ if (lwrite) then
+ print *,'ffxb0q: Taylor expansion of s2-2a'
+ print *,' in x = ',cx
+ print *,' gives s2p = ',s2p
+ endif
+ endif
+ 600 continue
+ xx = s1p + s2p
+ if ( lwarn .and. abs(xx) .lt. xloss*abs(s1p) ) then
+ call ffwarn(25,ier,xx,s1p)
+ endif
+*--#] second try:
+ endif
+ y = 0
+ endif
+ cb0p = DCMPLX(DBLE(xx),DBLE(y))
+ goto 990
+* -#] normal case:
+* #] unequal nonzero masses:
+* #[ debug:
+ 990 continue
+ if (lwrite) then
+ print *,'cb0p = ',cb0p,ier
+ endif
+* #] debug:
+*###] ffxb0p:
+ end
+*###[ ffxlmb:
+ subroutine ffxlmb(xlambd,a1,a2,a3,a12,a13,a23,ier)
+***#[*comment:***********************************************************
+* calculate in a numerically stable way *
+* lambda(a1,a2,a3) = *
+* a1**2 + a2**2 + a3**2 - 2*a2*a3 - 2*a3*a1 - 2*a1*a2 *
+* aij = ai - aj are required for greater accuracy at times *
+* ier is the usual error flag. *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xlambd,a1,a2,a3,a12,a13,a23
+*
+* local variables
+*
+ DOUBLE PRECISION aa1,aa2,aa3,aa12,aa13,aa23,
+ + xcheck,a,aff,asq
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ calculations:
+ aa1 = abs(a1)
+ aa2 = abs(a2)
+ aa3 = abs(a3)
+ aa12 = abs(a12)
+ aa13 = abs(a13)
+ aa23 = abs(a23)
+ if (ltest) then
+* xcheck input
+ xcheck = a1 - a2 - a12
+ if ( xloss*abs(xcheck) .gt. precx*max(aa1,aa2,aa12) )
+ + print *,'ffxlmb: input not OK, a12 /= a1 - a2',a12,a1,
+ + a2,xcheck
+ xcheck = a1 - a3 - a13
+ if ( xloss*abs(xcheck) .gt. precx*max(aa1,aa3,aa13) )
+ + print *,'ffxlmb: input not OK, a13 /= a1 - a3',a13,a3,
+ + a3,xcheck
+ xcheck = a2 - a3 - a23
+ if ( xloss*abs(xcheck) .gt. precx*max(aa2,aa3,aa23) )
+ + print *,'ffxlmb: input not OK, a23 /= a2 - a3',a23,a2,
+ + a3,xcheck
+ endif
+*
+* first see if there are input parameters with opposite sign:
+*
+ if ( a1 .lt. 0 .and. a2 .gt. 0 .or.
+ + a1 .gt. 0 .and. a2 .lt. 0 ) then
+ goto 12
+ elseif ( a1 .lt. 0 .and. a3 .gt. 0 .or.
+ + a1 .gt. 0 .and. a3 .lt. 0 ) then
+ goto 13
+*
+* all have the same sign, choose the smallest 4*ai*aj term
+*
+ elseif ( aa1 .gt. aa2 .and. aa1 .gt. aa3 ) then
+ goto 23
+ elseif ( aa2 .gt. aa3 ) then
+ goto 13
+ else
+ goto 12
+ endif
+ 12 continue
+ if ( aa1 .gt. aa2 ) then
+ a = a13 + a2
+ else
+ a = a1 + a23
+ endif
+ aff = 4*a1*a2
+ goto 100
+ 13 continue
+ if ( aa1 .gt. aa3 ) then
+ a = a12 + a3
+ else
+ a = a1 - a23
+ endif
+ aff = 4*a1*a3
+ goto 100
+ 23 continue
+ if ( aa2 .gt. aa3 ) then
+ a = a12 - a3
+ else
+ a = a13 - a2
+ endif
+ aff = 4*a2*a3
+ 100 continue
+ asq = a**2
+ xlambd = asq - aff
+ if ( lwarn .and. abs(xlambd) .lt. xloss*asq )
+ + call ffwarn(69,ier,xlambd,asq)
+* #] calculations:
+*###] ffxlmb:
+ end
+*###[ ffclmb:
+ subroutine ffclmb(clambd,cc1,cc2,cc3,cc12,cc13,cc23,ier)
+***#[*comment:***********************************************************
+* calculate in cc numerically stable way *
+* lambda(cc1,cc2,cc3) = *
+* cc1**2 + cc2**2 + cc3**2 - 2*cc2*cc3 - 2*cc3*cc1 - 2*cc1*cc2 *
+* cij = ci - cj are required for greater accuracy at times *
+* ier is the usual error flag. *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX clambd,cc1,cc2,cc3,cc12,cc13,cc23
+*
+* local variables
+*
+ DOUBLE PRECISION aa1,aa2,aa3,aa12,aa13,aa23,absc
+ DOUBLE COMPLEX check,cc,cff,csq,c
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ calculations (rather old style ...):
+ aa1 = absc(cc1)
+ aa2 = absc(cc2)
+ aa3 = absc(cc3)
+ aa12 = absc(cc12)
+ aa13 = absc(cc13)
+ aa23 = absc(cc23)
+ if (ltest) then
+* check input
+ check = cc1 - cc2 - cc12
+ if ( xloss*absc(check) .gt. precc*max(aa1,aa2,aa12) ) then
+ print *,'ffclmb: input not OK, cc12 /= cc1 - cc2',check
+ endif
+ check = cc1 - cc3 - cc13
+ if ( xloss*absc(check) .gt. precc*max(aa1,aa3,aa13) ) then
+ print *,'ffclmb: input not OK, cc13 /= cc1 - cc3',check
+ endif
+ check = cc2 - cc3 - cc23
+ if ( xloss*absc(check) .gt. precc*max(aa2,aa3,aa23) ) then
+ print *,'ffclmb: input not OK, cc23 /= cc2 - cc3',check
+ endif
+ endif
+*
+* first see if there are input parameters with opposite sign:
+*
+ if ( DBLE(cc1) .lt. 0 .and. DBLE(cc2) .gt. 0 .or.
+ + DBLE(cc1) .gt. 0 .and. DBLE(cc2) .lt. 0 ) then
+ goto 12
+ elseif ( DBLE(cc1) .lt. 0 .and. DBLE(cc3) .gt. 0 .or.
+ + DBLE(cc1) .gt. 0 .and. DBLE(cc3) .lt. 0 ) then
+ goto 13
+*
+* all have the same sign, choose the smallest 4*ci*cj term
+*
+ elseif ( aa1 .gt. aa2 .and. aa1 .gt. aa3 ) then
+ goto 23
+ elseif ( aa2 .gt. aa3 ) then
+ goto 13
+ else
+ goto 12
+ endif
+ 12 continue
+ if ( aa1 .gt. aa2 ) then
+ cc = cc13 + cc2
+ else
+ cc = cc1 + cc23
+ endif
+ cff = 4*cc1*cc2
+ goto 100
+ 13 continue
+ if ( aa1 .gt. aa3 ) then
+ cc = cc12 + cc3
+ else
+ cc = cc1 - cc23
+ endif
+ cff = 4*cc1*cc3
+ goto 100
+ 23 continue
+ if ( aa2 .gt. aa3 ) then
+ cc = cc12 - cc3
+ else
+ cc = cc13 - cc2
+ endif
+ cff = 4*cc2*cc3
+ 100 continue
+ csq = cc**2
+ clambd = csq - cff
+ if ( lwarn .and. absc(clambd) .lt. xloss*absc(csq) )
+ + call ffwarn(68,ier,absc(clambd),absc(csq))
+* #] calculations (rather old style ...):
+*###] ffclmb:
+ end
+*###[ ffdot2:
+ subroutine ffdot2(piDpj,xp,xma,xmb,dmap,dmbp,dmamb,ier)
+***#[*comment:***********************************************************
+* *
+* Store the 3 dotproducts in the common block ffdot. *
+* *
+* Input: see ffxb0p *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION piDpj(3,3),xp,xma,xmb,dmap,dmbp,dmamb
+*
+* local variables
+*
+ integer ier0,ier1
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+* absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ work:
+ ier1 = ier
+ piDpj(1,1) = xma
+ piDpj(2,2) = xmb
+ piDpj(3,3) = xp
+ if ( abs(dmap) .lt. abs(dmbp) ) then
+ piDpj(1,2) = (dmap + xmb)/2
+ else
+ piDpj(1,2) = (dmbp + xma)/2
+ endif
+ piDpj(2,1) = piDpj(1,2)
+ if ( lwarn .and. abs(piDpj(1,2)) .lt. xloss*min(xma,xmb)/2
+ + ) then
+ call ffwarn(24,ier1,piDpj(1,2),min(xma,xmb)/2)
+ endif
+ if ( abs(dmamb) .lt. abs(dmbp) ) then
+ piDpj(1,3) = (-dmamb - xp)/2
+ else
+ piDpj(1,3) = (dmbp - xma)/2
+ endif
+ piDpj(3,1) = piDpj(1,3)
+ if ( lwarn .and. abs(piDpj(1,3)) .lt. xloss*min(xma,
+ + abs(xp))/2) then
+ ier0 = ier
+ call ffwarn(25,ier0,piDpj(1,3),min(xma,abs(xp))/2)
+ ier1 = max(ier0,ier1)
+ endif
+ if ( abs(dmamb) .lt. abs(dmap) ) then
+ piDpj(2,3) = (-dmamb + xp)/2
+ else
+ piDpj(2,3) = (-dmap + xmb)/2
+ endif
+ piDpj(3,2) = piDpj(2,3)
+ if ( lwarn .and. abs(piDpj(2,3)) .lt. xloss*min(xmb,
+ + abs(xp))/2) then
+ ier0 = ier
+ call ffwarn(25,ier0,piDpj(2,3),min(xmb,abs(xp))/2)
+ ier1 = max(ier0,ier1)
+ endif
+ ier = ier1
+* #] work:
+*###] ffdot2:
+ end
diff --git a/ff-2.0/ffxb1.f b/ff-2.0/ffxb1.f
new file mode 100644
index 0000000..602c4cb
--- /dev/null
+++ b/ff-2.0/ffxb1.f
@@ -0,0 +1,372 @@
+*###[ ffxb1:
+ subroutine ffxb1(cb1,cb0,ca0i,xp,xm1,xm2,piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate 1 / d^n Q Q(mu) *
+* ------ | ------------------------ = B1*p(mu) *
+* i pi^2 / (Q^2-m1^2)((Q+p)^2-m2^2) *
+* *
+* Input: cb0 complex scalar twopoint function *
+* ca0i(2) complex scalar onepoint function with *
+* m1,m2 *
+* xp real p.p in B&D metric *
+* xm1,2 real m_1^2,m_2^2 *
+* piDpj(3,3) real dotproducts between s1,s2,p *
+* ier integer digits lost so far *
+* Output: cb1 complex B1 *
+* ier integer digits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xp,xm1,xm2,piDpj(3,3)
+ DOUBLE COMPLEX cb1,cb0,ca0i(2)
+*
+* local variables
+*
+ integer ier0
+ DOUBLE PRECISION dm1p,dm2p,dm1m2
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ get differences:
+ ier0 = 0
+ dm1m2 = xm1 - xm2
+ dm1p = xm1 - xp
+ dm2p = xm2 - xp
+ if ( lwarn ) then
+ if ( abs(dm1m2) .lt. xloss*abs(xm1) .and. xm1 .ne. xm2 )
+ + call ffwarn(97,ier0,dm1m2,xm1)
+ if ( abs(dm1p) .lt. xloss*abs(xp) .and. xp .ne. xm1 )
+ + call ffwarn(98,ier0,dm1p,xp)
+ if ( abs(dm2p) .lt. xloss*abs(xp) .and. xp .ne. xm2 )
+ + call ffwarn(99,ier0,dm2p,xp)
+ endif
+* #] get differences:
+* #[ call ffxb1a:
+ call ffxb1a(cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj,ier)
+* #] call ffxb1a:
+*###] ffxb1:
+ end
+*###[ ffxb1a:
+ subroutine ffxb1a(cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj,
+ + ier)
+***#[*comment:***********************************************************
+* *
+* Calculate 1 / d^n Q Q(mu) *
+* ------ | ------------------------ = B1*p(mu) *
+* i pi^2 / (Q^2-m1^2)((Q+p)^2-m2^2) *
+* *
+* Input: cb0 complex scalar twopoint function *
+* ca0i(2) complex scalar onepoint function with *
+* m1,m2 *
+* xp real p.p in B&D metric *
+* xm1,2 real m_1^2,m_2^2 *
+* piDpj(3,3) real dotproducts between s1,s2,p *
+* ier integer digits lost so far *
+* Output: cb1 complex B1 *
+* ier integer digits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj(3,3)
+ DOUBLE COMPLEX cb1,cb0,ca0i(2)
+*
+* local variables
+*
+ integer i,ier0
+ logical lneg
+ DOUBLE PRECISION xmax,absc,s,s1,h,slam,bnd101,bnd105,bnd110,
+ + bnd115,xma,xmb,x,ax,xlogm,small,dmbma,xprec,xlam,ts2Dp,
+ + xnul,rloss,xmxp,xlo3,dfflo3
+ DOUBLE COMPLEX cs(5),cc,csom
+ DOUBLE PRECISION ffbnd,dfflo1
+ save xprec,bnd101,bnd105,bnd110,bnd115
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* data
+*
+ data xprec /0./
+*
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ rloss = xloss**2*DBLE(10)**(-mod(ier,50))
+ xmax = max(xm1,xm2,abs(xp))
+ xnul = 2*piDpj(1,2) - xm1 - xm2 + xp
+ if ( rloss*abs(xnul) .gt. precx*xmax ) print *,
+ + 'ffxb1a: error: s1.s2 wrong: ',2*piDpj(1,2),xm1+xm2-xp,
+ + xnul,ier
+ xnul = 2*piDpj(1,3) + xm1 - xm2 + xp
+ if ( rloss*abs(xnul) .gt. precx*xmax ) print *,
+ + 'ffxb1a: error: s1.p wrong: ',2*piDpj(1,3),-xm1+xm2-xp,
+ + xnul,ier
+ xnul = 2*piDpj(2,3) + xm1 - xm2 - xp
+ if ( rloss*abs(xnul) .gt. precx*xmax ) print *,
+ + 'ffxb1a: error: s2.p wrong: ',2*piDpj(2,3),-xm1+xm2+xp,
+ + xnul,ier
+ endif
+* #] check input:
+* #[ p^2 != 0:
+ if ( xp .ne. 0 ) then
+* #[ normal case:
+ if ( dm1m2 .ne. 0 ) then
+ cs(1) = -ca0i(2)
+ cs(2) = +ca0i(1)
+ else
+ cs(1) = 0
+ cs(2) = 0
+ endif
+ cs(3) = +DBLE(2*piDpj(1,3))*cb0
+ cb1 = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( absc(cb1) .ge. xloss*xmax ) goto 110
+* #] normal case:
+* #[ almost equal masses:
+ if ( abs(dm1m2) .le. xloss*xm1 ) then
+ if ( lwrite ) print *,'Using algorithms for dm1m2 small'
+ cs(2) = DBLE(dm1m2/xm1)*cs(2)
+ cs(1) = -xm2*dfflo1(-dm1m2/xm2,ier)
+ if ( lwrite ) print *,'cb1 was',cb1,xmax
+ cb1 = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( lwrite ) print *,'cb1 is ',cb1,xmax
+ if ( absc(cb1) .ge. xloss*xmax ) goto 110
+* for the perfectionist (not me (today)):
+* if d0=0 and mu~m1(~m2), then the terms of order
+* (m1^2-m2^2) also cancel. To patch this I need d0 and mu
+ endif
+* #] almost equal masses:
+* #[ p2 -> 0:
+ if ( xloss**2*max(xm1,xm2) .gt. abs(xp) ) then
+ if ( xm2.gt.xm1 ) then
+ xma = xm1
+ xmb = xm2
+ ts2Dp = +2*piDpj(2,3)
+ lneg = .FALSE.
+ else
+ xma = xm2
+ xmb = xm1
+ ts2Dp = -2*piDpj(1,3)
+ lneg = .TRUE.
+ endif
+ else
+ goto 100
+ endif
+*
+* We found a situation in which p2 is much smaller than
+* the masses.
+*
+ if ( lwrite ) print *,'Using algorithms for p2 small'
+ dmbma = abs(dm1m2)
+ if ( xma.eq.0 ) then
+ xlogm = 1
+ elseif ( dmbma .gt. xloss*xmb ) then
+ xlogm = log(xmb/xma)
+ else
+ xlogm = dfflo1(-dmbma/xma,ier)
+ endif
+ xlam = (dmbma-xp)**2 - 4*xma*xp
+ if ( xlam.gt.0 ) then
+* #[ real roots:
+ slam = sqrt(xlam)
+ small = xp*(-2*(xma+xmb) + xp)/(slam+dmbma)
+ if ( lwrite ) then
+ print *,'small = ',small
+ print *,'vgl ',slam-dmbma,slam
+ endif
+ h = slam+2*piDpj(1,2)
+ cs(1) = xlogm*xma*(4*xmb*(small-xp) + (small-xp)**2)/(2*
+ + (slam+dmbma)*h)
+ if ( lwrite ) then
+ print *,'cs(1) = ',cs(1)
+ print *,'vgl ',
+ + +xma*xlogm*(x05+(xma+xmb-xp/2)/(slam-xma+xmb))
+ + +xmb*xlogm*(x05-(xma+xmb-xp/2)/(slam-xma+xmb))
+ endif
+ if ( xprec.ne.precx ) then
+ xprec = precx
+ bnd101 = ffbnd(2,1,xinfac)
+ bnd105 = ffbnd(2,5,xinfac)
+ bnd110 = ffbnd(2,10,xinfac)
+ bnd115 = ffbnd(2,15,xinfac)
+ endif
+ x = xp/slam
+ if ( lwrite ) print *,'Taylor expansion in ',x
+ ax = abs(x)
+ if ( lwarn .and. ax.gt.bnd115 )
+ + call ffwarn(220,ier,precx,xinfac(16)*ax**14)
+ if ( ax.gt.bnd110 ) then
+ s = x*(xinfac(12) + x*(xinfac(13) + x*(xinfac(14) +
+ + x*(xinfac(15) + x*xinfac(16) ))))
+ else
+ s = 0
+ endif
+ if ( ax.gt.bnd105 ) then
+ s = x*(xinfac(7) + x*(xinfac(8) + x*(xinfac(9) +
+ + x*(xinfac(10) + x*(xinfac(11) + s )))))
+ endif
+ if ( ax.gt.bnd101) then
+ s = x*(xinfac(3) + x*(xinfac(4) + x*(xinfac(5) +
+ + x*(xinfac(6) + s ))))
+ endif
+ s = x**2*(x05 + s)
+ h = ts2Dp + slam
+ s1 = 2*xp/h*(s + x)
+ h = -4*xp**2*xmb/(slam*h**2) - s + s1
+ if ( lwarn .and. abs(h) .lt. xloss*max(abs(s),abs(s1)) )
+ + then
+ call ffwarn(221,ier,h,max(abs(s),abs(s1)))
+ endif
+ if ( lwrite ) then
+ print *,'arg ',h
+ print *,'vgl ',1-(1-2*xp/(xp+dmbma+slam))*exp(xp/
+ + slam)
+ endif
+ if ( abs(h) .lt. .1 ) then
+ cs(2) = dmbma*slam/xp*dfflo1(h,ier)
+ else
+ if ( lwrite ) then
+ print *,
+ + 'ffxb1: warning: I thought this was small: ',h
+ print *,' xp,xma,xmb = ',xp,xma,xmb
+ endif
+ goto 100
+ endif
+ if ( lneg ) then
+ cs(1) = -cs(1)
+ cs(2) = -cs(2)
+ endif
+ cs(3) = -DBLE(xp)*cb0
+ if ( lwrite ) print *,'cb1 was',cb1,xmax
+ cb1 = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( lwrite ) then
+ print *,'cb1 is ',cb1,xmax
+ print *,'cs = ',cs
+ endif
+ if ( absc(cb1) .gt. xloss*xmax) goto 110
+*
+* this still occurs in the case xp << dmamb << xma,
+* with a cancellation of order dmamb/xma between cs1 and
+* cs2; as the standard model does not contain these kind
+* of doublets I leave this as an exercise for the
+* reader...
+*
+* #] real roots:
+ else
+* #[ imaginary roots:
+ if ( lwrite ) print *,'Cannot handle p^2 small, ',
+ + 'with imaginary roots yet'
+* #] imaginary roots:
+ endif
+* #] p2 -> 0:
+* #[ give up:
+*
+* give up...
+*
+ 100 continue
+ if ( lwarn ) then
+ call ffwarn(167,ier,absc(cb1),xmax)
+ if ( lwrite ) then
+ print *,'cs(i) = ',cs
+ print *,'xp,xm1,xm2 = ',xp,xm1,xm2
+ endif
+ endif
+ 110 continue
+* #] give up:
+ cb1 = cb1*(1/DBLE(2*xp))
+* #] p^2 != 0:
+* #[ p^2=0, m1 != m2:
+ elseif ( dm1m2 .ne. 0 ) then
+ cs(1) = +DBLE(xm2/(2*dm1m2**2))*(ca0i(2)+DBLE(xm2)/2)
+ cs(2) = -DBLE(xm1/(2*dm1m2**2))*(ca0i(1)+DBLE(xm1)/2)
+ cs(3) = +ca0i(2)*(1/DBLE(dm1m2))
+ cb1 = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)))
+ if ( absc(cb1).ge.xloss**2*xmax ) goto 120
+ if ( lwrite ) then
+ print *,'cb1 = ',cb1,xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,3)
+ endif
+*
+* m1 ~ m2, see b21.frm
+*
+ if ( abs(dm1m2).lt.xloss*xm1 ) then
+ xlogm = dfflo1(dm1m2/xm1,ier)
+ else
+ xlogm = log(xm2/xm1)
+ endif
+ cs(1) = -(xm1/dm1m2)/2
+ cs(2) = -xlogm/2*(xm1/dm1m2)**2
+ cs(3) = +1/DBLE(4) - ca0i(1)*DBLE(1/(2*xm1))
+ cs(4) = xlogm/2
+ csom = cs(1) + cs(2) + cs(3) + cs(4)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)))
+ if ( lwrite ) then
+ print *,'cb1+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,4)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb1 = csom
+ if ( absc(cb1).gt.xloss**2*xmax ) goto 120
+ endif
+*
+* better
+*
+ xlo3 = dfflo3(dm1m2/xm1,ier)
+ cs(1) = -(dm1m2/xm1)**2/4
+ cs(2) = -(dm1m2/xm1)/2
+ cs(3) = -xlo3/(dm1m2/xm1)**2/2
+ cs(4) = xlo3/2
+ cs(5) = 1/DBLE(2) - ca0i(1)*DBLE(1/(2*xm1))
+ csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
+ if ( lwrite ) then
+ print *,'cb1+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,5)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb1 = csom
+ if ( absc(cb1).gt.xloss**2*xmax ) goto 120
+ endif
+*
+* give up
+*
+ if ( lwarn ) then
+ if ( absc(cb1) .lt. xloss*xmax )
+ + call ffwarn(167,ier,absc(cb1),xmax)
+ endif
+ 120 continue
+* #] p^2=0, m1 != m2:
+* #[ p^2=0, m1 == m2:
+ else
+ cb1 = -cb0/2
+ endif
+* #] p^2=0, m1 == m2:
+*###] ffxb1a:
+ end
diff --git a/ff-2.0/ffxb2p.f b/ff-2.0/ffxb2p.f
new file mode 100644
index 0000000..8b6a369
--- /dev/null
+++ b/ff-2.0/ffxb2p.f
@@ -0,0 +1,487 @@
+*###[ ffxb2p:
+ subroutine ffxb2p(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu) *
+* of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2) *
+* originally based on aaxbx by Andre Aeppli. *
+* *
+* Input: cb1 complex vector two point function *
+* cb0 complex scalar two point function *
+* ca0i(2) complex scalar onepoint function with *
+* m1,m2 *
+* xp real p.p in B&D metric *
+* xm1,2 real m_1^2,m_2^2 *
+* piDpj(3,3) real dotproducts between s1,s2,p *
+* ier integer digits lost so far *
+* *
+* Output: cb2i(2) complex B21,B22: coeffs of p*p, g in B2 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xp,xm1,xm2,piDpj(3,3)
+ DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
+*
+* local variables
+*
+ DOUBLE PRECISION dm1p,dm2p,dm1m2
+*
+* #] declarations:
+* #[ work:
+*
+ dm1p = xm1 - xp
+ dm2p = xm2 - xp
+ dm1m2= xm1 - xm2
+ call ffxb2q(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,
+ + piDpj,ier)
+*
+* #] work:
+*###] ffxb2p:
+ end
+*###[ ffxb2q:
+ subroutine ffxb2q(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,
+ + piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu) *
+* of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2) *
+* originally based on aaxbx by Andre Aeppli. *
+* *
+* Input: cb1 complex vector two point function *
+* cb0 complex scalar two point function *
+* ca0i(2) complex scalar onepoint function with *
+* m1,m2 *
+* xp real p.p in B&D metric *
+* xm1,2 real m_1^2,m_2^2 *
+* piDpj(3,3) real dotproducts between s1,s2,p *
+* ier integer digits lost so far *
+* *
+* Output: cb2i(2) complex B21,B22: coeffs of p*p, g in B2 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj(3,3)
+ DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
+*
+* local variables
+*
+ integer i,j,ier0,ier1
+ logical llogmm
+ DOUBLE PRECISION xmax,absc,xlam,slam,alp,bet,xmxp,dfflo3,xlo3,
+ + xmxsav,xnoe,xnoe2,xlogmm,dfflo1,rloss,
+ + qiDqj(3,3)
+ DOUBLE COMPLEX cs(16),cc,csom,clo2,clo3,zfflo2,zfflo3
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ test input:
+ if ( ltest ) then
+ ier0 = ier
+ call ffdot2(qiDqj,xp,xm1,xm2,dm1p,dm2p,dm1m2,ier0)
+ rloss = xloss*DBLE(10)**(-mod(ier0,50))
+ do 20 j=1,3
+ do 10 i=1,3
+ if ( rloss*abs(piDpj(i,j)-qiDqj(i,j)).gt.precx*
+ + abs(piDpj(i,j))) print *,'ffxb2q: error: piDpj('
+ + ,i,j,') wrong: ',piDpj(i,j),qiDqj(i,j),
+ + piDpj(i,j)-qiDqj(i,j),ier0
+ 10 continue
+ 20 continue
+ endif
+* #] test input:
+* #[ normal case:
+ ier0 = ier
+ ier1 = ier
+*
+* with thanks to Andre Aeppli, off whom I stole the original
+*
+ if ( xp .ne. 0) then
+ cs(1) = ca0i(2)
+ cs(2) = DBLE(xm1)*cb0
+ cs(3) = DBLE(2*piDpj(1,3))*cb1
+ cs(4) = (xm1+xm2)/2
+ cs(5) = -xp/6
+ cb2i(1) = cs(1) - cs(2) + 2*cs(3) - cs(4) - cs(5)
+ cb2i(2) = cs(1) + 2*cs(2) - cs(3) + 2*cs(4) + 2*cs(5)
+ xmax = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
+ xmxsav = xmax
+ if ( absc(cb2i(1)) .ge. xloss*xmax ) goto 100
+ if ( lwrite ) then
+ print *,'cb2i(1) = ',cb2i(1),xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',1,cs(1),2,-cs(2),3,2*cs(3),4,
+ + -cs(4),5,-cs(5)
+ endif
+* #] normal case:
+* #[ improve: m1=m2:
+*
+* a relatively simple case: dm1m2 = 0 (bi0.frm)
+*
+ if ( dm1m2.eq.0 .and. xm1.ne.0 ) then
+ if ( xp.lt.0 ) then
+ slam = sqrt(xp**2-4*xm1*xp)
+ xlo3 = dfflo3((xp-slam)/(2*xm1),ier)
+ cs(1) = xp*(-1/DBLE(3) + slam/(4*xm1))
+ cs(2) = xp**2*(-slam/(4*xm1**2) - 3/(4*xm1))
+ cs(3) = xp**3/(4*xm1**2)
+ cs(4) = DBLE(xp/xm1)*ca0i(1)
+ cs(5) = xlo3/xp*(-xm1*slam)
+ cs(6) = xlo3*slam
+ else
+ slam = isgnal*sqrt(-xp**2+4*xm1*xp)
+ clo3 = zfflo3(DCMPLX(DBLE(xp/(2*xm1)),
+ + DBLE(-slam/(2*xm1))),ier)
+ cs(1) = DBLE(xp)*DCMPLX(-1/DBLE(3),
+ + DBLE(slam/(4*xm1)))
+ cs(2) = DBLE(xp**2)*DCMPLX(DBLE(-3/(4*xm1)),
+ + DBLE(-slam/(4*xm1**2)))
+ cs(3) = DBLE(xp**3/(4*xm1**2))
+ cs(4) = DBLE(xp/xm1)*ca0i(1)
+ cs(5) = clo3*DCMPLX(DBLE(0),DBLE(-xm1*slam/xp))
+ cs(6) = clo3*DCMPLX(DBLE(0),DBLE(slam))
+ endif
+ csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5) + cs(6)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ + absc(cs(5)),absc(cs(6)))
+*
+* get rid of noise in the imaginary part
+*
+ if ( xloss*abs(DIMAG(csom)).lt.precc*abs(DBLE(csom)) )
+ + csom = DCMPLX(DBLE(csom),DBLE(0))
+ if ( lwrite ) then
+ print *,'cb2i(1)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,6)
+ endif
+ if ( xmxp.lt.xmax ) then
+ cb2i(1) = csom
+ xmax = xmxp
+ endif
+ if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
+ endif
+* #] improve: m1=m2:
+* #[ improve: |xp| < xm1 < xm2:
+*
+* try again (see bi.frm)
+*
+ xlam = 4*(piDpj(1,3)**2 - xm1*xp)
+ if ( xm1.eq.0 .or. xm2.eq.0 ) then
+ xlogmm = 0
+ elseif ( abs(dm1m2).lt.xloss*xm1 ) then
+ xlogmm = dfflo1(dm1m2/xm1,ier)
+ else
+ xlogmm = log(xm2/xm1)
+ endif
+ if ( xlam.gt.0 .and. abs(xp).lt.xloss*xm2 .and.
+ + xm1.lt.xm2 ) then
+ slam = sqrt(xlam)
+ alp = (2*xm1*xm2/(2*piDpj(1,2)+slam) + xm1)/(slam-dm1m2)
+* bet = [xm2-xm1-xp-slam]
+ bet = 4*xm1*xp/(2*piDpj(1,3)+slam)
+ cs(1) = DBLE(xp/xm2)*ca0i(2)
+ cs(2) = xlogmm*bet*(-2*xm1**2*xm2 - 2*xm1**3)
+ + /((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
+ cs(3) = xlogmm*(-4*xp*xm1**3)
+ + /((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
+ xnoe = 1/(2*piDpj(2,3)+slam)
+ xnoe2 = xnoe**2
+ cs(4) = xnoe2*xm1*bet*(xp-4*xm2)
+ cs(5) = xnoe2*xm1*2*xp*xm2
+ cs(6) = xnoe2*xm1**2*bet
+ cs(7) = xnoe2*xm1**2*4*xp
+ cs(8) = xnoe2*bet*(xp*xm2+3*xm2**2)
+ cs(9) = xnoe2*(-6*xp*xm2**2)
+ cs(10)= xp*(7/6.d0 - 2*xm1*slam*xnoe2 +
+ + 4*xm2*slam*xnoe2 - 2*slam*xnoe)
+ cs(11)= xp**2*( -2*slam*xnoe2 )
+ xlo3 = dfflo3(2*xp*xnoe,ier)
+ cs(12) = xlo3*dm1m2**2*slam/xp**2
+ cs(13) = xlo3*(xm1 - 2*xm2)*slam/xp
+ cs(14) = xlo3*slam
+ csom = 0
+ xmxp = 0
+ do 50 i=1,14
+ csom = csom + cs(i)
+ xmxp = max(xmxp,absc(cs(i)))
+ 50 continue
+ if ( lwrite ) then
+ print *,'cb2i(1)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,14)
+ endif
+ if ( xmxp.lt.xmax ) then
+ cb2i(1) = csom
+ xmax = xmxp
+ endif
+ if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
+ endif
+* #] improve: |xp| < xm1 < xm2:
+* #[ improve: |xp| < xm2 < xm1:
+ if ( xlam.gt.0 .and. abs(xp).lt.xloss*xm1 .and.
+ + xm2.lt.xm1 ) then
+ slam = sqrt(xlam)
+ alp = (2*xm2*xm1/(2*piDpj(1,2)+slam) + xm2)/(slam+dm1m2)
+* bet = [xm1-xm2-xp-slam]
+ bet = 4*xm2*xp/(-2*piDpj(2,3)+slam)
+ xnoe = 1/(-2*piDpj(1,3)+slam)
+ xnoe2 = xnoe**2
+ cs(1) = DBLE(xp/xm1)*ca0i(1)
+ cs(2) = -xlogmm*bet*(12*xp*xm1*xm2+6*xp*xm2**2-
+ + 6*xp**2*xm2-2*xm1*xm2**2-2*xm2**3)
+ + /((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
+ cs(3) = -xlogmm*(-24*xp*xm1**2*xm2-4*xp*xm2**3+36*
+ + xp**2*xm1*xm2+12*xp**2*xm2**2-12*xp**3*xm2)
+ + /((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
+ cs(4) = xnoe2*xm2*bet*(xp-4*xm1)
+ cs(5) = xnoe2*xm2*(-10*xp*xm1)
+ cs(6) = xnoe2*xm2**2*bet
+ cs(7) = xnoe2*xm2**2*4*xp
+ cs(8) = xnoe2*bet*(xp*xm1+3*xm1**2)
+ cs(9) = xnoe2*6*xp*xm1**2
+ cs(10)= xp*(7/6.d0 - 2*xm1*slam*xnoe2 +
+ + 4*xm2*slam*xnoe2 - 2*slam*xnoe)
+ cs(11)= xp**2*( -2*slam*xnoe2 )
+ xlo3 = dfflo3(2*xp*xnoe,ier)
+ cs(12) = xlo3*dm1m2**2*slam/xp**2
+ cs(13) = xlo3*(xm1 - 2*xm2)*slam/xp
+ cs(14) = xlo3*slam
+ csom = 0
+ xmxp = 0
+ do 60 i=1,14
+ csom = csom + cs(i)
+ xmxp = max(xmxp,absc(cs(i)))
+ 60 continue
+ if ( lwrite ) then
+ print *,'cb2i(1)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,14)
+ endif
+ if ( xmxp.lt.xmax ) then
+ cb2i(1) = csom
+ xmax = xmxp
+ endif
+ if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
+ endif
+* #] improve: |xp| < xm2 < xm1:
+* #[ wrap up:
+ if ( lwarn ) then
+ call ffwarn(225,ier0,absc(cb2i(1)),xmax)
+ if ( lwrite ) then
+ print *,'xp,xm1,xm2 = ',xp,xm1,xm2
+ endif
+ endif
+ 100 continue
+ xmax = xmxsav
+ if ( absc(cb2i(2)) .lt. xloss**2*xmax ) then
+ if ( lwrite ) then
+ print *,'cb2i(2) = ',cb2i(2),xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',1,cs(1),2,2*cs(2),3,-cs(3),
+ + 4,2*cs(4)
+ endif
+*
+ if ( lwarn ) then
+ call ffwarn(226,ier1,absc(cb2i(2)),xmax)
+ endif
+ 110 continue
+ if ( lwrite ) print *,'cb2i(2)+= ',cb2i(2)
+ endif
+ cb2i(1) = DBLE(1/(3*xp)) * cb2i(1)
+ cb2i(2) = DBLE(1/6.d0) * cb2i(2)
+* #] wrap up:
+* #[ xp=0, m1!=m2:
+ elseif (dm1m2 .ne. 0) then
+* #[ old code:
+* first calculate B21
+* cs(1) = +DBLE(xm1*xm1/dm1m2) * ca0i(1)
+* cs(2) = - xm1*xm1/dm1m2 * xm1
+* cs(3) = -DBLE((3*xm1**2-3*xm1*xm2+xm2**2)/dm1m2) * ca0i(2)
+* cs(4) = + (3*xm1**2-3*xm1*xm2+xm2**2)/dm1m2 * xm2
+* cs(5) = (11*xm1**2-7*xm1*xm2+2*xm2**2)/6
+**
+* cb2i(2) = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
+* if ( lwarn ) then
+* xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)),
+* + absc(cs(4)),absc(cs(5)))
+* if ( absc(cb2i(2)) .lt. xloss*xmax )
+* + call ffwarn(298,ier0,absc(cb2i(2)),xmax)
+* endif
+* cb2i(1)=1/(3*dm1m2**2) * cb2i(2)
+* B22 in the same way as with xp diff from zero
+* 18-nov-1993 fixed sign error in cs(2) GJ
+* cs(1) = ca0i(2)
+* cs(2) =+DBLE(2*xm1)*cb0
+* cs(3) = DBLE(dm1m2)*cb1
+* cs(4) = xm1+xm2
+* cb2i(2) = cs(1) + cs(2) + cs(3) + cs(4)
+* if ( lwarn ) then
+* xmax = max(absc(cs(1)),absc(cs(3)),absc(cs(4)))
+* if ( absc(cb2i(2)) .lt. xloss*xmax )
+* + call ffwarn(298,ier1,absc(cb2i(2)),xmax)
+* endif
+* cb2i(2) = cb2i(2)/6
+* #] old code:
+* #[ B21:
+ llogmm = .FALSE.
+*
+* B21 (see thesis, b21.frm)
+*
+ cs(1) = DBLE(xm1**2/3/dm1m2**3)*ca0i(1)
+ cs(2) = DBLE((-xm1**2 + xm1*xm2 - xm2**2/3)/dm1m2**3)*
+ + ca0i(2)
+ cs(3) = (5*xm1**3/18 - xm1*xm2**2/2 + 2*xm2**3/9)
+ + /dm1m2**3
+ cb2i(1) = cs(1)+cs(2)+cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
+ if ( lwrite ) then
+ print *,'cb2i(1) = ',cb2i(1),xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,3)
+ endif
+*
+* ma ~ mb
+*
+ if ( abs(dm1m2).lt.xloss*xm1 ) then
+ xlogmm = dfflo1(dm1m2/xm1,ier)
+ else
+ xlogmm = log(xm2/xm1)
+ endif
+ llogmm = .TRUE.
+ cs(1) = (xm1/dm1m2)/6
+ cs(2) = (xm1/dm1m2)**2/3
+ cs(3) = (xm1/dm1m2)**3*xlogmm/3
+ cs(4) = -2/DBLE(9) + ca0i(1)*DBLE(1/(3*xm1))
+ cs(5) = -xlogmm/3
+ csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ + absc(cs(5)))
+ if ( lwrite ) then
+ print *,'cb2i(1)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,5)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb2i(1) = csom
+ if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
+ endif
+*
+* and last try
+*
+ xlo3 = dfflo3(dm1m2/xm1,ier)
+ cs(1) = (dm1m2/xm1)**2/6
+ cs(2) = (dm1m2/xm1)/3
+ cs(3) = xlo3/(3*(dm1m2/xm1)**3)
+*same cs(4) = -2/DBLE(9) + ca0i(1)*DBLE(1/(3*xm1))
+ cs(5) = -xlo3/3
+ csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ + absc(cs(5)))
+ if ( lwrite ) then
+ print *,'cb2i(1)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,5)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb2i(1) = csom
+ if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
+ endif
+*
+* give up
+*
+ if ( lwarn ) then
+ call ffwarn(225,ier,absc(cb2i(1)),xmax)
+ if ( lwrite ) then
+ print *,'xp,xm1,xm2 = ',xp,xm1,xm2
+ endif
+ endif
+ 160 continue
+* #] B21:
+* #[ B22:
+*
+* B22
+*
+ cs(1) = +DBLE(xm1/(4*dm1m2))*ca0i(1)
+ cs(2) = -DBLE(xm2/(4*dm1m2))*ca0i(2)
+ cs(3) = (xm1+xm2)/8
+ cb2i(2) = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
+ if ( lwrite ) then
+ print *,'cb2i(2) = ',cb2i(2),xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,3)
+ endif
+*
+* second try, close together
+*
+ if ( .not.llogmm ) then
+ if ( abs(dm1m2).lt.xloss*xm1 ) then
+ xlogmm = dfflo1(dm1m2/xm1,ier)
+ else
+ xlogmm = log(xm2/xm1)
+ endif
+ endif
+ cs(1) = dm1m2*( -1/DBLE(8) - ca0i(1)*DBLE(1/(4*xm1)) )
+ cs(2) = dm1m2*xlogmm/4
+ cs(3) = xm1*(xm1/dm1m2)/4*xlogmm
+ cs(4) = xm1*( 1/DBLE(4) + ca0i(1)*DBLE(1/(2*xm1)) )
+ cs(5) = -xm1*xlogmm/2
+ csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
+ xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ + absc(cs(5)))
+ if ( lwrite ) then
+ print *,'cb2i(2)+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,2)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb2i(2) = csom
+ endif
+ if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
+*
+* give up
+*
+ if ( lwarn ) then
+ call ffwarn(226,ier,absc(cb2i(2)),xmax)
+ if ( lwrite ) then
+ print *,'xp,xm1,xm2 = ',xp,xm1,xm2
+ endif
+ endif
+ 210 continue
+* #] B22:
+* #] xp=0, m1!=m2:
+* #[ xp=0, m1==m2:
+ else
+*
+* taken over from ffxb2a, which in turns stem from my thesis GJ
+*
+ cb2i(1) = cb0/3
+ cb2i(2) = DBLE(xm1/2)*(cb0 + 1)
+ endif
+* #] xp=0, m1==m2:
+* #[ finish up:
+ ier = max(ier0,ier1)
+* #] finish up:
+*###] ffxb2q:
+ end
diff --git a/ff-2.0/ffxc0.f b/ff-2.0/ffxc0.f
new file mode 100644
index 0000000..310a69e
--- /dev/null
+++ b/ff-2.0/ffxc0.f
@@ -0,0 +1,994 @@
+* $Id: ffxc0.f,v 1.5 1996/08/15 09:36:47 gj Exp $
+*###[ ffxc0:
+ subroutine ffxc0(cc0,xpi,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the threepoint function closely following *
+* recipe in 't Hooft & Veltman, NP B(183) 1979. *
+* Bjorken and Drell metric is used nowadays! *
+* *
+* p2 | | *
+* v | *
+* / \ *
+* m2/ \m3 *
+* p1 / \ p3 *
+* -> / m1 \ <- *
+* ------------------------ *
+* *
+* 1 / 1 *
+* = ----- \d^4Q---------------------------------------- *
+* ipi^2 / [Q^2-m1^2][(Q+p1)^2-m2^2][(Q-p3)^2-m3^2] *
+* *
+* If the function is infra-red divergent (p1=m2,p3=m3,m1=0 or *
+* cyclic) the function is calculated with a user-supplied cutoff *
+* delta in the common block /ffcut/. *
+* *
+* Input: xpi (real) i=1,3: mass^2, i=4,6: pi.pi *
+* Output: cc0 (complex) C0, the threepoint function. *
+* ier (integer) 0=ok, 1=inaccurate, 2=error *
+* Calls: ffxc0p,ffxb0p *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cc0
+ DOUBLE PRECISION xpi(6)
+ integer ier
+*
+* local variables:
+*
+ integer i,j,ier0
+ DOUBLE PRECISION dpipj(6,6)
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ convert input:
+ if ( lwrite ) then
+ print *,'ffxc0: input = ',xpi
+ endif
+ if ( lwarn ) then
+ do 30 i=1,6
+ dpipj(i,i) = 0
+ do 29 j = i+1,6
+ dpipj(j,i) = xpi(j) - xpi(i)
+ dpipj(i,j) = - dpipj(j,i)
+ if ( abs(dpipj(j,i)) .lt. xloss*abs(xpi(i)) .and.
+ + xpi(i) .ne. xpi(j) ) then
+ ier0 = 0
+ call ffwarn(87,ier0,dpipj(j,i),xpi(i))
+ if ( lwrite ) print *,'between xpi(',i,
+ + ') and xpi(',j,')'
+ endif
+ 29 continue
+ 30 continue
+ else
+ do 40 i=1,6
+ do 39 j = 1,6
+ dpipj(j,i) = xpi(j) - xpi(i)
+ 39 continue
+ 40 continue
+ endif
+* #] convert input:
+* #[ call ffxc0a:
+ call ffxc0a(cc0,xpi,dpipj,ier)
+* #] call ffxc0a:
+*###] ffxc0:
+ end
+*###[ ffxc0a:
+ subroutine ffxc0a(cc0,xpi,dpipj,ier)
+***#[*comment:***********************************************************
+* *
+* See ffxc0. *
+* *
+* Input: xpi (real) i=1,3: mass^2, i=4,6: pi.pi *
+* dpipj (real) = xpi(i) - xpi(j) *
+* Output: cc0 (complex) C0, the threepoint function. *
+* ier (integer) 0=ok, 1=inaccurate, 2=error *
+* Calls: ffxc0p,ffxb0p *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cc0
+ DOUBLE PRECISION xpi(6),dpipj(6,6)
+ integer ier
+*
+* local variables:
+*
+ logical ljust
+ integer i,j,inew(6,6),idotsa,ier0
+* DOUBLE COMPLEX cs,cs1,cs2
+ DOUBLE COMPLEX c
+ DOUBLE PRECISION xqi(6),dqiqj(6,6),qiDqj(6,6),absc,delta0,
+ + dum66(6,6),rloss,xnul,xmax
+ save inew,delta0
+*
+* common blocks:
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* memory
+*
+ integer iermem(memory),ialmem(memory),memind,ierini
+ DOUBLE PRECISION xpimem(6,memory),dl2mem(memory)
+ DOUBLE COMPLEX cc0mem(memory)
+ save memind,iermem,ialmem,xpimem,dl2mem,cc0mem
+ data memind /0/
+*
+* statement function:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data delta0 /0./
+ data inew /1,2,3,4,5,6,
+ + 2,3,1,5,6,4,
+ + 3,1,2,6,4,5,
+ + 1,3,2,6,5,4,
+ + 3,2,1,5,4,6,
+ + 2,1,3,4,6,5/
+* #] declarations:
+* #[ initialisations:
+ if ( lmem .and. memind .eq. 0 ) then
+ do 2 i=1,memory
+ do 1 j=1,6
+ xpimem(j,i) = 0
+ 1 continue
+ ialmem(i) = 0
+ 2 continue
+ endif
+ idsub = 0
+ ljust = .FALSE.
+* #] initialisations:
+* #[ check input:
+ if ( ltest ) then
+* I have had too many problems here ...
+ if ( abs(isgnal) .ne. 1 ) then
+ print *,'ffxc0: error: ab(isgnal) /= 1!',isgnal
+ if ( isgnal .eq. 0 ) then
+ isgnal = 1
+ else
+ isgnal = sign(1,isgnal)
+ endif
+ endif
+* check input dot products if present
+ if ( idot.gt.0 ) then
+ ier0 = ier
+ idotsa = idot
+ idot = 0
+ call ffdot3(qiDqj,xpi,dpipj,6,ier0)
+ idot = idotsa
+ rloss = xloss**2*DBLE(10)**(-mod(ier0,50))
+ if ( idot.le.2 ) then
+ do 20 i=4,6
+ do 10 j=4,6
+ xnul = abs(fpij3(j,i)-qiDqj(j,i))
+ xmax = abs(qiDqj(j,i))
+ if ( rloss*xnul .gt. precx*xmax ) print *,
+ + 'ffxc0a: error: input dotproduct piDpj(',j,
+ + i,') wrong:',fpij3(j,i),qiDqj(j,i),xnul,ier0
+ 10 continue
+ 20 continue
+ else
+ do 40 i=1,6
+ do 30 j=1,6
+ xnul = abs(fpij3(j,i)-qiDqj(j,i))
+ xmax = abs(qiDqj(j,i))
+ if ( rloss*xnul .gt. precx*xmax ) print *,
+ + 'ffxc0a: error: input dotproduct piDpj(',j,
+ + i,') wrong:',fpij3(j,i),qiDqj(j,i),xnul,ier0
+ 30 continue
+ 40 continue
+ endif
+ endif
+ endif
+* #] check input:
+* #[ handel special cases:
+*
+* The infrared divergent diagrams are calculated in ffxc0i:
+*
+ if ( dpipj(2,4).eq.0 .and. dpipj(3,6).eq.0 .and. xpi(1).eq.0
+ + .or. dpipj(3,5).eq.0 .and. dpipj(1,4).eq.0 .and. xpi(2).eq.0
+ + .or. dpipj(1,6).eq.0 .and. dpipj(2,5).eq.0 .and. xpi(3).eq.0 )
+ + then
+ call ffxc0i(cc0,xpi,dpipj,ier)
+ return
+ endif
+**
+* The general case cannot handle xpi=0, pj=pk. These are simple
+* though.
+**
+* goto 50
+* if ( xpi(4) .eq. 0 .and. dpipj(5,6) .eq. 0 .and.
+* + dpipj(1,2) .ne. 0 ) then
+* call ffxb0p(cs1,-xpi(5),xpi(1),xpi(3),dpipj(1,6),dpipj(3,5),
+* + dpipj(1,3),ier)
+* call ffxb0p(cs2,-xpi(5),xpi(2),xpi(3),dpipj(2,5),dpipj(3,5),
+* + dpipj(2,3),ier)
+* cs = cs1 - cs2
+* cc0 = cs/dpipj(1,2)
+* elseif ( xpi(6) .eq. 0 .and. dpipj(4,5) .eq. 0 .and.
+* + dpipj(3,1) .ne. 0 ) then
+* call ffxb0p(cs1,-xpi(4),xpi(3),xpi(2),dpipj(3,5),dpipj(2,4),
+* + dpipj(3,2),ier)
+* call ffxb0p(cs2,-xpi(4),xpi(1),xpi(2),dpipj(1,4),dpipj(2,4),
+* + dpipj(1,2),ier)
+* cs = cs1 - cs2
+* cc0 = cs/dpipj(3,1)
+* elseif ( xpi(5) .eq. 0 .and. dpipj(6,4) .eq. 0 .and.
+* + dpipj(2,3) .ne. 0 ) then
+* call ffxb0p(cs1,-xpi(6),xpi(2),xpi(1),dpipj(2,4),dpipj(1,6),
+* + dpipj(2,1),ier)
+* call ffxb0p(cs2,-xpi(6),xpi(3),xpi(1),dpipj(3,6),dpipj(1,6),
+* + dpipj(3,1),ier)
+* cs = cs1 - cs2
+* cc0 = cs/dpipj(2,3)
+* else
+* goto 50
+* endif
+**
+* common piece - excuse my style
+**
+* print *,'ffcc0: WARNING: this algorithm has not yet been tested'
+* if ( lwarn .and. absc(cs) .lt. xloss*absc(cs1) )
+* + call ffwarn(28,ier,absc(cs),absc(cs1))
+**
+* debug output
+**
+* if (lwrite) then
+* print *,'simple case xpi=0,xpj=xpk, two twopoint functions:'
+* print *,cs1,cs2
+* print *,'result: cc0=',cc0,ier
+* endif
+* return
+* 50 continue
+* #] handel special cases:
+* #[ rotate to alpha in (0,1):
+ call ffrot3(irota3,xqi,dqiqj,qiDqj,xpi,dpipj,dum66,6,2,3,ier)
+* #] rotate to alpha in (0,1):
+* #[ look in memory:
+ ierini = ier+ner
+ if ( lmem .and. delta .eq. delta0 ) then
+ do 70 i=1,memory
+ do 60 j=1,6
+ if ( xqi(j) .ne. xpimem(j,i) ) goto 70
+ 60 continue
+ if ( ialmem(i) .ne. isgnal ) goto 70
+* we found an already calculated masscombination ..
+* (maybe check differences as well)
+ if ( lwrite ) print *,'ffxc0: using previous result'
+ cc0 = cc0mem(i)
+ ier = ier+iermem(i)
+ if ( ldot ) then
+ fdel2 = dl2mem(i)
+* we forgot to recalculate the stored quantities
+ ljust = .TRUE.
+ goto 71
+ endif
+ return
+ 70 continue
+* if ( lwrite ) print *,'ffxc0: not found in memory'
+ elseif ( lmem ) then
+ delta0 = delta
+ endif
+ 71 continue
+* #] look in memory:
+* #[ dot products:
+ call ffdot3(qiDqj,xqi,dqiqj,6,ier)
+*
+* save dotproducts for tensor functions if requested
+*
+ if ( ldot ) then
+ do 75 i=1,6
+ do 74 j=1,6
+ fpij3(j,i) = qiDqj(inew(i,irota3),inew(j,irota3))
+ 74 continue
+ 75 continue
+ if ( irota3 .gt. 3 ) then
+*
+* the sign of the s's has been changed!
+*
+ do 77 i=1,3
+ do 76 j=4,6
+ fpij3(j,i) = -fpij3(j,i)
+ fpij3(i,j) = -fpij3(i,j)
+ 76 continue
+ 77 continue
+ endif
+ endif
+ if ( ljust ) return
+* #] dot products:
+* #[ call ffxc0b:
+ call ffxc0b(cc0,xqi,dqiqj,qiDqj,ier)
+* #] call ffxc0b:
+* #[ add to memory:
+ if ( lmem ) then
+ memind = memind + 1
+ if ( memind .gt. memory ) memind = 1
+ do 200 j=1,6
+ xpimem(j,memind) = xqi(j)
+ 200 continue
+ cc0mem(memind) = cc0
+ iermem(memind) = ier+ner-ierini
+ ialmem(memind) = isgnal
+ dl2mem(memind) = fdel2
+ endif
+* #] add to memory:
+*###] ffxc0a:
+ end
+*###[ ffxc0b:
+ subroutine ffxc0b(cc0,xqi,dqiqj,qiDqj,ier)
+***#[*comment:***********************************************************
+* *
+* See ffxc0. *
+* *
+* Input: xpi (real) i=1,3: mass^2, i=4,6: pi.pi *
+* dpipj (real) = xpi(i) - xpi(j) *
+* Output: cc0 (complex) C0, the threepoint function. *
+* ier (integer) 0=ok, 1=inaccurate, 2=error *
+* Calls: ffxc0p,ffxb0p *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cc0
+ DOUBLE PRECISION xqi(6),dqiqj(6,6),qiDqj(6,6)
+ integer ier
+*
+* local variables:
+*
+ integer nerr
+ parameter(nerr=6)
+ integer isoort(8),ipi12(8),i,j,k,ipi12t,ilogi(3),ier0,ieri(nerr)
+ DOUBLE COMPLEX cs3(80),cs,cs1,cs2,c,clogi(3),cslam,cetalm,
+ + cetami(6),cel2s(3),clamp,calph(3),cblph(3),csdel2,
+ + cqi(6),cdqiqj(6,6),cqiDqj(6,6),celpsi(3),cdum(3),
+ + cdum2(3,3)
+ DOUBLE PRECISION del2,del2s(3),del3,delpsi(3),
+ + del3mi(3)
+ DOUBLE PRECISION xmax,absc,alph(3),etalam,etami(6),sdel2,
+ + xlamp,eta,blph(3)
+*
+* common blocks:
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* statement function:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'input: xqi,dqiqj'
+ do 1 i=1,6
+ print *,xqi(i),(dqiqj(i,j),j=1,6)
+ 1 continue
+ endif
+* #] check input:
+* #[ calculations:
+*
+* some determinants
+*
+ if ( lwrite ) print '(a)',' ##[ determinants:'
+ do 98 i = 1,nerr
+ ieri(i) = 0
+ 98 continue
+ call ffdel2(del2,qiDqj, 6, 4,5,6, 1,ier)
+ if ( lwrite ) print *,'ffxc0: del2 = ',del2
+ if ( ldot ) fdel2 = del2
+ if ( del2 .gt. 0 ) then
+* shouldn't occur ...
+* 12-10-1993 three spacelike momenta are OK
+ if ( .not.(xqi(4).lt.0 .and. xqi(5).lt.0 .and. xqi(6).lt.0)
+ + ) then
+ call fferr(41,ier)
+ print *,'xpi = ',xqi
+ endif
+ elseif ( del2 .eq. 0 ) then
+ call fferr(42,ier)
+ return
+ endif
+ call ffdel3(del3,xqi,qiDqj,6,ier)
+ call ffdl3m(del3mi,.TRUE.,del3,del2,xqi,dqiqj,qiDqj,6, 4,5,6,
+ + 1,3,ier)
+ do 101 i=1,3
+ j = i+1
+ if ( j .eq. 4 ) j = 1
+ call ffdel2(del2s(i),qiDqj,6, i+3,i,j, 1,ieri(i))
+ k = i-1
+ if ( k .eq. 0 ) k = 3
+ call ffdl2p(delpsi(i),xqi,dqiqj,qiDqj,i+3,j+3,k+3,i,j,k,6,
+ + ieri(i+3))
+ 101 continue
+ ier0 = 0
+ do 99 i=1,nerr
+ ier0 = max(ier0,ieri(i))
+ 99 continue
+ ier = ier + ier0
+*
+* initialize cs3:
+*
+ do 80 i=1,80
+ cs3(i) = 0
+ 80 continue
+ do 90 i=1,8
+ ipi12(i) = 0
+ 90 continue
+ do 100 i=1,3
+ clogi(i) = 0
+ ilogi(i) = 0
+ 100 continue
+* #[ complex case:
+* in case of three spacelike momenta or unphysical real ones
+ if ( del2 .gt. 0 ) then
+ do 102 i=1,3
+ cel2s(i) = del2s(i)
+ celpsi(i) = delpsi(i)
+ cetami(i) = del3mi(i)/del2
+ 102 continue
+ do 104 i=1,6
+ cqi(i) = xqi(i)
+ do 103 j=1,6
+ cdqiqj(j,i) = dqiqj(j,i)
+ cqiDqj(j,i) = qiDqj(j,i)
+ 103 continue
+ 104 continue
+ cetalm = del3/del2
+ csdel2 = isgnal*DCMPLX(x0,sqrt(del2))
+*
+* get alpha,1-alpha
+*
+ call ffcoot(cblph(1),calph(1),cqi(5),-cqiDqj(5,6),cqi(6),
+ + csdel2,ier)
+ call ffcoot(calph(3),cblph(3),cqi(5),-cqiDqj(5,4),cqi(4),
+ + csdel2,ier)
+ cslam = 2*csdel2
+ if (lwrite) then
+ print '(a)',' ##[ get roots: (ffxc0)'
+ print *,'cslam =',2*csdel2
+ ier0 = ier
+* call ffclmb(clamp,cqi(4),cqi(5),cqi(6),cdqiqj(4,5),
+* + cdqiqj(4,6),cdqiqj(5,6),ier0)
+* print *,'cslamp =',sqrt(clamp)
+ print *,'ceta =',-4*del3
+* call ffeta(eta,xpi,dpipj,6,ier0)
+* print *,'cetap =',eta
+ print *,'cetalam =',cetalm
+ print *,'calpha = ',calph(1),calph(3)
+ endif
+ if ( lwrite ) print '(a)',' ##] determinants:'
+ call ffcc0p(cs3,ipi12,isoort,clogi,ilogi,cqi,cdqiqj,cqiDqj,
+ + csdel2,cel2s,cetalm,cetami,celpsi,calph,3,ier)
+ goto 109
+ endif
+* #] complex case:
+ etalam = del3/del2
+ do 106 i=1,3
+ etami(i) = del3mi(i)/del2
+ 106 continue
+ if ( abs(isgnal).ne.1 ) then
+ print *,'ffxc0b: error: isgnal should be +/-1, not ',isgnal
+ print *,' forgot to call ffini?'
+ call ffini
+ endif
+ sdel2 = isgnal*sqrt(-del2)
+*
+* get alpha,1-alpha
+*
+ call ffroot(blph(1),alph(1),xqi(5),-qiDqj(5,6),xqi(6),sdel2,ier)
+ call ffroot(alph(3),blph(3),xqi(5),-qiDqj(5,4),xqi(4),sdel2,ier)
+ if ( l4also .and. ( alph(1) .gt. 1 .or. alph(1) .lt. 0 ) .and.
+ + abs(blph(1)-x05) .lt. abs(alph(1)-x05) ) then
+ alph(1) = blph(1)
+ alph(3) = blph(3)
+ sdel2 = -sdel2
+ isgnal = -isgnal
+ endif
+ cslam = 2*sdel2
+ if (lwrite) then
+ print '(a)',' ##[ get roots:'
+ print *,'slam =',2*sdel2
+* ier0 = ier
+* call ffxlmb(xlamp,xqi(4),xqi(5),xqi(6),dqiqj(4,5),
+* + dqiqj(4,6),dqiqj(5,6),ier0)
+* print *,'slamp =',sqrt(xlamp)
+ print *,'eta =',-4*del3
+* call ffeta(eta,xpi,dpipj,6,ier0)
+* print *,'etap =',eta
+ print *,'etalam =',etalam
+ print *,'alpha = ',alph(1),alph(3)
+ endif
+ if ( lwrite ) print '(a)',' ##] determinants:'
+*
+* and the calculations
+*
+ call ffxc0p(cs3,ipi12,isoort,clogi,ilogi,xqi,dqiqj,qiDqj,
+ + sdel2,del2s,etalam,etami,delpsi,alph,3,ier)
+*
+* sum'em up:
+*
+ 109 continue
+ cs = 0
+ xmax = 0
+ do 110 i=1,80
+* if ( cs3(i) .ne. 0 ) then
+ cs = cs + cs3(i)
+ xmax = max(xmax,absc(cs))
+* endif
+ 110 continue
+ ipi12t = 0
+ do 120 i=1,8
+ ipi12t = ipi12t + ipi12(i)
+ 120 continue
+ cs = cs + ipi12t*DBLE(pi12)
+*
+* Check for cancellations in the final adding up (give a fctor 2)
+*
+ if ( lwarn .and. 2*absc(cs) .lt. xloss*xmax )
+ + call ffwarn(29,ier,absc(cs),xmax)
+*
+* Check for a sum close to the minimum of the range (underflow
+* problems)
+*
+ if ( lwarn .and. absc(cs) .lt. xalogm/precc )
+ + call ffwarn(120,ier,absc(cs),xalogm/precc)
+*
+* A imaginary component less than precc times the real part is
+* zero (may be removed)
+*
+ if ( abs(DIMAG(cs)) .lt. precc*abs(DBLE(cs)) )
+ + cs = DCMPLX(DBLE(cs))
+*
+* Finally ...
+*
+ cc0 = - cs/cslam
+* #] calculations:
+* #[ debug:
+ if(lwrite)then
+* print '(a)',' ##[ all terms: '
+* print *,'s3''s :'
+* 1000 format(g12.6,1x,g12.6,1x,g12.6,1x,g12.6,1x,g12.6,1x,
+* + g12.6,1x,g12.6,1x,g12.6)
+* print 1000,(cs3(i),cs3(i+20),cs3(i+40),cs3(i+60),i=1,20)
+ print *,'ipi12: ',ipi12
+ print *,'isoort:' ,isoort
+* print '(a)',' ##] all terms: '
+ print *,'som :',cs,ipi12t,ier
+ print *,'cc0 :',cc0
+ endif
+* #] debug:
+*###] ffxc0b:
+ end
+*###[ ffrot3:
+ subroutine ffrot3(irota,xqi,dqiqj,qiDqj,xpi,dpipj,piDpj,ns,
+ + iflag,npoin,ier)
+***#[*comment:***********************************************************
+* *
+* rotates the arrays xpi, dpipj into xqi,dqiqj so that *
+* xpi(6),xpi(4) suffer the strongest outside cancellations and *
+* xpi(6) > xpi(4) if iflag = 1, so that xpi(5) largest and xpi(5) *
+* and xpi(6) suffer cancellations if iflag = 2. *
+* if iflag = 3 make xqi(3)=0. *
+* If npoin=4, rotate piDpj into qiDqj as well. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer irota,ns,iflag,ier,npoin
+ DOUBLE PRECISION xpi(6),dpipj(6,6),piDpj(6,6),xqi(6),dqiqj(6,6),
+ + qiDqj(6,6)
+*
+* local variables
+*
+ DOUBLE PRECISION a1,a2,a3,xpimax
+ DOUBLE COMPLEX chulp(3,3)
+ integer i,j,inew(6,6)
+ save inew
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data inew /1,2,3,4,5,6,
+ + 2,3,1,5,6,4,
+ + 3,1,2,6,4,5,
+ + 1,3,2,6,5,4,
+ + 3,2,1,5,4,6,
+ + 2,1,3,4,6,5/
+* #] declarations:
+* #[ check input:
+ if ( ltest .and. ns .ne. 6 ) print *,'ffrot3: error: ns /= 6'
+* #] check input:
+* #[ get largest cancellation:
+ if ( iflag .eq. 1 ) then
+ a1 = abs(dpipj(6,4))/max(abs(xpi(6)+xpi(4)),xalogm)
+ a2 = abs(dpipj(5,4))/max(abs(xpi(5)+xpi(4)),xalogm)
+ a3 = abs(dpipj(5,6))/max(abs(xpi(6)+xpi(5)),xalogm)
+ if ( a1 .le. a2 .and. a1 .le. a3 ) then
+ irota = 1
+ if ( abs(xpi(6)) .lt. abs(xpi(4)) ) then
+ irota = 4
+ endif
+ elseif ( a2 .le. a3 ) then
+ irota = 3
+ if ( abs(xpi(4)) .lt. abs(xpi(5)) ) then
+ irota = 6
+ endif
+ else
+ irota = 2
+ if ( abs(xpi(5)) .lt. abs(xpi(6)) ) then
+ irota = 5
+ endif
+ endif
+ elseif ( iflag .eq. 2 ) then
+ xpimax = max(xpi(4),xpi(5),xpi(6))
+ if ( xpimax .eq. 0 ) then
+ if ( xpi(5) .ne. 0 ) then
+ irota = 1
+ elseif ( xpi(4) .ne. 0 ) then
+ irota = 2
+ elseif ( xpi(6) .ne. 0 ) then
+ irota = 3
+ else
+ call fferr(40,ier)
+ irota = 1
+ endif
+ elseif ( xpi(5) .eq. xpimax ) then
+ if ( xpi(4) .le. xpi(6) ) then
+ irota = 1
+ else
+ irota = 4
+ endif
+ elseif ( xpi(4) .eq. xpimax ) then
+ if ( xpi(5) .ge. xpi(6) ) then
+ irota = 2
+ else
+ irota = 5
+ endif
+ else
+ if ( xpi(4) .ge. xpi(6) ) then
+ irota = 3
+ else
+ irota = 6
+ endif
+ endif
+ elseif ( iflag .eq. 3 ) then
+ if ( dpipj(2,4).eq.0 .and. dpipj(3,6).eq.0 .and.
+ + xpi(1).eq.0 ) then
+ irota = 3
+ elseif ( dpipj(1,6).eq.0 .and. dpipj(2,5).eq.0 .and.
+ + xpi(3).eq.0 ) then
+ irota = 1
+ elseif ( dpipj(3,5).eq.0 .and. dpipj(1,4).eq.0 .and.
+ + xpi(2).eq.0 ) then
+ irota = 2
+ else
+ call fferr(35,ier)
+ irota = 1
+ endif
+ else
+ call fferr(35,ier)
+ irota = 1
+ endif
+ if ( lwrite ) print *,'ffrot3: rotated over ',irota,' positions'
+* #] get largest cancellation:
+* #[ rotate:
+ do 20 i=1,6
+ xqi(inew(i,irota)) = xpi(i)
+ do 10 j=1,6
+ dqiqj(inew(i,irota),inew(j,irota)) = dpipj(i,j)
+ 10 continue
+ 20 continue
+*
+* when called in a 4pointfunction we already have the dotproducts
+*
+ if ( npoin .eq. 4 ) then
+ do 80 j=1,6
+ do 70 i=1,6
+ qiDqj(inew(i,irota),inew(j,irota)) = piDpj(i,j)
+ 70 continue
+ 80 continue
+ endif
+*DEBUG if ( iflag .eq. 3 .and. lsmug ) then
+ if ( lsmug ) then
+*
+* do not forget to rotate the smuggled differences
+*
+ do 40 j=1,3
+ do 30 i=1,3
+ chulp(i,j) = cmipj(i,j)
+ 30 continue
+ 40 continue
+ do 60 j=1,3
+ do 50 i=1,3
+ cmipj(inew(i,irota),inew(j+3,irota)-3) = chulp(i,j)
+ 50 continue
+ 60 continue
+ endif
+* #] rotate:
+* #[ test output:
+ if ( ltest ) then
+ call ffxhck(xqi,dqiqj,6,ier)
+ if ( iflag .eq. 3 .and. xqi(3) .ne. 0 ) print *,
+ + 'ffrot3: IR divergent C0 rotated wrongly!',xqi
+ endif
+* #] test output:
+*###] ffrot3:
+ end
+*###[ ffdot3:
+ subroutine ffdot3(piDpj,xpi,dpipj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the dotproducts pi.pj with *
+* *
+* pi = si i1=1,3 *
+* pi = p(i-3) i1=4,6 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ns,ier
+ DOUBLE PRECISION xpi(6),dpipj(6,6),piDpj(6,6)
+*
+* locals
+*
+ integer is1,is2,is3,ip1,ip2,ip3,i,j,ier0,ier1,inew(6,6)
+ DOUBLE PRECISION xheck,xlosn
+ save inew
+*
+* rest
+*
+ include 'ff.h'
+*
+* data
+*
+ data inew /1,2,3,4,5,6,
+ + 2,3,1,5,6,4,
+ + 3,1,2,6,4,5,
+ + 1,3,2,6,5,4,
+ + 3,2,1,5,4,6,
+ + 2,1,3,4,6,5/
+*
+* #] declarations:
+* #[ check input:
+ if ( ns .ne. 6 ) print *,'ffdot3: error: ns /= 6 '
+ if ( ltest ) call ffxhck(xpi,dpipj,6,ier)
+* #] check input:
+* #[ copy if known:
+*
+ if ( idot.ge.3 ) then
+ do 2 i=1,6
+ do 1 j=1,6
+ piDpj(inew(j,irota3),inew(i,irota3)) = fpij3(j,i)
+ 1 continue
+ 2 continue
+ if ( irota3 .gt. 3 ) then
+*
+* the sign of the s's has been changed!
+*
+ do 4 i=1,3
+ do 3 j=4,6
+ piDpj(j,i) = -piDpj(j,i)
+ piDpj(i,j) = -piDpj(i,j)
+ 3 continue
+ 4 continue
+ endif
+ return
+ endif
+*
+* #] copy if known:
+* #[ calculations:
+ ier1 = ier
+ do 10 is1=1,3
+ is2 = is1 + 1
+ if ( is2 .eq. 4 ) is2 = 1
+ is3 = is2 + 1
+ if ( is3 .eq. 4 ) is3 = 1
+ ip1 = is1 + 3
+ ip2 = is2 + 3
+ ip3 = is3 + 3
+*
+* pi.pj, si.sj
+*
+ piDpj(is1,is1) = xpi(is1)
+ piDpj(ip1,ip1) = xpi(ip1)
+*
+* si.s(i+1)
+*
+ if ( xpi(is2) .le. xpi(is1) ) then
+ piDpj(is1,is2) = (dpipj(is1,ip1) + xpi(is2))/2
+ else
+ piDpj(is1,is2) = (dpipj(is2,ip1) + xpi(is1))/2
+ endif
+ if ( lwarn ) then
+ ier0 = ier
+ if ( abs(piDpj(is1,is2)) .lt. xloss*min(xpi(is1),
+ + xpi(is2))/2 ) call ffwarn(100,ier0,piDpj(is1,
+ + is2),min(xpi(is1),xpi(is2))/2)
+ ier1 = max(ier1,ier0)
+ endif
+ piDpj(is2,is1) = piDpj(is1,is2)
+*
+* pi.si
+*
+ if ( abs(xpi(ip1)) .le. xpi(is1) ) then
+ piDpj(ip1,is1) = (dpipj(is2,is1) - xpi(ip1))/2
+ else
+ piDpj(ip1,is1) = (dpipj(is2,ip1) - xpi(is1))/2
+ endif
+ piDpj(is1,ip1) = piDpj(ip1,is1)
+ if ( lwarn ) then
+ ier0 = ier
+ if ( abs(piDpj(ip1,is1)) .lt. xloss*min(abs(xpi(ip1)),
+ + xpi(is1))/2) call ffwarn(101,ier0,
+ + piDpj(ip1,is1),min(abs(xpi(ip1)),xpi(is1))/2)
+ ier1 = max(ier1,ier0)
+ endif
+*
+* pi.s(i+1)
+*
+ if ( abs(xpi(ip1)) .le. xpi(is2) ) then
+ piDpj(ip1,is2) = (dpipj(is2,is1) + xpi(ip1))/2
+ else
+ piDpj(ip1,is2) = (dpipj(ip1,is1) + xpi(is2))/2
+ endif
+ piDpj(is2,ip1) = piDpj(ip1,is2)
+ if ( lwarn ) then
+ ier0 = ier
+ if ( abs(piDpj(ip1,is2)) .lt. xloss*min(abs(xpi(ip1)),
+ + xpi(is2))/2) call ffwarn(102,ier0,
+ + piDpj(ip1,is2),min(abs(xpi(ip1)),xpi(is2))/2)
+ ier1 = max(ier1,ier0)
+ endif
+*
+* pi.s(i+2)
+*
+ if ( min(abs(dpipj(is2,is1)),abs(dpipj(ip3,ip2))) .le.
+ + min(abs(dpipj(ip3,is1)),abs(dpipj(is2,ip2))) ) then
+ piDpj(ip1,is3) = (dpipj(ip3,ip2) + dpipj(is2,is1))/2
+ else
+ piDpj(ip1,is3) = (dpipj(ip3,is1) + dpipj(is2,ip2))/2
+ endif
+ piDpj(is3,ip1) = piDpj(ip1,is3)
+ if ( lwarn ) then
+ ier0 = ier
+ if ( abs(piDpj(ip1,is3)) .lt. xloss*min(abs(dpipj(ip3,
+ + ip2)),abs(dpipj(ip3,is1)))/2 ) call ffwarn(103,
+ + ier0,piDpj(ip1,is3),min(abs(dpipj(ip3,ip2)),
+ + abs(dpipj(ip3,is1)))/2)
+ ier1 = max(ier1,ier0)
+ endif
+*
+* pi.p(i+1)
+*
+ if ( idot.le.0 ) then
+ if ( abs(xpi(ip2)) .le. abs(xpi(ip1)) ) then
+ piDpj(ip1,ip2) = (dpipj(ip3,ip1) - xpi(ip2))/2
+ else
+ piDpj(ip1,ip2) = (dpipj(ip3,ip2) - xpi(ip1))/2
+ endif
+ piDpj(ip2,ip1) = piDpj(ip1,ip2)
+ if ( lwarn ) then
+ ier0 = ier
+ if ( abs(piDpj(ip1,ip2)) .lt.
+ + xloss*min(abs(xpi(ip1)),abs(xpi(ip2)))/2 ) call
+ + ffwarn(104,ier0,piDpj(ip1,ip2),
+ + min(abs(xpi(ip1)),abs(xpi(ip2)))/2)
+ ier1 = max(ier1,ier0)
+ endif
+ else
+ piDpj(inew(ip2,irota3),inew(ip1,irota3)) =
+ + fpij3(ip1,ip2)
+ piDpj(inew(ip1,irota3),inew(ip2,irota3)) =
+ + piDpj(inew(ip2,irota3),inew(ip1,irota3))
+ endif
+ 10 continue
+ ier = ier1
+*
+* #] calculations:
+* #[ check:
+ if ( ltest ) then
+ xlosn = xloss*DBLE(10)**(-2-mod(ier,50))
+ do 20 i = 1,6
+ xheck = piDpj(i,4) + piDpj(i,5) + piDpj(i,6)
+ if ( xlosn*abs(xheck) .gt. precx*max(abs(piDpj(i,4)),
+ + abs(piDpj(i,5)),abs(piDpj(i,6))) ) print *,
+ + 'ffdot3: error: dotproducts with p(',i,
+ + ') wrong: ',xheck,(piDpj(i,j),j=4,6)
+ 20 continue
+ endif
+* #] check:
+*###] ffdot3:
+ end
+*###[ ffxc0r:
+ subroutine ffxc0r(cc0,xpi,ier)
+***#[*comment:***********************************************************
+* *
+* Tries all 2 permutations of the 3pointfunction *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ier
+ DOUBLE PRECISION xpi(6),xqi(6)
+ DOUBLE COMPLEX cc0,cc0p
+ integer inew(6,2),irota,ier1,i,j,icon,ialsav,init
+ logical lcon
+ parameter (icon=3)
+ save inew,init,lcon
+ include 'ff.h'
+ data inew /1,2,3,4,5,6,
+ + 1,3,2,6,5,4/
+ data init /0/
+* #] declarations:
+* #[ open console for some activity on screen:
+ if ( init .eq. 0 ) then
+ init = 1
+ if ( lwrite ) then
+ open(icon,file='CON:',status='old',err=11)
+ lcon = .TRUE.
+ goto 13
+ endif
+ 11 continue
+ lcon = .FALSE.
+ 13 continue
+ endif
+* #] open console for some activity on screen:
+* #[ calculations:
+ cc0 = 0
+ ier = 999
+ ialsav = isgnal
+ do 30 j = -1,1,2
+ do 20 irota=1,2
+ do 10 i=1,6
+ xqi(inew(i,irota)) = xpi(i)
+ 10 continue
+ print '(a,i1,a,i2)','---#[ rotation ',irota,': isgnal ',
+ + isgnal
+ if (lcon) write(icon,'(a,i1,a,i2)')'rotation ',irota,',
+ + isgnal ',isgnal
+ ier1 = 0
+ ner = 0
+ id = id + 1
+ isgnal = ialsav
+ call ffxc0(cc0p,xqi,ier1)
+ ier1 = ier1 + ner
+ print '(a,i1,a,i2)','---#] rotation ',irota,': isgnal ',
+ + isgnal
+ print '(a,2g28.16,i3)','c0 = ',cc0p,ier1
+ if (lcon) write(icon,'(a,2g28.16,i3)')'d0 = ',cc0p,ier1
+ if ( ier1 .lt. ier ) then
+ cc0 = cc0p
+ ier = ier1
+ endif
+ 20 continue
+ ialsav = -ialsav
+ 30 continue
+* #] calculations:
+*###] ffxc0r:
+ end
diff --git a/ff-2.0/ffxc0i.f b/ff-2.0/ffxc0i.f
new file mode 100644
index 0000000..7870b44
--- /dev/null
+++ b/ff-2.0/ffxc0i.f
@@ -0,0 +1,956 @@
+*--#[ log:
+* $Id: ffxc0i.f,v 1.3 1996/06/03 12:11:43 gj Exp $
+* $Log: ffxc0i.f,v $
+c Revision 1.3 1996/06/03 12:11:43 gj
+c Added an error message for ffxc0j with zero masses, which is ill-defined.
+c
+c Revision 1.2 1995/12/01 15:04:40 gj
+c Fixed a ridiculous bug: wrong sign for p4^2=0, m2<m1.
+c
+*--#] log:
+*###[ ffxc0i:
+ subroutine ffxc0i(cc0,xpi,dpipj,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the infrared finite part of a infrared divergent *
+* threepoint function with the factor ipi^2. The cutoff *
+* parameter is assumed to be in a common block /ffcut/. (ugly) *
+* *
+* Input: xpi(6) (real) pi.pi (B&D) *
+* dpipj(6,6) (real) xpi(i)-xpi(j) *
+* /ffcut/delta (real) cutoff (either foton mass**2 or *
+* radiation limit). *
+* Output: cc0 (complex) C0, the threepoint function. *
+* ier (integer) usual error flag *
+* Calls: *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cc0
+ DOUBLE PRECISION xpi(6),dpipj(6,6)
+*
+* local variables
+*
+ integer init,ipi12,i,ilogi(3),irota,n
+ integer j,inew(6,6)
+ DOUBLE COMPLEX cs(15),csum,c,clogi(3)
+ DOUBLE PRECISION xqi(6),dqiqj(6,6),qiDqj(6,6),sdel2,xmax,absc,
+ + dum66(6,6),del2
+ save init,inew,ilogi
+*
+* common blocks etc
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* data
+*
+ data init /0/
+ data inew /1,2,3,4,5,6,
+ + 2,3,1,5,6,4,
+ + 3,1,2,6,4,5,
+ + 1,3,2,6,5,4,
+ + 3,2,1,5,4,6,
+ + 2,1,3,4,6,5/
+ data ilogi /3*0/
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* initialisations
+*
+ do 1 i=1,15
+ cs(i) = 0
+ 1 continue
+ ipi12 = 0
+* #] declarations:
+* #[ check input:
+ if ( init .eq. 0 .and. .not.lsmug ) then
+ init = 1
+ print *,'ffxc0i: infra-red divergent threepoint function, ',
+ + 'working with a cutoff ',delta
+ endif
+ if ( .not.lsmug .and. delta .eq. 0 ) then
+ call fferr(59,ier)
+ return
+ endif
+ if ( lwrite ) then
+* print input
+ print *,'ffxc0i: infrared divergent threepoint function'
+ if ( .not.lsmug ) then
+ print *,' cutoff parameter:',delta
+ endif
+ endif
+* #] check input:
+* #[ groundwork:
+*
+* rotate to xpi(3)=0, xpi(1)=xpi(6), xpi(2)=xpi(5)
+*
+ call ffrot3(irota,xqi,dqiqj,qiDqj,xpi,dpipj,dum66,6,3,3,ier)
+*
+* get some dotproducts
+*
+ if ( ldot ) then
+ call ffdot3(qiDqj,xqi,dqiqj,6,ier)
+ do 5 i=1,6
+ do 4 j=1,6
+ fpij3(j,i) = qiDqj(inew(i,irota),inew(j,irota))
+ 4 continue
+ 5 continue
+ else
+ if ( abs(xqi(4)) .lt. xqi(1) ) then
+ qiDqj(4,1) = dqiqj(2,1) - xqi(4)
+ xmax = abs(xqi(4))
+ else
+ qiDqj(4,1) = dqiqj(2,4) - xqi(1)
+ xmax = xqi(1)
+ endif
+ if ( lwarn .and. abs(qiDqj(4,1)) .lt. xloss*xmax )
+ + call ffwarn(156,ier,qiDqj(4,1),xmax)
+ qiDqj(4,1) = qiDqj(4,1)/2
+ qiDqj(1,4) = qiDqj(4,1)
+
+ if ( abs(xqi(4)) .lt. xqi(2) ) then
+ qiDqj(4,2) = dqiqj(2,1) + xqi(4)
+ xmax = abs(xqi(4))
+ else
+ qiDqj(4,2) = xqi(2) - dqiqj(1,4)
+ xmax = xqi(2)
+ endif
+ if ( lwarn .and. abs(qiDqj(4,2)) .lt. xloss*xmax )
+ + call ffwarn(156,ier,qiDqj(4,2),xmax)
+ qiDqj(4,2) = qiDqj(4,2)/2
+ qiDqj(2,4) = qiDqj(4,2)
+
+ if ( (xqi(1)) .lt. (xqi(2)) ) then
+ qiDqj(1,2) = xqi(1) + dqiqj(2,4)
+ xmax = xqi(1)
+ else
+ qiDqj(1,2) = xqi(2) + dqiqj(1,4)
+ xmax = xqi(2)
+ endif
+ if ( lwarn .and. abs(qiDqj(1,2)) .lt. xloss*xmax )
+ + call ffwarn(156,ier,qiDqj(1,2),xmax)
+ qiDqj(1,2) = qiDqj(1,2)/2
+ qiDqj(2,1) = qiDqj(1,2)
+
+ qiDqj(1,1) = xqi(1)
+ qiDqj(2,2) = xqi(2)
+ qiDqj(4,4) = xqi(4)
+ endif
+* #] groundwork:
+* #[ calculations:
+*
+ call ffdel2(del2,qiDqj,6,1,2,4,1,ier)
+ if ( ldot ) fdel2 = del2
+*
+* the case del2=0 is hopeless - this is really a two-point function
+*
+ if ( del2 .eq. 0 ) then
+ call fferr(58,ier)
+ return
+ endif
+*
+* we cannot yet handle the complex case
+*
+ if ( del2 .gt. 0 ) then
+ call fferr(83,ier)
+ return
+ endif
+*
+ sdel2 = isgnal*sqrt(-del2)
+*
+ call ffxc0j(cs,ipi12,sdel2,clogi,ilogi,xqi,dqiqj,qiDqj,
+ + delta,3,ier)
+* #] calculations:
+* #[ sum:
+*
+* Sum
+*
+ xmax = 0
+ csum = 0
+ if ( .not.lsmug ) then
+ n = 10
+ else
+ n = 15
+ endif
+ do 10 i=1,n
+ csum = csum + cs(i)
+ xmax = max(xmax,absc(csum))
+ 10 continue
+ csum = csum + ipi12*DBLE(pi12)
+ if ( lwarn .and. 2*absc(csum) .lt. xloss*xmax ) then
+ call ffwarn(157,ier,absc(csum),xmax)
+ endif
+ cc0 = -csum*DBLE(1/(2*sdel2))
+* #] sum:
+* #[ debug:
+ 900 continue
+ if (lwrite) then
+ print '(a)','cs(i) = '
+ print '(i3,2g20.10,1x)',(i,cs(i),i=1,n)
+ print '(a3,2g20.10,1x)','pi ',ipi12*pi12
+ print '(a)','+-----------'
+ print '(a3,2g20.10,1x)','som :',csum
+ print '(a)',' '
+ print *,'cc0 :',cc0,ier
+ endif
+* #] debug:
+*###] ffxc0i:
+ end
+*###[ ffxc0j:
+ subroutine ffxc0j(cs,ipi12,sdel2i,clogi,ilogi,
+ + xpi,dpipj,piDpj,delta,npoin,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the infrared finite part of a infrared divergent *
+* threepoint function with the factor ipi^2. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ipi12,ilogi(3),npoin,ier
+ DOUBLE COMPLEX cs(15),clogi(3)
+ DOUBLE PRECISION xpi(6),dpipj(6,6),piDpj(6,6),delta,sdel2i
+*
+* local variables
+*
+ integer i,ieps,ieps1,n,ier0
+ DOUBLE COMPLEX clog1,clog2,cdum(2),cel3,cdyzm,cdyzp,cli,chulp,
+ + carg1,carg2,chulp1
+ DOUBLE COMPLEX zfflog,zxfflg,cc
+ DOUBLE PRECISION del2,zm,zp,zm1,zp1,sdel2,hulp,xheck,dum(3),
+ + dfflo1,dyzp,dyzm,wm,wp,absc,arg1,arg2,del3
+*
+* common blocks etc
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ call ffxhck(xpi,dpipj,6,ier)
+ endif
+ if ( lwrite ) then
+ print '(a)',' ##[ ffxc0j:'
+ print *,'ffxc0j: input: '
+ print *,'xpi = ',xpi
+ if ( .not.lsmug ) then
+ print *,'delta = ',delta
+ else
+ print *,'cmipj(2,2) = ',cmipj(2,2)
+ print *,'cmipj(1,3) = ',cmipj(1,3)
+ endif
+ endif
+* #] check input:
+* #[ get determinants, roots, ieps:
+*
+ if ( lsmug ) then
+ del3 = (- DBLE(xpi(1))*DBLE(cmipj(2,2))**2
+ + - DBLE(xpi(2))*DBLE(cmipj(1,3))**2
+ + + 2*DBLE(piDpj(1,2))*DBLE(cmipj(2,2))*
+ + DBLE(cmipj(1,3)) )/4
+ if ( nschem .ge. 3 ) then
+ cel3 = (- DBLE(xpi(1))*cmipj(2,2)**2
+ + - DBLE(xpi(2))*cmipj(1,3)**2
+ + + 2*DBLE(piDpj(1,2))*cmipj(2,2)*cmipj(1,3) )/4
+ else
+ cel3 = DBLE(del3)
+ endif
+ if ( lwrite ) print *,'cel3 = ',cel3
+ endif
+ del2 = -sdel2i**2
+*
+* the routine as it stands can not handle sdel2<0.
+* the simplest solution seems to be to switch to sdel2>0 for
+* the time being - we calculate a complete 3point function so it
+* should not be a problem (just a sign). Of course this spoils a
+* good check on the correctness.
+*
+ sdel2 = abs(sdel2i)
+ if ( sdel2i .gt. 0 .and. lwrite ) print *,
+ + 'ffxc0j: cannot handle sdel2>0, switched to sdel2<0'
+*
+ if ( xpi(4).eq.0 ) then
+ zm = xpi(2)/dpipj(2,1)
+ zm1 = -xpi(1)/dpipj(2,1)
+ else
+ call ffroot(zm,zp,xpi(4),piDpj(4,2),xpi(2),sdel2,ier)
+ if ( dpipj(1,2) .ne. 0 ) then
+ call ffroot(zp1,zm1,xpi(4),-piDpj(4,1),xpi(1),sdel2,ier)
+ else
+ zm1 = zp
+ zp1 = zm
+ endif
+ endif
+ if ( lwrite ) then
+ print *,'ffxc0j: found roots:'
+ print *,' zm = ',zm,zm1
+ if ( xpi(4).ne.0 ) print *,' zp = ',zp,zp1
+ endif
+ if ( ltest ) then
+ xheck = zm + zm1 - 1
+ if ( xloss*abs(xheck) .gt. precx*max(x1,abs(zm)) ) print *,
+ + 'ffxc0j: zm + zm1 <> 1: ',zm,zm1,xheck
+ if ( xpi(4).ne.0 ) then
+ xheck = zp + zp1 - 1
+ if ( xloss*abs(xheck) .gt. precx*max(x1,abs(zp)) )
+ + print *,'ffxc0j: zp + zp1 <> 1: ',zp,zp1,xheck
+ endif
+ endif
+
+* imag sign ok 30-oct-1989
+ ieps = -1
+ if ( xpi(4).ne.0 ) dyzp = -2*sdel2/xpi(4)
+*
+* #] get determinants, roots, ieps:
+* #[ the finite+divergent S1:
+*
+ if ( xpi(4).ne.0 ) then
+ call ffcxr(cs(1),ipi12,zm,zm1,zp,zp1,dyzp,
+ + .FALSE.,x0,x0,x0,.FALSE.,dum,ieps,ier)
+ endif
+*
+* Next the divergent piece
+*
+ if ( .not.lsmug ) then
+*
+* Here we dropped the term log(lam/delta)*log(-zm/zm1)
+*
+ if ( abs(zm1) .gt. 1/xloss ) then
+ clog1 = dfflo1(1/zm1,ier)
+ elseif ( zm.ne.0 ) then
+ clog1 = zxfflg(-zm/zm1,-2,x0,ier)
+ else
+ call fferr(97,ier)
+ return
+ endif
+ hulp = zm*zm1*4*del2/delta**2
+*
+* 14-jan-1994: do not count when this is small, this was
+* meant to be so by the user carefully adjusting delta
+*
+ ier0 = ier
+ if ( hulp.eq.0 ) call fferr(97,ier)
+ clog2 = zxfflg(hulp,2,x0,ier0)
+ cs(8) = -clog1*clog2/2
+ if ( lwrite ) then
+* print *,'arg1 = ',-zm/zm1,1/zm1
+ print *,'log1 = ',clog1
+* print *,'arg2 = ',hulp
+ print *,'log2 = ',clog2
+ print *,'cs(8)= ',cs(8)
+ endif
+ else
+*
+* checked 4-aug-1992, but found Yet Another Bug 30-sep-1992
+*
+ cdyzm = cel3*DBLE(1/(-2*sdel2*del2))
+ dyzm = del3/(-2*sdel2*del2)
+ carg1 = +cdyzm*DBLE(1/zm)
+ arg1 = +dyzm/zm
+ clog1 = zfflog(-carg1,+ieps,DCMPLX(DBLE(zm),DBLE(0)),ier)
+ if (DIMAG(cdyzm) .lt. 0 .and. arg1 .gt. 0 ) then
+ clog1 = clog1 - c2ipi
+ if ( lwrite ) then
+ print *,'added -2*pi*i to log1 S1'
+ print *,' arg1,zm = ',arg1,zm
+ print *,'carg1 = ',carg1
+ endif
+* ier = ier + 50
+ endif
+ cs(8) = -clog1**2/2
+ carg2 = -cdyzm*DBLE(1/zm1)
+ arg2 = -dyzm/zm1
+ clog2 = zfflog(-carg2,ieps,DCMPLX(DBLE(-zm1),DBLE(0)),ier)
+ if ( DIMAG(cdyzm) .lt. 0 .and. arg2 .gt. 0 ) then
+ clog2 = clog2 + c2ipi
+ if ( lwrite ) then
+ print *,'added +2*pi*i to log2 S1'
+ print *,' arg2,zm = ',arg2,zm
+ print *,'carg2 = ',carg2
+ endif
+ endif
+ cs(9) = +clog2**2/2
+ if ( lwrite ) then
+ print *,'y=zm = ',zm,zm1
+ if ( xpi(4).ne.0 ) print *,' zp = ',zp,zp1
+ print *,'cdyzm= ',cdyzm
+ print *,'arg1 = ',1/carg1
+ print *,'log1 = ',clog1
+ print *,'cs(8)= ',cs(8)
+ print *,'arg2 = ',1/carg2
+ print *,'log2 = ',clog2
+ print *,'cs(9)= ',cs(9)
+ print *,'ipi12= ',ipi12
+ print *,'S1 = ',cs(1)+cs(2)+cs(3)+cs(4)+cs(5)+cs(6)+
+ + cs(7)+cs(8)+cs(9)+ipi12*DBLE(pi12)
+ print *,' '
+ endif
+ endif
+* #] the finite+divergent S1:
+* #[ log(1) for npoin=4:
+ if ( npoin .eq. 4 ) then
+ if ( ilogi(1) .eq. -999 ) then
+ if ( .not.lsmug ) then
+ hulp = xpi(4)*delta/(4*del2)
+ ier0 = ier
+ if ( hulp.eq.0 ) call fferr(97,ier)
+ clogi(1) = -zxfflg(abs(hulp),0,x0,ier0)
+ if ( hulp .lt. 0 ) then
+ if ( xpi(4) .gt. 0 ) then
+ ilogi(1) = -1
+ else
+ ilogi(1) = +1
+ endif
+ if ( ltest ) then
+ print *,'ffxc0j: I am not 100% sure of the',
+ + ' terms pi^2, please check against the',
+ + ' limit lam->0 (id=',id,')'
+ ier = ier + 50
+ endif
+ else
+ ilogi(1) = 0
+ endif
+ else
+ if ( xpi(4).eq.0 ) then
+ print *,'ffxc0i: cannot handle t=0 yet, sorry'
+ print *,'Please regularize with a small mass'
+ stop
+ endif
+ chulp = -cdyzm*DBLE(1/dyzp)
+ chulp1 = 1+chulp
+ if ( absc(chulp1) .lt. xloss )
+ + call ffwarn(129,ier,absc(chulp1),x1)
+ call ffxclg(clogi(1),ilogi(1),chulp,chulp1,dyzp,
+ + ier)
+ endif
+ endif
+ endif
+* #] log(1) for npoin=4:
+* #[ the log(lam) Si:
+ if ( .not.lsmug ) then
+*
+* Next the divergent S_i (easy).
+* The term -2*log(lam/delta)*log(xpi(2)/xpi(1)) has been discarded
+* with lam the photon mass (regulator).
+* If delta = sqrt(xpi(1)*xpi(2)) the terms cancel as well
+*
+ if ( dpipj(1,2).ne.0 .and. xloss*abs(xpi(1)*xpi(2)-delta**2)
+ + .gt.precx*delta**2 ) then
+ if ( xpi(1) .ne. delta ) then
+ ier0 = ier
+ if ( xpi(1).eq.0 ) call fferr(97,ier)
+ cs(9) = -zxfflg(xpi(1)/delta,0,x0,ier0)**2 /4
+ endif
+ if ( xpi(2) .ne. delta ) then
+ ier0 = ier
+ if ( xpi(2).eq.0 ) call fferr(97,ier)
+ cs(10) = zxfflg(xpi(2)/delta,0,x0,ier0)**2 /4
+ endif
+ endif
+ if ( lwrite ) then
+ print *,'cs(9)= ',cs(9)
+ print *,'cs(10)=',cs(10)
+ endif
+* #] the log(lam) Si:
+* #[ the logs for A_i<0:
+ if ( npoin.eq.4 ) then
+ clogi(2) = 0
+ ilogi(2) = 0
+ clogi(3) = 0
+ ilogi(3) = 0
+ endif
+* #] the logs for A_i<0:
+* #[ the off-shell S3:
+ else
+*
+* the divergent terms in the offshell regulator scheme - not
+* quite as easy
+* wm = p3.p2/sqrtdel - 1 = -s1.s2/sqrtdel - 1
+* wp = p3.p2/sqrtdel + 1 = -s1.s2/sqrtdel + 1
+* Note that we took the choice sdel2<0 in S1 when
+* \delta^{p1 s2}_{p1 p2} < 0 by using yp=zm
+*
+ wm = -1 - piDpj(1,2)/sdel2
+ wp = wm + 2
+ if ( lwrite ) print *,'wm,wp = ',wm,wp
+ if ( abs(wm) .lt. abs(wp) ) then
+ wm = -xpi(5)*xpi(6)/(del2*wp)
+ if ( lwrite ) print *,'wm+ = ',wm
+ else
+ wp = -xpi(5)*xpi(6)/(del2*wm)
+ if ( lwrite ) print *,'wp+ = ',wp
+ endif
+*
+* the im sign
+*
+ if ( -DBLE(cmipj(1,3)) .gt. 0 ) then
+ ieps = -1
+ else
+ ieps = +1
+ endif
+*
+ if ( nschem .lt. 3 .or. DIMAG(cmipj(1,3)).eq.0 .and.
+ + DIMAG(cmipj(2,2)).eq.0 ) then
+* #[ real case:
+ if ( lwrite ) print *,'ffxc0i: Real S3'
+*
+* first z-,z+
+*
+ dyzp = -DBLE(cmipj(1,3))*DBLE(wm)/(2*DBLE(xpi(6))) -
+ + DBLE(cmipj(2,2))/(2*DBLE(sdel2))
+ dyzm = -DBLE(cmipj(1,3))*DBLE(wp)/(2*DBLE(xpi(6))) -
+ + DBLE(cmipj(2,2))/(2*DBLE(sdel2))
+*
+* the (di)logs
+*
+ clog1 = zxfflg(-dyzp,-ieps,x1,ier)
+ cs(10) = -clog1**2/2
+ ipi12 = ipi12 - 4
+ clog2 = zxfflg(-dyzm,+ieps,x1,ier)
+ cs(11) = -clog2**2/2
+ ipi12 = ipi12 - 2
+ hulp = dyzp/dyzm
+ if ( dyzp .lt. 0 ) then
+ ieps1 = -ieps
+ else
+ ieps1 = +ieps
+ endif
+ call ffzxdl(cli,i,cdum(1),hulp,+ieps1,ier)
+ cs(12) = -cli
+ ipi12 = ipi12 - i
+*
+* the log for npoin=4
+*
+ if ( npoin.eq.4 ) then
+ if ( ilogi(3) .eq. -999 ) then
+ if ( DBLE(cmipj(1,3)) .eq. 0 ) then
+ chulp = -1
+ chulp1 = 0
+ elseif ( dyzp .lt. dyzm ) then
+ chulp = -dyzm/dyzp
+ chulp1 = +DBLE(cmipj(1,3))/DBLE(xpi(6)*dyzp)
+ else
+ chulp = -dyzp/dyzm
+ chulp1 = -DBLE(cmipj(1,3))/DBLE(xpi(6)*dyzm)
+ endif
+ call ffxclg(clogi(3),ilogi(3),chulp,chulp1,dyzp,
+ + ier)
+ endif
+ endif
+*
+* and some debug output:
+*
+ if ( lwrite ) then
+ print *,'z = 1,0'
+ print *,'y-zm = ',dyzm
+ print *,'y-zp = ',dyzp
+ print *,'+Li2(y/(y-zp)) = ',cs(10)
+ print *,'+Li2(y/(y-zm)) = ',cs(11)
+ print *,'-Li2((y-1)/(y-zm))= ',cs(12)
+ print *,'ipi12 = ',ipi12
+ endif
+* #] real case:
+ else
+* #[ complex case:
+ if ( lwrite ) print *,'ffxc0i: Complex S3'
+*
+* first z+
+*
+ cdyzp = -cmipj(1,3)*DBLE(wm)/(2*DBLE(xpi(6))) -
+ + cmipj(2,2)/(2*DBLE(sdel2))
+ clog1 = zfflog(-cdyzp,-ieps,c1,ier)
+ if ( ieps*DIMAG(cdyzp).lt.0.and.DBLE(cdyzp).gt.0 ) then
+ if ( lwrite ) then
+ print *,'added ',-ieps,'*2*pi*i to log1 S3'
+ print *,'carg1 = ',-cdyzp
+ print *,'clog1 was ',clog1
+ print *,'clog1 is ',clog1 - ieps*c2ipi
+ endif
+ clog1 = clog1 - ieps*c2ipi
+ else
+ if ( lwrite ) then
+ print *,'carg1 = ',-cdyzp
+ print *,'clog1 is ',clog2
+ endif
+ endif
+ cs(10) = -clog1**2/2
+ ipi12 = ipi12 - 4
+*
+* now z-
+*
+ cdyzm = -cmipj(1,3)*DBLE(wp)/(2*DBLE(xpi(6))) -
+ + cmipj(2,2)/(2*DBLE(sdel2))
+ clog2 = zfflog(-cdyzm,+ieps,c1,ier)
+ if ( ieps*DIMAG(cdyzm).gt.0.and.DBLE(cdyzm).gt.0 ) then
+ if ( lwrite ) then
+ print *,'added ',ieps,'*2*pi*i to log2 S3'
+ print *,'carg2 = ',-cdyzm
+ print *,'clog2 was ',clog2
+ print *,'clog2 is ',clog2 + ieps*c2ipi
+ endif
+ clog2 = clog2 + ieps*c2ipi
+* ier = ier + 50
+ else
+ if ( lwrite ) then
+ print *,'carg2 = ',-cdyzm
+ print *,'clog2 is ',clog2
+ endif
+ endif
+ cs(11) = -clog2**2/2
+ ipi12 = ipi12 - 2
+*
+* the dilog
+*
+ chulp = cdyzp/cdyzm
+ hulp = DBLE(cdyzp)/DBLE(cdyzm)
+ if ( DBLE(cdyzp) .lt. 0 ) then
+ ieps1 = -ieps
+ else
+ ieps1 = +ieps
+ endif
+ if ( DIMAG(chulp) .eq. 0 ) then
+ hulp = DBLE(chulp)
+ call ffzxdl(cli,i,cdum(1),hulp,+ieps1,ier)
+ else
+ call ffzzdl(cli,i,cdum(1),chulp,ier)
+ if ( hulp.gt.1 .and. ieps1*DIMAG(chulp).lt.0 ) then
+ if ( lwrite ) then
+ print *,'addded 2ipi*log(z) to Li'
+ print *,'chulp = ',chulp
+ print *,'cli was ',cli
+ print *,'cli is ',cli +
+ + ieps1*c2ipi*zfflog(chulp,0,c0,ier)
+ call ffzxdl(cdum(2),i,cdum(1),hulp,+ieps1,
+ + ier)
+ print *,'vgl ',cdum(2)
+ endif
+ cli = cli + ieps1*c2ipi*zfflog(chulp,0,c0,ier)
+ endif
+ endif
+ cs(12) = -cli
+ ipi12 = ipi12 - i
+*
+* the log for npoin=4
+*
+ if ( npoin.eq.4 ) then
+ if ( ilogi(3) .eq. -999 ) then
+ if ( cmipj(1,3) .eq. 0 ) then
+ chulp = -1
+ chulp1 = 0
+ elseif ( DBLE(cdyzp) .lt. DBLE(cdyzm) ) then
+ chulp = -cdyzm/cdyzp
+ chulp1 = +cmipj(1,3)/cdyzp*DBLE(1/xpi(6))
+ else
+ chulp = -cdyzp/cdyzm
+ chulp1 = -cmipj(1,3)/cdyzm*DBLE(1/xpi(6))
+ endif
+ dyzp = DBLE(cdyzp)
+ call ffxclg(clogi(3),ilogi(3),chulp,chulp1,dyzp,
+ + ier)
+ endif
+ endif
+*
+* and some debug output:
+*
+ if ( lwrite ) then
+ print *,'z = 1,0'
+ print *,'y-zm = ',cdyzm
+ print *,'y-zp = ',cdyzp
+ print *,'+Li2(y/(y-zp)) = ',cs(10)
+ print *,'+Li2(y/(y-zm)) = ',cs(11)
+ print *,'-Li2((y-1)/(y-zm))= ',cs(12)
+ print *,'ipi12 = ',ipi12
+ endif
+* #] complex case:
+ endif
+* #] the off-shell S3:
+* #[ the off-shell S2:
+*
+* the im sign
+*
+ if ( -DBLE(cmipj(2,2)) .gt. 0 ) then
+ ieps = -1
+ else
+ ieps = +1
+ endif
+*
+ if ( nschem .lt. 3 ) then
+* #[ real case:
+ if ( lwrite ) print *,'ffxc0i: Real S2'
+*
+* first z-
+*
+ dyzm = -DBLE(cmipj(2,2))*DBLE(wp)/(2*DBLE(xpi(5))) -
+ + DBLE(cmipj(1,3))/(2*DBLE(sdel2))
+ clog1 = zxfflg(+dyzm,-ieps,x1,ier)
+ cs(13) = +clog1**2/2
+ ipi12 = ipi12 + 4
+*
+* now z+
+*
+ dyzp = -DBLE(cmipj(2,2))*DBLE(wm)/(2*DBLE(xpi(5))) -
+ + DBLE(cmipj(1,3))/(2*DBLE(sdel2))
+ clog2 = zxfflg(+dyzp,+ieps,x1,ier)
+ cs(14) = +clog2**2/2
+ ipi12 = ipi12 + 2
+ hulp = dyzm/dyzp
+ if ( dyzm .lt. 0 ) then
+ ieps1 = -ieps
+ else
+ ieps1 = +ieps
+ endif
+ call ffzxdl(cli,i,cdum(1),hulp,-ieps1,ier)
+ cs(15) = +cli
+ ipi12 = ipi12 + i
+*
+* the log for npoin=4
+*
+ if ( npoin.eq.4 ) then
+ if ( ilogi(2) .eq. -999 ) then
+ if ( DBLE(cmipj(2,2)) .eq. 0 ) then
+ chulp = -1
+ chulp1 = 0
+ elseif ( dyzp .lt. dyzm ) then
+ chulp = -dyzm/dyzp
+ chulp1 = +DBLE(cmipj(2,2))/DBLE(xpi(5)*dyzp)
+ elseif ( dyzp .gt. dyzm ) then
+ chulp = -dyzp/dyzm
+ chulp1 = -DBLE(cmipj(2,2))/DBLE(xpi(5)*dyzm)
+ endif
+ call ffxclg(clogi(2),ilogi(2),chulp,chulp1,dyzp,
+ + ier)
+ endif
+ endif
+*
+* and some debug output:
+*
+ if ( lwrite ) then
+ print *,'z = 0,1'
+ print *,'y-zm = ',dyzm
+ print *,'y-zp = ',dyzp
+ print *,'-Li2((y-1)/(y-zm))= ',cs(13)
+ print *,'-Li2((y-1)/(y-zp))= ',cs(14)
+ print *,'+Li2(y/(y-zp)) = ',cs(15)
+ print *,'ipi12 = ',ipi12
+ endif
+* #] real case:
+ else
+* #[ complex case:
+ if ( lwrite ) print *,'ffxc0i: Complex S2'
+*
+* first z-
+*
+ cdyzm = -cmipj(2,2)*DBLE(wp)/(2*DBLE(xpi(5))) -
+ + cmipj(1,3)/(2*DBLE(sdel2))
+ clog1 = zfflog(+cdyzm,-ieps,c1,ier)
+ if ( DBLE(cdyzm).lt.0.and.ieps*DIMAG(cdyzm).gt.0 ) then
+ if ( lwrite ) print *,'added 2*i*pi to log1'
+ clog1 = clog1 - ieps*c2ipi
+ endif
+ cs(13) = +clog1**2/2
+ ipi12 = ipi12 + 4
+*
+* now z+
+*
+ cdyzp = -cmipj(2,2)*DBLE(wm)/(2*DBLE(xpi(5))) -
+ + cmipj(1,3)/(2*DBLE(sdel2))
+ clog2 = zfflog(+cdyzp,+ieps,c1,ier)
+ if ( DBLE(cdyzp).lt.0.and.ieps*DIMAG(cdyzp).lt.0 ) then
+ if ( lwrite ) then
+ print *,'added ',ieps,'*2*pi*i to log2 S2'
+ print *,'carg1 = ',+cdyzp
+ endif
+ clog2 = clog2 + ieps*c2ipi
+ endif
+ cs(14) = +clog2**2/2
+ ipi12 = ipi12 + 2
+*
+* and ghe dilog
+*
+ chulp = cdyzm/cdyzp
+ hulp = DBLE(dyzm)/DBLE(dyzp)
+ if ( DBLE(cdyzm) .lt. 0 ) then
+ ieps1 = -ieps
+ else
+ ieps1 = +ieps
+ endif
+ if ( DIMAG(chulp ) .eq. 0 ) then
+ hulp = DBLE(chulp)
+ call ffzxdl(cli,i,cdum(1),hulp,-ieps1,ier)
+ else
+ call ffzzdl(cli,i,cdum(1),chulp,ier)
+ if ( hulp.gt.1 .and. ieps1*DIMAG(chulp).gt.0 ) then
+ if ( lwrite ) then
+ print *,'addded 2ipi*log(z) to Li'
+ print *,'chulp = ',chulp
+ print *,'cli was ',cli
+ print *,'cli is ',cli -
+ + ieps1*c2ipi*zfflog(chulp,0,c0,ier)
+ call ffzxdl(cdum(2),i,cdum(1),hulp,-ieps1,
+ + ier)
+ print *,'vgl ',cdum(2)
+ endif
+ cli = cli - ieps1*c2ipi*zfflog(chulp,0,c0,ier)
+ endif
+ endif
+ cs(15) = +cli
+ ipi12 = ipi12 + i
+*
+* the log for npoin=4
+*
+ if ( npoin.eq.4 ) then
+ if ( ilogi(2) .eq. -999 ) then
+ if ( cmipj(2,2) .eq. 0 ) then
+ chulp = -1
+ chulp1 = 0
+ elseif ( DBLE(cdyzp) .lt. DBLE(cdyzm) ) then
+ chulp = -cdyzm/cdyzp
+ chulp1 = +cmipj(2,2)/cdyzp*DBLE(1/xpi(5))
+ elseif ( DBLE(cdyzp) .gt. DBLE(cdyzm) ) then
+ chulp = -cdyzp/cdyzm
+ chulp1 = -cmipj(2,2)/cdyzm*DBLE(1/xpi(5))
+ endif
+ dyzp = DBLE(cdyzp)
+ call ffxclg(clogi(2),ilogi(2),chulp,chulp1,dyzp,
+ + ier)
+ endif
+ endif
+*
+* and some debug output:
+*
+ if ( lwrite ) then
+ print *,'z = 0,1'
+ print *,'y-zm = ',cdyzm
+ print *,'y-zp = ',cdyzp
+ print *,'-Li2((y-1)/(y-zm))= ',cs(13)
+ print *,'-Li2((y-1)/(y-zp))= ',cs(14)
+ print *,'+Li2(y/(y-zp)) = ',cs(15)
+ print *,'ipi12 = ',ipi12
+ endif
+* #] complex case:
+ endif
+ endif
+* #] the off-shell S2:
+* #[ sdel2<0!:
+ if ( sdel2i.gt.0 .neqv. xpi(4).eq.0.and.xpi(1).gt.xpi(2) ) then
+ if ( .not.lsmug ) then
+ n = 10
+ else
+ n = 15
+ endif
+ do 10 i=1,n
+ cs(i) = -cs(i)
+ 10 continue
+ ipi12 = -ipi12
+ if ( npoin.eq.4 ) then
+ do 20 i=1,3
+ ilogi(i) = -ilogi(i)
+ clogi(i) = -clogi(i)
+ 20 continue
+ endif
+ endif
+ if ( lwrite ) print '(a)',' ##] ffxc0j:'
+* #] sdel2<0!:
+*###] ffxc0j:
+ end
+*###[ ffxclg:
+ subroutine ffxclg(clg,ilg,chulp,chulp1,dyzp,ier)
+***#[*comment:***********************************************************
+* *
+* compute the extra logs for npoin=4 given chulp=-cdyzm/cdyzp *
+* all flagchecking has already been done. *
+* *
+* Input: chulp (complex) see above *
+* chulp1 (complex) 1+chulp (in case chulp ~ -1) *
+* dyzp (real) (real part of) y-z+ for im part *
+* Output: clg (complex) the log *
+* ilg (integer) factor i*pi split off clg *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ilg,ier
+ DOUBLE PRECISION dyzp
+ DOUBLE COMPLEX clg,chulp,chulp1
+*
+* local variables
+*
+ DOUBLE PRECISION hulp,hulp1,dfflo1
+ DOUBLE COMPLEX zxfflg,zfflog,zfflo1,check
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ check:
+ if ( ltest ) then
+ check = c1 + chulp - chulp1
+ if ( xloss*abs(check) .gt. precc*max(abs(c1),abs(chulp)) )
+ + print *,'ffxclg: error: chulp1 != 1+chulp: ',chulp1,
+ + c1+chulp,check
+ endif
+* #] check:
+* #[ work:
+*
+ if ( DIMAG(chulp) .eq. 0 ) then
+ hulp = DBLE(chulp)
+ hulp1 = DBLE(chulp1)
+ if ( abs(hulp1) .lt. xloss ) then
+ clg = DBLE(dfflo1(hulp1,ier))
+ else
+ clg = zxfflg(abs(hulp),0,x0,ier)
+ endif
+ if ( hulp .lt. 0 ) then
+ if ( dyzp.lt.0 ) then
+ ilg = +1
+ else
+ ilg = -1
+ endif
+ else
+ ilg = 0
+ endif
+ if ( lwrite ) print *,'clg(real) = ',clg+c2ipi*ilg/2
+ else
+*
+* may have to be improved
+*
+ if ( abs(DBLE(chulp1))+abs(DIMAG(chulp1)) .lt. xloss ) then
+ clg = zfflo1(chulp1,ier)
+ else
+ clg = zfflog(chulp,0,c0,ier)
+ endif
+ ilg = 0
+ if ( DBLE(chulp) .lt. 0 ) then
+ if ( dyzp.lt.0 .and. DIMAG(clg).lt.0 ) then
+ if ( lwrite ) print *,'ffxclg: added -2*pi to log'
+ ilg = +2
+ elseif ( dyzp.gt.0 .and. DIMAG(clg).gt.0 ) then
+ if ( lwrite ) print *,'ffxclg: added +2*pi to log'
+ ilg = -2
+ endif
+ endif
+ if ( lwrite ) print *,'clg(cmplx)= ',clg+c2ipi*ilg/2
+ endif
+* #] work:
+*###] ffxclg:
+ end
diff --git a/ff-2.0/ffxc0p.f b/ff-2.0/ffxc0p.f
new file mode 100644
index 0000000..5a609df
--- /dev/null
+++ b/ff-2.0/ffxc0p.f
@@ -0,0 +1,641 @@
+* $Id: ffxc0p.f,v 1.3 1995/10/06 09:17:26 gj Exp $
+* $Log: ffxc0p.f,v $
+c Revision 1.3 1995/10/06 09:17:26 gj
+c Found stupid typo in ffxc0p which caused the result to be off by pi^2/3 in
+c some equal-mass cases. Added checks to ffcxs4.f ffcrr.f.
+c
+*###[ ffxc0p:
+ subroutine ffxc0p(cs3,ipi12,isoort,clogi,ilogi,xpi,dpipj,piDpj,
+ + sdel2,del2s,etalam,etami,delpsi,alph,npoin,ier)
+***#[*comment:***********************************************************
+* *
+* DOUBLE PRECISIONLY calculates the threepoint function closely following *
+* recipe in 't Hooft & Veltman, NP B(183) 1979. *
+* Bjorken and Drell metric is used nowadays! *
+* *
+* p2 ^ | *
+* | | *
+* / \ *
+* m2/ \m3 *
+* p1 / \ p3 *
+* <- / m1 \ -> *
+* ------------------------ *
+* *
+* Input: xpi(1-3) (real) pi squared *
+* xpi(4-6) (real) internal mass squared *
+* dpipj(6,6) (real) xpi(i)-xpi(j) *
+* piDpj(6,6) (real) pi(i).pi(j) *
+* sdel2 (real) sqrt(delta_{p_1 p_2}^{p_1 p_2}) *
+* del2s(3) (real) delta_{p_i s_i}^{p_i s_i} *
+* etalam (real) delta_{s_1 s_2 s_3}^{s_1 s_2 s_3}
+* /delta_{p_1 p_2}^{p_1 p_2} *
+* etami(6) (real) m_i^2 - etalam *
+* alph(3) (real) alph(1)=alpha, alph(3)=1-alpha *
+* *
+* Output: cs3(80) (complex) C0, not yet summed. *
+* ipi12(8) (integer) factors pi^2/12, not yet summed *
+* slam (complex) lambda(p1,p2,p3). *
+* isoort(8) (integer) indication of he method used *
+* clogi(3) (complex) log(-dyz(2,1,i)/dyz(2,2,i)) *
+* ilogi(3) (integer) factors i*pi in this *
+* ier (integer) number of digits inaccurate in *
+* answer *
+* *
+* Calls: ffdel3,ffdel3m,ffroot,ffxxyz,ffcxyz,ffdwz,ffcdwz, *
+* ffcxs3,ffcs3,ffcxs4,ffcs4 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(8),isoort(8),ilogi(3),npoin,ier
+ DOUBLE COMPLEX cs3(80),clogi(3)
+ DOUBLE PRECISION xpi(6),dpipj(6,6),piDpj(6,6),sdel2,del2s(3),
+ + etalam,etami(6),delpsi(3),alph(3)
+*
+* local variables:
+*
+ integer i,j,k,m,ip,jsoort(8),ierw,iw,ier0,ier1,irota,
+ + ilogip(3)
+ logical l4,lcompl,lcpi,l4pos
+ DOUBLE COMPLEX c,cs,calph(3),csdl2i(3),csdel2
+ DOUBLE COMPLEX cy(4,3),cz(4,3),cw(4,3),cdyz(2,2,3),cdwy(2,2,3),
+ + cdwz(2,2,3),cd2yzz(3),cd2yww(3)
+ DOUBLE COMPLEX cpi(6),cdpipj(6,6),cpiDpj(6,6),cetami(6),
+ + clogip(3)
+ DOUBLE PRECISION y(4,3),z(4,3),w(4,3),dyz(2,2,3),dwy(2,2,3),
+ + dwz(2,2,3),d2yzz(3),d2yww(3),dy2z(4,3)
+ DOUBLE PRECISION sdel2i(3),s1,s2
+ DOUBLE PRECISION absc,s,xqi(6),dqiqj(6,6),qiDqj(6,6)
+ DOUBLE PRECISION dfflo1
+ DOUBLE COMPLEX zxfflg,zfflog
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ call ffxhck(xpi,dpipj,6,ier)
+ do i=1,8
+ if ( ipi12(i).ne.0 ) then
+ print *,'ffxc0p: error: ipi12(',i,') != 0: ',
+ + ipi12(i)
+ endif
+ enddo
+ endif
+* #] check input:
+* #[ IR case:
+*
+* but only the off-shell regulator case - the log(lam) has been
+* caught before
+*
+ if ( lsmug ) then
+ do 5 i=1,3
+ if ( xpi(i) .eq. 0 ) then
+ j = mod(i,3)+1
+ k = mod(j,3)+1
+ if ( piDpj(i,j).eq.0 .and. piDpj(i,k).eq.0 ) then
+ call ffrot3(irota,xqi,dqiqj,qiDqj,
+ + xpi,dpipj,piDpj,6,3,4,ier)
+ if ( lwrite ) print *,'ffxc0p: rotated over ',
+ + irota
+ if ( npoin.eq.4 ) call ffrt3p(clogip,ilogip,
+ + irota,clogi,ilogi,+1)
+ call ffxc0j(cs3(1),ipi12(1),sdel2,clogip,ilogip,
+ + xqi,dqiqj,qiDqj,x0,4,ier)
+ if ( npoin.eq.4 ) call ffrt3p(clogi,ilogi,irota,
+ + clogip,ilogip,-1)
+ return
+ endif
+ endif
+ 5 continue
+ endif
+* #] IR case:
+* #[ get roots etc:
+* #[ get z-roots:
+* if ( npoin .eq. 3 ) then
+ l4pos = l4also
+* else
+* l4pos = .FALSE.
+* endif
+ lcompl = .FALSE.
+ if ( lwrite ) print '(a)',' ##[ get roots:'
+ ier1 = ier
+ do 10 i=1,3
+*
+* get roots (y,z,w) and flag what to do: 0=nothing, 1=normal,
+* -1=complex
+*
+ ip = i+3
+* first get the roots
+ ier0 = ier
+ if ( del2s(i) .le. 0 ) then
+* real case
+ sdel2i(i) = sqrt(-del2s(i))
+ csdl2i(i) = sdel2i(i)
+* then handle the special case Si = 0
+ if ( xpi(ip) .eq. 0 ) then
+ if ( i .eq. 1 .and. alph(3) .eq. 0 .or.
+ + i .eq. 3 .and. alph(1) .eq. 0 ) then
+ isoort(2*i-1) = 0
+ isoort(2*i) = 0
+ l4pos = .FALSE.
+ goto 10
+ endif
+ endif
+ call ffxxyz(y(1,i),z(1,i),dyz(1,1,i),d2yzz(i),dy2z(1,i),
+ + i,sdel2,sdel2i(i),etalam,etami,delpsi(i),xpi,
+ + dpipj,piDpj,isoort(2*i-1),.FALSE.,6,ier0)
+ else
+* complex case
+ sdel2i(i) = sqrt(del2s(i))
+ csdl2i(i) = DCMPLX(x0,sdel2i(i))
+ lcompl = .TRUE.
+ call ffcxyz(cy(1,i),cz(1,i),cdyz(1,1,i),cd2yzz(i),i,
+ + sdel2,sdel2i(i),etalam,etami,delpsi(i),xpi,
+ + piDpj,isoort(2*i-1),.FALSE.,6,ier0)
+ endif
+ ier1 = max(ier1,ier0)
+ 10 continue
+ ier = ier1
+* #] get z-roots:
+* #[ get w-roots:
+*
+* get w's:
+*
+ ierw = ier
+ l4 = .FALSE.
+ lcpi = .FALSE.
+ if ( isoort(4) .eq. 0 ) then
+* no error message; just bail out
+ ierw = ierw + 100
+ goto 90
+ endif
+ do 70 iw = 1,3,2
+ if ( .not. l4pos .or. alph(4-iw) .eq. 0 ) then
+ jsoort(2*iw-1) = 0
+ jsoort(2*iw) = 0
+ l4pos = .FALSE.
+ else
+ if ( isoort(4) .gt. 0 .and. isoort(2*iw) .ge. 0 ) then
+ jsoort(2*iw-1) = 1
+ jsoort(2*iw) = 1
+ d2yww(iw) = -d2yzz(2)/alph(4-iw)
+ do 20 j=1,2
+ w(j+iw-1,iw) = z(j+3-iw,2)/alph(4-iw)
+ w(j+3-iw,iw) = 1 - w(j+iw-1,iw)
+ if ( abs(w(j+3-iw,iw)) .lt. xloss ) then
+ if ( lwrite ) print *,' w(',j+3-iw,iw,') = ',
+ + w(j+3-iw,iw),x1
+ s = z(j+iw-1,2) - alph(iw)
+ if ( abs(s) .lt. xloss*alph(iw) ) then
+ ierw = ierw + 15
+ goto 70
+ endif
+ w(j+3-iw,iw) = s/alph(4-iw)
+ if ( lwrite ) print *,' w(',j+3-iw,iw,')+ = ',
+ + w(j+3-iw,iw),abs(alph(iw)/alph(4-iw))
+ endif
+ dwy(j,2,iw) = dyz(2,j,2)/alph(4-iw)
+ do 15 i=1,2
+ dwz(j,i,iw) = w(j,iw) - z(i,iw)
+ if ( abs(dwz(j,i,iw)) .ge. xloss*abs(w(j,iw)) )
+ + goto 14
+ if ( lwrite ) print *,' dwz(',j,i,iw,') = ',
+ + dwz(j,i,iw),abs(w(j,iw))
+ dwz(j,i,iw) = z(i+2,iw) - w(j+2,iw)
+ if ( lwrite ) print *,' dwz(',j,i,iw,')+ = ',
+ + dwz(j,i,iw),abs(w(j+2,iw))
+ if ( abs(dwz(j,i,iw)) .ge. xloss*abs(w(j+2,iw)) )
+ + goto 14
+ dwz(j,i,iw) = dwy(j,2,iw) + dyz(2,i,iw)
+ if ( lwrite ) print *,' dwz(',j,i,iw,')++= ',
+ + dwz(j,i,iw),abs(dwy(j,2,iw))
+ if ( abs(dwz(j,i,iw)) .ge. xloss*abs(dwy(j,2,iw)) )
+ + goto 14
+ l4 = .TRUE.
+ call ffdwz(dwz(1,1,iw),w(1,iw),z(1,iw),j,i,iw,
+ + alph(1),alph(3),xpi,dpipj,piDpj,sdel2i,6,ierw)
+ 14 continue
+ 15 continue
+ 20 continue
+ else
+* convert to complex ...
+ jsoort(2*iw-1) = -10
+ jsoort(2*iw) = -10
+ if ( isoort(4).ge.0 .and. (iw.eq.1 .or. isoort(2).ge.0) )
+ + then
+ cd2yzz(2) = d2yzz(2)
+ do 21 i=1,4
+ cy(i,2) = y(i,2)
+ cz(i,2) = z(i,2)
+ 21 continue
+ do 23 i=1,2
+ do 22 j=1,2
+ cdyz(j,i,2) = dyz(j,i,2)
+ 22 continue
+ 23 continue
+ endif
+ if ( isoort(2*iw) .ge. 0 ) then
+ cd2yzz(iw) = d2yzz(iw)
+ do 24 i=1,4
+ cy(i,iw) = y(i,iw)
+ cz(i,iw) = z(i,iw)
+ 24 continue
+ do 26 i=1,2
+ do 25 j=1,2
+ cdyz(j,i,iw) = dyz(j,i,iw)
+ 25 continue
+ 26 continue
+ endif
+ cd2yww(iw) = -cd2yzz(2)/DBLE(alph(4-iw))
+ do 30 j=1,2
+ cw(j+iw-1,iw) = cz(j+3-iw,2)/DBLE(alph(4-iw))
+ cw(j+3-iw,iw) = 1 - cw(j+iw-1,iw)
+ if ( absc(cw(j+3-iw,iw)) .lt. xloss ) then
+ if (lwrite) print *,' cw(',j+3-iw,iw,') = ',
+ + cw(j+3-iw,iw),x1
+ cs = cz(j+iw-1,2) - DBLE(alph(iw))
+ if ( absc(cs) .lt. xloss*alph(iw) ) ierw = ierw + 15
+ cw(j+3-iw,iw) = cs/DBLE(alph(4-iw))
+ if (lwrite) print *,' cw(',j+3-iw,iw,')+ = ',
+ + cw(j+3-iw,iw),abs(alph(iw)/alph(4-iw))
+ endif
+ cdwy(j,2,iw) = cdyz(2,j,2)/DBLE(alph(4-iw))
+ do 29 i=1,2
+ cdwz(j,i,iw) = cw(j,iw) - cz(i,iw)
+ if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cw(j,iw)) )
+ + goto 31
+ if ( lwrite ) print *,' cdwz(',j,i,iw,') = ',
+ + cdwz(j,i,iw),absc(cw(j,iw))
+ cdwz(j,i,iw) = cz(i+2,iw) - cw(j+2,iw)
+ if ( lwrite ) print *,' cdwz(',j,i,iw,')+ = ',
+ + cdwz(j,i,iw),absc(cw(j+2,iw))
+ if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cw(j+2,iw)))
+ + goto 31
+ cdwz(j,i,iw) = cdwy(j,2,iw) + cdyz(2,i,iw)
+ if ( lwrite ) print *,' cdwz(',j,i,iw,')++= ',
+ + cdwz(j,i,iw),absc(cdwy(j,2,iw))
+ if ( absc(cdwz(j,i,iw)).ge.xloss*absc(cdwy(j,2,iw)))
+ + goto 31
+ l4 = .TRUE.
+ if ( .not. lcpi ) then
+ lcpi = .TRUE.
+ calph(1) = alph(1)
+ calph(3) = alph(3)
+ csdel2 = sdel2
+ cetami(1) = etami(1)
+ cetami(3) = etami(3)
+ do 28 k=1,6
+ cpi(k) = xpi(k)
+ do 27 m=1,6
+ cdpipj(m,k) = dpipj(m,k)
+ cpiDpj(m,k) = piDpj(m,k)
+ 27 continue
+ 28 continue
+ endif
+ call ffcdwz(cdwz(1,1,iw),cw(1,iw),cz(1,iw),j,i,iw,
+ + calph(1),calph(3),cpi,cdpipj,cpiDpj,csdl2i,
+ + csdel2,6,ierw)
+ 31 continue
+ 29 continue
+ 30 continue
+ endif
+ endif
+ 70 continue
+ 90 continue
+ ierw = ierw-ier
+* #] get w-roots:
+* #[ write output:
+ if ( lwrite ) then
+ print *,'ffxc0p: found roots:'
+ do 85 i=1,3
+ print *,' k = ',i
+ if ( isoort(2*i) .gt. 0 ) then
+ print *,' ym,ym1 = ',y(1,i),y(3,i),' (not used)'
+ print *,' yp,yp1 = ',y(2,i),y(4,i)
+ print *,' zm,zm1 = ',z(1,i),z(3,i)
+ print *,' zp,zp1 = ',z(2,i),z(4,i)
+ if ( l4 .and. i.ne.2 .and. jsoort(2*i-1).ne.0 ) then
+ if ( isoort(4) .gt. 0 ) then
+ print *,' wm,wm1 = ',w(1,i),w(3,i)
+ print *,' wp,wp1 = ',w(2,i),w(4,i)
+ else
+ print *,' cwm,cwm1 = ',cw(1,i),cw(3,i)
+ print *,' cwp,cwp1 = ',cw(2,i),cw(4,i)
+ endif
+ endif
+ elseif ( isoort(2*i) .eq. 0 ) then
+ if ( isoort(2*i-1) .eq. 0 ) then
+ print *,' no roots, all is zero'
+ else
+ print *,' yp,yp1 = ',y(2,i),y(4,i)
+ print *,' zp,zp1 = ',z(2,i),z(4,i)
+ if ( l4 .and. i.ne.2 .and. jsoort(2*i-1).ne.0 )
+ + then
+ if ( isoort(4) .gt. 0 ) then
+ print *,' wm,wm1 = ',w(1,i),w(3,i)
+ print *,' wp,wp1 = ',w(2,i),w(4,i)
+ else
+ print *,' cwm,cwm1 = ',cw(1,i),cw(3,i)
+ print *,' cwp,cwp1 = ',cw(2,i),cw(4,i)
+ endif
+ endif
+ endif
+ else
+ print *,' cym,cym1 = ',cy(1,i),cy(3,i),'(not used)'
+ print *,' cyp,cyp1 = ',cy(2,i),cy(4,i)
+ print *,' czm,czm1 = ',cz(1,i),cz(3,i)
+ print *,' czp,czp1 = ',cz(2,i),cz(4,i)
+ if ( i .ne. 2 .and. isoort(2*i-1) .ne. 0 ) then
+ print *,' cwm,cwm1 = ',cw(1,i),cw(3,i)
+ print *,' cwp,cwp1 = ',cw(2,i),cw(4,i)
+ endif
+ endif
+ 85 continue
+ endif
+ if ( lwrite ) print '(a)',' ##] get roots:'
+* #] write output:
+* #[ which case:
+ if ( l4 ) then
+* 21-aug-1995. added check for isoort(2*i-1).eq.0 to avoid
+* undefined variables etc in ffdcs, ffdcrr. They should be
+* able to handle this, but are not (yet?)
+ if ( ierw .ge. 1 .or. isoort(1).eq.0 .or. isoort(3).eq.0
+ + .or. isoort(5).eq.0 ) then
+ l4pos = .FALSE.
+ else
+ ier = ier + ierw
+ endif
+ endif
+* #] which case:
+* #] get roots etc:
+* #[ logarithms for 4point function:
+ if ( npoin .eq. 4 ) then
+ if ( lwrite ) print '(a)',' ##[ logarithms for Ai<0:'
+ do 95 i = 1,3
+ if ( ilogi(i) .ne. -999 ) goto 95
+ if ( isoort(2*i) .gt. 0 .and.
+ + isoort(2*i-1) .ge. 0 ) then
+ s1 = -dyz(2,1,i)/dyz(2,2,i)
+ if ( lwrite ) then
+* fantasize imag part, but suppress error message
+ ier0 = 0
+ clogi(i) = zxfflg(s1,1,x1,ier0)
+ print *,'clogi = ',clogi(i)
+ endif
+ if ( abs(s1-1) .lt. xloss ) then
+ clogi(i) = dfflo1(d2yzz(i)/dyz(2,2,i),ier)
+ ilogi(i) = 0
+ else
+ if ( abs(s1+1) .lt. xloss ) then
+ clogi(i) = dfflo1(-2*sdel2i(i)/(xpi(i+3)*
+ + dyz(2,2,i)),ier)
+ else
+ clogi(i) = zxfflg(abs(s1),0,x0,ier)
+ endif
+ if ( dyz(2,2,i).gt.0 .and. dyz(2,1,i).gt.0 ) then
+ ilogi(i) = -1
+ elseif ( dyz(2,1,i).lt.0 .and. dyz(2,2,i).lt.0) then
+ ilogi(i) = +1
+ else
+ ilogi(i) = 0
+ endif
+ endif
+ if ( lwrite ) print *,'clogi+ = ',clogi(i)+
+ + DCMPLX(x0,pi)*ilogi(i)
+ elseif ( isoort(2*i-1) .lt. 0 ) then
+* for stability split the unit circle up in 4*pi/2
+* (this may have to be improved to 8*pi/4...)
+ ier0 = 0
+ if ( lwrite ) then
+ if ( abs(DBLE(cdyz(2,1,i))) .lt. xalog2 .or.
+ + abs(DIMAG(cdyz(2,2,i))) .lt. xalog2 ) then
+ cs = -DCMPLX(DBLE(cdyz(2,1,i))/xalog2,DIMAG(cdyz
+ + (2,1,i))/xalog2) / DCMPLX(DBLE(cdyz(2,2,
+ + i))/xalog2,DIMAG(cdyz(2,2,i))/xalog2)
+ else
+ cs = -cdyz(2,1,i)/cdyz(2,2,i)
+ endif
+ clogi(i)=zfflog(cs,0,c0,ier0)
+ print *,'isoort = ',isoort(2*i-1)
+ print *,'cdyz(2,1) = ',cdyz(2,1,i)
+ print *,'cdyz(2,2) = ',cdyz(2,2,i)
+ print *,'clogi = ',clogi(i)
+ endif
+ if ( DBLE(cdyz(2,1,i)) .gt. DIMAG(cdyz(2,1,i)) ) then
+ s = 2*atan2(DIMAG(cdyz(2,1,i)),DBLE(cdyz(2,1,i)))
+ clogi(i) = DCMPLX(x0,s)
+ ilogi(i) = -1
+ elseif ( DBLE(cdyz(2,1,i)) .lt. -DIMAG(cdyz(2,1,i)))
+ + then
+ if ( DIMAG(cdyz(2,1,i)) .eq. 0 ) then
+ call fferr(84,ier)
+ endif
+ s = 2*atan2(-DIMAG(cdyz(2,1,i)),-DBLE(cdyz(2,1,i)))
+ clogi(i) = DCMPLX(x0,s)
+ ilogi(i) = 1
+ else
+ s1 = -DBLE(cdyz(2,1,i))
+ s2 = DIMAG(cdyz(2,1,i))
+ s = 2*atan2(s1,s2)
+ clogi(i) = DCMPLX(x0,s)
+ ilogi(i) = 0
+ endif
+ if ( lwrite ) print *,'clogi+= ',clogi(i)+
+ + DCMPLX(x0,pi)*ilogi(i)
+ endif
+ if ( lwrite ) then
+ print *,'ffxc0p:',i,': ',clogi(i),' + ',ilogi(i),'*i*pi'
+ endif
+ 95 continue
+* An algorithm to obtain the sum of two small logarithms more
+* accurately has been put in ffcc0p, not yet here
+ if ( lwrite ) print '(a)',' ##] logarithms for Ai<0:'
+ endif
+* #] logarithms for 4point function:
+* #[ real case integrals:
+ ier1 = ier
+ if ( .not. lcompl ) then
+ if ( .not. l4 .or. .not. l4pos ) then
+* normal case
+ do 100 i=1,3
+ if ( lwrite ) print '(a,i1,a)',' ##[ xs3 nr ',i,':'
+ j = 2*i-1
+ if ( isoort(j) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffxc0p: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j),isoort(j+1)
+ endif
+ else
+ ier0 = ier
+ call ffcxs3(cs3(20*i-19),ipi12(j),y(1,i),z(1,i),
+ + dyz(1,1,i),d2yzz(i),dy2z(1,i),xpi,piDpj,
+ + i,6,isoort(j),ier0)
+ ier1 = max(ier1,ier0)
+ endif
+ if ( lwrite ) print '(a,i1,a)',' ##] xs3 nr ',i,':'
+ 100 continue
+ isoort(7) = 0
+ isoort(8) = 0
+ else
+ do 110 i=1,3,2
+ j = 2*i-1
+ isoort(j+2) = jsoort(j)
+ isoort(j+3) = jsoort(j+1)
+ if ( lwrite ) print '(a,i1,a)',' ##[ xs4 nr ',i,':'
+ ier0 = ier
+ call ffcxs4(cs3(20*i-19),ipi12(j),w(1,i),y(1,i),
+ + z(1,i),dwy(1,1,i),dwz(1,1,i),dyz(1,1,i),
+ + d2yww(i),d2yzz(i),xpi,piDpj,i,6,isoort(j),ier0)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print '(a,i1,a)',' ##] xs4 nr ',i,':'
+ 110 continue
+ endif
+* #] real case integrals:
+* #[ complex case integrals:
+ else
+* convert xpi
+ if ( .not.lcpi ) then
+ cetami(1) = etami(1)
+ cetami(3) = etami(3)
+ do 190 i=1,6
+ cpi(i) = xpi(i)
+ 190 continue
+ endif
+ if ( .not. l4 .or. .not. l4pos ) then
+* normal case
+ do 200 i=1,3
+ if ( lwrite ) print '(a,i1,a)',' ##[ xs3 nr ',i,':'
+ j = 2*i-1
+ ier0 = ier
+ if ( isoort(j) .eq. 0 ) then
+ if ( lwrite ) then
+ print *,'ffxc0p: xk=0, ma=mb/Si-0 -> S3 = 0'
+ print *,'isoort:',isoort(j),isoort(j+1)
+ endif
+ elseif ( isoort(j) .gt. 0 ) then
+ call ffcxs3(cs3(20*i-19),ipi12(2*i-1),y(1,i),
+ + z(1,i),dyz(1,1,i),d2yzz(i),dy2z(1,i),
+ + xpi,piDpj,i,6,isoort(j),ier0)
+ else
+ call ffcs3(cs3(20*i-19),ipi12(2*i-1),cy(1,i),
+ + cz(1,i),cdyz(1,1,i),cd2yzz(i),cpi,
+ + cpiDpj,i,6,isoort(j),ier0)
+ endif
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print '(a,i1,a)',' ##] xs3 nr ',i,':'
+ 200 continue
+ isoort(7) = 0
+ isoort(8) = 0
+ else
+ isoort(3) = jsoort(1)
+ isoort(4) = jsoort(2)
+ if ( lwrite ) print '(a)',' ##[ xs4 nr 1:'
+ ier0 = ier
+ if ( isoort(1) .gt. 0 .and. isoort(3) .gt. 0 ) then
+ call ffcxs4(cs3(1),ipi12(1),w(1,1),y(1,1),
+ + z(1,1),dwy(1,1,1),dwz(1,1,1),dyz(1,1,1),
+ + d2yww(1),d2yzz(1),xpi,piDpj,1,6,isoort(1),ier0)
+ else
+ call ffcs4(cs3(1),ipi12(1),cw(1,1),cy(1,1),
+ + cz(1,1),cdwy(1,1,1),cdwz(1,1,1),cdyz(1,1,1),
+ + cd2yww(1),cd2yzz(1),cpi,cpiDpj,
+ + DCMPLX(xpi(5)*alph(3)**2),cetami,1,6,isoort(1),
+ + ier0)
+ endif
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print '(a)',' ##] xs4 nr 1:'
+ if ( lwrite ) print '(a)',' ##[ xs4 nr 2:'
+ isoort(7) = jsoort(5)
+ isoort(8) = jsoort(6)
+ ier0 = ier
+ if ( isoort(5) .gt. 0 .and. isoort(7) .gt. 0 ) then
+ call ffcxs4(cs3(41),ipi12(5),w(1,3),y(1,3),
+ + z(1,3),dwy(1,1,3),dwz(1,1,3),dyz(1,1,3),
+ + d2yww(3),d2yzz(3),xpi,piDpj,3,6,isoort(5),ier0)
+ else
+ call ffcs4(cs3(41),ipi12(5),cw(1,3),cy(1,3),
+ + cz(1,3),cdwy(1,1,3),cdwz(1,1,3),cdyz(1,1,3),
+ + cd2yww(3),cd2yzz(3),cpi,cpiDpj,
+ + DCMPLX(xpi(5)*alph(1)**2),cetami,3,6,isoort(5),
+ + ier0)
+ endif
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print '(a)',' ##] xs4 nr 2:'
+ endif
+ endif
+ ier = ier1
+* #] complex case integrals:
+*###] ffxc0p:
+ end
+*###[ ffrt3p:
+ subroutine ffrt3p(clogip,ilogip,irota,clogi,ilogi,idir)
+***#[*comment:***********************************************************
+* *
+* rotates the arrays clogi,ilogi also over irota (idir=+1) or *
+* back (-1) *
+* *
+* Input: irota (integer) index in rotation array *
+* clogi(3) (complex) only if idir=-1 *
+* ilogi(3) (integer) indicates which clogi are needed*
+* (idir=+1), i*pi terms (idir=-1) *
+* idir (integer) direction: forward (+1) or *
+* backward (-1) *
+* Output: clogip(3) (integer) clogi rotated *
+* ilogip(3) (integer) ilogi rotated *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer irota,idir,ilogi(3),ilogip(3)
+ DOUBLE COMPLEX clogi(3),clogip(3)
+*
+* local variables
+*
+ integer i,inew(6,6)
+ save inew
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data inew /1,2,3,4,5,6,
+ + 2,3,1,5,6,4,
+ + 3,1,2,6,4,5,
+ + 1,3,2,6,5,4,
+ + 3,2,1,5,4,6,
+ + 2,1,3,4,6,5/
+* #] declarations:
+* #[ rotate:
+*
+* the clogi, ilogi are numbered according to the p_i
+*
+ if ( idir .eq. +1 ) then
+ do 10 i=1,3
+ ilogip(inew(i+3,irota)-3) = ilogi(i)
+ clogip(inew(i+3,irota)-3) = clogi(i)
+ 10 continue
+ else
+ do 20 i=1,3
+ ilogip(i) = ilogi(inew(i+3,irota)-3)
+ clogip(i) = clogi(inew(i+3,irota)-3)
+ 20 continue
+ endif
+*
+* #] rotate:
+*###] ffrt3p:
+ end
+
diff --git a/ff-2.0/ffxc1.f b/ff-2.0/ffxc1.f
new file mode 100644
index 0000000..ff2abd2
--- /dev/null
+++ b/ff-2.0/ffxc1.f
@@ -0,0 +1,256 @@
+*###[ ffxc1:
+ subroutine ffxc1(cc1i,cc0,cb0i,xpi,piDpj,del2,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the C1(mu) = C11*p1(mu) + C12*p2(mu) numerically *
+* *
+* Input: cc0 complex scalar threepoint function *
+* cb0i(3) complex scalar twopoint functions *
+* without m1,m2,m3 *
+* (=with p2,p3,p1) *
+* xpi(6) real masses (1-3), momenta^2 (4-6) *
+* piDpj(6,6) real dotproducts as in C0 *
+* del2 real overall determinant *
+* ier integer digits lost so far *
+* Output: cc1i(2) complex C11,C12 *
+* ier integer number of dgits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xpi(6),piDpj(6,6),del2
+ DOUBLE COMPLEX cc1i(2),cc0,cb0i(3)
+*
+* local variables
+*
+ integer i,j,ier0
+ DOUBLE PRECISION xmax,absc,xnul,xlosn,mc1i(2),mc0,mb0i(3)
+ DOUBLE PRECISION dpipj(6,6),piDpjp(6,6)
+ DOUBLE COMPLEX cc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffxc1: input:'
+ print *,'xpi = ',xpi
+ print *,'del2 = ',del2
+ endif
+ if ( ltest ) then
+ xlosn = xloss*DBLE(10)**(-1-mod(ier,50))
+ do 1 i=1,6
+ if ( xpi(i) .ne. piDpj(i,i) ) then
+ print *,'ffxc1: error: xpi and piDpj do not agree'
+ endif
+ 1 continue
+ do 4 i=1,6
+ do 3 j=1,6
+ dpipj(j,i) = xpi(j) - xpi(i)
+ 3 continue
+ 4 continue
+ ier0 = 0
+ call ffdot3(piDpjp,xpi,dpipj,6,ier0)
+ do 7 i=1,6
+ do 6 j=1,6
+ xnul = piDpj(j,i) - piDpjp(j,i)
+ if ( xlosn*abs(xnul) .gt. precx*abs(piDpjp(j,i)) )
+ + print *,'piDpj(',j,i,') not correct, cmp:',
+ + piDpj(j,i),piDpjp(j,i),xnul
+ 6 continue
+ 7 continue
+ xnul = del2 - xpi(4)*xpi(5) + piDpj(4,5)**2
+ xmax = max(abs(del2),abs(xpi(4)*xpi(5)))
+ if ( xlosn*abs(xnul) .gt. precx*xmax ) then
+ print *,'ffxc1: error: del2 != pi(4)*pi(5)-pi.pj(4,5)^2'
+ + ,del2,xpi(4)*xpi(5),piDpj(4,5)**2,xnul
+ endif
+ i = 0
+ ltest = .FALSE.
+ call ffxb0(cc,x0,x1,xpi(4),xpi(1),xpi(2),i)
+ if ( xlosn*absc(cc-cb0i(3)) .gt. precc*absc(cc) ) print *,
+ + 'cb0i(3) not right: ',cb0i(3),cc,cb0i(3)-cc
+ call ffxb0(cc,x0,x1,xpi(5),xpi(2),xpi(3),i)
+ if ( xlosn*absc(cc-cb0i(1)) .gt. precc*absc(cc) ) print *,
+ + 'cb0i(1) not right: ',cb0i(1),cc,cb0i(1)-cc
+ call ffxb0(cc,x0,x1,xpi(6),xpi(3),xpi(1),i)
+ if ( xlosn*absc(cc-cb0i(2)) .gt. precc*absc(cc) ) print *,
+ + 'cb0i(2) not right: ',cb0i(2),cc,cb0i(2)-cc
+ call ffxc0(cc,xpi,ier0)
+ if ( xlosn*absc(cc-cc0) .gt. precc*absc(cc) ) print *,
+ + 'cc0 not right: ',cc0,cc,cc0-cc
+ ltest = .TRUE.
+ endif
+* #] check input:
+* #[ call ffxc1a:
+*
+ mc0 = absc(cc0)*DBLE(10)**mod(ier,50)
+ mb0i(1) = absc(cb0i(1))*DBLE(10)**mod(ier,50)
+ mb0i(2) = absc(cb0i(2))*DBLE(10)**mod(ier,50)
+ mb0i(3) = absc(cb0i(3))*DBLE(10)**mod(ier,50)
+ call ffxc1a(cc1i,mc1i,cc0,mc0,cb0i,mb0i,xpi,piDpj,del2,ier)
+*
+* #] call ffxc1a:
+*###] ffxc1:
+ end
+*###[ ffxc1a:
+ subroutine ffxc1a(cc1i,mc1i,cc0,mc0,cb0i,mb0i,xpi,piDpj,del2,
+ + ier)
+***#[*comment:***********************************************************
+* *
+* calculate the C1(mu) = C11*p1(mu) + C12*p2(mu) numerically *
+* *
+* Input: cc0 complex scalar threepoint function *
+* mc0 real maximal partial sum in C0 *
+* cb0i(3) complex scalar twopoint functions *
+* without m1,m2,m3 *
+* (=with p2,p3,p1) *
+* mb0i(3) real maxoimal partial sum in B0i *
+* xpi(6) real masses (1-3), momenta^2 (4-6) *
+* piDpj(6,6) real dotproducts as in C0 *
+* del2 real overall determinant *
+* ier integer digits lost so far *
+* Output: cc1i(2) complex C11,C12 *
+* mc1i(2) real maximal partial sum in C11,C12 *
+* ier integer number of dgits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION mc1i(2),mc0,mb0i(3),xpi(6),piDpj(6,6),del2
+ DOUBLE COMPLEX cc1i(2),cc0,cb0i(3)
+*
+* local variables
+*
+ integer i,ier0,ier1
+ DOUBLE PRECISION xmax,absc,del2s2,dpipj(6,6),ms(5)
+ DOUBLE COMPLEX cs(5),cc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ debug input:
+ if ( lwrite ) then
+ print *,'ffxc1: input, ier = ',ier
+ print *,'cc0 = ',cc0,mc0
+ print *,'cb0i(1) = ',cb0i(1),mb0i(1)
+ print *,'cb0i(2) = ',cb0i(2),mb0i(2)
+ print *,'cb0i(3) = ',cb0i(3),mb0i(3)
+ print *,'xpi = ',xpi
+ print *,'del2= ',del2
+ endif
+ if ( del2.eq.0 ) then
+ call fferr(92,ier)
+ return
+ endif
+* #] debug input:
+* #[ calculations:
+* C1 =
+* + p1(mu)*Del2^-1 * ( - 1/2*B(p1)*p1.p2 - 1/2*B(p2)*p2.p2 - 1/2*B(p3)*
+* p2.p3 - C*p1.p2*p2.s1 + C*p1.s1*p2.p2 )
+*
+* + p2(mu)*Del2^-1 * ( 1/2*B(p1)*p1.p1 + 1/2*B(p2)*p1.p2 + 1/2*B(p3)*
+* p1.p3 + C*p1.p1*p2.s1 - C*p1.p2*p1.s1 );
+*
+ cs(1) = - cb0i(1)*DBLE(piDpj(5,5))
+ cs(2) = - cb0i(2)*DBLE(piDpj(6,5))
+ cs(3) = - cb0i(3)*DBLE(piDpj(4,5))
+ cs(4) = - 2*cc0*DBLE(piDpj(1,5)*piDpj(4,5))
+ cs(5) = + 2*cc0*DBLE(piDpj(1,4)*piDpj(5,5))
+ ms(1) = mb0i(1)*abs(piDpj(5,5))
+ ms(2) = mb0i(2)*abs(piDpj(6,5))
+ ms(3) = mb0i(3)*abs(piDpj(4,5))
+ ms(4) = 2*mc0*abs(piDpj(1,5)*piDpj(4,5))
+ ms(5) = 2*mc0*abs(piDpj(1,4)*piDpj(5,5))
+* exceptions
+ if ( xpi(1).eq.xpi(3) .and. xpi(5).eq.xpi(6) ) then
+ if ( lwrite ) print *,'special case m1=m3,p5=p6'
+ cs(2) = + cb0i(2)*DBLE(xpi(5))
+ cs(3) = 0
+ ms(2) = + mb0i(2)*xpi(5)
+ ms(3) = 0
+ endif
+* more to come?
+*
+ cc1i(1) = 0
+ mc1i(1) = 0
+ xmax = 0
+ do 10 i=1,5
+ cc1i(1) = cc1i(1) + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ mc1i(1) = max(mc1i(1),ms(i))
+ 10 continue
+ ier0 = ier
+ if ( lwarn .and. absc(cc1i(1)) .lt. xloss*xmax ) then
+ call ffwarn(163,ier0,absc(cc1i(1)),xmax)
+ if ( lwrite ) then
+ print *,'cs(i),ms(i) = '
+ print '(i2,3g16.8)',(i,cs(i),ms(i),i=1,5)
+ print '(a2,3g16.8)','+ ',cc1i(1),mc1i(1)
+ endif
+ endif
+ cc1i(1) = cc1i(1)*DBLE(1/(2*del2))
+ mc1i(1) = mc1i(1)*abs(1/(2*del2))
+*
+ cs(1) = + cb0i(1)*DBLE(piDpj(5,4))
+ cs(2) = + cb0i(2)*DBLE(piDpj(6,4))
+ cs(3) = + cb0i(3)*DBLE(piDpj(4,4))
+* invalidate dpipj
+ dpipj(1,1) = 1
+ ier1 = ier
+ call ffdl2p(del2s2,xpi,dpipj,piDpj, 4,5,6, 1,2,3, 6,ier1)
+ cs(4) = + 2*cc0*DBLE(del2s2)
+ ms(1) = mb0i(1)*abs(piDpj(5,4))
+ ms(2) = mb0i(2)*abs(piDpj(6,4))
+ ms(3) = mb0i(3)*abs(piDpj(4,4))
+ ms(4) = 2*mc0*abs(del2s2)*DBLE(10)**mod(ier1-ier,50)
+*
+ cc1i(2) = 0
+ mc1i(2) = 0
+ xmax = 0
+ do 20 i=1,4
+ cc1i(2) = cc1i(2) + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ mc1i(2) = max(mc1i(2),ms(i))
+ 20 continue
+ if ( lwarn .and. absc(cc1i(2)) .lt. xloss*xmax ) then
+ call ffwarn(163,ier0,absc(cc1i(2)),xmax)
+ if ( lwrite ) then
+ print *,'cs(i),ms(i) = '
+ print '(i2,3g16.8)',(i,cs(i),ms(i),i=1,4)
+ print '(a2,3g16.8)','+ ',cc1i(2),mc1i(2)
+ endif
+ endif
+ cc1i(2) = cc1i(2)*DBLE(1/(2*del2))
+ mc1i(2) = mc1i(2)*abs(1/(2*del2))
+ ier = max(ier0,ier1)
+*
+* #] calculations:
+* #[ print output:
+ if ( lwrite ) then
+ print *,'ffxc1: results:'
+ print *,'C11 = ',cc1i(1),mc1i(1),ier
+ print *,'C12 = ',cc1i(2),mc1i(2),ier
+ endif
+* #] print output:
+*###] ffxc1a:
+ end
diff --git a/ff-2.0/ffxd0.f b/ff-2.0/ffxd0.f
new file mode 100644
index 0000000..11e2b31
--- /dev/null
+++ b/ff-2.0/ffxd0.f
@@ -0,0 +1,1005 @@
+*--#[ log:
+* $Id: ffxd0.f,v 1.4 1996/01/22 13:32:52 gj Exp $
+* $Log: ffxd0.f,v $
+c Revision 1.4 1996/01/22 13:32:52 gj
+c Added sanity check on ier; if it is larger than 16 some routines will not
+c compute anything.
+c
+c Revision 1.3 1995/11/28 13:37:47 gj
+c Found wrong sign in ffcdna, fixed typo in ffcrp.
+c Killed first cancellation in ffcdna - more to follow
+c Added warnings to ffwarn.dat; slightly changed debug output in ffxd0.f
+c
+c Revision 1.2 1995/10/17 06:55:12 gj
+c Fixed ieps error in ffdcrr (ffcxs4.f), added real case in ffcrr, debugging
+c info in ffxd0, and warned against remaining errors for del2=0 in ffrot4
+c (ffxd0h.f)
+c
+*--#] log:
+*###[ ffxd0:
+ subroutine ffxd0(cd0,xpi,ier)
+***#[*comment:***********************************************************
+* *
+* 1 / *
+* calculate cd0 = ----- \dq [(q^2 + 2*s_1.q)*(q^2 + 2*s2.q) *
+* ipi^2 / *(q^2 + 2*s3.q)*(q^2 + 2*s4.q)]^-1 *
+* *
+* |p9 *
+* \p8 V p7/ *
+* \ / *
+* \________/ *
+* | m4 | *
+* = | | /____ *
+* m1| |m3 \ p10 *
+* | | all momenta are incoming *
+* |________| *
+* / m2 \ *
+* / \ *
+* /p5 p6\ *
+* *
+* *
+* following the two-three-point-function method in 't hooft & *
+* veltman. this is only valid if there is a lambda(pij,mi,mj)>0 *
+* *
+* Input: xpi = mi^2 (real) i=1,4 *
+* xpi = pi.pi (real) i=5,8 (note: B&D metric) *
+* xpi(9)=s (real) (=p13) *
+* xpi(10)=t (real) (=p24) *
+* xpi(11)=u (real) u=p5.p5+..-p9.p9-p10.10 or 0 *
+* xpi(12)=v (real) v=-p5.p5+p6.p6-p7.p7+.. or 0 *
+* xpi(13)=w (real) w=p5.p5-p6.p6+p7.p7-p8.p8+.. *
+* output: cd0 (complex) *
+* ier (integer) <50:lost # digits 100=error *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE PRECISION xpi(13)
+ DOUBLE COMPLEX cd0
+ integer ier
+*
+* local variables
+*
+ logical luvw(3)
+ DOUBLE PRECISION dpipj(10,13)
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ call ffdif4, ffxd0a:
+*
+ call ffdif4(dpipj,luvw,xpi,ier)
+ call ffxd0a(cd0,xpi,dpipj,ier)
+*
+* restore the zeros for u,v,w as we have calculated them
+* ourselves and the user is unlikely to do this...
+*
+ if ( luvw(1) ) xpi(11) = 0
+ if ( luvw(2) ) xpi(12) = 0
+ if ( luvw(3) ) xpi(13) = 0
+*
+* #] call ffdif4, ffxd0a:
+*###] ffxd0:
+ end
+*###[ ffxd0a:
+ subroutine ffxd0a(cd0,xpi,dpipj,ier)
+*
+* glue routine which calls ffxd0b with ndiv=0
+*
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xpi(13),dpipj(10,13)
+ DOUBLE COMPLEX cd0
+*
+* locals
+*
+ DOUBLE COMPLEX cs,cfac
+*
+* and go!
+*
+ call ffxd0b(cs,cfac,xpi,dpipj,0,ier)
+ cd0 = cs*cfac
+*
+*###] ffxd0a:
+ end
+*###[ ffxd0b:
+ subroutine ffxd0b(cs,cfac,xpi,dpipj,ndiv,ier)
+***#[*comment:***********************************************************
+* *
+* 1 / *
+* calculate cd0 = ----- \dq [(q^2 + 2*s_1.q)*(q^2 + 2*s2.q) *
+* ipi^2 / *(q^2 + 2*s3.q)*(q^2 + 2*s4.q)]^-1 *
+* *
+* |p9 *
+* \p8 V p7/ *
+* \ / *
+* \________/ *
+* | m4 | *
+* = | | /____ *
+* m1| |m3 \ p10 *
+* | | all momenta are incoming *
+* |________| *
+* / m2 \ *
+* / \ *
+* /p5 p6\ *
+* *
+* *
+* following the two-three-point-function method in 't hooft & *
+* veltman. this is only valid if there is a lambda(pij,mi,mj)>0 *
+* *
+* Input: xpi = mi^2 (real) i=1,4 *
+* xpi = pi.pi (real) i=5,8 (note: B&D metric) *
+* xpi(9)=s (real) (=p13) *
+* xpi(10)=t (real) (=p24) *
+* xpi(11)=u (real) u=p5.p5+..-p9.p9-p10.10 *
+* xpi(12)=v (real) v=-p5.p5+p6.p6-p7.p7+.. *
+* xpi(13)=w (real) w=p5.p5-p6.p6+p7.p7-p8.p8+.. *
+* dpipj(10,13) (real) = pi(i) - pi(j) *
+* output: cs,cfac (complex) cd0 = cs*cfac *
+* ier (integr) 0=ok 1=inaccurate 2=error *
+* calls: ffcxs3,ffcxr,ffcrr,... *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ndiv,ier
+ DOUBLE PRECISION xpi(13),dpipj(10,13)
+ DOUBLE COMPLEX cs,cfac
+*
+* local variables
+*
+ integer i,j,itype,ini2ir,ier2,idone,ier0,ii(6),idotsa
+ logical ldel2s
+ DOUBLE COMPLEX c,cs1,cs2
+ DOUBLE PRECISION absc,xmax,xpip(13),dpipjp(10,13),piDpjp(10,10),
+ + qiDqj(10,10),del2s,delta0,xnul,rloss,vgl
+ save ini2ir,delta0
+*
+* common blocks:
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* memory
+*
+ integer iermem(memory),ialmem(memory),memind,ierini,nscsav,
+ + isgnsa
+ logical onssav
+ DOUBLE PRECISION xpimem(10,memory),dl4mem(memory)
+ DOUBLE COMPLEX csmem(memory),cfcmem(memory)
+ save memind,iermem,ialmem,xpimem,dl4mem,nscsav,onssav,csmem,
+ + cfcmem
+*
+* statement function:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data memind /0/
+ data ini2ir /0/
+ data delta0 /0./
+*
+* #] declarations:
+* #[ initialisations:
+ cs = 0
+ cfac = 1
+ idsub = 0
+ idone = 0
+* #] initialisations:
+* #[ check input if dotproducts are input:
+*
+ if ( ltest .and. idot.gt.0 ) then
+ if ( lwrite ) print *,'ffxd0b: checking input dotproducts'
+ ier0 = ier
+ idotsa = idot
+ idot = 0
+ call ffdot4(qiDqj,xpi,dpipj,10,ier0)
+ idot = idotsa
+ rloss = xloss*DBLE(10)**(-2-mod(ier0,50))
+ if ( idot.le.2 ) then
+ do 20 i=5,10
+ do 10 j=5,10
+ xnul = fpij4(j,i)-qiDqj(j,i)
+ xmax = abs(qiDqj(j,i))
+ if ( abs(rloss*xnul) .gt. precx*xmax ) print *,
+ + 'ffxd0b: error: input dotproduct piDpj(',j,
+ + i,') wrong: ',fpij4(j,i),qiDqj(j,i),xnul,
+ + ier0
+ 10 continue
+ 20 continue
+ else
+ do 40 i=1,10
+ do 30 j=1,10
+ xnul = fpij4(j,i)-qiDqj(j,i)
+ xmax = abs(qiDqj(j,i))
+ if ( abs(rloss*xnul) .gt. precx*xmax ) print *,
+ + 'ffxd0b: error: input dotproduct piDpj(',j,
+ + i,') wrong:',fpij4(j,i),qiDqj(j,i),xnul,ier0
+ 30 continue
+ 40 continue
+ endif
+ endif
+ if ( ltest ) then
+ if ( abs(idot).ge.2 ) then
+ if ( lwrite ) print *,'ffxd0b: checking input fdel3 ',
+ + fdel3,ier0
+ if ( idot.lt.0 ) then
+ ier0 = ier
+ idotsa = idot
+ idot = 0
+ call ffdot4(qiDqj,xpi,dpipj,10,ier0)
+ idot = idotsa
+ endif
+ ii(1) = 5
+ ii(2) = 6
+ ii(3) = 7
+ ii(4) = 8
+ ii(5) = 9
+ ii(6) = 10
+ call ffdl3p(vgl,qiDqj,10,ii,ii,ier0)
+ rloss = xloss**2*DBLE(10)**(-mod(ier0,50))
+ xnul = fdel3 - vgl
+ xmax = abs(vgl)
+ if ( abs(rloss*xnul).gt.precx*xmax ) print *,
+ + 'ffxd0b: error: input del3p wrong: ',fdel3,vgl,
+ + xnul,ier0
+ endif
+ if ( idot.ge.4 ) then
+ if ( lwrite ) print *,'ffxd0b: checking input fdel4s'
+ call ffdel4(vgl,xpi,qiDqj,10,ier0)
+ xnul = fdel4s - vgl
+ xmax = abs(vgl)
+ if ( abs(rloss*xnul).gt.precx*xmax ) print *,
+ + 'ffxd0b: error: input del4s wrong: ',fdel4s,vgl,
+ + xnul,ier0
+ endif
+ endif
+*
+* #] check input if dotproducts are input:
+* #[ check for IR 4point function:
+*
+ call ffxdir(cs,cfac,idone,xpi,dpipj,4,ndiv,ier)
+ if ( idone .le. 0 .and. ndiv .gt. 0 ) then
+ if ( lwrite ) print *,'ffxd0b: at most log divergence'
+ cs = 0
+ cfac = 1
+ ier = 0
+ return
+ endif
+ if ( idone .gt. 0 ) then
+ return
+ endif
+*
+* #] check for IR 4point function:
+* #[ rotate to calculable position:
+ call ffrot4(irota4,del2s,xpip,dpipjp,piDpjp,xpi,dpipj,qiDqj,4,
+ + itype,ier)
+ if ( itype .lt. 0 ) then
+ print *,'ffxd0b: error: Cannot handle this ',
+ + ' masscombination yet:'
+ print *,(xpi(i),i=1,13)
+ return
+ endif
+ if ( itype .eq. 1 ) then
+ ldel2s = .TRUE.
+ isgnal = +1
+ else
+ ldel2s = .FALSE.
+ endif
+* #] rotate to calculable position:
+* #[ treat doubly IR divergent case:
+ if ( itype .eq. 2 ) then
+*
+* double IR divergent diagram, i.e. xpi(3)=xpi(4)=xpi(7)=0
+*
+ if ( ini2ir .eq. 0 ) then
+ ini2ir = 1
+ print *,'ffxd0b: using the log(lam) prescription to'
+ print *,' regulate the 2 infrared poles to match'
+ print *,' with soft gluon massive, lam^2 =',delta
+ endif
+ if ( ltest .and. idone .ne. 2 ) then
+ print *,'ffxd0: error: itype=2 but idone != 2'
+ endif
+ ier2 = 0
+ call ffx2ir(cs1,cs2,xpip,dpipjp,ier2)
+ del2s = -delta**2/4
+*
+* correct for the wrongly treated IR pole
+*
+ cs = cs + (cs1 + cs2)/cfac
+ ier = max(ier,ier2)
+ xmax = max(absc(cs1),absc(cs2))/absc(cfac)
+ if ( absc(cs) .lt. xloss*xmax )
+ + call ffwarn(172,ier,absc(cs),xmax)
+ if ( .not.ldot ) return
+ endif
+*
+* #] treat doubly IR divergent case:
+* #[ look in memory:
+ ierini = ier
+ isgnsa = isgnal
+*
+* initialise memory
+*
+ if ( lmem .and. idone .eq. 0 .and. (memind .eq. 0 .or. nschem
+ + .ne. nscsav .or. (onshel .neqv. onssav) ) ) then
+ memind = 0
+ nscsav = nschem
+ onssav = onshel
+ do 2 i=1,memory
+ do 1 j=1,10
+ xpimem(j,i) = 0
+ 1 continue
+ ialmem(i) = 0
+ 2 continue
+ endif
+*
+ if ( lmem .and. idone .eq. 0 .and. delta .eq. delta0 ) then
+ do 150 i=1,memory
+ do 130 j=1,10
+ if ( xpip(j) .ne. xpimem(j,i) ) goto 150
+ 130 continue
+* we use ialmem(i)==0 to signal that both are covered as
+* the sign was flipped during the computation
+ if ( ialmem(i).ne.isgnal .and. ialmem(i).ne.0 ) goto 150
+* we found an already calculated masscombination ..
+* (maybe check differences as well)
+ if ( lwrite ) print *,'ffxd0b: using previous result'
+ cs = csmem(i)
+ cfac = cfcmem(i)
+ ier = ier+iermem(i)
+ if ( ldot ) then
+ fdel4s = dl4mem(i)
+* we forgot to calculate the dotproducts
+ idone = 1
+ goto 51
+ endif
+ return
+ 150 continue
+* if ( lwrite ) print *,'ffxd0b: not found in memory'
+ elseif ( lmem ) then
+ delta0 = delta
+ endif
+ 51 continue
+* #] look in memory:
+* #[ get dotproducts:
+*
+* Calculate the dotproducts (in case it comes out of memory the
+* error is already included in ier)
+*
+ ier0 = ier
+ call ffgdt4(piDpjp,xpip,dpipjp,xpi,dpipj,itype,ier0)
+ if ( idone .gt. 0 ) return
+ ier = ier0
+ if ( ier.ge.100 ) then
+ cs = 0
+ cfac = 1
+ return
+ endif
+*
+* #] get dotproducts:
+* #[ calculations:
+*
+ call ffxd0e(cs,cfac,xmax, .FALSE.,ndiv,xpip,dpipjp,piDpjp,del2s,
+ + ldel2s,ier)
+*
+* Finally ...
+* Check for cancellations in the final adding up
+*
+ if ( lwarn .and. 2*absc(cs) .lt. xloss*xmax )
+ + call ffwarn(84,ier,absc(cs),xmax)
+*
+* #] calculations:
+* #[ add to memory:
+*
+* memory management :-)
+*
+ if ( lmem ) then
+ memind = memind + 1
+ if ( memind .gt. memory ) memind = 1
+ do 200 j=1,10
+ xpimem(j,memind) = xpip(j)
+ 200 continue
+ csmem(memind) = cs
+ cfcmem(memind) = cfac
+ iermem(memind) = ier-ierini
+ ialmem(memind) = isgnal
+ dl4mem(memind) = fdel4s
+ if ( isgnal.ne.isgnsa ) then
+ ialmem(memind) = 0
+ endif
+ endif
+* #] add to memory:
+*###] ffxd0b:
+ end
+*###[ ffxd0e:
+ subroutine ffxd0e(cs,cfac,xmax,lir,ndiv,xpip,dpipjp,piDpjp,
+ + del2s,ldel2s,ier)
+***#[*comment:***********************************************************
+* *
+* Break in the calculation of D0 to allow the E0 to tie in in a *
+* logical position. This part gets untransformed momenta but *
+* rotated momenta in and gives the D0 (in two pieces) and the *
+* maximum term back. *
+* *
+* Input xpip real(13) *
+* dpipjp real(10,13) *
+* piDpjp real(10,10) *
+* del2s real *
+* ldel2s logical *
+* lir logical if TRUE it can still be IR-div *
+* ndiv integer number of required divergences *
+* *
+* Output: cs complex the fourpoint function without *
+* overall factor (sum of dilogs) *
+* cfac complex this overall factor *
+* xmax real largest term in summation *
+* ier integer usual error flag *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ndiv,ier
+ logical lir,ldel2s
+ DOUBLE PRECISION xpip(13),dpipjp(10,13),piDpjp(10,10),xmax,del2s
+ DOUBLE COMPLEX cs,cfac
+*
+* local variables
+*
+ DOUBLE COMPLEX c,cs4(175),cs3(2)
+ logical laai
+ integer i,j,ier0,itime,maxlos,init,isoort(16),ipi12(26),
+ + ipi123(2),ipi12t,idone
+ DOUBLE PRECISION absc,sdel2s,ai(4),daiaj(4,4),aai(4),
+ + dt3t4,xqi(10),dqiqj(10,10),qiDqj(10,10),xfac
+ save maxlos
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data init /0/
+* #] declarations:
+* #[ check for IR 4point function:
+ if ( lir ) then
+*
+ ier0 = ier
+ call ffxdir(cs,cfac,idone,xpip,dpipjp,4,0,ier)
+ if ( idone .le. 0 .and. ndiv .gt. 0 ) then
+ if ( lwrite ) print *,'ffxd0e: at most log divergence'
+ cs = 0
+ cfac = 1
+ xmax = 0
+ ier = 0
+ return
+ endif
+ if ( idone .gt. 0 ) then
+ xmax = abs(cs)*10d0**(-mod((ier0-ier),50))
+ return
+ endif
+ endif
+*
+* #] check for IR 4point function:
+* #[ init:
+*
+* initialize cs4:
+*
+ do 80 i=1,175
+ cs4(i) = 0
+ 80 continue
+ do 90 i=1,26
+ ipi12(i) = 0
+ 90 continue
+ cs = 0
+*
+* check ier for sanity
+*
+ if ( ltest ) then
+ if ( ier.lt.0 .or. mod(ier,50).gt.20 ) then
+ print *,'ffxd0e: error: found ier = ',ier
+ print *,' are you sure I lost THAT many digits?'
+ print *,' please check that ier is set to 0 '//
+ + 'before calling FF!'
+ endif
+ endif
+*
+* #] init:
+* #[ transform the masses and momenta:
+ itime = 1
+ 25 continue
+*
+* Transform with the A's of gerard 't hooft's transformation:
+*
+ if ( lwrite ) print '(a)',' ##[ transform momenta:'
+*
+* NOTE: for some odd reason I cannot vary isgnal,isgn34
+* independently!
+*
+ isgn34 = isgnal
+ sdel2s = isgn34*sqrt(-del2s)
+ ier0 = ier
+ call ffai(ai,daiaj,aai,laai,del2s,sdel2s,xpip,dpipjp,piDpjp,
+ + ier0)
+ if ( ier0 .ge. 100 ) goto 70
+ call fftran(ai,daiaj,aai,laai,xqi,dqiqj,qiDqj,del2s,sdel2s,
+ + xpip,dpipjp,piDpjp,ier0)
+ if ( ier0 .ge. 100 ) goto 70
+ if ( .not.ldel2s ) then
+ dt3t4 = -2*ai(3)*ai(4)*sdel2s
+ if ( ltest ) then
+ if ( xloss*abs(dt3t4-xqi(3)+xqi(4)) .gt. precx*max(
+ + abs(dt3t4),abs(xqi(3)),abs(xqi(4))) ) then
+ print *,'ffxd0a: error: dt3t4 <> t3 - t4',dt3t4,
+ + xqi(3),xqi(4),dt3t4-xqi(3)+xqi(4)
+ endif
+ endif
+ if ( dt3t4 .eq. 0 ) then
+* don't know what to do...
+ call fferr(85,ier)
+ return
+ endif
+ else
+* this value is modulo the delta of xpip(4)=xpip(3)(1+2delta)
+ dt3t4 = -2*ai(4)**2*xpip(3)
+ endif
+
+ 70 continue
+ if ( lwrite ) print '(a)',' ##] transform momenta:'
+*
+* If we lost too much accuracy try the other root...
+* (to do: build in a mechanism for remembering this later)
+*
+ if ( init .eq. 0 ) then
+ init = 1
+* go ahead if we have half the digits left
+ maxlos = -int(log10(precx))/2
+ if ( lwrite ) print *,'ffxd0a: redo trans if loss > ',maxlos
+ endif
+ if ( ier0-ier .gt. maxlos ) then
+ if ( itime .eq. 1 ) then
+ itime = 2
+ if ( ier0-ier .ge. 100 ) itime = 100
+ isgnal = -isgnal
+ if ( lwrite ) print *,'ffxd0a: trying other root, ier=',
+ + ier0
+ goto 25
+ else
+ if ( ier0-ier .lt. 100 ) then
+* it does not make any sense to go on, but do it anyway
+ if ( lwrite ) print *,'ffxd0a: both roots rotten ',
+ + 'going on'
+ elseif ( itime.eq.100 ) then
+ if ( lwrite ) print *,'ffxd0a: both roots rotten ',
+ + 'giving up'
+ call fferr(72,ier)
+ cfac = 1
+ return
+ elseif ( itime.le.2 ) then
+* the first try was better
+ isgnal = -isgnal
+ itime = 3
+ goto 25
+ endif
+ endif
+ endif
+ ier = ier0
+* #] transform the masses and momenta:
+* #[ calculations:
+ call ffxd0p(cs4,ipi12,isoort,cfac,xpip,dpipjp,piDpjp,
+ + xqi,dqiqj,qiDqj,ai,daiaj,ldel2s,ier)
+ xfac = -ai(1)*ai(2)*ai(3)*ai(4)/dt3t4
+*
+* see the note at the end of this section about the sign
+*
+ if ( DIMAG(cfac) .eq. 0 ) then
+ cfac = xfac/DBLE(cfac)
+ else
+ cfac = DBLE(xfac)/cfac
+ endif
+*
+* sum'em up:
+*
+ cs3(1) = 0
+ cs3(2) = 0
+ xmax = 0
+ do 110 i=1,80
+ cs3(1) = cs3(1) + cs4(i)
+ xmax = max(xmax,absc(cs3(1)))
+ 110 continue
+ do 111 i=81,160
+ cs3(2) = cs3(2) + cs4(i)
+ xmax = max(xmax,absc(cs3(2)))
+ 111 continue
+ cs = cs3(1) - cs3(2)
+ do 112 i=161,175
+ cs = cs + cs4(i)
+ xmax = max(xmax,absc(cs))
+ 112 continue
+ ipi123(1) = 0
+ ipi123(2) = 0
+ do 113 i=1,8
+ ipi123(1) = ipi123(1) + ipi12(i)
+ 113 continue
+ do 114 i=9,16
+ ipi123(2) = ipi123(2) + ipi12(i)
+ 114 continue
+ ipi12t = ipi123(1) - ipi123(2)
+ do 120 i=17,26
+ ipi12t = ipi12t + ipi12(i)
+ 120 continue
+ cs = cs + ipi12t*DBLE(pi12)
+*
+* Check for a sum close to the minimum of the range (underflow
+* problems)
+*
+ if ( lwarn .and. absc(cs) .lt. xalogm/precc .and. cs .ne. 0 )
+ + call ffwarn(119,ier,absc(cs),xalogm/precc)
+*
+* If the imaginary part is very small it most likely is zero
+* (can be removed, just esthetically more pleasing)
+*
+ if ( abs(DIMAG(cs)) .lt. precc*abs(DBLE(cs)) )
+ + cs = DCMPLX(DBLE(cs))
+*
+* it is much nicer to have the sign of cfac fixed, say positive
+*
+ if ( DBLE(cfac) .lt. 0 .or. (DBLE(cfac) .eq. 0 .and. DIMAG(cfac)
+ + .lt. 0 ) ) then
+ cfac = -cfac
+ cs = -cs
+ endif
+* #] calculations:
+* #[ debug:
+ if(lwrite)then
+* print *,'s3''s :'
+* print *,' '
+* print 1004,(cs4(i),cs4(i+20),cs4(i+40),cs4(i+60),i=1,20)
+* print *,' '
+* print 1004,(cs4(i+80),cs4(i+100),cs4(i+120),cs4(i+140),i=
+* + 1,20)
+* print *,' '
+ print *,'C3:'
+ do i=1,80
+ if ( cs4(i).ne.0 ) print '(i4,2g16.8)',i,cs4(i)
+ enddo
+ print *,'C4:'
+ do i=81,160
+ if ( cs4(i).ne.0 ) print '(i4,2g16.8)',i,cs4(i)
+ enddo
+ print *,'Threepoint functions:'
+ print '(a,2g24.14,i3)','C3 = ',cs3(1),ipi123(1)
+ print '(a,2g24.14,i3)','C4 = ',cs3(2),ipi123(2)
+ print '(a,2g24.14,i3)','sum = ',cs3(1)-cs3(2),
+ + ipi123(1)-ipi123(2)
+ if ( ipi123(1) .ne. ipi123(2) ) print '(a,2g24.14)',
+ + ' = ',cs3(1)-cs3(2)+(ipi123(1)-ipi123(2))*DBLE(pi12)
+ print *,'Correction terms for Ai negative'
+ print 1013,(cs4(160+i),ipi12(16+i),
+ + cs4(161+i),ipi12(17+i),
+ + cs4(162+i),ipi12(18+i),i=1,4,3)
+ c = 0
+ j = 0
+ do 803 i=1,6
+ j = j + ipi12(16+i)
+ c = c + cs4(160+i)
+ 803 continue
+ print '(a,2g24.14,i3)','sum = ',c,j
+ if ( j .ne. 0 ) print '(a,2g24.14)',' = ',
+ + c+j*DBLE(pi12)
+ print *,'S of ''t Hooft and Veltman'
+ print 1012,(cs4(166+i),ipi12(22+i),
+ + cs4(167+i),ipi12(23+i),i=1,3,2)
+ c = 0
+ j = ipi12(23)+ipi12(24)+ipi12(25)+ipi12(26)
+ do 804 i=1,6
+ c = c + cs4(166+i)
+ 804 continue
+ print '(a,2g24.14,i3)','sum = ',c,j
+ if ( j .ne. 0 ) print '(a,2g24.14)',' = ',
+ + c+j*DBLE(pi12)
+* print *,' '
+* print *,'ipi12: ',ipi12
+* print *,'isoort:',isoort
+ print '(a,2g24.14,2i6)','som : ',cs-ipi12t*DBLE(pi12),
+ + ipi12t,ier
+ if ( ipi12t .ne. 0 ) print '(a,2g24.14)','som = ',cs
+ print *,'fac :',cfac
+ print *,'cd0 :',cs*cfac
+ 1012 format(g12.6,1x,g12.6,i4,2x,g12.6,1x,g12.6,i4)
+ 1013 format(g12.6,1x,g12.6,i4,2x,g12.6,1x,g12.6,i4,2x,g12.6,1x,
+ +g12.6,i4)
+ 1004 format(g12.6,1x,g12.6,2x,g12.6,1x,g12.6,2x,g12.6,1x,g12.6,
+ +2x,g12.6,1x,g12.6)
+ endif
+* #] debug:
+*###] ffxd0e:
+ end
+*###[ ffxd0r:
+ subroutine ffxd0r(cd0,xpi,ier)
+***#[*comment:***********************************************************
+* *
+* Tries all 12 permutations of the 4pointfunction *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ier
+ DOUBLE PRECISION xpi(13),xqi(13)
+ DOUBLE COMPLEX cd0,cd0p
+ integer inew(13,6),irota,ier0,ier1,i,j,icon,ialsav,init
+ logical lcon
+ parameter (icon=3)
+ save inew,init,lcon
+ include 'ff.h'
+ data inew /1,2,3,4,5,6,7,8,9,10,11,12,13,
+ + 4,1,2,3,8,5,6,7,10,9,11,13,12,
+ + 3,4,1,2,7,8,5,6,9,10,11,12,13,
+ + 2,3,4,1,6,7,8,5,10,9,11,13,12,
+ + 4,2,3,1,10,6,9,8,7,5,12,11,13,
+ + 1,3,2,4,9,6,10,8,5,7,12,11,13/
+ data init /0/
+* #] declarations:
+* #[ open console for some activity on screen:
+ if ( init .eq. 0 ) then
+ init = 1
+ if ( lwrite ) then
+ open(icon,file='CON:',status='old',err=11)
+ lcon = .TRUE.
+ goto 13
+ endif
+ 11 continue
+ lcon = .FALSE.
+ 13 continue
+ endif
+* #] open console for some activity on screen:
+* #[ calculations:
+ cd0 = 0
+ ier0 = ier
+ ier = 999
+ ialsav = isgnal
+ do 30 j = -1,1,2
+ do 20 irota=1,6
+ do 10 i=1,13
+ xqi(inew(i,irota)) = xpi(i)
+ 10 continue
+ ier1 = ier0
+ ner = 0
+ id = id + 1
+ isgnal = ialsav
+ print '(a,i1,a,i2)','---#[ rotation ',irota,': isgnal ',
+ + isgnal
+ if (lcon) write(icon,'(a,i1,a,i2)')'rotation ',irota,',
+ + isgnal ',isgnal
+ call ffxd0(cd0p,xqi,ier1)
+ ier1 = ier1 + ner
+ print '(a,i1,a,i2,a)','---#] rotation ',irota,
+ + ': isgnal ',isgnal,' '
+ print '(a,2g28.16,i3)','d0 = ',cd0p,ier1
+ if (lcon) write(icon,'(a,2g28.16,i3)')'d0 = ',cd0p,ier1
+ if ( ier1 .lt. ier ) then
+ cd0 = cd0p
+ ier = ier1
+ endif
+ 20 continue
+ ialsav = -ialsav
+ 30 continue
+* #] calculations:
+*###] ffxd0r:
+ end
+*###[ ffxd0d:
+ subroutine ffxd0d(cd0,xpi,piDpj,del3p,del4s,info,ier)
+***#[*comment:***********************************************************
+* *
+* Entry point to the four point function with dotproducts given. *
+* Necessary to avoid cancellations near the borders of phase *
+* space. *
+* *
+* Input: xpi(13) real 1-4: mi^2, 5-10: pi^2,s,t *
+* optional: 11:u, 12:v, 13:w *
+* info integer 0: no extra info *
+* 1: piDpj(i,j), i,j>4 is defined *
+* 2: del3p is also defined *
+* 3: all piDpj are given *
+* 4: del4s is also given *
+* piDpj(10,10) real pi.pj in B&D metric; *
+* 1-4:si.sj=(m_i^2+m_j^2-p_ij^2)/2*
+* cross: si.pjk=si.pj-si.pk *
+* 5-10: pi.pj *
+* del3p real det(pi.pj) *
+* del4s real det(si.sj) (~square overall fac)*
+* ier integer #digits accuracy lost in input *
+* Output: cd0 complex D0 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer info,ier
+ DOUBLE PRECISION xpi(13),piDpj(10,10),del3p,del4s
+ DOUBLE COMPLEX cd0
+*
+* local vars
+*
+ integer i,j
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ hide information in common blocks:
+*
+ idot = info
+ if ( idot.ne.0 ) then
+ if ( idot.gt.0 .and. idot.le.2 ) then
+ do 20 i=5,10
+ do 10 j=5,10
+ fpij4(j,i) = piDpj(j,i)
+ 10 continue
+ 20 continue
+ elseif ( idot.ge.3 ) then
+ do 40 i=1,10
+ do 30 j=1,10
+ fpij4(j,i) = piDpj(j,i)
+ 30 continue
+ 40 continue
+ endif
+ if ( abs(idot).ge.2 ) then
+ fdel3 = del3p
+ endif
+ if ( abs(idot).ge.4 ) then
+ fdel4s = del4s
+ endif
+ endif
+*
+* #] hide information in common blocks:
+* #[ call ffxd0:
+*
+ call ffxd0(cd0,xpi,ier)
+*
+* invalidate all the common blocks for the next call
+*
+ idot = 0
+*
+* #] call ffxd0:
+*###] ffxd0d:
+ end
+*###[ ffdif4:
+ subroutine ffdif4(dpipj,luvw,xpi,ier)
+***#[*comment:***********************************************************
+* *
+* Compute the elements 11-13 in xpi and the differences dpipj *
+* Note that the digits lost in dpipj are not counted towards *
+* the total. *
+* *
+* Input: xpi(1:10) real masses, momenta^2 *
+* *
+* Output: xpi(11:13) real u and similar vars v,w *
+* luvw(3) logical TRUE if xpi(10+i) has *
+* been computed here *
+* dpipj(10,13) real xpi(i) - xpi(j) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ logical luvw(3)
+ DOUBLE PRECISION xpi(13),dpipj(10,13)
+*
+* local variables
+*
+ integer i,j,ier1,ier0
+ DOUBLE PRECISION xmax
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ get differences:
+* simulate the differences in the masses etc..
+ if ( lwrite ) print *,'ffdif4: input xpi: ',xpi
+ ier1 = ier
+ if ( xpi(11) .eq. 0 ) then
+ xpi(11) = xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+ if ( lwarn ) then
+ xmax = max(abs(xpi(5)),abs(xpi(6)),abs(xpi(7)),
+ + abs(xpi(8)),abs(xpi(9)),abs(xpi(10)))
+ if ( abs(xpi(11)) .lt. xloss*xmax )
+ + call ffwarn(153,ier1,xpi(11),xmax)
+ endif
+ luvw(1) = .TRUE.
+ else
+ luvw(1) = .FALSE.
+ endif
+ if ( xpi(12) .eq. 0 ) then
+ xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+ if ( lwarn ) then
+ ier0 = ier
+ xmax = max(abs(xpi(5)),abs(xpi(6)),abs(xpi(7)),
+ + abs(xpi(8)),abs(xpi(9)),abs(xpi(10)))
+ if ( abs(xpi(12)) .lt. xloss*xmax )
+ + call ffwarn(154,ier0,xpi(12),xmax)
+ ier1 = max(ier1,ier0)
+ endif
+ luvw(2) = .TRUE.
+ else
+ luvw(2) = .FALSE.
+ endif
+ if ( xpi(13) .eq. 0 ) then
+ if ( max(abs(xpi(5)),abs(xpi(7))) .gt.
+ + max(abs(xpi(9)),abs(xpi(10))) ) then
+ xpi(13) = -xpi(12) + 2*(xpi(9)+xpi(10))
+ else
+ xpi(13) = -xpi(11) + 2*(xpi(5)+xpi(7))
+ endif
+* xpi(13) = xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+ if ( lwarn ) then
+ ier0 = ier
+ xmax = 2*min(max(abs(xpi(5)),abs(xpi(7))),
+ + max(abs(xpi(9)),abs(xpi(10))))
+ if ( abs(xpi(13)) .lt. xloss*xmax )
+ + call ffwarn(155,ier0,xpi(13),xmax)
+ ier1 = max(ier1,ier0)
+ endif
+ luvw(3) = .TRUE.
+ else
+ luvw(3) = .FALSE.
+ endif
+ if ( lwarn ) then
+ do 10 i=1,13
+ if ( i .le. 10 ) dpipj(i,i) = 0
+ do 9 j=1,min(i-1,10)
+ dpipj(j,i) = xpi(j) - xpi(i)
+ if ( i .le. 10 ) then
+ dpipj(i,j) = -dpipj(j,i)
+ endif
+* we do not need the differences of s,t,u,v,w accurately
+ if ( i .gt. 8 .and. j .gt. 8 ) goto 9
+ if ( abs(dpipj(j,i)) .lt. xloss*abs(xpi(i))
+ + .and. xpi(i) .ne. xpi(j) ) then
+ ier0 = ier
+ call ffwarn(121,ier0,dpipj(j,i),xpi(i))
+ if ( lwrite ) print *,'between xpi(',i,
+ + ') and xpi(',j,')'
+ endif
+ 9 continue
+ 10 continue
+ ier = ier1
+ else
+ do 20 i=1,13
+ do 19 j=1,10
+ dpipj(j,i) = xpi(j) - xpi(i)
+ 19 continue
+ 20 continue
+ endif
+* #] get differences:
+*###] ffdif4:
+ end
diff --git a/ff-2.0/ffxd0h.f b/ff-2.0/ffxd0h.f
new file mode 100644
index 0000000..0641227
--- /dev/null
+++ b/ff-2.0/ffxd0h.f
@@ -0,0 +1,897 @@
+*--#[ log:
+* $Id: ffxd0h.f,v 1.6 1996/01/22 13:33:49 gj Exp $
+* $Log: ffxd0h.f,v $
+c Revision 1.6 1996/01/22 13:33:49 gj
+c Added the word 'error' to print statements in ffxuvw that u,v,w were wrong
+c
+c Revision 1.5 1995/12/08 10:48:32 gj
+c Changed xloss to xlosn to prevent spurious error messages.
+c
+c Revision 1.4 1995/11/10 18:55:46 gj
+c JUst added some comments in ffrot4
+c
+c Revision 1.3 1995/10/29 15:37:43 gj
+c Revision 1.2 1995/10/17 06:55:13 gj
+c Fixed ieps error in ffdcrr (ffcxs4.f), added real case in ffcrr, debugging
+c info in ffxd0, and warned against remaining errors for del2=0 in ffrot4
+c (ffxd0h.f)
+c
+*--#] log:
+*###[ ffrot4:
+ subroutine ffrot4(irota,del2,xqi,dqiqj,qiDqj,xpi,dpipj,piDpj,ii,
+ + itype,ier)
+***#[*comment:***********************************************************
+* *
+* rotates the arrays xpi, dpipj into xqi,dqiqj over irota places *
+* such that del2(s3,s4)<=0. itype=0 unless del2(s3,s4)=0 (itype=1)*
+* itype=2 if the 4pointfunction is doubly IR-divergent *
+* ((0,0,0)vertex) *
+* *
+* Input: xpi(13) real momenta squared *
+* dpipj(10,13) real xpi(i) - xpi(j) *
+* piDpj(10,10) real if ( ii>4) pi.pj *
+* ii integer 4: from Do, 5: from E0 *
+* Output: irota integer # of positions rotated + 1 *
+* del2 real delta(s3,s4,s3,s4) chosen * *
+* xqi,dqiqj,qiDqj real rotated (q->p) *
+* itype integer 0:normal, -1:failure, 1:del2=0 *
+* 2:doubly IR *
+* ier integer usual error flag *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer irota,ier,ii,itype
+ DOUBLE PRECISION del2,xpi(13),dpipj(10,13),piDpj(10,10),
+ + xqi(13),dqiqj(10,13),qiDqj(10,10),qiDqjp(10,10)
+*
+* local variables
+*
+ integer i,j,izero,istart,ier0,init
+ DOUBLE PRECISION del2p,xlosn
+ DOUBLE COMPLEX chulp(4,4)
+ save init
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data init /0/
+*
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ ier0 = ier
+ if ( ii .eq. 5 ) then
+ do 890 i=1,10
+ if ( xpi(i) .ne. piDpj(i,i) ) then
+ print *,'ffrot4: error: xpi(',i,')!=piDpj(',i,i,
+ + '):',xpi(i),piDpj(i,i),xpi(i)-piDpj(i,i)
+ endif
+ 890 continue
+ endif
+ call ffxhck(xpi,dpipj,10,ier0)
+ call ffxuvw(xpi,dpipj,ier0)
+ if ( ier0 .gt. ier ) print *,'ffrot4: error: input wrong!'
+ endif
+* #] check input:
+* #[ find out which del2 is negative: (or zero)
+ izero = 0
+ do 40 irota = 1,12
+*
+* first check if we have a doubly IR divergent diagram
+*
+ if ( xpi(iold(3,irota)) .eq. 0 .and.
+ + xpi(iold(4,irota)) .eq. 0 .and.
+ + xpi(iold(7,irota)) .eq. 0 .and.
+ + dpipj(iold(1,irota),iold(8,irota)) .eq. 0 .and.
+ + dpipj(iold(2,irota),iold(6,irota)) .eq. 0 ) then
+ del2 = 0
+ goto 41
+ endif
+*
+* We can at this moment only handle s3^2 = 0
+* (Hope to include two masses 0 later)
+* I hope nothing goes wrong if we leave out:
+* >xpi(iold(1,irota)) .eq. 0 .or.
+* + xpi(iold(2,irota)) .eq. 0 .or.
+* + <
+* 'cause I can't see why it was included in the first place..
+*
+ if ( xpi(iold(4,irota)) .eq. 0 ) then
+ if ( lwrite ) print *,'no good, s4^2 = 0'
+ goto 40
+ endif
+*
+* Well, the combination s2=0, p6=s3, p10=s4 gives 1/A2=0 twice
+*
+ if ( xpi(iold(2,irota)) .eq. 0 .and.
+ + dpipj(iold( 6,irota),iold(3,irota)) .eq. 0 .and.
+ + dpipj(iold(10,irota),iold(4,irota)) .eq. 0) then
+ if ( lwrite ) print *,'no good, s2^2, s3^2=p6^2 and ',
+ + 's4^2=p10^2'
+ goto 40
+ endif
+*
+* phenomenologically this combo also gives an infinite result
+*
+ if ( xpi(iold(1,irota)) .eq. 0 .and.
+ + xpi(iold(2,irota)) .eq. 0 .and.
+ + dpipj(iold( 8,irota),iold(4,irota)) .eq. 0 .and.
+ + dpipj(iold( 9,irota),iold(3,irota)) .eq. 0) then
+ if ( lwrite ) print *,'no good, s1^2=s2^2=0, s4^2=p8^2',
+ + ' and s3^2 = p9^2'
+ goto 40
+ endif
+*
+* I just found out that this gives two times 1/A1 = 0
+*
+ if ( xpi(iold(7,irota)) .eq. 0 .and.
+ + dpipj(iold(9,irota),iold(3,irota))+
+ + dpipj(iold(4,irota),iold(8,irota)) .eq. 0 ) then
+ if ( lwrite ) print *,'no good, p7^2=0 and ',
+ + 'p9^2-s3^2+s4^2-p8^2 = 0'
+ goto 40
+ endif
+ if ( xpi(iold(1,irota)) .eq. 0 .and.
+ + dpipj(iold(9,irota),iold(3,irota)) .eq. 0 .and.
+ + dpipj(iold(4,irota),iold(8,irota)) .eq. 0 .and.
+ + .not.lnasty ) then
+ if ( lwrite ) print *,'no good, s1^2=0 and ',
+ + 's1.s3 = 0 and s1.s4 = 0'
+ goto 40
+ endif
+*
+* the nasty case wants xpi(1)=0, xpi(2) real:
+*
+ if ( lnasty ) then
+ if ( xpi(iold(1,irota)).ne.0 .or. DIMAG(
+ + c2sisj(iold(1,irota),iold(2,irota))).ne.0 ) then
+ print *,'no good: nasty but s1!=0 or s2 not real'
+ goto 40
+ endif
+ endif
+*
+ ier0 = 0
+ call ffxlam(del2,xpi,dpipj,10,
+ + iold(3,irota),iold(4,irota),iold(7,irota) ,ier0)
+*
+* we can only handle del2=0 if p_i^2 = 0 (and thus m_i=m_{i+1})
+*
+ if ( del2 .lt. 0 ) then
+ if ( lwrite ) print *,'irota = ',irota,' seems OK'
+ itype = 0
+ goto 50
+ endif
+ if ( del2 .eq. 0 .and. izero .eq. 0 .and. xpi(iold(7,irota))
+ + .eq. 0 ) then
+ izero = irota
+ if ( lwrite ) print *,'del2=0, but we can try it'
+ else
+ if ( lwrite ) print *,'no good, del2>=0: ',del2
+ endif
+ 40 continue
+ ier = ier + ier0
+ if ( izero .eq. 0 ) then
+ call fferr(54,ier)
+ itype = -1
+ irota = 1
+ else
+ irota = izero
+ del2 = 0
+ itype = 1
+ if ( init.lt.10 ) then
+ init = init + 1
+ print *,'ffrota: warning: the algorithms for del2=0 have not '
+ print *,' yet been tested thoroughly, and in fact are '
+ print *,' known to contain bugs.'
+ print *,' ==> DOUBLECHECK EVERYTHING WITH SMALL SPACELIKE p^2'
+ endif
+ endif
+ goto 50
+ 41 continue
+ itype = 2
+ 50 continue
+ if ( lwrite ) then
+ print *,'ffrot4: chose permutation no ',irota
+ endif
+* #] find out which del2 is negative:
+* #[ rotate:
+ do 20 i=1,13
+ xqi(i) = xpi(iold(i,irota))
+ do 10 j=1,10
+ dqiqj(j,i) = dpipj(iold(j,irota),iold(i,irota))
+ 10 continue
+ 20 continue
+ if ( ii .eq. 5 ) then
+ do 120 i=1,10
+ do 110 j=1,10
+ qiDqj(j,i) = isgrot(iold(j,irota),irota)*
+ + isgrot(iold(i,irota),irota)*
+ + piDpj(iold(j,irota),iold(i,irota))
+ 110 continue
+ 120 continue
+ endif
+ if ( lsmug .or. lnasty ) then
+ do 220 j=1,4
+ do 210 i=1,4
+ chulp(i,j) = c2sisj(i,j)
+ 210 continue
+ 220 continue
+ do 240 j=1,4
+ do 230 i=1,4
+ c2sisj(i,j) = chulp(iold(i,irota),iold(j,irota))
+ 230 continue
+ 240 continue
+ endif
+* #] rotate:
+* #[ test output:
+ if ( ltest ) then
+ ier0 = ier
+ call ffxhck(xqi,dqiqj,10,ier0)
+ call ffxuvw(xqi,dqiqj,ier0)
+ call ffxlam(del2p,xqi,dqiqj,10,3,4,7,ier0)
+ if ( del2p .ne. del2 .or. del2 .gt. 0 ) then
+ print *,'ffrot4: error: rotated wrongly!!'
+ print *,'del2 = ',del2
+ print *,'del2p = ',del2p
+ endif
+ if ( ii .eq. 5 ) then
+ call ffdot4(qiDqjp,xqi,dqiqj,10,ier0)
+ xlosn = xloss*DBLE(10)**(-mod(ier0,50))
+ do 990 i=1,10
+ do 980 j=1,10
+ if ( xlosn*abs(qiDqjp(j,i)-qiDqj(j,i)).gt.precx*
+ + abs(qiDqjp(j,i)) ) print*,'ffrot4: error ',
+ + 'qiDqj(',j,i,') wrong: ',qiDqjp(j,i),
+ + qiDqj(j,i),qiDqjp(j,i)-qiDqj(j,i)
+ 980 continue
+ 990 continue
+ endif
+ endif
+* #] test output:
+*###] ffrot4:
+ end
+*###[ ffxlam:
+ subroutine ffxlam(xlam,xpi,dpipj,ns,i1,i2,i3,ier)
+*************************************************************************
+* *
+* calculate in a numerically stable way *
+* xlam(xpi(i1),xpi(i2),xpi(i3)) = *
+* = -((xpi(i1)+xpi(i2)-xpi(i3))/2)^2 + xpi(i1)*xpi(i2) *
+* or a permutation *
+* ier is the usual error flag. *
+* *
+*************************************************************************
+ implicit none
+*
+* arguments:
+*
+ integer ns,i1,i2,i3,ier
+ DOUBLE PRECISION xlam,xpi(ns),dpipj(ns,ns)
+*
+* local variables
+*
+ DOUBLE PRECISION s1,s2
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* calculations
+*
+ if ( abs(xpi(i1)) .gt. max(abs(xpi(i2)),abs(xpi(i3))) ) then
+ s1 = xpi(i2)*xpi(i3)
+ if ( abs(dpipj(i1,i2)) .lt. abs(dpipj(i1,i3)) ) then
+ s2 = ((dpipj(i1,i2) - xpi(i3))/2)**2
+ else
+ s2 = ((dpipj(i1,i3) - xpi(i2))/2)**2
+ endif
+ elseif ( abs(xpi(i2)) .gt. abs(xpi(i3)) ) then
+ s1 = xpi(i1)*xpi(i3)
+ if ( abs(dpipj(i1,i2)) .lt. abs(dpipj(i2,i3)) ) then
+ s2 = ((dpipj(i1,i2) + xpi(i3))/2)**2
+ else
+ s2 = ((dpipj(i2,i3) - xpi(i1))/2)**2
+ endif
+ else
+ s1 = xpi(i1)*xpi(i2)
+ if ( abs(dpipj(i1,i3)) .lt. abs(dpipj(i2,i3)) ) then
+ s2 = ((dpipj(i1,i3) + xpi(i2))/2)**2
+ else
+ s2 = ((dpipj(i2,i3) + xpi(i1))/2)**2
+ endif
+ endif
+ xlam = s1 - s2
+ if ( lwarn .and. abs(xlam) .lt. xloss*s2 )
+ + call ffwarn(71,ier,xlam,s2)
+*###] ffxlam:
+ end
+*###[ ffdot4:
+ subroutine ffdot4(piDpj,xpi,dpipj,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the dotproducts pi.pj with *
+* *
+* pi = si i1=1,4 *
+* pi = p(i-3) i1=5,10 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ns,ier
+ DOUBLE PRECISION xpi(13),dpipj(10,13),piDpj(10,10)
+ integer is1,is2,is3,ip1,ip2,ip3,i,j,ier0,ier1
+ DOUBLE PRECISION xheck,xmax,xlosn,som,xmxp
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( ns .ne. 10 ) print *,'ffdot4: error: ns <> 10 '
+ if ( ltest ) then
+ call ffxhck(xpi,dpipj,10,ier)
+ call ffxuvw(xpi,dpipj,ier)
+ endif
+* #] check input:
+* #[ special case: already known:
+ if ( idot.ge.3 ) then
+ do 2 i=1,10
+ do 1 j=1,10
+ piDpj(j,i) = isgrot(iold(j,irota4),irota4)*
+ + isgrot(iold(i,irota4),irota4)*
+ + fpij4(iold(j,irota4),iold(i,irota4))
+ 1 continue
+ 2 continue
+ return
+ endif
+* #] special case: already known:
+* #[ indices:
+ ier1 = ier
+ do 10 is1=1,4
+ is2 = is1 + 1
+ if ( is2 .eq. 5 ) is2 = 1
+ is3 = is2 + 1
+ if ( is3 .eq. 5 ) is3 = 1
+ ip1 = is1 + 4
+ ip2 = is2 + 4
+ if ( mod(is1,2) .eq. 1 ) then
+ ip3 = 9
+ else
+ ip3 = 10
+ endif
+* #] indices:
+* #[ all in one vertex:
+*
+* pi.pj, si.sj
+*
+ piDpj(is1,is1) = xpi(is1)
+ piDpj(ip1,ip1) = xpi(ip1)
+*
+* si.s(i+1)
+*
+ if ( xpi(is2) .le. xpi(is1) ) then
+ piDpj(is1,is2) = (dpipj(is1,ip1) + xpi(is2))/2
+ else
+ piDpj(is1,is2) = (dpipj(is2,ip1) + xpi(is1))/2
+ endif
+ piDpj(is2,is1) = piDpj(is1,is2)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(is1,is2)) .lt.
+ + xloss*min(xpi(is1),xpi(is2)) )call ffwarn(105,ier0,
+ + piDpj(is1,is2),min(xpi(is1),xpi(is2)))
+ ier1 = max(ier1,ier0)
+*
+* si.s(i+2)
+*
+ if ( is1 .le. 2 ) then
+ if ( xpi(is1) .le. xpi(is3) ) then
+ piDpj(is3,is1) = (dpipj(is3,ip3) + xpi(is1))/2
+ else
+ piDpj(is3,is1) = (dpipj(is1,ip3) + xpi(is3))/2
+ endif
+ piDpj(is1,is3) = piDpj(is3,is1)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(is1,is3)) .lt.
+ + xloss*min(xpi(is1),xpi(is3)) ) call ffwarn(106,
+ + ier0,piDpj(is1,is3),min(xpi(is1),xpi(is3)))
+ ier1 = max(ier1,ier0)
+ endif
+*
+* pi.si
+*
+ if ( abs(xpi(ip1)) .le. xpi(is1) ) then
+ piDpj(ip1,is1) = (dpipj(is2,is1) - xpi(ip1))/2
+ else
+ piDpj(ip1,is1) = (dpipj(is2,ip1) - xpi(is1))/2
+ endif
+ piDpj(is1,ip1) = piDpj(ip1,is1)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(ip1,is1)) .lt.
+ + xloss*min(abs(xpi(ip1)),xpi(is1))) call ffwarn(107,ier0,
+ + piDpj(ip1,is1),min(abs(xpi(ip1)),xpi(is1)))
+ ier1 = max(ier1,ier0)
+*
+* pi.s(i+1)
+*
+ if ( abs(xpi(ip1)) .le. xpi(is2) ) then
+ piDpj(ip1,is2) = (dpipj(is2,is1) + xpi(ip1))/2
+ else
+ piDpj(ip1,is2) = (dpipj(ip1,is1) + xpi(is2))/2
+ endif
+ piDpj(is2,ip1) = piDpj(ip1,is2)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(ip1,is2)) .lt.
+ + xloss*min(abs(xpi(ip1)),xpi(is2))) call ffwarn(108,ier0,
+ + piDpj(ip1,is2),min(abs(xpi(ip1)),xpi(is2)))
+ ier1 = max(ier1,ier0)
+*
+* p(i+2).s(i)
+*
+ if ( abs(xpi(ip3)) .le. xpi(is1) ) then
+ piDpj(ip3,is1) = (dpipj(is1,is3) + xpi(ip3))/2
+ else
+ piDpj(ip3,is1) = (dpipj(ip3,is3) + xpi(is1))/2
+ endif
+ if ( is1 .eq. 2 .or. is1 .eq. 3 )
+ + piDpj(ip3,is1) = -piDpj(ip3,is1)
+ piDpj(is1,ip3) = piDpj(ip3,is1)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(ip3,is1)) .lt.
+ + xloss*min(abs(xpi(ip3)),xpi(is1))) call ffwarn(109,ier0,
+ + piDpj(ip3,is1),min(abs(xpi(ip3)),xpi(is1)))
+ ier1 = max(ier1,ier0)
+*
+* #] all in one vertex:
+* #[ all in one 3point:
+*
+* pi.s(i+2)
+*
+ if ( min(abs(dpipj(is2,is1)),abs(dpipj(ip3,ip2))) .le.
+ + min(abs(dpipj(ip3,is1)),abs(dpipj(is2,ip2))) ) then
+ piDpj(ip1,is3) = (dpipj(ip3,ip2) + dpipj(is2,is1))/2
+ else
+ piDpj(ip1,is3) = (dpipj(ip3,is1) + dpipj(is2,ip2))/2
+ endif
+ piDpj(is3,ip1) = piDpj(ip1,is3)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(ip1,is3)) .lt.
+ + xloss*min(abs(dpipj(ip3,ip2)),abs(dpipj(ip3,is1))) )
+ + call ffwarn(110,ier0,piDpj(ip1,is3),
+ + min(abs(dpipj(ip3,ip2)),abs(dpipj(ip3,is1))))
+ ier1 = max(ier1,ier0)
+*
+* p(i+1).s(i)
+*
+ if ( min(abs(dpipj(is3,is2)),abs(dpipj(ip1,ip3))) .le.
+ + min(abs(dpipj(ip1,is2)),abs(dpipj(is3,ip3))) ) then
+ piDpj(ip2,is1) = (dpipj(ip1,ip3) + dpipj(is3,is2))/2
+ else
+ piDpj(ip2,is1) = (dpipj(ip1,is2) + dpipj(is3,ip3))/2
+ endif
+ piDpj(is1,ip2) = piDpj(ip2,is1)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(ip2,is1)) .lt.
+ + xloss*min(abs(dpipj(ip1,ip3)),abs(dpipj(ip1,is2))) )
+ + call ffwarn(111,ier0,piDpj(ip2,is1),
+ + min(abs(dpipj(ip1,ip3)),abs(dpipj(ip1,is2))))
+ ier1 = max(ier1,ier0)
+*
+* p(i+2).s(i+1)
+*
+ if ( min(abs(dpipj(is1,is3)),abs(dpipj(ip2,ip1))) .le.
+ + min(abs(dpipj(ip2,is3)),abs(dpipj(is1,ip1))) ) then
+ piDpj(ip3,is2) = (dpipj(ip2,ip1) + dpipj(is1,is3))/2
+ else
+ piDpj(ip3,is2) = (dpipj(ip2,is3) + dpipj(is1,ip1))/2
+ endif
+ if ( is1 .eq. 2 .or. is1 .eq. 3 )
+ + piDpj(ip3,is2) = -piDpj(ip3,is2)
+ piDpj(is2,ip3) = piDpj(ip3,is2)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(ip3,is2)) .lt.
+ + xloss*min(abs(dpipj(ip2,ip1)),abs(dpipj(ip2,is3))) )
+ + call ffwarn(112,ier0,piDpj(ip3,is2),
+ + min(abs(dpipj(ip2,ip1)),abs(dpipj(ip2,is3))))
+ ier1 = max(ier1,ier0)
+*
+* #] all in one 3point:
+* #[ all external 3point:
+ if ( idot.le.0 ) then
+*
+* pi.p(i+1)
+*
+ if ( abs(xpi(ip2)) .le. abs(xpi(ip1)) ) then
+ piDpj(ip1,ip2) = (dpipj(ip3,ip1) - xpi(ip2))/2
+ else
+ piDpj(ip1,ip2) = (dpipj(ip3,ip2) - xpi(ip1))/2
+ endif
+ piDpj(ip2,ip1) = piDpj(ip1,ip2)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(ip1,ip2)) .lt.
+ + xloss*min(abs(xpi(ip1)),abs(xpi(ip2))) ) call
+ + ffwarn(113,ier0,piDpj(ip1,ip2),
+ + min(abs(xpi(ip1)),abs(xpi(ip2))))
+ ier1 = max(ier1,ier0)
+*
+* p(i+1).p(i+2)
+*
+ if ( abs(xpi(ip3)) .le. abs(xpi(ip2)) ) then
+ piDpj(ip2,ip3) = (dpipj(ip1,ip2) - xpi(ip3))/2
+ else
+ piDpj(ip2,ip3) = (dpipj(ip1,ip3) - xpi(ip2))/2
+ endif
+ if ( is1 .eq. 2 .or. is1 .eq. 3 )
+ + piDpj(ip2,ip3) = -piDpj(ip2,ip3)
+ piDpj(ip3,ip2) = piDpj(ip2,ip3)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(ip2,ip3)) .lt.
+ + xloss*min(abs(xpi(ip2)),abs(xpi(ip3))) ) call
+ + ffwarn(114,ier0,piDpj(ip2,ip3),
+ + min(abs(xpi(ip2)),abs(xpi(ip3))))
+ ier1 = max(ier1,ier0)
+*
+* p(i+2).p(i)
+*
+ if ( abs(xpi(ip1)) .le. abs(xpi(ip3)) ) then
+ piDpj(ip3,ip1) = (dpipj(ip2,ip3) - xpi(ip1))/2
+ else
+ piDpj(ip3,ip1) = (dpipj(ip2,ip1) - xpi(ip3))/2
+ endif
+ if ( is1 .eq. 2 .or. is1 .eq. 3 )
+ + piDpj(ip3,ip1) = -piDpj(ip3,ip1)
+ piDpj(ip1,ip3) = piDpj(ip3,ip1)
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(ip3,ip1)) .lt.
+ + xloss*min(abs(xpi(ip3)),abs(xpi(ip1))) ) call
+ + ffwarn(115,ier0,piDpj(ip3,ip1),
+ + min(abs(xpi(ip3)),abs(xpi(ip1))))
+ ier1 = max(ier1,ier0)
+*
+ else
+*
+* idot > 0: copy the dotproducts from fpij4
+*
+ piDpj(ip1,ip2) = isgrot(iold(ip1,irota4),irota4)*
+ + isgrot(iold(ip2,irota4),irota4)*
+ + fpij4(iold(ip1,irota4),iold(ip2,irota4))
+ piDpj(ip2,ip1) = piDpj(ip1,ip2)
+ piDpj(ip1,ip3) = isgrot(iold(ip1,irota4),irota4)*
+ + isgrot(iold(ip3,irota4),irota4)*
+ + fpij4(iold(ip1,irota4),iold(ip3,irota4))
+ piDpj(ip3,ip1) = piDpj(ip1,ip3)
+ piDpj(ip2,ip3) = isgrot(iold(ip2,irota4),irota4)*
+ + isgrot(iold(ip3,irota4),irota4)*
+ + fpij4(iold(ip2,irota4),iold(ip3,irota4))
+ piDpj(ip3,ip2) = piDpj(ip2,ip3)
+ endif
+ 10 continue
+* #] all external 3point:
+* #[ real 4point:
+*
+* the awkward 4point dotproducts:
+*
+ piDpj(9,9) = xpi(9)
+ piDpj(10,10) = xpi(10)
+ if ( idot.le.0 ) then
+*--#[ p5.p7:
+ if ( abs(xpi(7)) .lt. abs(xpi(5)) ) then
+ piDpj(5,7) = (-xpi(7) - dpipj(5,11))/2
+ else
+ piDpj(5,7) = (-xpi(5) - dpipj(7,11))/2
+ endif
+ xmax = min(abs(xpi(5)),abs(xpi(7)))
+ if ( abs(piDpj(5,7)) .lt. xloss*xmax ) then
+*
+* second try (old algorithm)
+*
+ if ( lwrite ) print *,'piDpj(5,7) = ',piDpj(5,7),xmax
+ if ( min(abs(dpipj(6,9)),abs(dpipj(8,10))) .le.
+ + min(abs(dpipj(8,9)),abs(dpipj(6,10))) ) then
+ som = (dpipj(6,9) + dpipj(8,10))/2
+ else
+ som = (dpipj(8,9) + dpipj(6,10))/2
+ endif
+ xmxp = min(abs(dpipj(6,9)),abs(dpipj(8,9)))
+ if ( lwrite ) print *,'piDpj(5,7)+= ',som,xmxp
+ if ( xmxp.lt.xmax ) then
+ piDpj(5,7) = som
+ xmax = xmxp
+ endif
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(5,7)) .lt.
+ + xloss*min(abs(dpipj(6,9)),abs(dpipj(8,9))) ) call
+ + ffwarn(116,ier0,piDpj(5,7),xmax)
+ ier1 = max(ier1,ier0)
+ endif
+ piDpj(7,5) = piDpj(5,7)
+*--#] p5.p7:
+*--#[ p6.p8:
+ if ( abs(xpi(6)) .lt. abs(xpi(8)) ) then
+ piDpj(6,8) = (-xpi(6) - dpipj(8,11))/2
+ else
+ piDpj(6,8) = (-xpi(8) - dpipj(6,11))/2
+ endif
+ xmax = min(abs(xpi(6)),abs(xpi(8)))
+ if ( abs(piDpj(6,8)) .lt. xloss*xmax ) then
+*
+* second try (old algorithm)
+*
+ if ( lwrite ) print *,'piDpj(6,8) = ',piDpj(6,8),xmax
+ if ( min(abs(dpipj(5,9)),abs(dpipj(7,10))) .le.
+ + min(abs(dpipj(7,9)),abs(dpipj(5,10))) ) then
+ som = (dpipj(5,9) + dpipj(7,10))/2
+ else
+ som = (dpipj(7,9) + dpipj(5,10))/2
+ endif
+ xmxp = min(abs(dpipj(5,9)),abs(dpipj(7,9)))
+ if ( lwrite ) print *,'piDpj(6,8)+= ',som,xmxp
+ if ( xmxp.lt.xmax ) then
+ piDpj(6,8) = som
+ xmax = xmxp
+ endif
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(6,8)) .lt.
+ + xloss*min(abs(dpipj(5,9)), abs(dpipj(7,9))) ) call
+ + ffwarn(117,ier0,piDpj(6,8),xmax)
+ ier1 = max(ier1,ier0)
+ endif
+ piDpj(8,6) = piDpj(6,8)
+*--#] p6.p8:
+*--#[ p9.p10:
+ if ( abs(xpi(9)) .lt. abs(xpi(10)) ) then
+ piDpj(9,10) = (-xpi(9) - dpipj(10,13))/2
+ else
+ piDpj(9,10) = (-xpi(10) - dpipj(9,13))/2
+ endif
+ xmax = min(abs(xpi(9)),abs(xpi(10)))
+ if ( abs(piDpj(9,10)) .lt. xloss*xmax ) then
+*
+* second try (old algorithm)
+*
+ if ( lwrite ) print *,'piDpj(9,10) = ',piDpj(9,10),xmax
+ if ( min(abs(dpipj(5,6)),abs(dpipj(7,8))) .le.
+ + min(abs(dpipj(7,6)),abs(dpipj(5,8))) ) then
+ som = (dpipj(5,6) + dpipj(7,8))/2
+ else
+ som = (dpipj(7,6) + dpipj(5,8))/2
+ endif
+ xmxp = min(abs(dpipj(5,6)),abs(dpipj(7,6)))
+ if ( lwrite ) print *,'piDpj(9,10)+= ',som,xmxp
+ if ( xmxp.lt.xmax ) then
+ piDpj(9,10) = som
+ xmax = xmxp
+ endif
+ ier0 = ier
+ if ( lwarn .and. abs(piDpj(9,10)) .lt.
+ + xloss*min(abs(dpipj(5,6)),abs(dpipj(7,6))) ) call
+ + ffwarn(118,ier0,piDpj(9,10),xmax)
+ ier1 = max(ier1,ier0)
+ endif
+ piDpj(10,9) = piDpj(9,10)
+*--#] p9.p10:
+ else
+*--#[ copy:
+*
+* idot > 1: just copy from fpij4...
+*
+ piDpj(5,7) = isgrot(iold(5,irota4),irota4)*
+ + isgrot(iold(7,irota4),irota4)*
+ + fpij4(iold(5,irota4),iold(7,irota4))
+ piDpj(7,5) = piDpj(5,7)
+ piDpj(6,8) = isgrot(iold(6,irota4),irota4)*
+ + isgrot(iold(8,irota4),irota4)*
+ + fpij4(iold(6,irota4),iold(8,irota4))
+ piDpj(8,6) = piDpj(6,8)
+ piDpj(9,10)= isgrot(iold(9,irota4),irota4)*
+ + isgrot(iold(10,irota4),irota4)*
+ + fpij4(iold(9,irota4),iold(10,irota4))
+ piDpj(10,9) = piDpj(9,10)
+*--#] copy:
+ endif
+ ier = ier1
+* #] real 4point:
+* #[ check:
+ if ( ltest ) then
+ xlosn = xloss*DBLE(10)**(-2-mod(ier,50))
+ do 40 i = 1,10
+ xheck = piDpj(i,5)
+ xmax = abs(piDpj(i,5))
+ do 20 j=6,8
+ xheck = xheck + piDpj(j,i)
+ xmax = max(abs(piDpj(j,i)),xmax)
+ 20 continue
+ if ( xlosn*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffdot4: error: dotproducts with p(',i,
+ + ') wrong: ',(j,piDpj(i,j),j=5,8),xheck,ier
+ xheck = piDpj(i,5) + piDpj(i,6) + piDpj(i,9)
+ xmax = max(abs(piDpj(i,5)),abs(piDpj(i,6)),abs(
+ + piDpj(i,9)))
+ if ( xlosn*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffdot4: error: dotproducts with p(',i,
+ + ') wrong: ',5,piDpj(i,5),6,piDpj(i,6),
+ + 9,piDpj(i,9),xheck,ier
+ xheck = piDpj(i,5) + piDpj(i,8) + piDpj(i,10)
+ xmax = max(abs(piDpj(i,5)),abs(piDpj(i,8)),abs(
+ + piDpj(i,10)))
+ if ( xlosn*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffdot4: error: dotproducts with p(',i,
+ + ') wrong: ',5,piDpj(i,5),8,piDpj(i,8),
+ + 10,piDpj(i,10),xheck,ier
+ do 30 j=1,10
+ if ( piDpj(i,j) .ne. piDpj(j,i) ) print *,
+ + 'ffdot4: error: piDpj(',i,j,') <> piDpj',j,i,')'
+ 30 continue
+ 40 continue
+ endif
+* #] check:
+*###] ffdot4:
+ end
+*###[ ffxuvw:
+ subroutine ffxuvw(xpi,dpipj,ier)
+***#[*comment:***********************************************************
+* *
+* check the consistency of the s,t-like variables u,v,w and their *
+* differences. *
+* *
+* Input: xpi real(13) the invariants *
+* dpipj real(10,13) their differences *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xpi(13),dpipj(10,13)
+*
+* local variables
+*
+ integer i,j
+ DOUBLE PRECISION xheck,xmax,xlosn
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check!:
+ xlosn = xloss*DBLE(10)**(-2-mod(ier,50))
+ xmax = max(abs(xpi(5)),abs(xpi(6)),abs(xpi(7)),
+ + abs(xpi(8)),abs(xpi(9)),abs(xpi(10)))
+ xheck = -xpi(11)+xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+ if ( xlosn*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffxuvw: error: u wrong! ',xpi(11),+xpi(5)+xpi(6)+xpi(7)
+ + +xpi(8)-xpi(9)-xpi(10),xheck,xmax
+ xheck = -xpi(12)-xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+ if ( xlosn*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffxuvw: error: v wrong! ',xpi(12),-xpi(5)+xpi(6)-xpi(7)
+ + +xpi(8)+xpi(9)+xpi(10),xheck,xmax
+ xheck = -xpi(13)+xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+ if ( xlosn*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffxuvw: error: w wrong! ',xpi(13),xpi(5)-xpi(6)+xpi(7)-
+ + xpi(8)+xpi(9)+xpi(10),xheck,xmax
+ do 20 i=10,13
+ do 10 j=1,10
+ xheck = dpipj(j,i) - xpi(j) + xpi(i)
+ xmax = max(abs(xpi(i)),abs(xpi(j)))
+ if ( xloss*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffxuvw: error: dpipj(',j,i,') != xpi(',j,')-xpi(',
+ + i,')',dpipj(j,i),xpi(j),xpi(i),xheck
+ 10 continue
+ 20 continue
+* #] check!:
+*###] ffxuvw:
+ end
+*###[ ffgdt4:
+ subroutine ffgdt4(piDpj,xpip,dpipjp,xpi,dpipj,itype,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the dotproducts pi.pj with *
+* and store results in common when asked for *
+* *
+* pi = si i1=1,4 *
+* pi = p(i-3) i1=5,10 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE PRECISION piDpj(10,10),xpip(13),dpipjp(10,13),xpi(13),
+ + dpipj(10,13)
+ integer itype,ier
+*
+* local variables
+*
+ integer i,j,iperm(3,4),ier0,ii(6)
+ DOUBLE PRECISION del2,dl3p,qiDqj(10,10)
+ save iperm
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* data
+*
+* the external threepoint vertices on which we have enough information
+*
+ data iperm/5,6,9, 6,7,10, 7,8,9, 8,5,10/
+*
+* #] declarations:
+* #[ get dotproducts:
+*
+* Calculate the dotproducts
+*
+ call ffdot4(piDpj,xpip,dpipjp,10,ier)
+ if ( ldot .and. idot.lt.3 ) then
+ do 65 i=1,10
+ do 64 j=1,10
+ fpij4(iold(j,irota4),iold(i,irota4)) =
+ + isgrot(iold(j,irota4),irota4)*
+ + isgrot(iold(i,irota4),irota4)*piDpj(j,i)
+ 64 continue
+ 65 continue
+ if ( ltest .and. itype .ne. 2 .and. idot.eq.0 ) then
+* (we messed around with the xpi if itype=2)
+ ier0 = ier
+ call ffdot4(qiDqj,xpi,dpipj,10,ier0)
+ do 72 i=1,10
+ do 71 j=1,10
+ if ( xloss*abs(qiDqj(j,i)-fpij4(j,i)) .gt.
+ + precx*abs(fpij4(j,i)) ) then
+ print *,
+ + 'ffxd0: error: fpij4(',j,i,') not correct!',
+ + fpij4(j,i),qiDqj(j,i),fpij4(j,i)-qiDqj(j,i),
+ + ' irota4 = ',irota4
+ endif
+ 71 continue
+ 72 continue
+ endif
+ endif
+ if ( ltest ) then
+* check whether the diagram is physical
+ ier0 = ier
+ do 60 i=1,4
+* if all spacelike everything is OK!
+ if ( xpi(iperm(1,i)).lt.0 .and. xpi(iperm(2,i)).lt.0
+ + .and. xpi(iperm(3,i)).lt.0 ) goto 60
+ call ffdel2(del2,piDpj,10,iperm(1,i),iperm(2,i),
+ + iperm(3,i), 1,ier0)
+ if ( del2 .gt. 0 ) then
+ call fferr(44,ier)
+* if ( lwrite )
+ print *,'vertex ',iperm(1,i),
+ + iperm(2,i),iperm(3,i),' has del2 ',del2
+ print *,'xpi = ',xpi
+ endif
+ 60 continue
+ endif
+ if ( ldot .or. ltest ) then
+ if ( abs(idot).lt.2 ) then
+ ii(1)= 5
+ ii(2)= 6
+ ii(3)= 7
+ ii(4)= 8
+ ii(5)= 9
+ ii(6)= 10
+ fidel3 = ier
+ call ffdl3p(dl3p,piDpj,10,ii,ii,fidel3)
+ fdel3 = dl3p
+ else
+ dl3p = fdel3
+ endif
+ if ( dl3p .lt. 0 ) then
+ call fferr(44,ier)
+* if ( lwrite )
+ print *,'overall vertex has del3 ',dl3p
+ print *,'xpi = ',xpi
+ endif
+ endif
+* #] get dotproducts:
+*###] ffgdt4:
+ end
diff --git a/ff-2.0/ffxd0i.f b/ff-2.0/ffxd0i.f
new file mode 100644
index 0000000..4080f33
--- /dev/null
+++ b/ff-2.0/ffxd0i.f
@@ -0,0 +1,187 @@
+*###[ ffx2ir:
+ subroutine ffx2ir(cs1,cs2,xpip,dpipjp,ier)
+***#[*comment:***********************************************************
+* *
+* Get the terms to correct for the second IR pole which is *
+* treated incorrectly if the first one is regulated with a small *
+* mass lam and they are adjacent. It is assumed that xpi(3)= *
+* xpi(4)=xpi(7)=0, xpi(1)=xpi(8), xpi(2)=xpi(6). The correction *
+* terms are *
+* *
+* cs1 = -C0(m2^2,0,lam^2;m2^2,0,p10^2)/(s-m1^2) *
+* cs2 = +C0(m2^2,lam^2,0;m2^2,0,p10^2)/(s-m1^2) *
+* *
+* when xpi(4)=lam^2=delta is taken in the D0, *
+* *
+* cs1 = -C0(lam^2,0,m1^2;0,m1^2,p9^2)/(t-m2^2) *
+* cs2 = +C0(0,lam^2,m1^2;0,m1^2,p9^2)/(t-m2^2) *
+* *
+* when xpi(3)=lam^2. Not yet tested. *
+* *
+* 10-oct-1991 Geert Jan van Oldenborgh *
+* *
+* Input: xpip(13) (real) usual 4point pi.pi *
+* dpipjp(10,13) (real) xpip(i) - xpip(j) *
+* output: xpip(13) (real) usual 4point pi.pi modified *
+* dpipjp(10,13) (real) xpip(i) - xpip(j) modified *
+* cs1,cs2 (complex) *
+* ier (integer) *
+* calls: ffxc0 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cs1,cs2
+ DOUBLE PRECISION xpip(13),dpipjp(10,13)
+*
+* local vars
+*
+ integer itest,ier0,ier1,i,j,iinx(6,4)
+ DOUBLE COMPLEX cc0
+ DOUBLE PRECISION xpi3(6),dpipj3(6,6)
+ save itest,iinx
+*
+* common
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* data
+*
+* 3=put mass on xpi(3)
+* 4=put mass on xpi(4)
+ data itest /4/
+ data iinx /2,3,4,6,7,10,
+ + 1,3,4,9,7,8,
+ + 1,2,4,5,10,8,
+ + 1,2,3,5,6,9/
+*
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( xpip(3).ne.0 .or. xpip(4).ne.0 .or. xpip(7).ne.0 )
+ + print *,'ffx2ir: wrong input: vertex (3,4,7) not all 0',
+ + xpip(3),xpip(4),xpip(7)
+ ier0 = 0
+ call ffxhck(xpip,dpipjp,10,ier0)
+ if ( ier0 .ne. 0 ) print *,'ffx2ir: error: input wrong'
+ endif
+* #] check input:
+* #[ work 3:
+ if ( itest .eq. 3 ) then
+ if ( lwrite ) then
+ print *,'ffx2ir: giving xpi(3) a mass ',delta
+ endif
+*
+* modify xpip,dpipjp
+*
+ xpip(3) = delta
+ do 10 i=1,10
+ dpipjp(i,3) = dpipjp(i,3) - delta
+ 10 continue
+ do 20 i=1,13
+ dpipjp(3,i) = dpipjp(3,i) + delta
+ 20 continue
+*
+* call first C0
+*
+ do 120 i=1,6
+ xpi3(i) = xpip(iinx(i,2))
+ do 110 j=1,6
+ dpipj3(j,i) = dpipjp(iinx(j,2),iinx(i,2))
+ 110 continue
+ 120 continue
+ idsub = idsub + 1
+ ier1 = 0
+ if ( lwrite ) print *,'ffx2ir: calling first C0'
+ call ffxc0a(cc0,xpi3,dpipj3,ier1)
+ cs1 = -cc0/DBLE(dpipjp(9,2))
+*
+* call second C0
+*
+ xpi3(2) = 0
+ xpi3(3) = delta
+ do 130 i=1,6
+ dpipj3(i,2) = dpipj3(i,2) + delta
+ dpipj3(i,3) = dpipj3(i,3) - delta
+ 130 continue
+ do 140 i=1,6
+ dpipj3(2,i) = dpipj3(2,i) - delta
+ dpipj3(3,i) = dpipj3(3,i) + delta
+ 140 continue
+ idsub = idsub + 1
+ ier0 = 0
+ if ( lwrite ) print *,'ffx2ir: calling second C0'
+ call ffxc0a(cc0,xpi3,dpipj3,ier0)
+ cs2 = +cc0/DBLE(dpipjp(9,2))
+ ier1 = max(ier1,ier0)
+ ier = ier + ier1
+* #] work 3:
+* #[ work 4:
+ elseif ( itest .eq. 4 ) then
+ if ( lwrite ) then
+ print *,'ffx2ir: giving xpi(4) a mass ',delta
+ endif
+*
+* modify xpip,dpipjp
+*
+ xpip(4) = delta
+ do 210 i=1,10
+ dpipjp(i,4) = dpipjp(i,4) - delta
+ 210 continue
+ do 220 i=1,13
+ dpipjp(4,i) = dpipjp(4,i) + delta
+ 220 continue
+*
+* call first C0
+*
+ do 320 i=1,6
+ xpi3(i) = xpip(iinx(i,1))
+ do 310 j=1,6
+ dpipj3(j,i) = dpipjp(iinx(j,1),iinx(i,1))
+ 310 continue
+ 320 continue
+ idsub = idsub + 1
+ ier1 = 0
+ if ( lwrite ) print *,'ffx2ir: calling first C0'
+ call ffxc0a(cc0,xpi3,dpipj3,ier1)
+ cs1 = -cc0/DBLE(dpipjp(10,1))
+*
+* call second C0
+*
+ xpi3(3) = 0
+ xpi3(2) = delta
+ do 330 i=1,6
+ dpipj3(i,3) = dpipj3(i,3) + delta
+ dpipj3(i,2) = dpipj3(i,2) - delta
+ 330 continue
+ do 340 i=1,6
+ dpipj3(3,i) = dpipj3(3,i) - delta
+ dpipj3(2,i) = dpipj3(2,i) + delta
+ 340 continue
+ idsub = idsub + 1
+ ier0 = 0
+ if ( lwrite ) print *,'ffx2ir: calling second C0'
+ call ffxc0a(cc0,xpi3,dpipj3,ier0)
+ cs2 = +cc0/DBLE(dpipjp(10,1))
+ ier1 = max(ier1,ier0)
+ ier = ier + ier1
+* #] work 4:
+* #[ error:
+ else
+ print *,'ffx2ir: error: itest should be either 3 or 4!',itest
+ endif
+* #] error:
+* #[ print:
+ if ( lwrite ) then
+ print *,' cs1 = ',cs1
+ print *,' cs2 = ',cs2
+ endif
+* #] print:
+*###] ffx2ir:
+ end
diff --git a/ff-2.0/ffxd0p.f b/ff-2.0/ffxd0p.f
new file mode 100644
index 0000000..4805434
--- /dev/null
+++ b/ff-2.0/ffxd0p.f
@@ -0,0 +1,814 @@
+*(##[ ffxd0p:
+ subroutine ffxd0p(cs4,ipi12,isoort,cfac,xpi,dpipj,piDpj,
+ + xqi,dqiqj,qiDqj,ai,daiaj,ldel2s,ier)
+***#[*comment:***********************************************************
+* *
+* calculate D0/pi^2/(A1*A2*A3*A4/dt3t4) *
+* *
+* = C0(t1,t2,t3) - C0(t1,t2,t4) *
+* *
+* The transformed momenta of the fourpoint functions are *
+* input. *
+* *
+* Input: xpi(10) untransformed fourpoint momenta *
+* dpipj(10,10) differences of xpi *
+* piDpj(10,10) dotproducts of xpi *
+* xqi(10) transformed fourpoint momenta *
+* dqiqj(10,10) differences of xqi *
+* qiDqj(10,10) dotproducts of xqi *
+* ai(4) the transformation parameters *
+* daiaj(4,4) their deifferences *
+* ldel2s if .TRUE. we took out factors delta *
+* *
+* Output: cs4(170) not added (assumed 0 on input) *
+* cfac the factor of cs4 from C0 (ie lam(pi)) *
+* ier 0=ok 1=inaccurate 2=error *
+* *
+* Calls: ffxc0p,ffpi34,ffxhck,ffdl3m,ffdel2,ffdel3,... *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cs4(175),cfac
+ integer ipi12(26),isoort(16),ier
+ logical ldel2s
+ DOUBLE PRECISION xpi(10),dpipj(10,10),piDpj(10,10),
+ + xqi(10),dqiqj(10,10),qiDqj(10,10),ai(4),daiaj(4,4)
+*
+* local variables
+*
+ integer i,j,k,ip,jp,m,ilogi(6),ii(6,2),jj(6,2),ier0,ier1,
+ + is1,is2
+ DOUBLE COMPLEX c,clogi(6),cipi
+ DOUBLE PRECISION xpi3(6,3:4),dpipj3(6,6,3:4),piDpj3(6,6,3:4),
+ + absc,del2,del2s(3,3:4),del3(3:4),del3mi(6,3:4),
+ + del4,etalam(3:4),etami(6,3:4),ddel2s(2:3),delpsi(3,3:4),
+ + alph(3),blph(3),sdel2,hulp,som,s(4),smax,xmax
+ DOUBLE COMPLEX cpi(6,3:4),cpiDpj(6,6,3:4),cdpipj(6,6,3:4),
+ + cetalm(3:4),cetami(6,3:4),calph(3),csdel2,
+ + cel2s(3,3:4),celpsi(3,3:4),zqi(10),zqiDqj(10,10),
+ + zdqiqj(10,10),cddl2s(2:3),cqi3(6,3:4),cqiqj3(6,6,3:4),
+ + cqiDqj3(6,6,3:4)
+ logical lcroot,lb
+ save ii,jj
+*
+* common blocks:
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* statement function:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data ii/1,2,3,5,6,9,1,2,3,5,6,9/
+ data jj/1,2,4,5,10,8,1,2,4,5,10,8/
+*
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+* call ffxhck(xpi,dpipj,10,ier)
+* call ffxhck(xqi,dqiqj,10,ier)
+* if ( ier .ne. 0 ) print *,'(input tested by ffxd0p)'
+ endif
+* #] check input:
+* #[ preparation:
+* Note that the piDpj3(,,3) contain now the threepoint function
+* with s3, (,,4) with s4 (and NOT *without* as before)
+ call ffpi43(xpi3(1,3),dpipj3(1,1,3),piDpj3(1,1,3),
+ + xqi,dqiqj,qiDqj,7-3,ier)
+ call ffpi43(xpi3(1,4),dpipj3(1,1,4),piDpj3(1,1,4),
+ + xqi,dqiqj,qiDqj,7-4,ier)
+*
+* set the logarithms to be calculated to -999
+*
+ do 40 i=1,6
+ clogi(i) = 0
+ ilogi(i) = 0
+ 40 continue
+ if ( ai(1) .lt. 0 .neqv. ai(2) .lt. 0 ) then
+ ilogi(1) = -999
+ ilogi(4) = -999
+ endif
+ if ( ai(2) .lt. 0 .neqv. ai(3) .lt. 0 ) then
+ ilogi(2) = -999
+ endif
+ if ( ai(3) .lt. 0 .neqv. ai(1) .lt. 0 ) then
+ ilogi(3) = -999
+ endif
+ if ( ai(2) .lt. 0 .neqv. ai(4) .lt. 0 ) then
+ ilogi(5) = -999
+ endif
+ if ( ai(4) .lt. 0 .neqv. ai(1) .lt. 0 ) then
+ ilogi(6) = -999
+ endif
+*
+* #] preparation:
+* #[ determinants:
+*
+* some determinants
+*
+ if ( lwrite ) print '(a)',' ##[ determinants:'
+*
+* note that not all errors are additive, only when a previous
+* result is used as input do we need to add ther ier's, otherwise
+* we can take the maximum value to get a decent estimate of the
+* number of digits lost.
+*
+ ier1 = ier
+ if ( .not.ldel2s ) then
+ ier0 = ier
+ call ffdel2(del2,qiDqj,10, 5,6,9, 0,ier0)
+ ier1 = max(ier1,ier0)
+ else
+ s(1) = xqi(5)*xqi(3)
+ s(2) = qiDqj(5,3)**2
+ del2 = s(1) - s(2)
+ if ( abs(del2) .lt. xloss*s(2) ) ier1 = 100
+ endif
+ if ( ier1 .ne. ier ) then
+ ier0 = ier
+ call ffdel4(del4,xpi,piDpj,10,ier0)
+ if ( ldel2s ) then
+ hulp = -(ai(1)*ai(2)*ai(3)*ai(4)/xqi(3))**2 * del4
+ else
+ hulp = -(2*ai(1)*ai(2)*ai(3)*ai(4)/dqiqj(3,4))**2 * del4
+ endif
+ if ( lwrite ) then
+ print *,'del2 was :',del2
+ print *,' and is :',hulp
+ endif
+ del2 = hulp
+ ier1 = ier0
+ fdel4s = del4
+ else
+ if ( ldel2s ) then
+ fdel4s = -del2*(xqi(3)/ai(1)*ai(2)*ai(3)*ai(4))**2
+ else
+ fdel4s=-del2*(dqiqj(3,4)/(2*ai(1)*ai(2)*ai(3)*ai(4)))**2
+ endif
+ endif
+ if ( del2 .gt. 0 ) then
+* use complex routines
+* call fferr(44,ier)
+ lcroot = .TRUE.
+ sdel2 = isgnal*sqrt(del2)
+ csdel2 = DCMPLX(x0,sdel2)
+ elseif ( del2 .eq. 0 ) then
+ call fferr(45,ier)
+ if ( ltest ) then
+ print *,'ffxd0p: error: del2 = 0'
+ print *,'xqi = ',xqi,ier
+ return
+ endif
+ else
+ lcroot = .FALSE.
+ sdel2 = isgnal*sqrt(-del2)
+ endif
+ ier0 = ier
+ call ffdl3s(del3(3),xpi,piDpj,ii,10,ier0)
+ ier1 = max(ier0,ier1)
+ if ( lwrite ) print *,'del3s(untransformed) 3 = ',del3(3)
+ ier0 = ier
+ call ffdl3s(del3(4),xpi,piDpj,jj,10,ier0)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'del3s(untransformed) 4 = ',del3(4)
+ del3(3) = ai(1)**2*ai(2)**2*ai(3)**2*del3(3)
+ del3(4) = ai(1)**2*ai(2)**2*ai(4)**2*del3(4)
+ do 108 m=3,4
+ ier0 = ier
+ if ( .not.ldel2s ) then
+ call ffdl3m(del3mi(1,m),.TRUE.,del3(m),del2,xpi3(1,m)
+ + ,dpipj3(1,1,m),piDpj3(1,1,m), 6, 4,5,6,1,3,ier0)
+ else
+*
+* the special case del2s = 0. Note that del3mi(i) and
+* del3mi(i+3) are used in S_{i-1}.
+*
+ call ffdl3m(del3mi(1,m),.FALSE.,x0,x0,xpi3(1,m),
+ + dpipj3(1,1,m),piDpj3(1,1,m), 6, 4,3,0, 1,2,ier0)
+ ier1= max(ier1,ier0)
+ ier0 = ier
+ call ffdl3m(del3mi(5,m),.FALSE.,x0,x0,xpi3(1,m),
+ + dpipj3(1,1,m),piDpj3(1,1,m), 6, 4,3,0, 5,2,ier0)
+ del3mi(3,m) = 0
+ del3mi(4,m) = 0
+ endif
+ ier1 = max(ier1,ier0)
+ do 105 i=1,3
+ j = i+1
+ if ( j .eq. 4 ) j = 1
+ ip = i
+ jp = j
+ if ( m .eq. 4 ) then
+ if ( jp .eq. 3 ) jp = 4
+ if ( ip .eq. 3 ) ip = 4
+ endif
+ if ( i.eq.1 .and. m.eq.4 ) then
+ del2s(1,4) = del2s(1,3)
+ else
+ ier0 = ier
+ call ffdel2(del2s(i,m),piDpj,10,inx(ip,jp),ip,
+ + jp,1,ier0)
+ del2s(i,m) = ai(ip)**2*ai(jp)**2*del2s(i,m)
+ ier1 = max(ier1,ier0)
+ endif
+ k = i-1
+ if ( k .eq. 0 ) k = 3
+ ier0 = ier
+ if ( .not.ldel2s ) then
+ call ffdl2p(delpsi(i,m),xpi3(1,m),dpipj3(1,1,m),
+ + piDpj3(1,1,m),i+3,j+3,k+3,i,j,k,6,ier0)
+ else
+ call ffdl2t(delpsi(i,m),qiDqj, m,5, ip,jp,inx(ip,jp)
+ + ,+1,+1, 10,ier0)
+ endif
+ ier1 = max(ier1,ier0)
+ etami(i,m) = del3mi(i,m)/del2
+ if ( ldel2s .and. i.gt.1 )
+ + etami(i+3,m) = del3mi(i+3,m)/del2
+ 105 continue
+ etalam(m) = del3(m)/del2
+ 108 continue
+*
+* the error analysis
+*
+ ier = ier1
+*
+* get alpha,1-alpha
+*
+ if ( .not. lcroot ) then
+ if ( .not.ldel2s ) then
+ if ( xpi3(5,3).eq.0 .and. (piDpj3(5,6,3).gt.0 .eqv.
+ + sdel2.gt.0) ) then
+ alph(1) = -xpi3(6,3)/(piDpj3(5,6,3)+sdel2)
+ alph(3) = -xpi3(4,3)/(piDpj3(5,4,3)-sdel2)
+ lb = .FALSE.
+ else
+ lb = .TRUE.
+ call ffroot(blph(1),alph(1),xpi3(5,3),
+ + -piDpj3(5,6,3),xpi3(6,3),sdel2,ier)
+ call ffroot(alph(3),blph(3),xpi3(5,3),
+ + -piDpj3(5,4,3),xpi3(4,3),sdel2,ier)
+ endif
+* We cannot change the sign as it is fixed by the choice
+* of sign in fftrans (sqrt(delta(s3,s4))) WRONG
+* if ( l4also .and. ( alph(1) .gt. 1 .or. alph(1) .lt. 0
+* + ) .and. abs(blph(1)-x05) .lt. abs(alph(1)-x05) ) then
+* alph(1) = blph(1)
+* alph(3) = blph(3)
+* sdel2 = -sdel2
+* isgnal = -isgnal
+* endif
+ else
+ alph(1) = 1
+ alph(3) = 0
+ endif
+ cfac = 2*sdel2
+ if (lwrite) then
+ print *,'slam = ',2*sdel2
+ print *,'del2s3 = ',(del2s(i,3),i=1,3)
+ print *,'del2s4 = ',(del2s(i,4),i=1,3)
+ print *,'del2ps3= ',(delpsi(i,3),i=1,3)
+ print *,'del2ps4= ',(delpsi(i,4),i=1,3)
+ print *,'del3mi3= ',(del3mi(i,3),i=1,3)
+ print *,'del3mi4= ',(del3mi(i,4),i=1,3)
+ print *,'etami3 = ',(etami(i,3),i=1,3)
+ print *,'etami4 = ',(etami(i,4),i=1,3)
+ print *,'eta3 = ',-4*del3(3)
+ print *,'eta4 = ',-4*del3(4)
+ print *,'alpha = ',alph(1),alph(3)
+ print *,'ier = ',ier
+ endif
+ else
+ do 4 k=3,4
+ do 3 i=1,6
+ cpi(i,k) = xpi3(i,k)
+ do 2 j=1,6
+ cdpipj(j,i,k) = dpipj3(j,i,k)
+ cpiDpj(j,i,k) = piDpj3(j,i,k)
+ 2 continue
+ 3 continue
+ 4 continue
+ if ( .not.ldel2s ) then
+ call ffcoot(c,calph(1),cpi(5,3),-cpiDpj(5,6,3),
+ + cpi(6,3),csdel2,ier)
+ call ffcoot(calph(3),c,cpi(5,3),-cpiDpj(5,4,3),
+ + cpi(4,3),csdel2,ier)
+ else
+ calph(1) = 1
+ calph(3) = 0
+ endif
+ cfac = 2*csdel2
+ if (lwrite) then
+ print *,'slam =',cfac
+ print *,'eta3 =',-4*del3(3)
+ print *,'eta4 =',-4*del3(4)
+ print *,'alpha =',calph(1),calph(3)
+ print *,'ier = ',ier
+ endif
+ endif
+ if ( lwrite ) print '(a)',' ##] determinants:'
+* #] determinants:
+* #[ convert to complex:
+ if ( lcroot ) then
+ do 110 k=3,4
+ cetalm(k) = etalam(k)
+ do 109 i=1,3
+ cel2s(i,k) = del2s(i,k)
+ celpsi(i,k) = delpsi(i,k)
+ cetami(i,k) = etami(i,k)
+ 109 continue
+ 110 continue
+ endif
+* #] convert to complex:
+* #[ simple case:
+ if ( ldel2s .or. abs(dqiqj(3,4)) .lt. xloss*abs(xqi(3)) ) then
+ if ( .not.lsmug .and. (ldel2s .or. ldc3c4) ) goto 500
+ if ( lwrite ) print *,'Expect cancellations of ',
+ + abs(dqiqj(3,4)/xqi(3))
+ endif
+*
+* and the calculations
+*
+ ier0 = ier
+ ier1 = ier
+ if ( lcroot ) then
+ call ffcc0p(cs4( 1),ipi12(1),isoort(1),clogi(1),ilogi(1),
+ + cpi(1,3),cdpipj(1,1,3),cpiDpj(1,1,3),csdel2,cel2s(1,3),
+ + cetalm(3),cetami(1,3),celpsi(1,3),calph,4,ier0)
+ call ffcc0p(cs4(81),ipi12(9),isoort(9),clogi(4),ilogi(4),
+ + cpi(1,4),cdpipj(1,1,4),cpiDpj(1,1,4),csdel2,cel2s(1,4),
+ + cetalm(4),cetami(1,4),celpsi(1,4),calph,4,ier1)
+ else
+ if ( lsmug ) call ffsm43(xpi3(1,3),7-3)
+ call ffxc0p(cs4( 1),ipi12(1),isoort(1),clogi(1),ilogi(1),
+ + xpi3(1,3),dpipj3(1,1,3),piDpj3(1,1,3),sdel2,del2s(1,3),
+ + etalam(3),etami(1,3),delpsi(1,3),alph,4,ier0)
+ if ( lsmug ) call ffsm43(xpi3(1,4),7-4)
+ call ffxc0p(cs4(81),ipi12(9),isoort(9),clogi(4),ilogi(4),
+ + xpi3(1,4),dpipj3(1,1,4),piDpj3(1,1,4),sdel2,del2s(1,4),
+ + etalam(4),etami(1,4),delpsi(1,4),alph,4,ier1)
+ endif
+ ier = max(ier0,ier1)
+ goto 600
+* #] simple case:
+* #[ cancellations:
+ 500 continue
+*
+* There are cancellations between the dilogarithms or the vertex
+* is on threshold.
+* we need the differences ddel2s(i) = del2s(i,3)-del2s(i,4)
+*
+ do 510 i=2,3
+ if ( i .eq. 2 ) then
+ j = 2
+ else
+ j = 1
+ endif
+ ddel2s(i) = del2s(i,3) - del2s(i,4)
+ xmax = abs(del2s(i,3))
+ if ( abs(ddel2s(i)) .ge. xloss*xmax ) goto 510
+ if ( lwrite ) print *,'ddel2s(',i,') = ',ddel2s(i),
+ + abs(del2s(i,3))
+*
+* Very first try with transformation
+*
+ s(1) = (ai(3)+ai(4))*daiaj(3,4)*del2s(i,3)/ai(3)**2
+ s(2) = ai(j)**2*ai(4)**2*xpi(j)*dpipj(3,4)
+ s(3) = ai(j)**2*ai(4)**2*piDpj(j,7)*piDpj(j,3)
+ s(4) = ai(j)**2*ai(4)**2*piDpj(j,7)*piDpj(j,4)
+ som = s(1) + s(2) + s(3) + s(4)
+ smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)))
+ if ( lwrite ) print *,'ddel2s(',i,')+ = ',som,
+ + s(1),s(2),s(3),s(4)
+ if ( abs(som) .ge. xloss*smax ) goto 510
+ if ( smax .lt. xmax ) then
+ ddel2s(i) = som
+ xmax = smax
+ endif
+**
+* first try (tested, but not needed)
+**
+* s(1) = xqi(j)*dqiqj(3,4)
+* s(2) = qiDqj(7,j)*qiDqj(j,3)
+* s(3) = qiDqj(7,j)*qiDqj(j,4)
+* som = s(1) + s(2) + s(3)
+* smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+* if ( abs(som) .ge. xloss*smax ) goto 510
+* if ( lwrite ) print *,' ddel2s(i) = ',som,s(1),s(2),s(3)
+* if ( smax .lt. xmax ) then
+* ddel2s(i) = som
+* xmax = smax
+* endif
+**
+* second try (tested, but not needed)
+**
+* s(1) = xqi(inx(j,3))*dqiqj(3,4)
+* s(2) = -isgn(j,3)*qiDqj(7,4)*qiDqj(inx(j,3),3)
+* s(3) = -isgn(j,4)*qiDqj(7,4)*qiDqj(inx(j,4),4)
+* som = s(1) + s(2) + s(3)
+* smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
+* if ( lwrite ) print *,' ddel2s(i)+ = ',som,s(1),s(2),s(3)
+* if ( abs(som) .ge. xloss*smax ) goto 510
+* if ( smax .lt. xmax ) then
+* ddel2s(i) = som
+* xmax = smax
+* endif
+*
+* maybe insert something intelligent later ...
+*
+ if ( lwarn ) call ffwarn(139,ier,ddel2s(i),xmax)
+ 510 continue
+ if ( .not. lcroot ) then
+ call ffdxc0(cs4,ipi12,isoort,clogi,ilogi,xpi3,dpipj3,piDpj3,
+ + xqi,dqiqj,qiDqj,sdel2,del2s,etalam,etami,delpsi,alph,
+ + ddel2s,ldel2s,4,ier)
+ else
+ cddl2s(2) = ddel2s(2)
+ cddl2s(3) = ddel2s(3)
+ do 530 i=1,10
+ zqi(i) = xqi(i)
+ do 520 j=1,10
+ zdqiqj(j,i) = dqiqj(j,i)
+ zqiDqj(j,i) = qiDqj(j,i)
+ 520 continue
+ 530 continue
+ call ffdcc0(cs4,ipi12,isoort,clogi,ilogi,cpi,cdpipj,cpiDpj,
+ + zqi,zdqiqj,zqiDqj,csdel2,cel2s,cetalm,cetami,celpsi,
+ + calph,cddl2s,ldel2s,4,ier)
+ endif
+ 600 continue
+* #] cancellations:
+* #[ Ai<0 terms:
+ cipi = DCMPLX(x0,pi)
+ if ( ai(3) .lt. 0 .neqv. ai(4) .lt. 0 ) then
+* we need the S term
+ if ( ai(1) .lt. 0 .eqv. ai(2) .lt. 0 ) then
+ if ( lcroot ) then
+ call ffcxra(cs4(167),ipi12(23),xqi,qiDqj,sdel2,1,ier)
+ else
+* call ffxtro(cs4(167),ipi12(23),xqi,qiDqj,sdel2,1,ier)
+ call ffxtra(cs4(167),ipi12(23),xqi,qiDqj,sdel2,1,ier)
+ endif
+ else
+ if ( lcroot ) then
+ call ffcxra(cs4(167),ipi12(23),xqi,qiDqj,sdel2,2,ier)
+ call ffcxra(cs4(169),ipi12(25),xqi,qiDqj,sdel2,3,ier)
+ else
+ call ffxtra(cs4(167),ipi12(23),xqi,qiDqj,sdel2,2,ier)
+ call ffxtra(cs4(169),ipi12(25),xqi,qiDqj,sdel2,3,ier)
+* call ffxtro(cs4(167),ipi12(23),xqi,qiDqj,sdel2,2,ier)
+* call ffxtro(cs4(169),ipi12(25),xqi,qiDqj,sdel2,3,ier)
+ endif
+ endif
+ endif
+*
+* The normal correction terms
+*
+ if ( ai(1) .lt. 0 .neqv. ai(2) .lt. 0 ) then
+ cs4(161) = -cipi*clogi(1)
+ ipi12(17) = 12*ilogi(1)
+ if ( ilogi(1) .eq. -999 ) call fferr(46,ier)
+ cs4(164) = cipi*clogi(4)
+ ipi12(20) = -12*ilogi(4)
+ if ( ilogi(4) .eq. -999 ) call fferr(46,ier)
+ endif
+ if ( ai(2) .lt. 0 .neqv. ai(3) .lt. 0 ) then
+ cs4(162) = -cipi*clogi(2)
+ ipi12(18) = 12*ilogi(2)
+ if ( ilogi(2) .eq. -999 ) call fferr(46,ier)
+ endif
+ if ( ai(3) .lt. 0 .neqv. ai(1) .lt. 0 ) then
+ cs4(163) = -cipi*clogi(3)
+ ipi12(19) = 12*ilogi(3)
+ if ( ilogi(3) .eq. -999 ) call fferr(46,ier)
+ endif
+ if ( ai(2) .lt. 0 .neqv. ai(4) .lt. 0 ) then
+ cs4(165) = cipi*clogi(5)
+ ipi12(21) = -12*ilogi(5)
+ if ( ilogi(5) .eq. -999 ) call fferr(46,ier)
+ endif
+ if ( ai(4) .lt. 0 .neqv. ai(1) .lt. 0 ) then
+ cs4(166) = cipi*clogi(6)
+ ipi12(22) = -12*ilogi(6)
+ if ( ilogi(6) .eq. -999 ) call fferr(46,ier)
+ endif
+ if ( lwrite ) print *,'signs Ai: ',(nint(sign(x1,ai(i))),i=1,4)
+* #] Ai<0 terms:
+*###] ffxd0p:
+ end
+*###[ ffpi43:
+ subroutine ffpi43(xpi3,dpipj3,piDpj3,xpi,dpipj,piDpj,imiss,ier)
+***#[*comment:***********************************************************
+* *
+* Fill the threepoint arrays xpi3 and dpipj3 with masses from the *
+* the fourpoint array xpi with leg imiss cut out. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE PRECISION xpi3(6),dpipj3(6,6),piDpj3(6,6)
+ DOUBLE PRECISION xpi(10),dpipj(10,10),piDpj(10,10)
+ integer imiss,ier
+*
+* local variables
+*
+ integer i,j
+ integer iinx(6,4)
+ DOUBLE PRECISION xmin,xmax,a
+ save iinx
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data iinx /2,3,4,6,7,10,
+ + 1,3,4,9,7,8,
+ + 1,2,4,5,10,8,
+ + 1,2,3,5,6,9/
+* #] declarations:
+* #[ calculations:
+* if ( lscale ) then
+* xmax = abs(xpi(iinx(1,imiss)))
+* xmin = xmax
+* do 5 i=2,6
+* a = abs(xpi(iinx(i,imiss)))
+* xmax = max(xmax,a)
+* xmin = min(xmin,a)
+* 5 continue
+* scale = (xmax*sqrt(xmin))**(-2/3.)
+* else
+* scale = 1
+* endif
+ do 20 i=1,6
+ xpi3(i) = xpi(iinx(i,imiss))
+ do 10 j=1,6
+ dpipj3(j,i) = dpipj(iinx(j,imiss),iinx(i,imiss))
+ piDpj3(j,i) = piDpj(iinx(j,imiss),iinx(i,imiss))
+ 10 continue
+ 20 continue
+* call ffxhck(xpi3,dpipj3,6,ier)
+* if ( lscale .and. lwrite ) then
+* print *,'ffpi43: scaled momenta:'
+* print *,xpi3
+* endif
+* #] calculations:
+*###] ffpi43:
+ end
+*###[ ffxtra:
+ subroutine ffxtra(cs4,ipi12,xqi,qiDqj,sdel2,ii,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the extra terms S_ii^{\infty\prime}, put them in *
+* cs4 and ipi12. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ipi12(3),ii,ier
+ DOUBLE COMPLEX cs4(3)
+ DOUBLE PRECISION xqi(10),qiDqj(10,10),sdel2
+*
+* local variables
+*
+ integer i,ip(5)
+ DOUBLE PRECISION x(2,3),dfflo1,s,s1
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data ip/5,6,8,5,6/
+* #] declarations:
+* #[ calculations:
+ if ( ii .eq. 3 ) return
+ do 10 i=1,3
+ if ( ii .eq. 1 .and. i .eq. 2 ) goto 10
+ call ffroot(x(1,i),x(2,i),xqi(ip(i)),-qiDqj(ip(i),
+ + ip(i+1)),xqi(ip(i+1)),sdel2,ier)
+ s = -x(2,i)/x(1,i)
+ if ( lwrite ) then
+ print *,'s = ',s
+ endif
+ if ( abs(s-1) .lt. xloss ) then
+ if ( lwrite ) then
+ print *,'s''=',1+2*qiDqj(ip(i),ip(i+1))/(xqi(ip(i))*
+ + x(1,i))
+ endif
+ s1 = dfflo1(-2*qiDqj(ip(i),ip(i+1))/(xqi(ip(i))*x(1,i)),
+ + ier)
+ elseif ( s .gt. 0 ) then
+ s1 = log(s)
+ else
+ if ( abs(s+1) .lt. xloss ) then
+ if ( lwrite ) then
+ print *,'s''=',-1-2*sdel2/(xqi(ip(i))*x(1,i))
+ endif
+ s1 = dfflo1(-2*sdel2/(xqi(ip(i))*x(1,i)),ier)
+ else
+ s1 = log(-s)
+ endif
+* also here an minus sign (-i*pi*log(-(p.p-sqrt)/(p.p+sqrt)))
+ if ( qiDqj(ip(i),ip(i+1))*xqi(ip(i))*sdel2 .gt. 0 ) then
+ ipi12(i) = +12
+ else
+ ipi12(i) = -12
+ endif
+* ier = ier + 50
+* print *,'ffxtra: imaginary part may well be wrong -> ',
+* + 'n*pi^2 fout'
+* print *,' ipi12(i) = ',ipi12(i)
+* print *,' qiDqj = ',qiDqj(ip(i),ip(i+1))
+* print *,' qi^2 = ',xqi(ip(i))
+ endif
+* there is an overall minus compared with Veltman
+ cs4(i) = DCMPLX(x0,-pi*s1)
+ if ( sdel2 .lt. 0 ) then
+ cs4(i) = -cs4(i)
+ ipi12(i) = -ipi12(i)
+ endif
+ if ( ii .ne. 1 ) then
+ cs4(i) = -cs4(i)
+ ipi12(i) = -ipi12(i)
+ endif
+ if ( i .eq. 2 ) then
+ cs4(i) = 2*cs4(i)
+ ipi12(i) = 2*ipi12(i)
+ endif
+ 10 continue
+* #] calculations:
+* #[ debug:
+ if ( lwrite ) then
+ print *,'ffxtra: ii = ',ii
+ print *,' sdel2 = ',sdel2
+ print *,' x = ',x
+ print *,' cs4 = ',cs4
+ print *,' ipi12 = ',ipi12
+ endif
+* #] debug:
+*###] ffxtra:
+ end
+*###[ ffcxra:
+ subroutine ffcxra(cs4,ipi12,xqi,qiDqj,sdel2,ii,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the extra terms S_ii^{\infty\prime}, put them in *
+* cs4 and ipi12 for qi real but sdel2 complex. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ipi12(3),ii,ier
+ DOUBLE COMPLEX cs4(3)
+ DOUBLE PRECISION xqi(10),qiDqj(10,10),sdel2
+*
+* local variables
+*
+ integer i,ip(5)
+ DOUBLE COMPLEX x(2,3),zfflo1,s,s1,c
+ DOUBLE PRECISION absc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data ip/5,6,8,5,6/
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ calculations:
+ if ( ii .eq. 3 ) return
+ do 10 i=1,3
+ if ( ii .eq. 1 .and. i .eq. 2 ) goto 10
+ x(1,i) = DCMPLX(-qiDqj(ip(i),ip(i+1))/xqi(ip(i)),
+ + -sdel2/xqi(ip(i)))
+ x(2,i) = DCMPLX(-qiDqj(ip(i),ip(i+1))/xqi(ip(i)),
+ + +sdel2/xqi(ip(i)))
+ s = -x(2,i)/x(1,i)
+ if ( lwrite ) then
+ print *,'s = ',s
+ endif
+ c = s-1
+ if ( absc(c) .lt. xloss ) then
+ if ( lwrite ) then
+ print *,'s''=',1+DBLE(2*qiDqj(ip(i),ip(i+1))/xqi(ip(i)))
+ + /x(1,i)
+ endif
+ s1 = zfflo1(DBLE(-2*qiDqj(ip(i),ip(i+1))/xqi(ip(i)))/
+ + x(1,i),ier)
+ elseif ( abs(s+1) .lt. xloss ) then
+ if ( lwrite ) then
+ print *,'s''=',-1+DCMPLX(x0,2*sdel2/xqi(ip(i)))/
+ + x(1,i)
+ endif
+ s1 = zfflo1(DCMPLX(x0,-2*sdel2/xqi(ip(i)))/x(1,i),ier)
+ if ( DIMAG(c).gt.0 ) then
+ ipi12(i) = +12
+ else
+ ipi12(i) = -12
+ endif
+ else
+ s1 = log(s)
+ endif
+* there is an overall minus compared with Veltman
+ cs4(i) = DCMPLX(pi*DIMAG(s1),-pi*DBLE(s1))
+ if ( ii .ne. 1 ) then
+ cs4(i) = -cs4(i)
+ ipi12(i) = -ipi12(i)
+ endif
+ if ( sdel2 .lt. 0 ) then
+ cs4(i) = -cs4(i)
+ ipi12(i) = -ipi12(i)
+ endif
+ if ( i .eq. 2 ) then
+ cs4(i) = 2*cs4(i)
+ ipi12(i) = 2*ipi12(i)
+ endif
+ 10 continue
+* #] calculations:
+* #[ debug:
+ if ( lwrite ) then
+ print *,'ffcxra: ii = ',ii
+ print *,' sdel2 = ',sdel2
+ print *,' x = ',x
+ print *,' cs4 = ',cs4
+ print *,' ipi12 = ',ipi12
+ endif
+* #] debug:
+*###] ffcxra:
+ end
+*###[ ffsm43:
+ subroutine ffsm43(xpi3,imiss)
+***#[*comment:***********************************************************
+* *
+* Distribute the smuggled 4point momenta to the 3point smuggled *
+* momenta. Note that because of the common block smuggling this *
+* cannot be included in ffpi43. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer imiss
+ DOUBLE PRECISION xpi3(6)
+*
+* local variables
+*
+ integer i,j,iinx(6,4)
+ save iinx
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data iinx /2,3,4,6,7,10,
+ + 1,3,4,9,7,8,
+ + 1,2,4,5,10,8,
+ + 1,2,3,5,6,9/
+*
+* #] declarations:
+* #[ parcel out:
+ if ( lsmug ) then
+*
+* parcel out the smuggled diffs
+*
+ do 30 i=1,3
+ j = mod(i,3)+1
+ if ( xpi3(j) .eq. 0 ) then
+ cmipj(i,i) = c2sisj(iinx(i,imiss),iinx(j,imiss))
+ elseif ( xpi3(i) .eq. 0 ) then
+ cmipj(j,i) = c2sisj(iinx(i,imiss),iinx(j,imiss))
+ endif
+ 30 continue
+ endif
+* #] parcel out:
+*)##] ffsm43:
+ end
diff --git a/ff-2.0/ffxd1.f b/ff-2.0/ffxd1.f
new file mode 100644
index 0000000..b4df6b9
--- /dev/null
+++ b/ff-2.0/ffxd1.f
@@ -0,0 +1,352 @@
+*###[ ffxd1:
+ subroutine ffxd1(cd1i,cd0,cc0i,xpi,piDpj,del3,del2i,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the D1(mu) = D11*p1(mu) + D12*p2(mu) + D13*p3(mu) *
+* numerically *
+* *
+* Input: cd0 complex scalar fourpoint function *
+* cc0i(4) complex scalar threepoint functions *
+* without s1,s2,s3,s4 *
+* xpi(13) real masses (1-4), momenta^2 (5-10) *
+* piDpj(10,10) real dotproducts as in D0 *
+* del3 real overall determinant *
+* del2i(4) real minors as in cc0i *
+* ier integer digits lost so far *
+* Output: cd1i(3) complex D11,D12,D13 *
+* ier integer number of dgits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xpi(13),piDpj(10,10),del3,del2i(4)
+ DOUBLE COMPLEX cd1i(3),cd0,cc0i(4)
+*
+* local variables
+*
+ DOUBLE PRECISION md1i(3),md0,mc0i(4)
+ integer i,j,ier0
+ logical wasnul(3)
+ DOUBLE PRECISION xmax,absc,xnul,xlosn
+ DOUBLE PRECISION dpipj(10,13),piDpjp(10,10),s(6),som
+ DOUBLE COMPLEX cc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffxd1: input:'
+ print *,'xpi = ',xpi
+ print *,'del3 = ',del3
+ endif
+ if ( ltest ) then
+ xlosn = xloss*DBLE(10)**(-mod(ier,50))
+ do 1 i=1,6
+ if ( xpi(i) .ne. piDpj(i,i) ) then
+ print *,'ffxd1: error: xpi and piDpj do not agree'
+ endif
+ 1 continue
+ if ( xpi(11).eq.0 ) then
+ xpi(11) = xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+ wasnul(1) = .TRUE.
+ else
+ wasnul(1) = .FALSE.
+ endif
+ if ( xpi(12).eq.0 ) then
+ xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+ wasnul(2) = .TRUE.
+ else
+ wasnul(2) = .FALSE.
+ endif
+ if ( xpi(13).eq.0 ) then
+ xpi(13) = xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+ wasnul(3) = .TRUE.
+ else
+ wasnul(3) = .FALSE.
+ endif
+ do 4 i=1,13
+ do 3 j=1,10
+ dpipj(j,i) = xpi(j) - xpi(i)
+ 3 continue
+ 4 continue
+ ier0 = ier
+ call ffdot4(piDpjp,xpi,dpipj,10,ier0)
+ if ( wasnul(1) ) xpi(11) = 0
+ if ( wasnul(2) ) xpi(12) = 0
+ if ( wasnul(3) ) xpi(13) = 0
+ do 7 i=1,10
+ do 6 j=1,10
+ xnul = piDpj(j,i) - piDpjp(j,i)
+ if ( xlosn*abs(xnul) .gt. precx*abs(piDpjp(j,i)) )
+ + print *,'piDpj(',j,i,') not correct, cmp:',
+ + piDpj(j,i),piDpjp(j,i),xnul
+ 6 continue
+ 7 continue
+ s(1) = + piDpj(5,5)*piDpj(6,6)*piDpj(7,7)
+ s(2) = - piDpj(5,5)*piDpj(6,7)*piDpj(7,6)
+ s(3) = - piDpj(5,6)*piDpj(6,5)*piDpj(7,7)
+ s(4) = + piDpj(5,6)*piDpj(6,7)*piDpj(7,5)
+ s(5) = + piDpj(5,7)*piDpj(6,5)*piDpj(7,6)
+ s(6) = - piDpj(5,7)*piDpj(6,6)*piDpj(7,5)
+ som = s(1) + s(2) + s(3) + s(4) + s(5) + s(6)
+ xmax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)),
+ + abs(s(5)),abs(s(6)))
+ xnul = del3-som
+ if ( xloss*abs(xnul) .gt. precx*xmax ) print *,
+ + 'ffxd1: error: del3 is not correct',del3,som,xmax
+ endif
+* #] check input:
+* #[ call ffxd1a:
+*
+ md0 = absc(cd0)*DBLE(10)**mod(ier,50)
+ mc0i(1) = absc(cc0i(1))*DBLE(10)**mod(ier,50)
+ mc0i(2) = absc(cc0i(2))*DBLE(10)**mod(ier,50)
+ mc0i(3) = absc(cc0i(3))*DBLE(10)**mod(ier,50)
+ mc0i(4) = absc(cc0i(4))*DBLE(10)**mod(ier,50)
+ call ffxd1a(cd1i,md1i,cd0,md0,cc0i,mc0i,xpi,piDpj,del3,del2i,
+ + ier)
+*
+* #] call ffxd1a:
+*###] ffxd1:
+ end
+*###[ ffxd1a:
+ subroutine ffxd1a(cd1i,md1i,cd0,md0,cc0i,mc0i,xpi,piDpj,del3,
+ + del2i,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the D1(mu) = D11*p1(mu) + D12*p2(mu) + D13*p3(mu) *
+* numerically *
+* *
+* Input: cd0 complex scalar fourpoint function *
+* md0 real maximum partial sum in D0 *
+* cc0i(4) complex scalar threepoint functions *
+* without s1,s2,s3,s4 *
+* mc0i(4) real maximum partial sum in C0i *
+* xpi(13) real masses (1-4), momenta^2 (5-10) *
+* piDpj(10,10) real dotproducts as in D0 *
+* del3 real overall determinant *
+* del2i(4) real minors as in cc0i *
+* ier integer digits lost so far *
+* Output: cd1i(3) complex D11,D12,D13 *
+* md1i(3) real maximum partial sum in D1i *
+* ier integer number of dgits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xpi(13),piDpj(10,10),del3,del2i(4)
+ DOUBLE PRECISION md1i(3),md0,mc0i(4)
+ DOUBLE COMPLEX cd1i(3),cd0,cc0i(4)
+*
+* local variables
+*
+ integer i,ier0,ier1,ier2
+ DOUBLE PRECISION xmax,absc,del2,del2sa,dl3q,ms(5),mdelsa
+ DOUBLE COMPLEX cs(5),cc
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+* #] declarations:
+* #[ Form-ula:
+* see the Form job D1.frm
+* D1 =
+* + p1(mu)*Del3^-1 * ( - 1/2*C(s1)*p2.p2*p3.p3 + 1/2*C(s1)*p2.p3^2 + 1/2
+* *C(s2)*p2.p3*p3.p4 - 1/2*C(s2)*p2.p4*p3.p3 + 1/2*C(s3)*p1.p2*p3.p4 -
+* 1/2*C(s3)*p1.p3*p2.p4 + 1/2*C(s4)*p1.p2*p2.p3 - 1/2*C(s4)*p1.p3*p2.p2
+* + D*delta(s1,p2,p3,p1,p2,p3) - D*delta(s1,p3,p2,p1,p2,p3) )
+*
+* + p2(mu)*Del3^-1 * ( 1/2*C(s1)*p1.p2*p3.p3 - 1/2*C(s1)*p1.p3*p2.p3 - 1/
+* 2*C(s2)*p1.p3*p3.p4 + 1/2*C(s2)*p1.p4*p3.p3 - 1/2*C(s3)*p1.p1*p3.p4
+* + 1/2*C(s3)*p1.p3*p1.p4 - 1/2*C(s4)*p1.p1*p2.p3 + 1/2*C(s4)*p1.p2*
+* p1.p3 - D*delta(s1,p1,p3,p1,p2,p3) + D*delta(s1,p3,p1,p1,p2,p3) )
+*
+* + p3(mu)*Del3^-1 * ( - 1/2*C(s1)*p1.p2*p2.p3 + 1/2*C(s1)*p1.p3*p2.p2
+* + 1/2*C(s2)*p1.p3*p2.p4 - 1/2*C(s2)*p1.p4*p2.p3 + 1/2*C(s3)*p1.p1*
+* p2.p4 - 1/2*C(s3)*p1.p2*p1.p4 + 1/2*C(s4)*p1.p1*p2.p2 - 1/2*C(s4)*
+* p1.p2^2 + D*delta(s1,p1,p2,p1,p2,p3) - D*delta(s1,p2,p1,p1,p2,p3) );
+*
+* #] Form-ula:
+* #[ D11:
+ if ( lwrite ) print *,'ffxd1: D11'
+ cs(1) = - cc0i(1)*DBLE(del2i(1))
+ ms(1) = mc0i(1)*abs(del2i(1))
+ if ( lwrite ) print *,'ffdl2i 1'
+ ier1 = ier
+ call ffdl2i(del2,piDpj,10, 6,7,10,+1,7,8,9,+1,ier1)
+ cs(2) = + cc0i(2)*DBLE(del2)
+ ms(2) = mc0i(2)*abs(del2)*DBLE(10)**mod(ier1-ier,50)
+ if ( lwrite ) print *,'ffdl2i 2'
+ ier0 = ier
+ call ffdl2i(del2,piDpj,10, 6,7,10,+1,8,5,10,-1,ier0)
+ ier1 = max(ier1,ier0)
+ cs(3) = - cc0i(3)*DBLE(del2)
+ ms(3) = mc0i(3)*abs(del2)*DBLE(10)**mod(ier0-ier,50)
+ if ( lwrite ) print *,'ffdl2i 3'
+ ier0 = ier
+ call ffdl2i(del2sa,piDpj,10, 6,7,10,+1,5,6,9,-1,ier0)
+ ier1 = max(ier1,ier0)
+ cs(4) = + cc0i(4)*DBLE(del2sa)
+ mdelsa = abs(del2sa)*DBLE(10)**mod(ier0-ier,50)
+ ms(4) = mc0i(4)*mdelsa
+ ier0 = ier
+ call ffdl3q(dl3q,piDpj, 1,6,7, 0,10,0, 0,-1,0, 0,+1,0, ier0)
+ ier1 = max(ier1,ier0)
+ cs(5) = + 2*cd0*DBLE(dl3q)
+ ms(5) = 2*md0*abs(dl3q)*DBLE(10)**mod(ier0-ier,50)
+
+ cd1i(1) = 0
+ xmax = 0
+ md1i(1) = 0
+ do 10 i=1,5
+ cd1i(1) = cd1i(1) + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ md1i(1) = max(md1i(1),ms(i))
+ 10 continue
+ if ( lwarn .and. absc(cd1i(1)) .lt. xloss*xmax ) then
+ call ffwarn(164,ier1,absc(cd1i(1)),xmax)
+ if ( awrite .or. lwrite ) then
+ print *,'cs = ',cs
+ print *,'D11 = ',cd1i(1),xmax
+ print *,'ms = ',ms
+ endif
+ endif
+ cd1i(1) = cd1i(1)*DBLE(1/(2*del3))
+ md1i(1) = md1i(1)*abs(1/(2*del3))
+ ier2 = ier1
+*
+* #] D11:
+* #[ D12:
+*
+ if ( lwrite ) print *,'ffxd1: D12'
+ ier1 = ier
+ call ffdl2t(del2,piDpj,7,5, 6,7,10,-1,-1, 10,ier1)
+ cs(1) = - cc0i(1)*DBLE(del2)
+ ms(1) = mc0i(1)*abs(del2)*DBLE(10)**mod(ier-ier1,50)
+ ier0 = ier
+ call ffdl2t(del2,piDpj,7,5, 7,8,9,-1,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ cs(2) = + cc0i(2)*DBLE(del2)
+ ms(2) = mc0i(2)*abs(del2)*DBLE(10)**mod(ier-ier0,50)
+ ier0 = ier
+ call ffdl2t(del2,piDpj,7,5, 8,5,10,+1,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ cs(3) = - cc0i(3)*DBLE(del2)
+ ms(3) = mc0i(3)*abs(del2)*DBLE(10)**mod(ier-ier0,50)
+ ier0 = ier
+ call ffdl2t(del2,piDpj,7,5, 5,6,9,+1,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ cs(4) = + cc0i(4)*DBLE(del2)
+ ms(4) = mc0i(4)*abs(del2)*DBLE(10)**mod(ier-ier0,50)
+ ier0 = ier
+ call ffdl3q(dl3q,piDpj, 1,7,5, 0,0,2, 0,0,-1, 0,0,+1, ier0)
+ ier1 = max(ier1,ier0)
+ cs(5) = + 2*cd0*DBLE(dl3q)
+ ms(5) = 2*md0*abs(dl3q)*DBLE(10)**mod(ier-ier0,50)
+
+ cd1i(2) = 0
+ xmax = 0
+ md1i(2) = 0
+ do 20 i=1,5
+ cd1i(2) = cd1i(2) + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ md1i(2) = max(md1i(2),ms(i))
+ 20 continue
+ if ( lwarn .and. absc(cd1i(2)) .lt. xloss*xmax ) then
+ call ffwarn(164,ier1,absc(cd1i(2)),xmax)
+ if ( lwrite .or. awrite ) then
+ print *,'cs = ',cs
+ print *,'D12 = ',cd1i(2),xmax
+ print *,'ms = ',ms
+ endif
+ endif
+ cd1i(2) = cd1i(2)*DBLE(1/(2*del3))
+ md1i(2) = md1i(2)*abs(1/(2*del3))
+ ier2 = max(ier2,ier1)
+*
+* #] D12:
+* #[ D13:
+*
+ if ( lwrite ) print *,'ffxd1: D13'
+ cs(1) = - cc0i(1)*DBLE(del2sa)
+ ms(1) = mc0i(1)*mdelsa
+ if ( lwrite ) print *,'ffdl2i 1'
+ ier1 = ier
+ call ffdl2i(del2,piDpj,10, 5,6,9,-1,7,8,9,+1,ier1)
+ cs(2) = + cc0i(2)*DBLE(del2)
+ ms(2) = mc0i(2)*abs(del2)*DBLE(10)**mod(ier-ier1,50)
+ if ( lwrite ) print *,'ffdl2i 2'
+ ier0 = ier
+ call ffdl2i(del2,piDpj,10, 5,6,9,-1,8,5,10,-1,ier0)
+ ier1 = max(ier1,ier0)
+ cs(3) = - cc0i(3)*DBLE(del2)
+ ms(3) = mc0i(3)*abs(del2)*DBLE(10)**mod(ier-ier0,50)
+ cs(4) = + cc0i(4)*DBLE(del2i(4))
+ ms(4) = mc0i(4)*abs(del2i(4))
+ ier0 = ier
+ call ffdl3q(dl3q,piDpj, 1,5,6, 2,9,0, -1,-1,0, +1,-1,0, ier0)
+ ier1 = max(ier1,ier0)
+ cs(5) = + 2*cd0*DBLE(dl3q)
+ ms(5) = 2*md0*abs(dl3q)*DBLE(10)**mod(ier-ier0,50)
+
+ cd1i(3) = 0
+ xmax = 0
+ md1i(3) = 0
+ do 30 i=1,5
+ cd1i(3) = cd1i(3) + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ md1i(3) = max(md1i(3),ms(i))
+ 30 continue
+ if ( lwarn .and. absc(cd1i(3)) .lt. xloss*xmax ) then
+ call ffwarn(164,ier1,absc(cd1i(3)),xmax)
+ if ( lwrite .or. awrite ) then
+ print *,'cs = ',cs
+ print *,'D13 = ',cd1i(3),xmax
+ print *,'ms = ',ms
+ endif
+ endif
+ cd1i(3) = cd1i(3)*DBLE(1/(2*del3))
+ md1i(3) = md1i(3)*abs(1/(2*del3))
+ ier2 = max(ier2,ier1)
+*
+* fidel3 is the error on del3, but only when del3=fdel3
+*
+ if ( fdel3.eq.del3 ) then
+ ier2 = max(ier2,fidel3)
+ do 40 i=1,3
+ md1i(i) = md1i(i)*DBLE(10**mod(fidel3,50))
+ 40 continue
+ endif
+ ier = ier2
+*
+* #] D13:
+* #[ print output:
+ if ( lwrite ) then
+ print *,'ffxd1: results:'
+ print *,'D11 = ',cd1i(1),md1i(1),ier
+ print *,'D12 = ',cd1i(2),md1i(2),ier
+ print *,'D13 = ',cd1i(3),md1i(3),ier
+ endif
+* #] print output:
+*###] ffxd1:
+ end
diff --git a/ff-2.0/ffxdb0.f b/ff-2.0/ffxdb0.f
new file mode 100644
index 0000000..affe1bf
--- /dev/null
+++ b/ff-2.0/ffxdb0.f
@@ -0,0 +1,827 @@
+*###[ ffxdb0:
+ subroutine ffxdb0(cdb0,cdb0p,xp,xma,xmb,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the the derivative of the two-point function with *
+* respect to p2 and the same times p2 (one is always well-defined)*
+* *
+* Input: xp (real) k2, in B&D metric *
+* xma (real) mass2 *
+* xmb (real) mass2 *
+* *
+* Output: cdb0 (complex) dB0/dxp *
+* cdb0p (complex) xp*dB0/dxp *
+* ier (integer) # of digits lost, if >=100: error *
+* *
+* Calls: ffxdba *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cdb0,cdb0p
+ DOUBLE PRECISION xp,xma,xmb
+*
+* local variables
+*
+ integer ier0
+ DOUBLE PRECISION dmamb,dmap,dmbp
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffxdb0: input:'
+ print *,'xma,xmb,xp,ier = ',xma,xmb,xp,ier
+ endif
+ if ( ltest ) then
+ if ( xma .lt. 0 .or. xmb .lt. 0 ) then
+ print *,'ffxdb0: error: xma,b < 0: ',xma,xmb
+ stop
+ endif
+ endif
+* #] check input:
+* #[ get differences:
+ ier0 = 0
+ dmamb = xma - xmb
+ dmap = xma - xp
+ dmbp = xmb - xp
+ if ( lwarn ) then
+ if ( abs(dmamb) .lt. xloss*abs(xma) .and. xma .ne. xmb )
+ + call ffwarn(97,ier0,dmamb,xma)
+ if ( abs(dmap) .lt. xloss*abs(xp) .and. xp .ne. xma )
+ + call ffwarn(98,ier0,dmap,xp)
+ if ( abs(dmbp) .lt. xloss*abs(xp) .and. xp .ne. xmb )
+ + call ffwarn(99,ier0,dmbp,xp)
+ endif
+* #] get differences:
+* #[ calculations:
+ call ffxdbp(cdb0,cdb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
+ if ( lwrite ) print *,'B0'' = ',cdb0,cdb0p,ier
+* #] calculations:
+*###] ffxdb0:
+ end
+*###[ ffxdbp:
+ subroutine ffxdbp(cdb0,cdb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
+***#[*comment:***********************************************************
+* *
+* calculates the derivatives of the two-point function *
+* Veltman) for all possible cases: masses equal, unequal, *
+* equal to zero. *
+* *
+* Input: xp (real) p.p, in B&D metric *
+* xma (real) mass2, *
+* xmb (real) mass2, *
+* dm[ab]p (real) xm[ab] - xp *
+* dmamb (real) xma - xmb *
+* *
+* Output: cdb0 (complex) B0' = dB0/dxp *
+* cdb0p (complex) xp*dB0/dxp *
+* ier (integer) 0=ok,>0=numerical problems,>100=error *
+* *
+* Calls: ffxdbp. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cdb0,cdb0p
+ DOUBLE PRECISION xp,xma,xmb,dmap,dmbp,dmamb
+*
+* local variables
+*
+ integer i,initeq,jsign,initir
+ DOUBLE PRECISION ax,ffbnd,
+ + xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ + xprcn3,bdn301,bdn305,bdn310,bdn315,
+ + xprcn5,bdn501,bdn505,bdn510,bdn515,
+ + xprec0,bdn001,bdn005,bdn010,bdn015,bdn020
+ DOUBLE PRECISION xcheck,xm,dmp,xm1,xm2,dm1m2,dm1p,
+ + dm2p,s,s1,s1a,s1b,s1p,s2,s2a,s2b,s2p,x,y,som,
+ + xlam,slam,xlogmm,alpha,alph1,xnoe,xpneq(30),
+ + xx,dfflo1,dfflo3,d1,d2,diff,h,a,b,c,d,beta,
+ + betm2n,xmax,s1c,s1d,s1e,s1f,s3
+ DOUBLE COMPLEX cc,zxfflg
+ save initeq,xpneq,initir,
+ + xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ + xprcn3,bdn301,bdn305,bdn310,bdn315,
+ + xprcn5,bdn501,bdn505,bdn510,bdn515,
+ + xprec0,bdn001,bdn005,bdn010,bdn015,bdn020
+*
+* common blocks
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* data
+*
+ data xprceq /-1./
+ data xprec0 /-1./
+ data xprcn3 /-1./
+ data xprcn5 /-1./
+ data initeq /0/
+*
+* #] declarations:
+* #[ check input:
+ if (ltest) then
+ xcheck = xma - xmb - dmamb
+ if ( abs(xcheck) .gt. precx*max(abs(xma),abs(xmb),abs(
+ + dmamb))/xloss ) then
+ print *,'ffxdbp: input not OK, dmamb <> xma-xmb',xcheck
+ endif
+ xcheck = -xp + xma - dmap
+ if ( abs(xcheck) .gt. precx*max(abs(xp),abs(xma),abs(
+ + dmap))/xloss ) then
+ print *,'ffxdbp: input not OK, dmap <> xma - xp',xcheck
+ endif
+ xcheck = -xp + xmb - dmbp
+ if ( abs(xcheck) .gt. precx*max(abs(xp),abs(xmb),abs(
+ + dmbp))/xloss ) then
+ print *,'ffxdbp: input not OK, dmbp <> xmb - xp',xcheck
+ endif
+ endif
+* #] check input:
+* #[ which case:
+*
+* sort according to the type of masscombination encountered:
+* 100: both masses zero, 200: one equal to zero, 300: both equal
+* 400: rest.
+*
+ if ( xma .eq. 0 ) then
+ if ( xmb .eq. 0 ) then
+ goto 100
+ endif
+ xm = xmb
+ dmp = dmbp
+ goto 200
+ endif
+ if ( xmb .eq. 0 ) then
+ xm = xma
+ dmp = dmap
+ goto 200
+ elseif ( dmamb .eq. 0 ) then
+ xm = xma
+ dmp = dmap
+ goto 300
+ elseif ( xma .gt. xmb ) then
+ xm2 = xma
+ xm1 = xmb
+ dm1m2 = -dmamb
+ dm1p = dmbp
+ dm2p = dmap
+ else
+ xm1 = xma
+ xm2 = xmb
+ dm1m2 = dmamb
+ dm1p = dmap
+ dm2p = dmbp
+ endif
+ goto 400
+* #] which case:
+* #[ both masses equal to zero:
+ 100 continue
+ if ( xp.ne.0 ) cdb0 = -1/xp
+ cdb0p = -1
+ return
+* #] both masses equal to zero:
+* #[ one mass equal to zero:
+ 200 continue
+*
+* special case xp = 0
+*
+ if ( xp .eq. 0 ) then
+ cdb0p = 0
+ cdb0 = 1/(2*xm)
+ goto 990
+*
+* special case xp = xm
+*
+ elseif ( dmp.eq.0 ) then
+ if ( lsmug ) then
+ if ( DBLE(cmipj(1,3)).lt.DBLE(cmipj(2,3)) ) then
+ cdb0p = -1 - log(cmipj(1,3)*DBLE(1/xm))
+ else
+ cdb0p = -1 - log(cmipj(2,3)*DBLE(1/xm))
+ endif
+ else
+ if ( initir.eq.0 ) then
+ initir = 1
+ print *,'ffxdb0: IR divergent B0'', using cutoff ',
+ + delta
+ endif
+ if ( delta.eq.0 ) then
+ call fferr(74,ier)
+ cdb0p = 0
+ else
+ cdb0p = -1 + log(xm/delta)/2
+ endif
+ endif
+ cdb0 = cdb0p*(1/DBLE(xp))
+ goto 990
+ endif
+*
+* Normal case:
+*
+ x = xp/xm
+ ax = abs(x)
+ if ( ax .lt. xloss ) then
+* #[ Taylor expansion:
+ if ( xprec0 .ne. precx ) then
+ xprec0 = precx
+ bdn001 = ffbnd(2,1,xninv)
+ bdn005 = ffbnd(2,5,xninv)
+ bdn010 = ffbnd(2,10,xninv)
+ bdn015 = ffbnd(2,15,xninv)
+ bdn020 = ffbnd(2,20,xninv)
+ endif
+ if ( lwarn .and. ax .gt. bdn020 ) then
+ call ffwarn(15,ier,precx,xninv(21)*ax**20)
+ endif
+ if ( ax .gt. bdn015 ) then
+ som = x*(xninv(17) + x*(xninv(18) + x*(xninv(19) +
+ + x*(xninv(20) + x*(xninv(21) )))))
+ else
+ som = 0
+ endif
+ if ( ax .gt. bdn010 ) then
+ som = x*(xninv(12) + x*(xninv(13) + x*(xninv(14) +
+ + x*(xninv(15) + x*(xninv(16) + som )))))
+ endif
+ if ( ax .gt. bdn005 ) then
+ som = x*(xninv(7) + x*(xninv(8) + x*(xninv(9) +
+ + x*(xninv(10) + x*(xninv(11) + som )))))
+ endif
+ if ( ax .gt. bdn001 ) then
+ som = x*(xninv(3) + x*(xninv(4) + x*(xninv(5) +
+ + x*(xninv(6) + som ))))
+ endif
+ cdb0p = x*(xninv(2) + som)
+ if ( lwrite ) then
+ print *,'cdb0p = ',cdb0p
+ print *,'verg ',-1 - xm/xp*dfflo1(x,ier),1
+ endif
+* #] Taylor expansion:
+ else
+* #[ short formula:
+ s = log(abs(dmp/xm))
+ cdb0p = -(1 + s*xm/xp)
+ if ( xp.gt.xm ) cdb0p = cdb0p+DCMPLX(DBLE(0),DBLE(xm/xp*pi))
+* #] short formula:
+ endif
+ cdb0 = cdb0p*(1/DBLE(xp))
+ goto 990
+* #] one mass equal to zero:
+* #[ both masses equal:
+ 300 continue
+*
+* Both masses are equal. Not only this speeds up things, some
+* cancellations have to be avoided as well.
+*
+* first a special case
+*
+ if ( abs(xp) .lt. 8*xloss*xm ) then
+* -#[ taylor expansion:
+*
+* a Taylor expansion seems appropriate as the result will go
+* as k^2 but seems to go as 1/k !!
+*
+*--#[ data and bounds:
+ if ( initeq .eq. 0 ) then
+ initeq = 1
+ xpneq(1) = x1/6
+ do 1 i=2,30
+ xpneq(i) = - xpneq(i-1)*DBLE(i)/DBLE(2*(2*i+1))
+ 1 continue
+ endif
+ if (xprceq .ne. precx ) then
+*
+* calculate the boundaries for the number of terms to be
+* included in the taylorexpansion
+*
+ xprceq = precx
+ bdeq01 = ffbnd(1,1,xpneq)
+ bdeq05 = ffbnd(1,5,xpneq)
+ bdeq11 = ffbnd(1,11,xpneq)
+ bdeq17 = ffbnd(1,17,xpneq)
+ bdeq25 = ffbnd(1,25,xpneq)
+ endif
+*--#] data and bounds:
+ x = -xp/xm
+ ax = abs(x)
+ if ( lwarn .and. ax .gt. bdeq25 ) then
+ call ffwarn(15,ier,precx,abs(xpneq(25))*ax**25)
+ endif
+ if ( ax .gt. bdeq17 ) then
+ som = x*(xpneq(18) + x*(xpneq(19) + x*(xpneq(20) +
+ + x*(xpneq(21) + x*(xpneq(22) + x*(xpneq(23) +
+ + x*(xpneq(24) + x*(xpneq(25) ))))))))
+ else
+ som = 0
+ endif
+ if ( ax .gt. bdeq11 ) then
+ som = x*(xpneq(12) + x*(xpneq(13) + x*(xpneq(14) +
+ + x*(xpneq(15) + x*(xpneq(16) + x*(xpneq(17) + som ))))
+ + ))
+ endif
+ if ( ax .gt. bdeq05 ) then
+ som = x*(xpneq(6) + x*(xpneq(7) + x*(xpneq(8) + x*(
+ + xpneq(9) + x*(xpneq(10) + x*(xpneq(11) + som ))))))
+ endif
+ if ( ax .gt. bdeq01 ) then
+ som = x*(xpneq(2) + x*(xpneq(3) + x*(xpneq(4) + x*(
+ + xpneq(5) + som ))))
+ endif
+ cdb0p = -x*(xpneq(1)+som)
+ if (lwrite) then
+ print *,'ffxdbp: m1 = m2, Taylor expansion in ',x
+ print *,'cdb0p = ',cdb0p
+ endif
+ if ( xp.ne.0 ) then
+ cdb0 = cdb0p*(1/DBLE(xp))
+ else
+ cdb0 = xpneq(1)/xm
+ endif
+ goto 990
+* -#] taylor expansion:
+ endif
+* -#[ normal case:
+*
+* normal case
+*
+ call ffxlmb(xlam,-xp,-xm,-xm,dmp,dmp,x0,ier)
+ if ( xlam .eq. 0 ) then
+ call fferr(86,ier)
+ return
+ elseif ( xlam .gt. 0 ) then
+* cases 1,2 and 4
+ slam = sqrt(xlam)
+ s2a = dmp + xm
+ s2 = s2a + slam
+ if ( abs(s2) .gt. xloss*slam ) then
+* looks fine
+ jsign = 1
+ else
+ s2 = s2a - slam
+ jsign = -1
+ endif
+ ax = abs(s2/(2*xm))
+ if ( ax .lt. xalogm ) then
+ if ( lwarn ) call ffwarn(16,ier,ax,xalogm)
+ s = 0
+ elseif( ax-1 .lt. .1 .and. s2 .gt. 0 ) then
+* In this case a quicker and more accurate way is to
+* calculate log(1-x).
+ s2 = (xp - slam)
+* the following line is superfluous.
+ if ( lwarn .and. abs(s2) .lt. xloss*slam )
+ + call ffwarn(17,ier,s2,slam)
+ s = 2*xm/slam*dfflo1(s2/(2*xm),ier)
+ else
+* finally the normal case
+ s = 2*xm/slam*log(ax)
+ if ( jsign .eq. -1 ) s = -s
+ endif
+ if ( xp .gt. 2*xm ) then
+* in this case ( xlam>0, so xp>(2*m)^2) ) there also
+* is an imaginary part
+ y = pi*2*xm/slam
+ else
+ y = 0
+ endif
+ else
+* the root is complex (k^2 between 0 and (2*m1)^2)
+ slam = sqrt(-xlam)
+ s = 4*xm/slam*atan2(xp,slam)
+ y = 0
+ endif
+ if (lwrite) print *,'s = ',s
+ xx = s - 1
+ if ( lwarn .and. abs(xx).lt.xloss ) call ffwarn(18,ier,xx,x1)
+ cdb0p = DCMPLX(DBLE(xx),DBLE(y))
+ cdb0 = cdb0p*(1/DBLE(xp))
+ goto 990
+* -#] normal case:
+*
+* #] both masses equal:
+* #[ unequal nonzero masses:
+* -#[ get log(xm2/xm1):
+ 400 continue
+ x = xm2/xm1
+ if ( 1 .lt. xalogm*x ) then
+ call fferr(8,ier)
+ xlogmm = 0
+ elseif ( abs(x-1) .lt. xloss ) then
+ xlogmm = dfflo1(dm1m2/xm1,ier)
+ else
+ xlogmm = log(x)
+ endif
+* -#] get log(xm2/xm1):
+* -#[ xp = 0:
+*
+* first a special case
+*
+ if ( xp .eq. 0 ) then
+*
+* repaired 19-nov-1993, see b2.frm
+*
+ s1 = xm1*xm2*xlogmm/dm1m2**3
+ s2 = (xm1+xm2)/(2*dm1m2**2)
+ s = s1 + s2
+ if ( abs(s) .lt. xloss**2*s2 ) then
+*
+* second try
+*
+ h = dfflo3(dm1m2/xm1,ier)
+ s1 = -xm1*h/dm1m2**2
+ s2 = 1/(2*xm1)
+ s3 = xm1**2*h/dm1m2**3
+ s = s1 + s2 + s3
+ if ( abs(s) .lt. xloss*max(abs(s2),abs(s3)) ) then
+ call ffwarn(228,ier,s,s2)
+ endif
+ endif
+ cdb0 = s
+ cdb0p = 0
+ goto 990
+ endif
+* -#] xp = 0:
+* -#[ normal case:
+*
+* proceeding with the normal case
+*
+ call ffxlmb(xlam,-xp,-xm2,-xm1,dm2p,dm1p,dm1m2,ier)
+ diff = xlam + xp*(dm2p+xm1)
+ if ( lwrite ) print *,'diff = ',diff
+ if ( abs(diff) .lt. xloss*xlam ) then
+ h = dm1m2**2 - xp*(xm1+xm2)
+ if ( lwrite ) print *,'diff+= ',h
+ if ( abs(h) .lt. xloss*dm1m2**2 ) then
+ if ( dm1m2**2 .lt. abs(xlam) ) diff = h
+ if ( lwarn ) then
+ call ffwarn(221,ier,diff,min(dm1m2**2,abs(xlam)))
+ endif
+ endif
+ endif
+ if ( xlam .eq. 0 ) then
+ call fferr(86,ier)
+ return
+ elseif ( xlam .gt. 0 ) then
+* cases k^2 < -(m2+m1)^2 or k^2 > -(m2-m1)^2:
+*--#[ first try:
+* first try the normal way
+ slam = sqrt(xlam)
+ s2a = dm2p + xm1
+ s2 = s2a + slam
+ if ( abs(s2) .gt. xloss*slam ) then
+* looks fine
+ jsign = 1
+ else
+ s2 = s2a - slam
+ jsign = -1
+ endif
+ s2 = s2**2/(4*xm1*xm2)
+ if ( abs(s2) .lt. xalogm ) then
+ call fferr(9,ier)
+ s2 = 0
+ elseif ( abs(s2-1) .lt. xloss ) then
+ if ( jsign.eq.1 ) then
+ if (lwrite) print *,'s2 ',-diff/(2*slam*xp)*log(s2)
+ s2 = -slam*(s2a+slam)/(2*xm1*xm2)
+ s2 = -diff/(2*slam*xp)*dfflo1(s2,ier)
+ else
+ ier = ier + 50
+ print *,'ffxdb0: untested: s2 better in first try'
+ if (lwrite) print *,'s2 ',+diff/(2*slam*xp)*log(s2)
+ s2 = +slam*(s2a-slam)/(2*xm1*xm2)
+ s2 = +diff/(2*slam*xp)*dfflo1(s2,ier)
+ endif
+ if ( lwrite ) print *,'s2+ ',s2,jsign
+ else
+ s2 = -diff/(2*slam*xp)*log(s2)
+ if ( jsign .eq. -1 ) s2 = -s2
+ endif
+ s1 = -dm1m2*xlogmm/(2*xp)
+ xx = s1+s2-1
+ if (lwrite) then
+ print *,'ffxdbp: lam>0, first try, xx = ',xx,s1,s2,-1
+ endif
+*--#] first try:
+ if ( abs(xx) .lt. xloss**2*max(abs(s1),abs(s2)) ) then
+*--#[ second try:
+* this is unacceptable, try a better solution
+ s1a = diff + slam*dm1m2
+ if (lwrite) print *,'s1 = ',-s1a/(2*xp*slam),diff/
+ + (2*xp*slam)
+ if ( abs(s1a) .gt. xloss*diff ) then
+* this works
+ s1 = -s1a/(2*xp*slam)
+ else
+* by division a more accurate form can be found
+ s1 = -2*xm1*xm2*xp/(slam*(diff - slam*dm1m2))
+ if (lwrite) print *,'s1+= ',s1
+ endif
+ s = s1
+ s1 = s1*xlogmm
+ if ( abs(xp) .lt. xm2 ) then
+ s2a = xp - dm1m2
+ else
+ s2a = xm2 - dm1p
+ endif
+ s2 = s2a - slam
+ if (lwrite) print *,'s2 = ',s2/(2*xm2),slam/(2*xm2)
+ if ( abs(s2) .gt. xloss*slam ) then
+* at least reasonable
+ s2 = s2 / (2*xm2)
+ else
+* division again
+ s2 = (2*xp) / (s2a+slam)
+ if (lwrite) print *,'s2+= ',s2
+ endif
+ if ( abs(s2) .lt. .1 ) then
+* choose a quick way to get the logarithm
+ s2 = dfflo1(s2,ier)
+ elseif ( s2.eq.1 ) then
+ print *,'ffxdbp: error: arg log would be 0!'
+ print *,' xp,xma,xmb = ',xp,xma,xmb
+ goto 600
+ else
+ h = abs(1-s2)
+ s2 = zxfflg(h,0,c0,ier)
+ endif
+ s2 = -diff/(slam*xp)*s2
+ xx = s1 + s2 - 1
+ if (lwrite) then
+ print *,'ffxdbp: lam>0, 2nd try, xx = ',xx,s1,s2,-1
+ endif
+*--#] second try:
+ if ( abs(xx) .lt. xloss**2*max(abs(s1),abs(s2)) ) then
+*--#[ third try:
+* (we accept two times xloss because that's the same
+* as in this try)
+* A Taylor expansion might work. We expand
+* inside the logs. Only do the necessary work.
+*
+* #[ split up 1:
+ xnoe = s2a+slam
+ a = 1
+ b = 2/xnoe-1/xp
+ c = -4/(xp*xnoe)
+ d = sqrt((2/xnoe)**2 + 1/xp**2)
+ call ffroot(d1,d2,a,b,c,d,ier)
+ if ( xp.gt.0 ) then
+ beta = d2
+ else
+ beta = d1
+ endif
+ alpha = beta*diff/slam
+ alph1 = 1-alpha
+ if ( alph1 .lt. xloss ) then
+ s1a = 4*xp**2*xm1*xm2/(slam*dm1m2*(diff-slam*
+ + dm1m2))
+ s1b = -diff/slam*4*xm1*xp/(dm1m2*xnoe*(2*xp-
+ + xnoe))
+ b = -1/xp
+ c = -(2/xnoe)**2
+ call ffroot(d1,d2,a,b,c,d,ier)
+ if ( xp.gt.0 ) then
+ betm2n = d2
+ else
+ betm2n = d1
+ endif
+ d1 = s1a + s1b - diff/slam*betm2n
+ if ( lwrite ) then
+ print *,'alph1 = ',d1,s1a,s1b,-diff/slam*
+ + betm2n
+ print *,'verg ',1-alpha
+ endif
+ xmax = max(abs(s1a),abs(s1b))
+ if ( xmax .lt. 1 ) then
+ alph1 = d1
+ else
+ xmax = 1
+ endif
+ if ( lwarn .and. abs(alph1).lt.xloss*xmax ) then
+ call ffwarn(222,ier,alph1,xmax)
+ if ( lwrite ) print *,'d1,s1a,s2b,... = ',
+ + d1,s1a,s1b,diff/slam*betm2n
+ endif
+ else
+ betm2n = beta - 2/xnoe
+ endif
+ if ( lwrite ) then
+ print *,' s1 - alph1 = ',s1-alph1
+ print *,' s2 - alpha = ',s2-alpha
+ endif
+* #] split up 1:
+* #[ s2:
+*
+* first s2:
+*
+ 490 continue
+ s2p = s2 - alpha
+ if ( abs(s2p) .lt. xloss*abs(s2) ) then
+* -#[ bounds:
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn5 .ne. precx ) then
+ xprcn5 = precx
+ bdn501 = ffbnd(3,1,xinfac)
+ bdn505 = ffbnd(3,5,xinfac)
+ bdn510 = ffbnd(3,10,xinfac)
+ bdn515 = ffbnd(3,15,xinfac)
+ endif
+* -#] bounds:
+ x = beta*xp
+ ax = abs(x)
+ if ( lwarn .and. ax .gt. bdn515 ) then
+* do not do the Taylor expansion
+ call ffwarn(23,ier,s2p,s2)
+ goto 495
+ endif
+ if ( ax .gt. bdn510 ) then
+ s2a = x*(xinfac(13) + x*(xinfac(14) + x*(
+ + xinfac(15) + x*(xinfac(16) + x*(
+ + xinfac(17))))))
+ else
+ s2a = 0
+ endif
+ if ( ax .gt. bdn505 ) then
+ s2a = x*(xinfac(8) + x*(xinfac(9) + x*(
+ + xinfac(10) + x*(xinfac(11) + x*(
+ + xinfac(12) + s2a)))))
+ endif
+ if ( ax .gt. bdn501 ) then
+ s2a = x*(xinfac(4) + x*(xinfac(5) + x*(
+ + xinfac(6) + x*(xinfac(7) + s2a))))
+ endif
+ s2a = x**3*(xinfac(3)+s2a)
+ s2b = 2*xp/xnoe*(s2a + x**2/2)
+ s2p = s2b - s2a
+ if ( lwarn .and. abs(s2p).lt.xloss*abs(s2a) )
+ + call ffwarn(24,ier,s2p,s2a)
+ s2p = -diff/(xp*slam)*dfflo1(s2p,ier)
+ if (lwrite) then
+ print *,'ffxdbp: Taylor expansion of s2-a'
+ print *,' in x = ',x
+ print *,' gives s2p = ',s2p
+ endif
+ endif
+* #] s2:
+* #[ s1:
+*
+* next s1:
+*
+ 495 continue
+ s1p = s1 - alph1
+ if ( abs(s1p) .lt. xloss*abs(s1) ) then
+* -#[ bounds:
+* determine the boundaries for 1,5,10,15 terms
+ if ( xprcn3 .ne. precx ) then
+ xprcn3 = precx
+ bdn301 = ffbnd(3,1,xinfac)
+ bdn305 = ffbnd(3,5,xinfac)
+ bdn310 = ffbnd(3,10,xinfac)
+ bdn315 = ffbnd(3,15,xinfac)
+ endif
+* -#] bounds:
+*
+ x = slam*(diff-slam*dm1m2)*alph1/(2*xp*xm1*xm2)
+ h = (2*xp*(xm1+xm2) - xp**2)/(slam-dm1m2)
+ ax = abs(x)
+ if ( lwarn .and. ax .gt. bdn315 ) then
+* do not do the Taylor expansion
+ call ffwarn(21,ier,s1p,s1)
+ goto 500
+ endif
+*
+* see form job gets1.frm
+*
+ s1b = diff*(diff-slam*dm1m2)*betm2n/(2*xp*xm1*
+ + xm2)
+ s1c = 1/(xm1*xnoe*(2*xp-xnoe))*(
+ + xp*( 4*xp*xm2 + 2*dm1m2**2/xm2*(xp-h) +
+ + 2*dm1m2*(3*xp-h) - 8*dm1m2**2 )
+ + - 2*dm1m2**3/xm2*(3*xp-h)
+ + + 4*dm1m2**4/xm2
+ + )
+ if ( lwrite ) then
+ print *,'s1c was ',-2*xp/dm1m2 + 2*diff*
+ + (diff-slam*dm1m2)/(xm2*dm1m2*xnoe*(2*xp-
+ + xnoe)) + dm1m2/xm1
+ print *,' en is ',s1c
+ print *,'s1b+s1c was ',dm1m2/xm1-x
+ print *,' en is ',s1b+s1c
+ endif
+ s1d = x*dm1m2/xm1
+ s1e = -x**2/2
+ if ( ax .gt. bdn310 ) then
+ s1a = x*(xinfac(13) + x*(xinfac(14) + x*(
+ + xinfac(15) + x*(xinfac(16) + x*(
+ + xinfac(17))))))
+ else
+ s1a = 0
+ endif
+ if ( ax .gt. bdn305 ) then
+ s1a = x*(xinfac(8) + x*(xinfac(9) + x*(
+ + xinfac(10) + x*(xinfac(11) + x*(
+ + xinfac(12) + s1a)))))
+ endif
+ if ( ax .gt. bdn301 ) then
+ s1a = x*(xinfac(4) + x*(xinfac(5) + x*(
+ + xinfac(6) + x*(xinfac(7) + s1a))))
+ endif
+ s1a = -x**3 *(xinfac(3) + s1a)
+ s1f = dm1m2/xm1*(x**2/2 - s1a)
+ s1p = s1e + s1d + s1c + s1b + s1a + s1f
+ xmax = max(abs(s1a),abs(s1b),abs(s1c),abs(s1d),
+ + abs(s1e))
+ if ( lwarn .and. abs(s1p).lt.xloss*xmax ) then
+ call ffwarn(223,ier,s1p,xmax)
+ if ( lwrite )
+ + print *,'s1p,s1e,s1d,s1c,s1b,s1a,s1f = '
+ + ,s1p,s1e,s1d,s1c,s1b,s1a,s1f
+ endif
+ s1p = s*dfflo1(s1p,ier)
+ if (lwrite) then
+ print *,'s1a = ',s1a
+ print *,'s1b = ',s1b
+ print *,'s1c = ',s1c
+ print *,'s1d = ',s1d
+ print *,'s1e = ',s1e
+ print *,'s1f = ',s1f
+ print *,'s = ',s
+ print *,'ffxdbp: Taylor exp. of s1-(1-a)'
+ print *,' in x = ',x
+ print *,' gives s1p = ',s1p
+ print *,' verg ',s*log(xm2/xm1
+ + *exp(x))
+ endif
+ endif
+* #] s1:
+*
+* finally ...
+*
+ 500 continue
+ xx = s1p + s2p
+ if ( lwarn .and. abs(xx) .lt. xloss*abs(s1p) ) then
+ call ffwarn(25,ier,xx,s1p)
+ endif
+*--#] third try:
+ endif
+ endif
+ 600 continue
+ if ( xp .gt. xm1+xm2 ) then
+*--#[ imaginary part:
+* in this case ( xlam>0, so xp>(m1+m2)^2) ) there also
+* is an imaginary part
+ y = -pi*diff/(slam*xp)
+ else
+ y = 0
+*--#] imaginary part:
+ endif
+ else
+* the root is complex (k^2 between -(m1+m2)^2 and -(m2-m1)^2)
+*--#[ first try:
+ slam = sqrt(-xlam)
+ xnoe = dm2p + xm1
+ s1 = -(dm1m2/(2*xp))*xlogmm
+ s2 = -diff/(slam*xp)*atan2(slam,xnoe)
+ xx = s1 + s2 - 1
+ if (lwrite) then
+ print *,'ffxdbp: lam<0, first try, xx = ',xx,s1,s2,-1
+* alpha = -xlam/(2*xp*xnoe)
+* alph1 = -(xp**2-dm1m2**2)/(2*xp*xnoe)
+* print *,' alpha = ',alpha
+* print *,' s1 = ',s1,' - 2alph1 = ',s1-2*alph1
+* print *,' s2 = ',s2,' - 2alpha = ',s2-2*alpha
+ endif
+*--#] first try:
+ if ( lwarn .and. abs(xx).lt.xloss**2*max(abs(s1),abs(s2)) )
+ + then
+ call ffwarn(224,ier,xx,max(abs(s1),abs(s2)))
+ endif
+ y = 0
+ endif
+ 590 continue
+ cdb0p = DCMPLX(DBLE(xx),DBLE(y))
+ cdb0 = cdb0p*(1/DBLE(xp))
+ goto 990
+* -#] normal case:
+* #] unequal nonzero masses:
+* #[ debug:
+ 990 continue
+ if (lwrite) then
+ print *,'cdb0 = ',cdb0,cdb0p
+ endif
+* #] debug:
+*###] ffxdbp:
+ end
diff --git a/ff-2.0/ffxdbd.f b/ff-2.0/ffxdbd.f
new file mode 100644
index 0000000..11d1625
--- /dev/null
+++ b/ff-2.0/ffxdbd.f
@@ -0,0 +1,1047 @@
+*###[ ffxdir:
+ subroutine ffxdir(cs,cfac,idone,xpi,dpipj,ipoin,ndiv,ier)
+***#[*comment:***********************************************************
+* *
+* Check if this 4point function is IRdivergent and if so, get it *
+* using ffxdbd and set idone to 1 (or 2 if 2 IR poles) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ipoin,idone,ndiv,ier
+ DOUBLE COMPLEX cs,cfac
+ DOUBLE PRECISION xpi(13),dpipj(10,13)
+*
+* local variables
+*
+ integer i,j,k,l,ier0,ii(6),notijk(4,4,4)
+ DOUBLE PRECISION del4s,rloss
+ save notijk
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data notijk/
+ + 0,0,0,0,0,0,4,3,0,4,0,2,0,3,2,0,0,0,4,3,0,0,0,0,4,0,0,1,3,0,1,0,
+ + 0,4,0,2,4,0,0,1,0,0,0,0,2,1,0,0,0,3,2,0,3,0,1,0,2,1,0,0,0,0,0,0/
+*
+* #] declarations:
+* #[ work:
+*
+ idone = 0
+ do 25 i=1,4
+ if ( xpi(i) .ne. 0 ) goto 25
+ do 24 j=1,3
+ if ( j .eq. i ) goto 24
+ if ( dpipj(j,inx(j,i)) .ne. 0 ) goto 24
+ do 23 k=j+1,4
+ if ( k .eq. i ) goto 23
+ if ( dpipj(k,inx(k,i)) .ne. 0 ) goto 23
+*
+* we found an IR divergent function;
+* first check whether it is linearly divergent
+*
+ l = notijk(k,j,i)
+ if ( ltest ) then
+ if ( l.eq.0 .or. l.eq.i .or. l.eq.j .or. l.eq.k
+ + ) print *,'ffxkbd: error, l wrong: ',l
+ endif
+*
+* do we have a linear divergence on our hands?
+*
+ if ( dpipj(l,inx(l,i)) .eq. 0 ) then
+ if ( lwrite ) print *,'ffxdir: found ',
+ + 'linearly divergent combo'
+ if ( ndiv.eq.-1 ) ndiv = 1
+ elseif ( ndiv.gt.0 ) then
+ if ( lwrite ) print *,'Not enough singularities'
+ cs = 0
+ cfac = 1
+ idone = 1
+ return
+ endif
+*
+* the complex case
+*
+ if ( lsmug ) then
+*
+* use Wim & Ansgard's formulae whenever possible
+*
+ if ( c2sisj(i,j).eq.0 .and. c2sisj(i,k).eq.0 )
+ + then
+ call ffxdbd(cs,cfac,xpi,dpipj,i,j,k,l,ier)
+ goto 98
+ endif
+ if ( c2sisj(i,j).eq.0 .and. dpipj(i,inx(i,l))
+ + .eq.0 .and. c2sisj(i,l).eq.0 ) then
+ call ffxdbd(cs,cfac,xpi,dpipj,i,j,l,k,ier)
+ goto 98
+ endif
+ if ( c2sisj(i,k).eq.0 .and. dpipj(i,inx(i,l))
+ + .eq.0 .and. c2sisj(i,l).eq.0 ) then
+ call ffxdbd(cs,cfac,xpi,dpipj,i,k,l,j,ier)
+ goto 98
+ endif
+*
+* is it nasty?
+*
+ if ( dpipj(i,inx(i,l)).eq.0 ) then
+ if ( c2sisj(j,i).eq.0 ) then
+ goto 99
+ elseif ( c2sisj(k,i).eq.0 ) then
+ goto 99
+ elseif ( c2sisj(l,i).eq.0 ) then
+ goto 99
+ else
+ call fferr(71,ier)
+ print *,'xpi = ',xpi
+ print *,'id,idsub = ',id,idsub
+ return
+ endif
+ endif
+*
+* then it just is logarithmiocally divergent
+* let the ffxc0i handle this
+*
+ else
+*
+* the real case
+*
+ if ( dpipj(i,inx(i,l)).eq.0 ) then
+ call fferr(73,ier)
+ print *,'xpi = ',xpi
+ idone = 1
+ return
+ endif
+ call ffxdbd(cs,cfac,xpi,dpipj,i,j,k,l,ier)
+ goto 98
+ endif
+ 23 continue
+ 24 continue
+ 25 continue
+ idone = 0
+ lnasty = .FALSE.
+ if ( ndiv.eq.-1 ) ndiv = 0
+ return
+*
+* clean up
+*
+ 98 continue
+ if ( ldot .and. ipoin.eq.4 ) then
+ ier0 = 0
+ if ( idot.lt.1 ) then
+ call ffdot4(fpij4,xpi,dpipj,10,ier0)
+ endif
+ ii(1)= 5
+ ii(2)= 6
+ ii(3)= 7
+ ii(4)= 8
+ ii(5)= 9
+ ii(6)= 10
+ if ( abs(idot).lt.2 ) then
+ fidel3 = ier0
+ call ffdl3p(fdel3,fpij4,10,ii,ii,fidel3)
+ endif
+ if ( ltest ) then
+ if ( lwrite ) print *,'ffxdir: checking fdel4s'
+ call ffdel4(del4s,xpi,fpij4,10,ier0)
+ rloss = xloss*DBLE(10)**(-mod(ier0,50))
+ if ( rloss*abs(del4s-fdel4s) .gt. precx*abs(del4s) )
+ + print *,'ffxdir: error: del4s wrong: ',fdel4s,
+ + del4s,fdel4s-del4s,ier0
+ endif
+ endif
+*
+* and finito
+*
+ if ( ndiv.eq.-1 ) ndiv = 0
+ idone = 1
+ if ( xpi(j) .eq. 0 .or. xpi(k) .eq. 0 ) idone = 2
+ if ( xpi(j) .eq. 0 .and. xpi(k) .eq. 0 ) idone = 3
+ return
+*
+* nasty - set some flags
+*
+ 99 continue
+ if ( lwrite ) print *,'ffxdir: nasty D0'
+ lnasty = .TRUE.
+ return
+*
+* #] work:
+*###] ffxdir:
+ end
+*###[ ffxdbd:
+ subroutine ffxdbd(csom,cfac,xpi,dpipj,ilam,i1,i4,ic,ier)
+***#[*comment:***********************************************************
+* *
+* The IR divergent fourpoint function with real masses *
+* according to Beenakker & Denner, Nucl.Phys.B338(1990)349. *
+* *
+* Input: xpi(13) real momenta^2 *
+* dpipj(10,13) real xpi(i)-xpi(j) *
+* ilam integer position of m=0 *
+* i1,i4 integer position of other 2 IR masses *
+* ic integer position of complex mass *
+* /ffcut/ delta real cutoff to use instead of lam^2 *
+* *
+* Output: csom,cfac complex D0 = csom*cfac *
+* ier integer number of digits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ilam,i1,i4,ic,ier
+ DOUBLE COMPLEX csom,cfac
+ DOUBLE PRECISION xpi(13),dpipj(10,13)
+*
+* local variables
+*
+ integer ier0,ier1,ipi12,ip,init,is,i2,i3,i,iepst,iepss,ieps2,
+ + ieps3
+ DOUBLE PRECISION absc,xmax
+ DOUBLE PRECISION xxs(3),xxt(1),xx2(3),xx3(3),xm0,xm1,xm4,xlam,
+ + d,dfflo1,fac
+ DOUBLE COMPLEX c,cs(21),z,zlg,som,cxt
+ DOUBLE COMPLEX zxfflg,zfflog
+ save init
+*
+* common blocks
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data init /0/
+*
+* #] declarations:
+* #[ check input:
+*
+ if ( init .eq. 0 ) then
+ init = 1
+ print *,'ffxdbd: using IR cutoff delta = lam^2 = ',delta
+ endif
+ if ( lwrite ) then
+ print *,'ffxdbd: input: ilam,i1,i4,ic = ',ilam,i1,i4,ic
+ endif
+ if ( ltest ) then
+ if ( delta .eq. 0 ) print *,'ffxdbd: error: (IR)delta = 0!'
+ if ( xpi(ilam) .ne. 0 ) print *,'ffxdbd: error: lam != 0 ',
+ + ilam,xpi(ilam)
+ if ( dpipj(i1,inx(ilam,i1)) .ne. 0 ) print *,
+ + 'ffxdbd: error: m1^2 != p1^2 ',i1,inx(ilam,i1),xpi(i1),
+ + xpi(inx(ilam,i1)),dpipj(i1,inx(ilam,i1))
+ if ( dpipj(i4,inx(ilam,i4)) .ne. 0 ) print *,
+ + 'ffxdbd: error: m4^2 != p4^2 ',i4,inx(ilam,i4),xpi(i4),
+ + xpi(inx(ilam,i4)),dpipj(i4,inx(ilam,i4))
+ if ( lsmug ) then
+ if ( c2sisj(i1,ilam).ne.0 ) print *,'ffxdbd: error: m(',i1,
+ + ') not onshell, c2sisj(',i1,ilam,') = ',c2sisj(i1,ilam)
+ if ( c2sisj(i4,ilam).ne.0 ) print *,'ffxdbd: error: m(',i4,
+ + ') not onshell, c2sisj(',i4,ilam,') = ',c2sisj(i4,ilam)
+ endif
+ endif
+ if ( xpi(i1).eq.0 .or. xpi(i4).eq.0 ) then
+ call fferr(98,ier)
+ return
+ endif
+*
+* #] check input:
+* #[ preliminaries:
+*
+ csom = 0
+ cfac = 1
+ xm0 = sqrt(xpi(ic))
+ xm1 = sqrt(xpi(i1))
+ xm4 = sqrt(xpi(i4))
+ xlam = sqrt(delta)
+*
+* #] preliminaries:
+* #[ special case m0=0, m1=m2, m3=m4:
+ if ( xpi(ic) .eq. 0 ) then
+*
+* even more special case: 2 points of IR divergence:
+*
+ if ( dpipj(i1,inx(ic,i1)).eq.0 .and.
+ + dpipj(i4,inx(ic,i4)).eq.0 ) then
+ if ( lwrite ) print *,'ffxdbd: doubly IR case'
+ ier0 = 0
+ call ffxkfn(xxs,iepss,xpi(inx(i1,i4)),xm1,xm4,ier0)
+ if ( ier0.ge.100 ) then
+ call fferr(44,ier)
+ return
+ endif
+ ier = ier + ier0
+ if ( abs(xxs(2)).gt.xloss ) then
+ zlg = zxfflg(xxs(1),iepss,x0,ier)
+ else
+ zlg = DBLE(dfflo1(xxs(2),ier))
+ endif
+ csom = -2*zlg*zxfflg(-delta/xpi(inx(ilam,ic)),-2,x0,ier)
+ fac = xxs(1)/(xm1*xm4*xpi(inx(ilam,ic))*xxs(2)*xxs(3))
+ cfac = fac
+ if ( ldot .and. abs(idot).lt.4 ) then
+ fdel4s = 1/(16*fac**2)
+ if ( lwrite ) print *,'del4s = ',fdel4s
+ endif
+ return
+ endif
+* #] special case m0=0, m1=m2, m3=m4:
+* #[ special case m0=0, m1=m2, m3!=m4:
+ if ( dpipj(i1,inx(ic,i1)).eq.0 .or.
+ + dpipj(i4,inx(ic,i4)).eq.0 ) then
+ if ( dpipj(i1,inx(ic,i1)).ne.0 ) then
+ i = i4
+ i4 = i1
+ i1 = i
+ endif
+ if ( lwrite ) print *,'ffxdbd: special case m0=0, ',
+ + 'm1=m2 but m3!=m4'
+*
+* From Wim Beenakker, Priv.Comm.
+*
+ ier0 = 0
+ call ffxkfn(xxs,iepss,xpi(inx(i1,i4)),xm1,xm4,ier0)
+ if ( ier0.ge.100 ) then
+ call fferr(44,ier)
+ return
+ endif
+ ier = ier + ier0
+ ier0 = ier
+ ier1 = ier
+ if ( abs(xxs(2)).gt.xloss ) then
+ zlg = zxfflg(xxs(1),iepss,x0,ier0)
+ else
+ zlg = DBLE(dfflo1(xxs(2),ier0))
+ endif
+ cs(1) = zlg**2
+ ier1 = max(ier0,ier1)
+ ier0 = ier
+ if ( xxs(1)**2.lt.xloss ) then
+ cs(2) = -2*DBLE(dfflo1(xxs(1)**2,ier0))*zlg
+ else
+ cs(2) = -2*zxfflg(xxs(2)*xxs(3),0,x0,ier0)*zlg
+ endif
+ ier1 = max(ier0,ier1)
+ ier0 = ier
+ cs(3) = zxfflg(delta/xpi(i4),0,x0,ier0)*zlg
+ ier1 = max(ier0,ier1)
+ ier0 = ier
+ cs(4) = 2*zxfflg(dpipj(inx(ic,i4),i4)/xpi(inx(ilam,ic)),
+ + -1,dpipj(inx(ic,i4),i4),ier0)*zlg
+ ier1 = max(ier0,ier1)
+ ier0 = ier
+ call ffzxdl(cs(5),ip,zlg,xxs(1)**2,iepss,ier0)
+ cs(5) = -cs(5)
+ ipi12 = -ip + 2
+ ier1 = max(ier0,ier1)
+ ier = ier1
+ som = cs(1) + cs(2) + cs(3) + cs(4) + cs(5) +
+ + ipi12*DBLE(pi12)
+ xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)),
+ + absc(cs(4)),absc(cs(5)))
+ if ( lwarn .and. absc(som) .lt. xloss*xmax )
+ + call ffwarn(194,ier,absc(som),xmax)
+*
+ if ( lwrite ) then
+ print *,'cs = '
+ print '(i5,2e16.8)',(i,cs(i),i=1,5),6,ipi12*pi12
+ print '(a,2e16.8,i4)','som = ',som,ier
+ endif
+ csom = som
+ fac = -xxs(1)/(xm1*xm4*xpi(inx(ilam,ic))*xxs(2)*xxs(3))
+ cfac = fac
+ if ( ldot .and. abs(idot).lt.4 ) then
+ fdel4s = 1/(16*fac**2)
+ if ( lwrite ) print *,'del4s = ',fdel4s
+ endif
+ return
+ endif
+* #] special case m0=0, m1=m2, m3!=m4:
+* #[ special case m0=0, m1!=m2, m3!=m4:
+*
+* This also crashes...
+*
+ xm0 = precx*max(xm1,xm4)
+ if ( lwrite ) print *,'ffxdir: dirty hack, put m0 != 0',xm0
+ endif
+* #] special case m0=0, m1!=m2, m3!=m4:
+* #[ get dimensionless vars:
+*
+* we follow the notation of Wim & Ansgar closely
+* remember that for -pi we have ieps=+2 and v.v.
+*
+ if ( lsmug ) then
+* all is not what it seems
+ if ( nschem .ge. 3 ) then
+ cxt = DBLE(xm0*xlam)/c2sisj(ic,ilam)
+ else
+ cxt = DBLE(xm0*xlam)/DBLE(c2sisj(ic,ilam))
+ endif
+ else
+ if ( dpipj(ic,inx(ilam,ic)) .eq. 0 ) then
+ call fferr(73,ier)
+ print *,'xpi = ',xpi
+ return
+ endif
+ xxt(1) = xm0*xlam/dpipj(ic,inx(ilam,ic))
+ endif
+ iepst = -2
+ ier1 = 0
+ ier0 = 0
+ call ffxkfn(xxs,iepss,xpi(inx(i1,i4)),xm1,xm4,ier0)
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ call ffxkfn(xx2,ieps2,xpi(inx(i1,ic)),xm1,xm0,ier0)
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ call ffxkfn(xx3,ieps3,xpi(inx(i4,ic)),xm4,xm0,ier0)
+ ier1 = max(ier0,ier1)
+ if ( ier1 .ge. 100 ) then
+ call ffzdbd(csom,cfac,xpi,dpipj,ilam,i1,i4,ic,ier)
+ return
+ endif
+ ier = ier + ier1
+*
+ if ( lwrite ) then
+ print *,'IR divergent fourpoint function according to ',
+ + 'Beenakker and Denner'
+ if ( lsmug ) then
+ print *,'cxt = ',cxt
+ else
+ print *,'xxt = ',xxt,iepst
+ endif
+ print *,'xxs = ',xxs,iepss
+ print *,'xx2 = ',xx2,ieps2
+ print *,'xx3 = ',xx3,ieps3
+ endif
+* #] get dimensionless vars:
+* #[ fill array:
+*
+ ier1 = 0
+ ier0 = 0
+ zlg = zxfflg(xxs(1),iepss,x0,ier)
+ d = xxs(1)**2
+ if ( abs(d) .lt. xloss ) then
+ cs(1) = 2*zlg*DBLE(dfflo1(d,ier0))
+ else
+ cs(1) = 2*zlg*zxfflg(xxs(2)*xxs(3),-iepss,x0,ier0)
+ endif
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ if ( lsmug ) then
+ cs(2) = -2*zlg*zfflog(cxt,iepst,c0,ier0)
+ else
+ cs(2) = -2*zlg*zxfflg(xxt(1),iepst,x0,ier0)
+ endif
+ ier1 = max(ier0,ier1)
+*
+ ipi12 = 6
+*
+ ier0 = 0
+ call ffzxdl(cs(3),ip,zlg,xxs(1)**2,iepss,ier0)
+ ipi12 = ipi12 + ip
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ if ( abs(xx2(2)) .gt. xloss ) then
+ z = zxfflg(xx2(1),ieps2,x0,ier0)
+ else
+ z = dfflo1(xx2(2),ier0)
+ endif
+ cs(4) = z**2
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ if ( abs(xx3(2)) .gt. xloss ) then
+ z = zxfflg(xx3(1),ieps3,x0,ier0)
+ else
+ z = dfflo1(xx3(2),ier0)
+ endif
+ cs(5) = z**2
+ ier1 = max(ier0,ier1)
+*
+ is = 6
+ do 110 i2=-1,+1,2
+ do 100 i3=-1,+1,2
+*
+ ier0 = 0
+ call ffzxdl(cs(is),ip,zlg,xxs(1)*xx2(1)**i2*xx3(1)**i3,
+ + 0,ier0)
+ cs(is) = -cs(is)
+ ipi12 = ipi12 - ip
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ if ( abs(xxs(2)) .gt. xloss ) then
+ cs(is) = -zlg*zxfflg(xxs(1),iepss,x0,ier0)
+ else
+ cs(is) = -zlg*DBLE(dfflo1(xxs(2),ier0))
+ endif
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ if ( abs(xx2(2)) .gt. xloss ) then
+ cs(is) = -zlg*zxfflg(xx2(1)**i2,i2*ieps2,x0,ier0)
+ elseif ( i2.eq.1 ) then
+ cs(is) = -zlg*DBLE(dfflo1(xx2(2),ier0))
+ else
+ cs(is) = -zlg*DBLE(dfflo1(-xx2(2)/xx2(1),ier0))
+ endif
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ if ( abs(xx3(2)) .gt. xloss ) then
+ cs(is) = -zlg*zxfflg(xx3(1)**i3,i3*ieps3,x0,ier0)
+ elseif ( i3.eq.1 ) then
+ cs(is) = -zlg*DBLE(dfflo1(xx3(2),ier0))
+ else
+ cs(is) = -zlg*DBLE(dfflo1(-xx3(2)/xx3(1),ier0))
+ endif
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ 100 continue
+ 110 continue
+ ier = ier + ier1
+*
+* #] fill array:
+* #[ sum:
+*
+ som = 0
+ xmax = 0
+ is = is - 1
+ do 200 i=1,is
+ som = som + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ 200 continue
+ som = som + ipi12*DBLE(pi12)
+ if ( lwarn .and. absc(som) .lt. xloss*xmax )
+ + call ffwarn(194,ier,absc(som),xmax)
+*
+* #] sum:
+* #[ overall factors:
+*
+ csom = som
+ if ( lsmug ) then
+ if ( nschem .ge. 2 ) then
+ cfac = -DBLE(xxs(1)/((xm1*xm4*xxs(2)*xxs(3))))/
+ + c2sisj(ilam,ic)
+ else
+ cfac = -DBLE(xxs(1))/(DBLE(xm1*xm4*xxs(2)*xxs(3))*
+ + DBLE(c2sisj(ilam,ic)))
+ endif
+ if ( ldot .and. abs(idot).lt.4 ) then
+ fdel4s = 16*(xm1*xm4*dpipj(inx(ilam,ic),ic)*xxs(2)*
+ + xxs(3)/xxs(1))**2
+ endif
+ else
+ fac = xxs(1)/(xm1*xm4*dpipj(inx(ilam,ic),ic)*xxs(2)*xxs(3))
+ cfac = fac
+ if ( ldot .and. abs(idot).lt.4 ) then
+ fdel4s = 1/(16*fac**2)
+ if ( lwrite ) print *,'del4s = ',fdel4s
+ endif
+ endif
+*
+* #] overall factors:
+* #[ print debug info:
+ if ( lwrite ) then
+ print *,'cs = '
+ do 910 i=1,is
+ print *,i,cs(i)
+ 910 continue
+ print *,'som = ',som,ipi12
+ print *,'cd0 = ',csom*cfac
+ endif
+* #] print debug info:
+*###] ffxdbd:
+ end
+*###[ ffxkfn:
+ subroutine ffxkfn(x,ieps,xpi,xm,xmp,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the K-function in this paper: *
+* *
+* 1-sqrt(1-4*m*mp/(z-(m-mp)^2)) *
+* K(p^2,m,mp) = ----------------------------- *
+* 1+sqrt(1-4*m*mp/(z-(m-mp)^2)) *
+* *
+* and fill x(1) = -K, x(2) = 1+K, x(3) = 1-K *
+* ieps gives the sign of the imaginary part: -2 -> +ieps and v.v. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ieps,ier
+ DOUBLE PRECISION x(3),xpi,xm,xmp
+*
+* local variables
+*
+ DOUBLE PRECISION wortel,xx1,xx2,xx3
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ work:
+*
+* special case
+*
+ if ( xpi.eq.0 .and. xm.eq.xmp ) then
+ x(1) = 1
+ x(2) = 0
+ x(3) = 2
+ return
+ endif
+*
+* normal case
+*
+ xx1 = xpi - (xm-xmp)**2
+ if ( lwarn .and. abs(xx1) .lt. xloss*max(abs(xpi),xm**2)
+ + ) then
+ call ffwarn(178,ier,xx1,max(xpi,xm**2))
+ if ( lwrite ) print *,'need extra input'
+ endif
+ xx2 = 1 - 4*xm*xmp/xx1
+ if ( lwarn .and. abs(xx2) .lt. xloss )
+ + call ffwarn(179,ier,xx2,x1)
+ if ( xx2 .lt. 0 ) then
+ if ( lwrite ) then
+ print *,'ffxkfn: cannot handle s < 4*m*mp, to ffzdbd'
+ print *,' s,m,mp = ',xpi,xm,xmp
+ endif
+ ier = ier + 100
+ return
+ endif
+ wortel = sqrt(xx2)
+ xx3 = 1/(1+wortel)
+ x(1) = -4*xm*xmp*xx3**2/xx1
+ x(2) = 2*xx3
+ x(3) = 2*wortel*xx3
+*
+ ieps = -2
+*
+* #] work:
+* #[ print output:
+ if ( lwrite ) then
+ print *,'ffxkfn: input: xpi,xm,xmp = ',xpi,xm,xmp
+ print *,' output: x,ier = ',x,ier
+ endif
+* #] print output:
+*###] ffxkfn:
+ end
+*###[ ffzdbd:
+ subroutine ffzdbd(csom,cfac,xpi,dpipj,ilam,i1,i4,ic,ier)
+***#[*comment:***********************************************************
+* *
+* The IR divergent fourpoint function with real masses *
+* according to Beenakker & Denner, Nucl.Phys.B338(1990)349. *
+* but in the case at least one of the roots is complex *
+* *
+* Input: xpi(13) real momenta^2 *
+* dpipj(10,13) real xpi(i)-xpi(j) *
+* ilam integer position of m=0 *
+* i1,i4 integer position of other 2 IR masses *
+* ic integer position of complex mass *
+* /ffcut/ delta real cutoff to use instead of lam^2 *
+* *
+* Output: csom,cfac complex D0 = csom*cfac *
+* ier integer number of digits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ilam,i1,i4,ic,ier
+ DOUBLE COMPLEX csom,cfac
+ DOUBLE PRECISION xpi(13),dpipj(10,13)
+*
+* local variables
+*
+ integer ier0,ier1,ipi12,ip,init,is,i2,i3,i,iepst,iepss,ieps2,
+ + ieps3
+ DOUBLE PRECISION absc,xmax
+ DOUBLE PRECISION xm0,xm1,xm4,xlam,xxt(1)
+ DOUBLE COMPLEX c,cs(21),z,zlg,som,cxt,cxs(3),cx2(3),cx3(3)
+ DOUBLE COMPLEX zxfflg,zfflog,zfflo1
+ save init
+*
+* common blocks
+*
+ include 'ff.h'
+ DOUBLE PRECISION delta
+ common /ffcut/ delta
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data init /0/
+*
+* #] declarations:
+* #[ check input:
+*
+ if ( init .eq. 0 ) then
+ init = 1
+ print *,'ffzdbd: using IR cutoff delta = lam^2 = ',delta
+ endif
+ if ( lwrite ) then
+ print *,'ffzdbd: input: ilam,i1,i4,ic = ',ilam,i1,i4,ic
+ endif
+ if ( ltest ) then
+ if ( delta .eq. 0 ) print *,'ffzdbd: error: (IR)delta = 0!'
+ if ( xpi(ilam) .ne. 0 ) print *,'ffzdbd: error: lam != 0 ',
+ + ilam,xpi(ilam)
+ if ( dpipj(i1,inx(ilam,i1)) .ne. 0 ) print *,
+ + 'ffzdbd: error: m1^2 != p1^2 ',i1,inx(ilam,i1),xpi(i1),
+ + xpi(inx(ilam,i1)),dpipj(i1,inx(ilam,i1))
+ if ( dpipj(i4,inx(ilam,i4)) .ne. 0 ) print *,
+ + 'ffzdbd: error: m4^2 != p4^2 ',i4,inx(ilam,i4),xpi(i4),
+ + xpi(inx(ilam,i4)),dpipj(i4,inx(ilam,i4))
+ endif
+*
+* #] check input:
+* #[ preliminaries:
+*
+ xm0 = sqrt(xpi(ic))
+ xm1 = sqrt(xpi(i1))
+ xm4 = sqrt(xpi(i4))
+ xlam = sqrt(delta)
+*
+* #] preliminaries:
+* #[ special case m0=0, m1=m2, m3!=m4:
+* UNPHYSICAL!
+* if ( xpi(ic) .eq. 0 ) then
+* if ( dpipj(i1,inx(ic,i1)).eq.0 .or.
+* + dpipj(i4,inx(ic,i4)).eq.0 ) then
+* if ( dpipj(i1,inx(ic,i1)).ne.0 ) then
+* i = i4
+* i4 = i1
+* i1 = i
+* endif
+* if ( lwrite ) print *,'ffzdbd: special case m0=0, ',
+* + 'm1=m2 but m3!=m4'
+**
+* From Wim Beenakker, Priv.Comm.
+**
+* call ffzkfn(cxs,iepss,xpi(inx(i1,i4)),xm1,xm4,ier)
+* ier0 = ier
+* ier1 = ier
+* if ( absc(cxs(2)).gt.xloss ) then
+* zlg = zfflog(cxs(1),iepss,c0,ier0)
+* else
+* zlg = zfflo1(cxs(2),ier0)
+* endif
+* cs(1) = zlg**2
+* ier1 = max(ier0,ier1)
+* ier0 = ier
+* if ( absc(cxs(1))**2.lt.xloss ) then
+* cs(2) = -2*zfflo1(cxs(1)**2,ier0)*zlg
+* else
+* cs(2) = -2*zfflog(cxs(2)*cxs(3),0,c0,ier0)*zlg
+* endif
+* ier1 = max(ier0,ier1)
+* ier0 = ier
+* cs(3) = zxfflg(delta/xpi(i4),0,x0,ier0)*zlg
+* ier1 = max(ier0,ier1)
+* ier0 = ier
+* cs(4) = 2*zxfflg(dpipj(inx(ic,i4),i4)/xpi(inx(ilam,ic)),
+* + -1,dpipj(inx(ic,i4),i4),ier0)*zlg
+* ier1 = max(ier0,ier1)
+* ier0 = ier
+* call ffzzdl(cs(5),ip,zlg,cxs(1)**2,ier0)
+* cs(5) = -cs(5)
+* ipi12 = -ip + 2
+* ier1 = max(ier0,ier1)
+* ier = ier1
+* som = cs(1) + cs(2) + cs(3) + cs(4) + cs(5) +
+* + ipi12*DBLE(pi12)
+* xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)),
+* + absc(cs(4)),absc(cs(5)))
+* if ( lwarn .and. absc(som) .lt. xloss*xmax )
+* + call ffwarn(194,ier,absc(som),xmax)
+**
+* if ( lwrite ) then
+* print *,'cs = '
+* print '(i5,2e16.8)',(i,cs(i),i=1,5),6,ipi12*pi12
+* print '(a,2e16.8,i4)','som = ',som,ier
+* endif
+* csom = som
+* cfac = -cxs(1)/(xm1*xm4*xpi(inx(ilam,ic))*cxs(2)*cxs(3))
+* if ( ldot .and. abs(idot).lt.4 ) then
+* fdel4s = 1/(16*DBLE(cfac)**2)
+* if ( xloss*abs(DIMAG(cfac)) .gt. precc*abs(DBLE(cfac
+* + )) ) then
+* print *,'ffzdbd: error: fac is not real: ',cfac
+* endif
+* if ( lwrite ) print *,'del4s = ',fdel4s
+* endif
+* return
+* endif
+**
+* otherwise the normal case is OK
+**
+* endif
+* #] special case m0=0, m1=m2, m3!=m4:
+* #[ get dimensionless vars:
+*
+* we follow the notation of Wim & Ansgar closely
+* remember that for -pi we have ieps=+2 and v.v.
+*
+ if ( lsmug ) then
+* all is not what it seems
+ if ( nschem .ge. 3 ) then
+ cxt = DBLE(xm0*xlam)/c2sisj(ic,ilam)
+ else
+ cxt = DBLE(xm0*xlam)/DBLE(c2sisj(ic,ilam))
+ endif
+ else
+ xxt(1) = xm0*xlam/dpipj(ic,inx(ilam,ic))
+ endif
+ iepst = -2
+ ier1 = 0
+ ier0 = 0
+ call ffzkfn(cxs,iepss,xpi(inx(i1,i4)),xm1,xm4,ier0)
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ call ffzkfn(cx2,ieps2,xpi(inx(i1,ic)),xm1,xm0,ier0)
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ call ffzkfn(cx3,ieps3,xpi(inx(i4,ic)),xm4,xm0,ier0)
+ ier1 = max(ier0,ier1)
+ ier = ier + ier1
+*
+ if ( lwrite ) then
+ print *,'IR divergent fourpoint function according to ',
+ + 'Beenakker and Denner'
+ if ( lsmug ) then
+ print *,'cxt = ',cxt
+ else
+ print *,'xxt = ',xxt,iepst
+ endif
+ print *,'cxs = ',cxs,iepss
+ print *,'cx2 = ',cx2,ieps2
+ print *,'cx3 = ',cx3,ieps3
+ endif
+* #] get dimensionless vars:
+* #[ fill array:
+*
+ ier1 = 0
+ ier0 = 0
+ zlg = zfflog(cxs(1),iepss,c0,ier)
+ c = cxs(1)**2
+ if ( absc(c) .lt. xloss ) then
+ cs(1) = 2*zlg*zfflo1(c,ier0)
+ else
+ cs(1) = 2*zlg*zfflog(cxs(2)*cxs(3),-iepss,c0,ier0)
+ endif
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ if ( lsmug ) then
+ cs(2) = -2*zlg*zfflog(cxt,iepst,c0,ier0)
+ else
+ cs(2) = -2*zlg*zxfflg(xxt(1),iepst,x0,ier0)
+ endif
+ ier1 = max(ier0,ier1)
+*
+ ipi12 = 6
+*
+ ier0 = 0
+ call ffzzdl(cs(3),ip,zlg,cxs(1)**2,ier0)
+ ipi12 = ipi12 + ip
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ z = zfflog(cx2(1),ieps2,c0,ier0)
+ cs(4) = z**2
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ z = zfflog(cx3(1),ieps3,c0,ier0)
+ cs(5) = z**2
+ ier1 = max(ier0,ier1)
+*
+ is = 6
+ do 110 i2=-1,+1,2
+ do 100 i3=-1,+1,2
+*
+ ier0 = 0
+ call ffzzdl(cs(is),ip,zlg,cxs(1)*cx2(1)**i2*cx3(1)**i3,
+ + ier0)
+ cs(is) = -cs(is)
+ ipi12 = ipi12 - ip
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ cs(is) = -zlg*zfflog(cxs(1),iepss,c0,ier0)
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ cs(is) = -zlg*zfflog(cx2(1)**i2,i2*ieps2,c0,ier0)
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ cs(is) = -zlg*zfflog(cx3(1)**i3,i3*ieps3,c0,ier0)
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ 100 continue
+ 110 continue
+ ier = ier + ier1
+*
+* #] fill array:
+* #[ sum:
+*
+ som = 0
+ xmax = 0
+ is = is - 1
+ do 200 i=1,is
+ som = som + cs(i)
+ xmax = max(xmax,absc(cs(i)))
+ 200 continue
+ som = som + ipi12*DBLE(pi12)
+ if ( lwarn .and. absc(som) .lt. xloss*xmax )
+ + call ffwarn(194,ier,absc(som),xmax)
+*
+* #] sum:
+* #[ overall factors:
+*
+ csom = som
+ if ( lsmug ) then
+ if ( nschem .ge. 2 ) then
+ cfac = -cxs(1)/(DBLE(xm1*xm4)*cxs(2)*cxs(3)*
+ + c2sisj(ilam,ic))
+ else
+ cfac = -cxs(1)/(DBLE(xm1*xm4)*cxs(2)*cxs(3)*
+ + DBLE(c2sisj(ilam,ic)))
+ endif
+ if ( ldot .and. abs(idot).lt.4 ) then
+ c = 16*(DBLE(xm1*xm4*dpipj(inx(ilam,ic),ic))*
+ + cxs(2)*cxs(3)/cxs(1))**2
+ fdel4s = DBLE(c)
+ if ( xloss*DIMAG(c) .gt. precc*DBLE(c) ) then
+ print *,'ffzdbd: error: Del4s is not real ',c
+ endif
+ endif
+ else
+ cfac = cxs(1)/(DBLE(xm1*xm4*dpipj(inx(ilam,ic),ic))*
+ + cxs(2)*cxs(3))
+ if ( ldot .and. abs(idot).lt.4 ) then
+ fdel4s = 1/(16*DBLE(cfac)**2)
+ if ( xloss*abs(DIMAG(cfac)) .gt. precc*abs(DBLE(cfac)) )
+ + then
+ print *,'ffzdbd: error: fac is not real: ',cfac
+ endif
+ if ( lwrite ) print *,'del4s = ',fdel4s
+ endif
+ endif
+*
+* #] overall factors:
+* #[ print debug info:
+ if ( lwrite ) then
+ print *,'cs = '
+ do 910 i=1,is
+ print *,i,cs(i)
+ 910 continue
+ print *,'som = ',som,ipi12
+ print *,'cd0 = ',csom*cfac
+ endif
+* #] print debug info:
+*###] ffzdbd:
+ end
+*###[ ffzkfn:
+ subroutine ffzkfn(cx,ieps,xpi,xm,xmp,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the K-function in this paper: *
+* *
+* 1-sqrt(1-4*m*mp/(z-(m-mp)^2)) *
+* K(p^2,m,mp) = ----------------------------- *
+* 1+sqrt(1-4*m*mp/(z-(m-mp)^2)) *
+* *
+* and fill x(1) = -K, x(2) = 1+K, x(3) = 1-K *
+* the roots are allowed to be imaginary *
+* ieps gives the sign of the imaginary part: -2 -> +ieps and v.v. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ieps,ier
+ DOUBLE PRECISION xpi,xm,xmp
+ DOUBLE COMPLEX cx(3)
+*
+* local variables
+*
+ DOUBLE PRECISION xx1,xx2
+ DOUBLE COMPLEX wortel,cx3
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ work:
+*
+ xx1 = xpi - (xm-xmp)**2
+ if ( lwarn .and. abs(xx1) .lt. xloss*max(abs(xpi),xm**2)
+ + ) then
+ call ffwarn(178,ier,xx1,max(xpi,xm**2))
+ if ( lwrite ) print *,'need extra input'
+ endif
+ xx2 = 1 - 4*xm*xmp/xx1
+ if ( lwarn .and. abs(xx2) .lt. xloss )
+ + call ffwarn(179,ier,xx2,x1)
+ if ( xx2 .ge. 0 ) then
+ wortel = sqrt(xx2)
+ else
+ wortel = DCMPLX(DBLE(0),DBLE(sqrt(-xx2)))
+ endif
+ cx3 = 1/(1+wortel)
+ if ( xx1.eq.0 ) then
+ print *,'ffzkfn: error: xx1=0, contact author'
+ cx(1) = 1/xclogm
+ else
+ cx(1) = DBLE(-4*xm*xmp/xx1)*cx3**2
+ endif
+ cx(2) = 2*cx3
+ cx(3) = 2*wortel*cx3
+*
+ ieps = -2
+*
+* #] work:
+* #[ print output:
+ if ( lwrite ) then
+ print *,'ffzkfn: input: xpi,xm,xmp = ',xpi,xm,xmp
+ print *,' output: cx,ier = ',cx,ier
+ endif
+* #] print output:
+*###] ffzkfn:
+ end
diff --git a/ff-2.0/ffxdi.f b/ff-2.0/ffxdi.f
new file mode 100644
index 0000000..99e3083
--- /dev/null
+++ b/ff-2.0/ffxdi.f
@@ -0,0 +1,938 @@
+*###[ ffxdi:
+ subroutine ffxdi(cd4pppp,cd4ppdel,cd4deldel, cd3ppp,cd3pdel,
+ + cd2pp,cd2del, cd1p, dl2pij, cd0,cc0i,cb0ij,ca0i,
+ + del4s,del3p,del2pi, xpi,piDpj, d0,xmu, degree, ier)
+***#[*comment:***********************************************************
+* *
+* Compute the tensor functions D1-D(degree) in the determinant *
+* scheme, i.e. with basis p1-p3 and (instead of d_(mu,nu)) *
+* \delta_{p1 p2 p3 mu}^{p1 p2 p3 nu}. *
+* *
+* Input: cd0 (complex) D0 *
+* cc0i(4) (complex) C0 with Ni=(Q+..)^2-mi^2 missing*
+* cb0ij(4,4) (complex) B0 _with_ Ni,Nj (only for *
+* degree>1) *
+* ca0i(4) (complex) A0 with Ni (only for degree>2) *
+* del4s (real) delta(s1,s2,s3,s4)(s1,s2,s3,s4) *
+* (only needed when degree>1) *
+* del3p (real) delta(p1,p2,p3,p1,p2,p3) *
+* del2pi(4) (real) delta(pipj)(pi,pj) belonging to *
+* cc0i(i) *
+* xpi(13) (real) 1-4: mi^2, 5-10: p(i-4)^2 *
+* piDpj(10,10) (re) pi.pj *
+* d0 (real) \ renormalization constants *
+* xmu (real) / used in B0, A0 *
+* degree (integer) 1-4 *
+* ier (integer) number of unreliable digits in *
+* input *
+* *
+* Output: ier number of digits lost in the *
+* least stable result *
+* dl2pij(6,6)(real) determinants delta(pi,pj,pk,pl) *
+* cd1p(3) (complex) coeffs of p1,p2,p3 *
+* only when degree>1: *
+* cd2pp(3,3) (complex) coeffs of p1p1,(p1p2+p2p1),... *
+* cd2del (complex) coeff of delta(p1,p2,p3,mu,..) *
+* only when degree>2: *
+* cd3ppp(3,3,3)(compl) coeffs of p1p1p1,p1(p1p2+p2p1), *
+* (p1p2p3+p1p3p2+p2p1p3+p2p3p1+..)*
+* cd3pdel(3) (complex) coeffs of pidel (symmetrized) *
+* only when degree>3: *
+* cd4pppp(3,3,3,3)(co) you guessed it! *
+* cd4ppdel(3,3)(compl) *
+* cd4deldel (complex) *
+* *
+* Note: at this moment (28-feb-1993) only D1 and D2 are coded. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer degree,ier
+ DOUBLE PRECISION dl2pij(6,6),del4s,del3p,del2pi(4),xpi(13),
+ + piDpj(10,10),d0,xmu
+ DOUBLE COMPLEX cd4pppp(3,3,3,3),cd4ppdel(3,3),cd4deldel,
+ + cd3ppp(3,3,3),cd3pdel(3),cd2pp(3,3),cd2del,
+ + cd1p(3),cd0,cc0i(4),cb0ij(4,4),ca0i(4)
+*
+* local variables
+*
+ integer i,j,k,ier0,ier1,ier2,inx43(6,4),sgn43(6,4),i2p(5:8,5:8),
+ + isgnsa,ii4(6)
+ logical lsave1,lsave2
+ DOUBLE PRECISION a,xpi3(6),xlosn,dl3qi(7),xmax,vgl,xnul
+ DOUBLE COMPLEX cc,cs(25),cnul
+ save inx43,sgn43,i2p,ii4
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data inx43 /2,3,4,6,7,10,
+ + 1,3,4,9,7,8,
+ + 1,2,4,5,10,8,
+ + 1,2,3,5,6,9/
+ data sgn43 /+1,+1,+1,+1,+1,-1,
+ + +1,+1,+1,-1,+1,+1,
+ + +1,+1,+1,+1,+1,+1,
+ + +1,+1,+1,+1,+1,+1/
+ data i2p /0,0,0,0,
+ + 1,0,0,0,
+ + 2,4,0,0,
+ + 3,5,6,0/
+ data ii4 /5,6,7,8,9,10/
+*
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffxdi: input:'
+ print *,' degree ',degree
+ print *,' xpi = ',xpi
+ print *,' ier = ',ier
+ endif
+ if ( degree .gt. 2 ) then
+ print *,'ffxdi: degree > 2 not yet supported: ',degree
+ stop
+ endif
+ if ( del2pi(1).eq.0 .or. del2pi(2).eq.0 .or. del2pi(3).eq.0
+ + .or. del2pi(4).eq.0 ) then
+ call fferr(87,ier)
+ return
+ endif
+ if ( ltest ) then
+*
+* the D0
+*
+ ier0 = ier
+ lsave1 = ldot
+ lsave2 = lwrite
+ ldot = .TRUE.
+ lwrite = .FALSE.
+ isgnsa = isgnal
+ call ffxd0(cc,xpi,ier0)
+ isgnal = isgnsa
+ ldot = lsave1
+ lwrite = lsave2
+ xlosn = xloss*DBLE(10)**(-mod(ier0,50))
+ if ( xlosn*abs(cc-cd0) .gt. precc*abs(cd0) ) print *,
+ + 'ffxdi: error: input D0 disagrees with recomputed: ',
+ + cd0,cc,cd0-cc,ier,ier0
+ if ( xlosn*abs(del3p-fdel3) .gt. precx*abs(del3p) ) print *,
+ + 'ffxdi: error: input del3p disagrees with recomputed: ',
+ + del3p,fdel3,del3p-fdel3,ier,ier0
+ if ( xlosn*abs(del4s-fdel4s) .gt. precx*abs(del4s) ) print*,
+ + 'ffxdi: error: input del4s disagrees with recomputed: ',
+ + del4s,fdel4s,del4s-fdel4s,ier,ier0
+ do 20 i=1,10
+ do 10 j=1,10
+ if ( xlosn*abs(piDpj(j,i)-fpij4(j,i)) .gt. precx*
+ + abs(piDpj(j,i)) ) print *,'ffxdi: error: input '
+ + ,'piDpj(',j,i,') disagrees with recomputed: ',
+ + piDpj(j,i),fpij4(j,i),piDpj(j,i)-fpij4(j,i)
+ 10 continue
+ 20 continue
+*
+* the C0s
+*
+ do 40 i=1,4
+ do 30 j=1,6
+ xpi3(j) = xpi(inx43(j,i))
+ 30 continue
+ if ( idot.gt.0 ) then
+ do 36 j=1,6
+* distribute dotproducts
+ do 35 k=1,6
+ fpij3(k,j) = fpij4(inx43(k,i),inx43(j,i))*
+ + sgn43(k,i)*sgn43(j,i)
+ 35 continue
+ 36 continue
+ endif
+ ier0 = ier
+ lsave1 = ldot
+ lsave2 = lwrite
+ ldot = .TRUE.
+ lwrite = .FALSE.
+ call ffxc0(cc,xpi3,ier0)
+ isgnal = isgnsa
+ ldot = lsave1
+ lwrite = lsave2
+ xlosn = xloss*DBLE(10)**(-mod(ier0,50))
+ if ( xlosn*abs(cc-cc0i(i)) .gt. precc*abs(cc0i(i)) )
+ + print *,'ffxdi: error: input C0(',i,') disagrees ',
+ + 'with recomputed: ',cc0i(i),cc,cc0i(i)-cc,ier,ier0
+ if ( xlosn*abs(del2pi(i)-fdel2) .gt. precx*abs(del2pi(i)
+ + ) ) print *,'ffxdi: error: input del2pi(',i,
+ + ') disagrees with recomputed: ',del2pi(i),fdel2,
+ + del2pi(i)-fdel2
+ 40 continue
+*
+* the B0s
+*
+ if ( degree .lt. 2 ) goto 80
+ do 60 i=1,3
+ do 50 j=i+1,4
+ ier0 = ier
+ lsave2 = lwrite
+ lwrite = .FALSE.
+ call ffxb0(cc,d0,xmu,xpi(inx(i,j)),xpi(i),xpi(j),
+ + ier0)
+ lwrite = lsave2
+ xlosn = xloss*DBLE(10)**(-mod(ier0,50))
+ if ( cb0ij(i,j) .ne. cb0ij(j,i) ) print *,
+ + 'ffxdi: error: cb0ij(',i,j,') != cb0ij(',j,i,
+ + ') : ',cb0ij(i,j),cb0ij(j,i)
+ if ( xlosn*abs(cc-cb0ij(i,j)) .gt. precc*abs(cb0ij(i
+ + ,j)) ) print *,'ffxdi: error: input B0(',i,j,
+ + ') disagrees with recomputed: ',cb0ij(i,j),cc,
+ + cb0ij(i,j)-cc,ier,ier0
+ 50 continue
+ 60 continue
+*
+* the A0s
+*
+ if ( degree .lt. 3 ) goto 80
+ do 70 i=1,4
+ ier0 = ier
+ lsave2 = lwrite
+ lwrite = .FALSE.
+ call ffxa0(cc,d0,xmu,xpi(i),ier0)
+ lwrite = lsave2
+ xlosn = xloss*DBLE(10)**(-mod(ier0,50))
+ if ( xlosn*abs(cc-ca0i(i)) .gt. precc*abs(ca0i(i)) )
+ + print *,'ffxdi: error: input A0(',i,') disagrees ',
+ + 'with recomputed: ',ca0i(i),cc,ca0i(i)-cc,ier,ier0
+ 70 continue
+ 80 continue
+ endif
+ if ( .not.ltest ) then
+* to check when called from ffzfi, ffzei
+ do i=1,10
+ xnul = piDpj(i,5) + piDpj(i,6) + piDpj(i,9)
+ xmax = max(abs(piDpj(i,6)),abs(piDpj(i,9)))
+ if ( xloss*abs(xnul).gt.precx*xmax ) then
+ print *,'ffxdi: error: i569 does not add up to 0: ',
+ + i,piDpj(i,5),piDpj(i,6),piDpj(i,9),xnul,ier
+ endif
+ xnul = piDpj(i,6) + piDpj(i,7) - piDpj(i,10)
+ xmax = max(abs(piDpj(i,7)),abs(piDpj(i,10)))
+ if ( xloss*abs(xnul).gt.precx*xmax ) then
+ print *,'ffxdi: error: i670 does not add up to 0: ',
+ + i,piDpj(i,6),piDpj(i,7),piDpj(i,10),xnul,ier
+ endif
+ xnul = piDpj(i,7) + piDpj(i,8) - piDpj(i,9)
+ xmax = max(abs(piDpj(i,8)),abs(piDpj(i,9)))
+ if ( xloss*abs(xnul).gt.precx*xmax ) then
+ print *,'ffxdi: error: i789 does not add up to 0: ',
+ + i,piDpj(i,7),piDpj(i,8),piDpj(i,9),xnul,ier
+ endif
+ xnul = piDpj(i,8) + piDpj(i,5) + piDpj(i,10)
+ xmax = max(abs(piDpj(i,5)),abs(piDpj(i,10)))
+ if ( xloss*abs(xnul).gt.precx*xmax ) then
+ print *,'ffxdi: error: i850 does not add up to 0: ',
+ + i,piDpj(i,8),piDpj(i,5),piDpj(i,10),xnul,ier
+ endif
+ enddo
+ ier0 = ier
+ call ffdl3p(vgl,piDpj,10,ii4,ii4,ier0)
+ xlosn = xloss*DBLE(10)**(-mod(ier0,50))
+ if ( xlosn*abs(del3p-vgl).gt.precx*abs(vgl) ) then
+ print *,'ffxdi: error: input del3p disagrees with '//
+ + 'recomputed: ',del3p,vgl,del3p-vgl,ier,ier0
+ endif
+ do i=1,4
+ ier0 = ier
+ call ffdel2(vgl,piDpj,10,inx43(4,i),inx43(5,i),
+ + inx43(6,i),0,ier0)
+ xlosn = xloss*DBLE(10)**(-mod(ier0,50))
+ if ( xlosn*abs(del2pi(i)-vgl).gt.precx*abs(vgl) ) then
+ print *,'ffxdi: error: input del2pi(',i,
+ + ') disagrees with recomputed: ',del2pi(i),vgl,
+ + del2pi(i)-vgl,ier,ier0
+ endif
+ enddo
+ endif
+ if ( degree .le. 0 ) then
+ if ( ltest ) print *,'ffxdi: rather useless call to ffxdi'
+ return
+ endif
+* #] check input:
+* #[ preliminaries:
+* not needed? security first!
+ if ( lwrite ) then
+ print *,'i2p(5,6) = ',i2p(5,6)
+ print *,'i2p(6,7) = ',i2p(6,7)
+ print *,'i2p(7,8) = ',i2p(7,8)
+ print *,'i2p(5,8) = ',i2p(5,8)
+ endif
+ dl2pij(i2p(5,6),i2p(5,6)) = del2pi(4)
+ dl2pij(i2p(6,7),i2p(6,7)) = del2pi(1)
+ dl2pij(i2p(7,8),i2p(7,8)) = del2pi(2)
+ dl2pij(i2p(5,8),i2p(5,8)) = del2pi(3)
+* #] preliminaries:
+* #[ get determinants:
+*
+ ier1 = ier
+ call ffdl2i(dl2pij(i2p(6,7),i2p(7,8)),piDpj,10,
+ + 6,7,10,+1,7,8,9,+1,ier1)
+ dl2pij(i2p(7,8),i2p(6,7)) = dl2pij(i2p(6,7),i2p(7,8))
+*
+ ier0 = ier
+ call ffdl2i(dl2pij(i2p(5,8),i2p(6,7)),piDpj,10,
+ + 6,7,10,+1,5,8,10,-1,ier0)
+ ier1 = max(ier1,ier0)
+ dl2pij(i2p(6,7),i2p(5,8)) = dl2pij(i2p(5,8),i2p(6,7))
+*
+ ier0 = ier
+ call ffdl2i(dl2pij(i2p(5,6),i2p(6,7)),piDpj,10,
+ + 6,7,10,+1,5,6,9,-1,ier0)
+ ier1 = max(ier1,ier0)
+ dl2pij(i2p(6,7),i2p(5,6)) = dl2pij(i2p(5,6),i2p(6,7))
+*
+ ier0 = ier
+ call ffdl2t(dl2pij(i2p(5,7),i2p(6,7)),piDpj,5,7,
+ + 6,7,10,-1,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ dl2pij(i2p(6,7),i2p(5,7)) = dl2pij(i2p(5,7),i2p(6,7))
+*
+ ier0 = ier
+ call ffdl2t(dl2pij(i2p(5,7),i2p(7,8)),piDpj,5,7,
+ + 7,8,9,-1,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ dl2pij(i2p(7,8),i2p(5,7)) = dl2pij(i2p(5,7),i2p(7,8))
+*
+ ier0 = ier
+ call ffdl2t(dl2pij(i2p(5,7),i2p(5,8)),piDpj,5,7,
+ + 5,8,10,+1,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ dl2pij(i2p(5,8),i2p(5,7)) = dl2pij(i2p(5,7),i2p(5,8))
+*
+ ier0 = ier
+ call ffdl2t(dl2pij(i2p(5,6),i2p(5,7)),piDpj,5,7,
+ + 5,6,9,+1,-1, 10,ier0)
+ ier1 = max(ier1,ier0)
+ dl2pij(i2p(5,7),i2p(5,6)) = dl2pij(i2p(5,6),i2p(5,7))
+*
+ ier0 = ier
+ call ffdl2i(dl2pij(i2p(5,6),i2p(7,8)),piDpj,10,
+ + 5,6,9,-1,7,8,9,+1,ier0)
+ ier1 = max(ier1,ier0)
+ dl2pij(i2p(7,8),i2p(5,6)) = dl2pij(i2p(5,6),i2p(7,8))
+*
+ ier0 = ier
+ call ffdl2i(dl2pij(i2p(5,6),i2p(5,8)),piDpj,10,
+ + 5,6,9,-1,5,8,10,-1,ier0)
+ ier1 = max(ier1,ier0)
+ dl2pij(i2p(5,8),i2p(5,6)) = dl2pij(i2p(5,6),i2p(5,8))
+*
+ ier0 = ier
+ call ffdl3q(dl3qi(i2p(6,7)),piDpj, 1,6,7, 0,10,0, 0,-1,0,
+ + 0,+1,0, ier0)
+ ier1 = max(ier1,ier0)
+*
+ ier0 = ier
+ call ffdl3q(dl3qi(i2p(5,7)),piDpj, 1,5,7, 2,0,0, -1,0,0,
+ + +1,0,0, ier0)
+ ier1 = max(ier1,ier0)
+*
+ ier0 = ier
+ call ffdl3q(dl3qi(i2p(5,6)),piDpj, 1,2,3, 5,6,9, +1,+1,+1,
+ + -1,-1,-1, ier0)
+ ier1 = max(ier1,ier0)
+*
+ if ( degree.gt.1 ) then
+*
+ ier0 = ier
+ call ffdl3q(dl3qi(i2p(5,8)),piDpj, 1,5,8, 2,10,4, -1,-1,+1,
+ + +1,-1,+1, ier0)
+ ier1 = max(ier1,ier0)
+*
+ ier0 = ier
+ call ffdl3q(dl3qi(i2p(7,8)),piDpj, 3,4,1, 7,8,10, +1,+1,+1,
+ + -1,-1,-1, ier0)
+ ier1 = max(ier1,ier0)
+*
+ ier0 = ier
+ call ffdl3q(dl3qi(7),piDpj, 2,3,4, 6,7,10, +1,+1,+1,
+ + -1,-1,+1, ier0)
+ ier1 = max(ier1,ier0)
+*
+ endif
+ ier = ier1
+ if ( lwrite ) print *,'ier after determinants = ',ier
+*
+* #] get determinants:
+* #[ D1:
+*- #[ D11:
+*
+* see the Form job D1.frm
+*
+ if ( lwrite ) print *,'ffxdi: D11'
+ cs(1) = - cc0i(1)*DBLE(del2pi(1))
+ cs(2) = + cc0i(2)*DBLE(dl2pij(i2p(6,7),i2p(7,8)))
+ cs(3) = + cc0i(3)*DBLE(dl2pij(i2p(5,8),i2p(6,7)))
+ cs(4) = + cc0i(4)*DBLE(dl2pij(i2p(5,6),i2p(6,7)))
+ cs(5) = + 2*cd0*DBLE(dl3qi(i2p(6,7)))
+*
+ cd1p(1) = 0
+ xmax = 0
+ do 110 i=1,5
+ cd1p(1) = cd1p(1) + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 110 continue
+ if ( lwarn .and. abs(cd1p(1)) .lt. xloss*xmax ) then
+ a = abs(cd1p(1))
+ call ffwarn(164,ier1,a,xmax)
+ if ( lwrite ) print *,'cs,cd1p(1) = ',(cs(i),i=1,5),cd1p(1)
+ endif
+ cd1p(1) = cd1p(1)*(1/DBLE(2*del3p))
+*
+*- #] D11:
+*- #[ D12:
+*
+ if ( lwrite ) print *,'ffxdi: D12'
+ cs(1) = + cc0i(1)*DBLE(dl2pij(i2p(5,7),i2p(6,7)))
+ cs(2) = - cc0i(2)*DBLE(dl2pij(i2p(5,7),i2p(7,8)))
+ cs(3) = - cc0i(3)*DBLE(dl2pij(i2p(5,7),i2p(5,8)))
+ cs(4) = - cc0i(4)*DBLE(dl2pij(i2p(5,6),i2p(5,7)))
+ cs(5) = - 2*cd0*DBLE(dl3qi(i2p(5,7)))
+*
+ cd1p(2) = 0
+ xmax = 0
+ do 120 i=1,5
+ cd1p(2) = cd1p(2) + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 120 continue
+ if ( lwarn .and. abs(cd1p(2)) .lt. xloss*xmax ) then
+ a = abs(cd1p(2))
+ ier0 = ier
+ call ffwarn(164,ier0,a,xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'cs,cd1p(2) = ',(cs(i),i=1,5),cd1p(2)
+ endif
+ cd1p(2) = cd1p(2)*(1/DBLE(2*del3p))
+*
+*- #] D12:
+*- #[ D13:
+*
+ if ( lwrite ) print *,'ffxdi: D13'
+ cs(1) = - cc0i(1)*DBLE(dl2pij(i2p(5,6),i2p(6,7)))
+ cs(2) = + cc0i(2)*DBLE(dl2pij(i2p(5,6),i2p(7,8)))
+ cs(3) = + cc0i(3)*DBLE(dl2pij(i2p(5,6),i2p(5,8)))
+ cs(4) = + cc0i(4)*DBLE(del2pi(4))
+ cs(5) = + 2*cd0*DBLE(dl3qi(i2p(5,6)))
+*
+ cd1p(3) = 0
+ xmax = 0
+ do 130 i=1,5
+ cd1p(3) = cd1p(3) + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 130 continue
+ if ( lwarn .and. abs(cd1p(3)) .lt. xloss*xmax ) then
+ a = abs(cd1p(3))
+ ier0 = ier
+ call ffwarn(164,ier0,a,xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'cs,cd1p(3) = ',(cs(i),i=1,5),cd1p(3)
+ endif
+ cd1p(3) = cd1p(3)*(1/DBLE(2*del3p))
+*
+*- #] D13:
+*- #[ print output:
+ if ( lwrite ) then
+ print *,'ffxdi: D1:'
+ print *,'cd1p = '
+ print '(6e20.13)',cd1p
+ print *,'ier = ',ier1
+ endif
+*- #] print output:
+ if ( degree .eq. 1 ) then
+ ier = ier1
+ return
+ endif
+* #] D1:
+* #[ D2:
+*
+* see the form job d2.frm
+*
+*- #[ D2del:
+*
+ if ( lwrite ) print *,'ffxdi: D2del'
+ cs(1) = -2*DBLE(del4s)*cd0
+ cs(2) = +DBLE(dl3qi(i2p(5,6)))*cc0i(4)
+ cs(3) = +DBLE(dl3qi(i2p(5,8)))*cc0i(3)
+ cs(4) = +DBLE(dl3qi(i2p(7,8)))*cc0i(2)
+ cs(5) = -DBLE(dl3qi(7))*cc0i(1)
+*
+ cd2del = 0
+ xmax = 0
+ do 210 i=1,5
+ cd2del = cd2del + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 210 continue
+ if ( lwarn .and. abs(cd2del) .lt. xloss*xmax ) then
+ a = abs(cd2del)
+ ier0 = ier
+ call ffwarn(189,ier0,a,xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'cs,cd2del = ',(cs(i),i=1,5),cd2del
+ endif
+ cd2del = cd2del*DBLE(1/(-2*Del3p**2))
+*
+*- #] D2del:
+*- #[ D2pp(1,1):
+*
+ if ( lwrite ) print *,'D2pp(1,1)'
+ cs(1) = -cb0ij(1,2)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*piDpj(5,6)*
+ + del3p/del2pi(4))
+ cs(2) = -cb0ij(1,2)*DBLE(dl2pij(i2p(5,8),i2p(6,7))*piDpj(5,10)*
+ + del3p/del2pi(3))
+ cs(3) = -cb0ij(1,3)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*piDpj(6,9)*
+ + del3p/del2pi(4))
+ cs(4) = +cb0ij(1,3)*DBLE(dl2pij(i2p(6,7),i2p(7,8))*piDpj(7,9)*
+ + del3p/del2pi(2))
+ cs(5) = -cb0ij(1,4)*DBLE(dl2pij(i2p(5,8),i2p(6,7))*piDpj(8,10)*
+ + del3p/del2pi(3))
+ cs(6) = -cb0ij(1,4)*DBLE(dl2pij(i2p(6,7),i2p(7,8))*piDpj(7,8)*
+ + del3p/del2pi(2))
+ cs(7) = -cb0ij(2,3)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*piDpj(6,6)*
+ + del3p/del2pi(4))
+ cs(8) = -cb0ij(2,4)*DBLE(dl2pij(i2p(5,8),i2p(6,7))*piDpj(10,10)*
+ + del3p/del2pi(3))
+ cs(9) = -cb0ij(3,4)*DBLE(dl2pij(i2p(6,7),i2p(7,8))*piDpj(7,7)*
+ + del3p/del2pi(2))
+ cs(10) = -4*cc0i(1)*DBLE(dl3qi(i2p(6,7))*del2pi(1))
+ cs(11) = +2*cc0i(1)*DBLE(dl3qi(7)*del2pi(1))
+ cs(12) = -2*cc0i(2)*DBLE(dl2pij(i2p(6,7),i2p(7,8))*
+ + dl2pij(i2p(6,7),i2p(7,8))*dl3qi(i2p(7,8))/del2pi(2))
+ cs(13) = +4*cc0i(2)*DBLE(dl2pij(i2p(6,7),i2p(7,8))*
+ + dl3qi(i2p(6,7)))
+ cs(14) = -2*cc0i(3)*DBLE(dl2pij(i2p(5,8),i2p(6,7))*
+ + dl2pij(i2p(5,8),i2p(6,7))*dl3qi(i2p(5,8))/del2pi(3))
+ cs(15) = +4*cc0i(3)*DBLE(dl2pij(i2p(5,8),i2p(6,7))*
+ + dl3qi(i2p(6,7)))
+ cs(16) = -2*cc0i(4)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*
+ + dl2pij(i2p(5,6),i2p(6,7))*dl3qi(i2p(5,6))/del2pi(4))
+ cs(17) = +4*cc0i(4)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*
+ + dl3qi(i2p(6,7)))
+ cs(18) = +4*cd0*DBLE(dl3qi(i2p(6,7))*dl3qi(i2p(6,7)))
+*
+ cd2pp(1,1) = 0
+ xmax = 0
+ do 220 i=1,18
+ cd2pp(1,1) = cd2pp(1,1) + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 220 continue
+ if ( lwarn .and. abs(cd2pp(1,1)) .lt. xloss*xmax ) then
+ a = abs(cd2pp(1,1))
+ ier0 = ier
+ call ffwarn(190,ier0,a,xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'cs,cd2pp(1,1) = ',(cs(i),i=1,18),
+ + cd2pp(1,1)
+ endif
+ cd2pp(1,1) = cd2pp(1,1)*DBLE(1/(4*Del3p**2))
+*
+*- #] D2pp(1,1):
+*- #[ D2pp(1,2):
+*
+ if ( lwrite ) print *,'D2pp(1,2)'
+ cs(1)=+cb0ij(1,2)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*piDpj(5,
+ + 6)*del3p/del2pi(4))
+ cs(2)=+cb0ij(1,2)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*piDpj(5,
+ + 10)*del3p/del2pi(3))
+ cs(3)=+cb0ij(1,3)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*piDpj(6,
+ + 9)*del3p/del2pi(4))
+ cs(4)=-cb0ij(1,3)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*piDpj(7,
+ + 9)*del3p/del2pi(2))
+ cs(5)=+cb0ij(1,4)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*piDpj(8,
+ + 10)*del3p/del2pi(3))
+ cs(6)=+cb0ij(1,4)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*piDpj(7,
+ + 8)*del3p/del2pi(2))
+ cs(7)=+cb0ij(2,3)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*piDpj(6,
+ + 6)*del3p/del2pi(4))
+ cs(8)=+cb0ij(2,4)*DBLE(dl2pij(i2p(5,8),i2p(6,7))*piDpj(5,
+ + 10)*del3p/del2pi(3))
+ cs(9)=-cb0ij(2,4)*DBLE(piDpj(7,10)*del3p)
+ cs(10)=+cb0ij(3,4)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*piDpj(7,
+ + 7)*del3p/del2pi(2))
+ cs(11)=-2*cc0i(1)*DBLE(dl2pij(i2p(5,7),i2p(6,7))*del3p)
+ cs(12)=+2*cc0i(1)*DBLE(dl3qi(i2p(5,7))*del2pi(1))
+ cs(13)=+2*cc0i(2)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*dl2pij(i2p(6,
+ + 7),i2p(7,8))*dl3qi(i2p(7,8))/del2pi(2))
+ cs(14)=-2*cc0i(2)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*dl3qi(i2p(6,
+ + 7)))
+ cs(15)=-2*cc0i(2)*DBLE(dl2pij(i2p(6,7),i2p(7,8))*dl3qi(i2p(5,
+ + 7)))
+ cs(16)=+2*cc0i(3)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*dl2pij(i2p(5,
+ + 8),i2p(6,7))*dl3qi(i2p(5,8))/del2pi(3))
+ cs(17)=-2*cc0i(3)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*dl3qi(i2p(6,
+ + 7)))
+ cs(18)=-2*cc0i(3)*DBLE(dl2pij(i2p(5,8),i2p(6,7))*dl3qi(i2p(5,
+ + 7)))
+ cs(19)=+2*cc0i(4)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*dl2pij(i2p(5,
+ + 6),i2p(6,7))*dl3qi(i2p(5,6))/del2pi(4))
+ cs(20)=-2*cc0i(4)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*dl3qi(i2p(6,
+ + 7)))
+ cs(21)=-2*cc0i(4)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*dl3qi(i2p(5,
+ + 7)))
+ cs(22)=-4*cd0*DBLE(dl3qi(i2p(5,7))*dl3qi(i2p(6,7)))
+*
+ cd2pp(1,2) = 0
+ xmax = 0
+ do 230 i=1,22
+ cd2pp(1,2) = cd2pp(1,2) + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 230 continue
+ if ( lwarn .and. abs(cd2pp(1,2)) .lt. xloss*xmax ) then
+ a = abs(cd2pp(1,2))
+ ier0 = ier
+ call ffwarn(190,ier0,a,xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'cs,cd2pp(1,2) = ',(cs(i),i=1,22),
+ + cd2pp(1,2)
+ endif
+ cd2pp(1,2) = cd2pp(1,2)*DBLE(1/(4*Del3p**2))
+ cd2pp(2,1) = cd2pp(1,2)
+*
+*- #] D2pp(1,2):
+*- #[ D2pp(1,3):
+*
+ if ( lwrite ) print *,'D2pp(1,3)'
+ cs(1)=-cb0ij(1,2)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*piDpj(5,
+ + 10)*del3p/del2pi(3))
+ cs(2)=-cb0ij(1,2)*DBLE(piDpj(5,6)*del3p)
+ cs(3)=+cb0ij(1,3)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*piDpj(7,
+ + 9)*del3p/del2pi(2))
+ cs(4)=-cb0ij(1,3)*DBLE(piDpj(6,9)*del3p)
+ cs(5)=-cb0ij(1,4)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*piDpj(8,
+ + 10)*del3p/del2pi(3))
+ cs(6)=-cb0ij(1,4)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*piDpj(7,
+ + 8)*del3p/del2pi(2))
+ cs(7)=-cb0ij(2,3)*DBLE(piDpj(6,6)*del3p)
+ cs(8)=-cb0ij(2,4)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*piDpj(10,
+ + 10)*del3p/del2pi(3))
+ cs(9)=-cb0ij(3,4)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*piDpj(7,
+ + 7)*del3p/del2pi(2))
+ cs(10)=+2*cc0i(1)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*del3p)
+ cs(11)=-2*cc0i(1)*DBLE(dl3qi(i2p(5,6))*del2pi(1))
+ cs(12)=-2*cc0i(2)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*dl2pij(i2p(6,
+ + 7),i2p(7,8))*dl3qi(i2p(7,8))/del2pi(2))
+ cs(13)=+2*cc0i(2)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*dl3qi(i2p(6,
+ + 7)))
+ cs(14)=+2*cc0i(2)*DBLE(dl2pij(i2p(6,7),i2p(7,8))*dl3qi(i2p(5,
+ + 6)))
+ cs(15)=-2*cc0i(3)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*dl2pij(i2p(5,
+ + 8),i2p(6,7))*dl3qi(i2p(5,8))/del2pi(3))
+ cs(16)=+2*cc0i(3)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*dl3qi(i2p(6,
+ + 7)))
+ cs(17)=+2*cc0i(3)*DBLE(dl2pij(i2p(5,8),i2p(6,7))*dl3qi(i2p(5,
+ + 6)))
+ cs(18)=+2*cc0i(4)*DBLE(dl3qi(i2p(6,7))*del2pi(4))
+ cs(19)=+4*cd0*DBLE(dl3qi(i2p(5,6))*dl3qi(i2p(6,7)))
+*
+ cd2pp(1,3) = 0
+ xmax = 0
+ do 240 i=1,19
+ cd2pp(1,3) = cd2pp(1,3) + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 240 continue
+ if ( lwarn .and. abs(cd2pp(1,3)) .lt. xloss*xmax ) then
+ a = abs(cd2pp(1,3))
+ ier0 = ier
+ call ffwarn(190,ier0,a,xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'cs,cd2pp(1,3) = ',(cs(i),i=1,19),
+ + cd2pp(1,3)
+ endif
+ cd2pp(1,3) = cd2pp(1,3)*DBLE(1/(4*Del3p**2))
+ cd2pp(3,1) = cd2pp(1,3)
+*
+*- #] D2pp(1,3):
+*- #[ D2pp(2,2):
+*
+ if ( lwrite ) print *,'D2pp(2,2)'
+ cs(1)=-cb0ij(1,2)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*piDpj(5,
+ + 5)*del3p/del2pi(4))
+ cs(2)=-cb0ij(1,2)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*piDpj(5,
+ + 5)*del3p/del2pi(3))
+ cs(3)=-cb0ij(1,3)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*piDpj(5,
+ + 9)*del3p/del2pi(4))
+ cs(4)=-cb0ij(1,3)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*piDpj(7,
+ + 9)*del3p/del2pi(2))
+ cs(5)=-cb0ij(1,4)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*piDpj(5,
+ + 8)*del3p/del2pi(3))
+ cs(6)=+cb0ij(1,4)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*piDpj(7,
+ + 8)*del3p/del2pi(2))
+ cs(7)=-cb0ij(2,3)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*piDpj(5,
+ + 6)*del3p/del2pi(4))
+ cs(8)=-cb0ij(2,3)*DBLE(dl2pij(i2p(5,7),i2p(6,7))*piDpj(6,
+ + 7)*del3p/del2pi(1))
+ cs(9)=-cb0ij(2,4)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*piDpj(5,
+ + 10)*del3p/del2pi(3))
+ cs(10)=+cb0ij(2,4)*DBLE(dl2pij(i2p(5,7),i2p(6,7))*piDpj(7,
+ + 10)*del3p/del2pi(1))
+ cs(11)=-cb0ij(3,4)*DBLE(dl2pij(i2p(5,7),i2p(6,7))*piDpj(7,
+ + 7)*del3p/del2pi(1))
+ cs(12)=+cb0ij(3,4)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*piDpj(7,
+ + 7)*del3p/del2pi(2))
+ cs(13)=+2*cc0i(1)*DBLE(dl2pij(i2p(5,7),i2p(6,7))*dl2pij(i2p(5,
+ + 7),i2p(6,7))*dl3qi(7)/del2pi(1))
+ cs(14)=-4*cc0i(1)*DBLE(dl2pij(i2p(5,7),i2p(6,7))*dl3qi(i2p(5,
+ + 7)))
+ cs(15)=-2*cc0i(2)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*dl2pij(i2p(5,
+ + 7),i2p(7,8))*dl3qi(i2p(7,8))/del2pi(2))
+ cs(16)=+4*cc0i(2)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*dl3qi(i2p(5,
+ + 7)))
+ cs(17)=-2*cc0i(3)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*dl2pij(i2p(5,
+ + 7),i2p(5,8))*dl3qi(i2p(5,8))/del2pi(3))
+ cs(18)=+4*cc0i(3)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*dl3qi(i2p(5,
+ + 7)))
+ cs(19)=-2*cc0i(4)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*dl2pij(i2p(5,
+ + 6),i2p(5,7))*dl3qi(i2p(5,6))/del2pi(4))
+ cs(20)=+4*cc0i(4)*DBLE(dl2pij(i2p(5,6),i2p(5,7))*dl3qi(i2p(5,
+ + 7)))
+ cs(21)=+4*cd0*DBLE(dl3qi(i2p(5,7))*dl3qi(i2p(5,7)))
+*
+ cd2pp(2,2) = 0
+ xmax = 0
+ do 250 i=1,21
+ cd2pp(2,2) = cd2pp(2,2) + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 250 continue
+ if ( lwarn .and. abs(cd2pp(2,2)) .lt. xloss*xmax ) then
+ a = abs(cd2pp(2,2))
+ ier0 = ier
+ call ffwarn(190,ier0,a,xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'cs,cd2pp(2,2) = ',(cs(i),i=1,21),
+ + cd2pp(2,2)
+ endif
+ cd2pp(2,2) = cd2pp(2,2)*DBLE(1/(4*Del3p**2))
+*
+*- #] D2pp(2,2):
+*- #[ D2pp(2,3):
+*
+ if ( lwrite ) print *,'D2pp(2,3)'
+*
+ cs(1)=+cb0ij(1,2)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*piDpj(5,
+ + 5)*del3p/del2pi(3))
+ cs(2)=+cb0ij(1,2)*DBLE(piDpj(5,5)*del3p)
+ cs(3)=+cb0ij(1,3)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*piDpj(7,
+ + 9)*del3p/del2pi(2))
+ cs(4)=+cb0ij(1,3)*DBLE(piDpj(5,9)*del3p)
+ cs(5)=+cb0ij(1,4)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*piDpj(5,
+ + 8)*del3p/del2pi(3))
+ cs(6)=-cb0ij(1,4)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*piDpj(7,
+ + 8)*del3p/del2pi(2))
+ cs(7)=+cb0ij(2,3)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*piDpj(6,
+ + 7)*del3p/del2pi(1))
+ cs(8)=+cb0ij(2,3)*DBLE(piDpj(5,6)*del3p)
+ cs(9)=+cb0ij(2,4)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*piDpj(5,
+ + 10)*del3p/del2pi(3))
+ cs(10)=-cb0ij(2,4)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*piDpj(7,
+ + 10)*del3p/del2pi(1))
+ cs(11)=+cb0ij(3,4)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*piDpj(7,
+ + 7)*del3p/del2pi(1))
+ cs(12)=-cb0ij(3,4)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*piDpj(7,
+ + 7)*del3p/del2pi(2))
+ cs(13)=-2*cc0i(1)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*dl2pij(i2p(5,
+ + 7),i2p(6,7))*dl3qi(7)/del2pi(1))
+ cs(14)=+2*cc0i(1)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*dl3qi(i2p(5,
+ + 7)))
+ cs(15)=+2*cc0i(1)*DBLE(dl2pij(i2p(5,7),i2p(6,7))*dl3qi(i2p(5,
+ + 6)))
+ cs(16)=+2*cc0i(2)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*dl2pij(i2p(5,
+ + 7),i2p(7,8))*dl3qi(i2p(7,8))/del2pi(2))
+ cs(17)=-2*cc0i(2)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*dl3qi(i2p(5,
+ + 7)))
+ cs(18)=-2*cc0i(2)*DBLE(dl2pij(i2p(5,7),i2p(7,8))*dl3qi(i2p(5,
+ + 6)))
+ cs(19)=+2*cc0i(3)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*dl2pij(i2p(5,
+ + 7),i2p(5,8))*dl3qi(i2p(5,8))/del2pi(3))
+ cs(20)=-2*cc0i(3)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*dl3qi(i2p(5,
+ + 7)))
+ cs(21)=-2*cc0i(3)*DBLE(dl2pij(i2p(5,7),i2p(5,8))*dl3qi(i2p(5,
+ + 6)))
+ cs(22)=-2*cc0i(4)*DBLE(dl3qi(i2p(5,7))*del2pi(4))
+ cs(23)=-4*cd0*DBLE(dl3qi(i2p(5,6))*dl3qi(i2p(5,7)))
+*
+ cd2pp(2,3) = 0
+ xmax = 0
+ do 260 i=1,23
+ cd2pp(2,3) = cd2pp(2,3) + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 260 continue
+ if ( lwarn .and. abs(cd2pp(2,3)) .lt. xloss*xmax ) then
+ a = abs(cd2pp(2,3))
+ ier = ier0
+ call ffwarn(190,ier0,a,xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'cs,cd2pp(2,3) = ',(cs(i),i=1,23),
+ + cd2pp(2,3)
+ endif
+ cd2pp(2,3) = cd2pp(2,3)*DBLE(1/(4*Del3p**2))
+ cd2pp(3,2) = cd2pp(2,3)
+*
+*- #] D2pp(2,3):
+*- #[ D2pp(3,3):
+*
+ if ( lwrite ) print *,'D2pp(3,3)'
+ cs(1)=+cb0ij(1,2)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*piDpj(5,
+ + 5)*del3p/del2pi(3))
+ cs(2)=+cb0ij(1,3)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*piDpj(9,
+ + 9)*del3p/del2pi(2))
+ cs(3)=+cb0ij(1,4)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*piDpj(5,
+ + 8)*del3p/del2pi(3))
+ cs(4)=-cb0ij(1,4)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*piDpj(8,
+ + 9)*del3p/del2pi(2))
+ cs(5)=-cb0ij(2,3)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*piDpj(6,
+ + 6)*del3p/del2pi(1))
+ cs(6)=+cb0ij(2,4)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*piDpj(5,
+ + 10)*del3p/del2pi(3))
+ cs(7)=+cb0ij(2,4)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*piDpj(6,
+ + 10)*del3p/del2pi(1))
+ cs(8)=-cb0ij(3,4)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*piDpj(6,
+ + 7)*del3p/del2pi(1))
+ cs(9)=-cb0ij(3,4)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*piDpj(7,
+ + 9)*del3p/del2pi(2))
+ cs(10)=+2*cc0i(1)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*dl2pij(i2p(5,
+ + 6),i2p(6,7))*dl3qi(7)/del2pi(1))
+ cs(11)=-4*cc0i(1)*DBLE(dl2pij(i2p(5,6),i2p(6,7))*dl3qi(i2p(5,
+ + 6)))
+ cs(12)=-2*cc0i(2)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*dl2pij(i2p(5,
+ + 6),i2p(7,8))*dl3qi(i2p(7,8))/del2pi(2))
+ cs(13)=+4*cc0i(2)*DBLE(dl2pij(i2p(5,6),i2p(7,8))*dl3qi(i2p(5,
+ + 6)))
+ cs(14)=-2*cc0i(3)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*dl2pij(i2p(5,
+ + 6),i2p(5,8))*dl3qi(i2p(5,8))/del2pi(3))
+ cs(15)=+4*cc0i(3)*DBLE(dl2pij(i2p(5,6),i2p(5,8))*dl3qi(i2p(5,
+ + 6)))
+ cs(16)=+2*cc0i(4)*DBLE(dl3qi(i2p(5,6))*del2pi(4))
+ cs(17)=+4*cd0*DBLE(dl3qi(i2p(5,6))*dl3qi(i2p(5,6)))
+*
+ cd2pp(3,3) = 0
+ xmax = 0
+ do 270 i=1,17
+ cd2pp(3,3) = cd2pp(3,3) + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 270 continue
+ if ( lwarn .and. abs(cd2pp(3,3)) .lt. xloss*xmax ) then
+ a = abs(cd2pp(3,3))
+ ier0 = ier
+ call ffwarn(190,ier0,a,xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'cs,cd2pp(3,3) = ',(cs(i),i=1,17),
+ + cd2pp(3,3)
+ endif
+ cd2pp(3,3) = cd2pp(3,3)*DBLE(1/(4*Del3p**2))
+*
+*- #] D2pp(3,3):
+*- #[ print output:
+ if ( lwrite ) then
+ print '(a,2e20.13)','cd2del = ',cd2del
+ print '(a)','cd2pp = '
+ print '(6e20.13)',cd2pp
+ print *,'ier = ',ier1
+ endif
+ if ( ltest ) then
+ xlosn = xloss*DBLE(10)**(-2-mod(ier1,50))
+ cs(1) = DBLE(piDpj(5,5))*cd2pp(1,1)
+ cs(2) = 2*DBLE(piDpj(5,6))*cd2pp(1,2)
+ cs(3) = 2*DBLE(piDpj(5,7))*cd2pp(1,3)
+ cs(4) = DBLE(piDpj(6,6))*cd2pp(2,2)
+ cs(5) = 2*DBLE(piDpj(6,7))*cd2pp(2,3)
+ cs(6) = DBLE(piDpj(7,7))*cd2pp(3,3)
+ cs(7) = DBLE(del3p)*cd2del
+ cs(8) = - cc0i(1)
+ cs(9) = - DBLE(piDpj(1,1))*cd0
+ cnul = 0
+ xmax = 0
+ do 910 i=1,9
+ cnul = cnul + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 910 continue
+ if ( lwrite ) print *,'ffxdi: checking D2.gmumu= ',cnul,xmax
+ if ( xlosn*abs(cnul) .gt. precc*xmax ) print *,'ffxdi: ',
+ + 'error: D2(mu,mu) not correct ',cnul,xmax,ier1
+ cs(1) = 4*DBLE(piDpj(5,5)*piDpj(7,5))*cd2pp(1,1)
+ cs(2) = 4*DBLE(piDpj(5,5)*piDpj(7,6))*cd2pp(1,2)
+ cs(3) = 4*DBLE(piDpj(5,6)*piDpj(7,5))*cd2pp(1,2)
+ cs(4) = 4*DBLE(piDpj(5,5)*piDpj(7,7))*cd2pp(1,3)
+ cs(5) = 4*DBLE(piDpj(5,7)*piDpj(7,5))*cd2pp(1,3)
+ cs(6) = 4*DBLE(piDpj(5,6)*piDpj(7,6))*cd2pp(2,2)
+ cs(7) = 4*DBLE(piDpj(5,6)*piDpj(7,7))*cd2pp(2,3)
+ cs(8) = 4*DBLE(piDpj(5,7)*piDpj(7,6))*cd2pp(2,3)
+ cs(9) = 4*DBLE(piDpj(5,7)*piDpj(7,7))*cd2pp(3,3)
+ cs(10)= - cb0ij(1,3)
+ cs(11)= + cb0ij(1,4)
+ cs(12)= + cb0ij(2,3)
+ cs(13)= - cb0ij(2,4)
+ cs(14)= - 2*DBLE(piDpj(1,7))*cc0i(2)
+ cs(15)= + 2*DBLE(piDpj(1,7))*cc0i(1)
+ cs(16)= - 2*DBLE(piDpj(1,5))*cc0i(4)
+ cs(17)= + 2*DBLE(piDpj(1,5))*cc0i(3)
+ cs(18)= - 4*DBLE(piDpj(1,5)*piDpj(1,7))*cd0
+ cnul = 0
+ xmax = 0
+ do 920 i=1,18
+ cnul = cnul + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 920 continue
+ if ( lwrite ) print *,'ffxdi: checking D2.p1p3 = ',cnul,xmax
+ if ( xlosn*abs(cnul) .gt. precc*xmax ) print *,'ffxdi :',
+ + 'error: D2(p1,p3) not correct ',cnul,xmax,ier1
+ cs(1) = 4*DBLE(piDpj(6,5)*piDpj(8,5))*cd2pp(1,1)
+ cs(2) = 4*DBLE(piDpj(6,5)*piDpj(8,6))*cd2pp(1,2)
+ cs(3) = 4*DBLE(piDpj(6,6)*piDpj(8,5))*cd2pp(1,2)
+ cs(4) = 4*DBLE(piDpj(6,5)*piDpj(8,7))*cd2pp(1,3)
+ cs(5) = 4*DBLE(piDpj(6,7)*piDpj(8,5))*cd2pp(1,3)
+ cs(6) = 4*DBLE(piDpj(6,6)*piDpj(8,6))*cd2pp(2,2)
+ cs(7) = 4*DBLE(piDpj(6,6)*piDpj(8,7))*cd2pp(2,3)
+ cs(8) = 4*DBLE(piDpj(6,7)*piDpj(8,6))*cd2pp(2,3)
+ cs(9) = 4*DBLE(piDpj(6,7)*piDpj(8,7))*cd2pp(3,3)
+ cs(10)= - cb0ij(2,4)
+ cs(11)= + cb0ij(1,2)
+ cs(12)= + cb0ij(3,4)
+ cs(13)= - cb0ij(1,3)
+ cs(14)= - 2*DBLE(piDpj(1,8))*cc0i(3)
+ cs(15)= + 2*DBLE(piDpj(1,8))*cc0i(2)
+ cs(16)= - 2*DBLE(piDpj(1,6))*cc0i(1)
+ cs(17)= + 2*DBLE(piDpj(1,6))*cc0i(4)
+ cs(18)= - 4*DBLE(piDpj(1,6)*piDpj(1,8))*cd0
+ cnul = 0
+ xmax = 0
+ do 930 i=1,18
+ cnul = cnul + cs(i)
+ a = abs(cs(i))
+ xmax = max(xmax,a)
+ 930 continue
+ if ( lwrite ) print *,'ffxdi: checking D2.p2p4 = ',cnul,xmax
+ if ( xlosn*abs(cnul) .gt. precc*xmax ) print *,'ffxdi :',
+ + 'error: D2(p2,p4) not correct ',cnul,xmax,ier1
+ endif
+*- #] print output:
+ if ( degree .eq. 2 ) then
+ ier = ier1
+ return
+ endif
+* #] D2:
+ print *,'ffxdi: error: D3 not ready'
+ stop
+*###] ffxdi:
+ end
diff --git a/ff-2.0/ffxdpv.f b/ff-2.0/ffxdpv.f
new file mode 100644
index 0000000..efc68f7
--- /dev/null
+++ b/ff-2.0/ffxdpv.f
@@ -0,0 +1,261 @@
+*###[ ffxdpv:
+ subroutine ffxdpv(cd0,cd1,cd2,cd3,cd4,xpi,degree,ier)
+***#[*comment:***********************************************************
+* *
+* Compute the scalar and tensor functions D0-D(degree) in the *
+* Passarino-Veltman scheme, i.e. with basis p1-p3 and d_(mu,nu)). *
+* *
+* Input: xpi(13) (real) 1-4: mi^2, 5-10: p(i-4)^2 *
+* 11-13: either 0 or u,v,w *
+* degree (integer) 0-4 *
+* *
+* Output: ier number of digits lost in the *
+* least stable result *
+* cd0 (complex) D0 *
+* only when degree>0: *
+* cd1(3) (complex) coeffs of p1,p2,p3 *
+* only when degree>1: *
+* cd2(7) (complex) .. *
+* only when degree>2: *
+* cd3(13) (complex) ... *
+* only when degree>3: *
+* cd4(22) (complex) ... *
+* *
+* Note: at this moment (28-feb-1993) only D1 and D2 are coded. *
+* I am undecided as yet about whether to include the Ci. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer degree,ier
+ DOUBLE PRECISION xpi(13)
+ DOUBLE COMPLEX cd0,cd1(3),cd2(7),cd3(13),cd4(22)
+*
+* local variables
+*
+ integer i,j,k,ier0,ier1,inx43(6,4),sgn43(6,4),isgnsa,idotsa
+ DOUBLE PRECISION del2pi(4),d0,xmu,absc
+ DOUBLE PRECISION h,del3sp(4),del2ij,xpi3(6),dl2pij(6,6)
+ DOUBLE COMPLEX cd4pppp(3,3,3,3),cd4ppdel(3,3),cd4deldel,
+ + cd3ppp(3,3,3),cd3pdel(3),cd2pp(3,3),cd2del,
+ + cc0i(4),cb0ij(4,4),ca0i(4),cc
+ save inx43,sgn43
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data inx43 /2,3,4,6,7,10,
+ + 1,3,4,9,7,8,
+ + 1,2,4,5,10,8,
+ + 1,2,3,5,6,9/
+ data sgn43 /+1,+1,+1,+1,+1,-1,
+ + +1,+1,+1,-1,+1,+1,
+ + +1,+1,+1,+1,+1,+1,
+ + +1,+1,+1,+1,+1,+1/
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ write input:
+ if ( lwrite ) then
+ print *,'ffxdpv: input:'
+ print *,'xpi = ',xpi
+ print *,'degree ',degree
+ endif
+* #] write input:
+* #[ get scalar functions and determinants:
+*
+ ldot = .TRUE.
+ isgnsa = isgnal
+*
+* the D0
+*
+ ier0 = ier
+ call ffxd0(cd0,xpi,ier0)
+ isgnal = isgnsa
+ ier1 = ier0
+*
+* the C0s
+*
+ do 40 i=1,4
+ do 30 j=1,6
+ xpi3(j) = xpi(inx43(j,i))
+* distribute dotproducts
+ do 25 k=1,6
+ fpij3(k,j) = fpij4(inx43(k,i),inx43(j,i))*
+ + sgn43(k,i)*sgn43(j,i)
+ 25 continue
+ 30 continue
+ ier0 = ier
+ idotsa = idot
+ idot = max(idot,3)
+ call ffxc0(cc0i(i),xpi3,ier0)
+ idot = idotsa
+ isgnal = isgnsa
+ ier1 = max(ier1,ier0)
+ del2pi(i) = fdel2
+ 40 continue
+*
+* the B0s
+*
+ if ( degree .lt. 2 ) goto 80
+ do 60 i=1,3
+ do 50 j=i+1,4
+ ier0 = ier
+ call ffxb0(cb0ij(i,j),x0,x0,xpi(inx(i,j)),xpi(i),
+ + xpi(j),ier0)
+ cb0ij(j,i) = cb0ij(i,j)
+ ier1 = max(ier1,ier0)
+ 50 continue
+ 60 continue
+*
+* the A0s
+*
+ if ( degree .lt. 3 ) goto 80
+ do 70 i=1,4
+ ier0 = ier
+ call ffxa0(ca0i(i),x0,x0,xpi(i),ier0)
+ ier1 = max(ier1,ier0)
+ 70 continue
+ 80 continue
+ ier = ier1
+*
+* #] get scalar functions and determinants:
+* #[ call ffxdi:
+ call ffxdi(cd4pppp,cd4ppdel,cd4deldel, cd3ppp,cd3pdel,
+ + cd2pp,cd2del, cd1, dl2pij, cd0,cc0i,cb0ij,ca0i, fdel4s,
+ + fdel3, del2pi, xpi,fpij4, x0,x0, degree, ier)
+* #] call ffxdi:
+* #[ convert to PV conventions:
+*
+ ier1 = ier
+ cd2(1) = cd2pp(1,1) - DBLE(del2pi(1))*cd2del
+ if ( lwarn .and. absc(cd2(1)).lt.xloss*absc(cd2pp(1,1)) ) then
+ call ffwarn(229,ier1,absc(cd2(1)),absc(cd2pp(1,1)))
+ endif
+ cd2(2) = cd2pp(1,2) + DBLE(dl2pij(2,4))*cd2del
+ if ( lwarn .and. absc(cd2(2)).lt.xloss*absc(cd2pp(1,2)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(2)),absc(cd2pp(1,2)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(3) = cd2pp(1,3) - DBLE(dl2pij(1,4))*cd2del
+ if ( lwarn .and. absc(cd2(3)).lt.xloss*absc(cd2pp(1,3)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(3)),absc(cd2pp(1,3)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(4) = cd2pp(2,2) - DBLE(xpi(5)*xpi(7)-fpij4(5,7)**2)*cd2del
+ if ( lwarn .and. absc(cd2(4)).lt.xloss*absc(cd2pp(2,2)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(4)),absc(cd2pp(2,2)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(5) = cd2pp(2,3) + DBLE(dl2pij(1,2))*cd2del
+ if ( lwarn .and. absc(cd2(5)).lt.xloss*absc(cd2pp(2,3)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(5)),absc(cd2pp(2,3)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(6) = cd2pp(3,3) - DBLE(del2pi(4))*cd2del
+ if ( lwarn .and. absc(cd2(6)).lt.xloss*absc(cd2pp(3,3)) ) then
+ ier0 = ier
+ call ffwarn(229,ier0,absc(cd2(6)),absc(cd2pp(3,3)))
+ ier1 = max(ier1,ier0)
+ endif
+ cd2(7) = DBLE(fdel3)*cd2del
+*
+* #] convert to PV conventions:
+* #[ print output:
+ if ( lwrite ) then
+ print *,'PV D1 = '
+ print '(6e20.13)',cd1
+ if ( degree .lt. 2 ) return
+ print *,'PV D2 = '
+ print '(6e20.13)',cd2
+ endif
+* #] print output:
+*###] ffxdpv:
+ end
+*###[ ffxdpd:
+ subroutine ffxdpd(cd0,cd1,cd2,cd3,cd4,xpi,piDpj,del3p,del4s,
+ + info,degree,ier)
+***#[*comment:***********************************************************
+* *
+* Compute the scalar and tensor functions D0-D(degree) in the *
+* Passarino-Veltman scheme, i.e. with basis p1-p3 and d_(mu,nu)). *
+* *
+* Input: xpi(13) real 1-4: mi^2, 5-10: p(i-4)^2 *
+* 11-13: either 0 or u,v,w *
+* piDpj(10,10) real dotproducts pi.pj *
+* del3 real det(pi.pj) *
+* info integer 0: piDpj, del3 invalid *
+* 1: piDpj(6:10,6:10) defined *
+* 2: del3p also *
+* 3: rest of piDpj (internal) also*
+* 4: del4s = det(si.sj) also *
+* degree integer 0-4: which tensor functions *
+* *
+* Output: see ffxdpv
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer info,degree,ier
+ DOUBLE PRECISION xpi(13),piDpj(10,10),del3p,del4s
+ DOUBLE COMPLEX cd0,cd1(3),cd2(7),cd3(13),cd4(22)
+*
+* local vars
+*
+ integer i,j
+*
+* common
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ hide information in common blocks:
+*
+ idot = info
+ if ( idot.ne.0 ) then
+ if ( idot.le.2 ) then
+ do 20 i=5,10
+ do 10 j=5,10
+ fpij4(j,i) = piDpj(j,i)
+ 10 continue
+ 20 continue
+ elseif ( idot.ge.3 ) then
+ do 40 i=1,10
+ do 30 j=1,10
+ fpij4(j,i) = piDpj(j,i)
+ 30 continue
+ 40 continue
+ endif
+ if ( abs(idot).ge.2 ) then
+ fdel3 = del3p
+ endif
+ if ( abs(idot).ge.4 ) then
+ fdel4s = del4s
+ endif
+ endif
+*
+* #] hide information in common blocks:
+* #[ call ffxdpv:
+*
+ call ffxdpv(cd0,cd1,cd2,cd3,cd4,xpi,degree,ier)
+ idot = 0
+*
+* #] call ffxdpv:
+*###] ffxdpd:
+ end
diff --git a/ff-2.0/ffxe0.f b/ff-2.0/ffxe0.f
new file mode 100644
index 0000000..b6cf9fe
--- /dev/null
+++ b/ff-2.0/ffxe0.f
@@ -0,0 +1,1236 @@
+* $Id: ffxe0.f,v 1.4 1996/01/10 15:36:51 gj Exp $
+*###[ ffxe0:
+ subroutine ffxe0(ce0,cd0i,xpi,ier)
+***#[*comment:***********************************************************
+* *
+* calculate *
+* *
+* 1 / / \-1*
+* e0= -----\dq |(q^2-m_1^2)((q+p_1)^2-m_2^2)...((q-p_5)^2-m_5^2| *
+* ipi^2/ \ / *
+* *
+* following the five four-point-function method in .... *
+* As an extra the five fourpoint function Di are also returned *
+* if ( ldot ) the dotproducts are left behind in fpij5(15,15) in *
+* /ffdot/ and the external determinants fdel4 and fdl3i(5) in *
+* /ffdel/. *
+* *
+* Input: xpi = m_i^2 (real) i=1,5 *
+* xpi = p_i.p_i (real) i=6,10 (note: B&D metric) *
+* xpi = (p_i+p_{i+1})^2 (r) i=11,15 *
+* xpi = (p_i+p_{i+2})^2 (r) i=16,20 OR 0 *
+* *
+* Output: ce0 (complex) *
+* cd0i(5) (complex) D0 with s_i missing *
+* ier (integr) 0=ok 1=inaccurate 2=error *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE PRECISION xpi(20)
+ DOUBLE COMPLEX ce0,cd0i(5)
+ integer ier
+*
+* local variables
+*
+ integer i,j,NMIN,NMAX,ier0,i6,i7,i8,i9
+ parameter(NMIN=15,NMAX=20)
+ DOUBLE PRECISION dpipj(NMIN,NMAX),xmax
+ logical lp5(NMAX-NMIN)
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ get differences:
+*
+* simulate the differences in the masses etc..
+*
+ if ( lwrite ) print *,'ffxe0: input xpi: ',xpi
+*
+* first p16-p20
+*
+ do 5 i=1,5
+ if ( xpi(i+15) .eq. 0 ) then
+ i6 = i+5
+ i7 = i6+1
+ if ( i7 .ge. 11 ) i7 = 6
+ i8 = i7+1
+ if ( i8 .ge. 11 ) i8 = 6
+ i9 = i8+1
+ if ( i9 .ge. 11 ) i9 = 6
+ xpi(i+15) = xpi(i6)+xpi(i7)+xpi(i8)-xpi(i6+5)-xpi(i7+5)+
+ + xpi(i9+5)
+ xmax = max(abs(xpi(i6)),abs(xpi(i7)),abs(xpi(i8)),abs(
+ + xpi(i6+5)),abs(xpi(i7+5)),abs(xpi(i9+5)))
+ if ( abs(xpi(i+15)) .lt. xloss*xmax )
+ + call ffwarn(168,ier,xpi(i+15),xmax)
+ lp5(i) = .TRUE.
+ else
+ lp5(i) = .FALSE.
+ endif
+ 5 continue
+*
+* next the differences
+*
+ ier0 = 0
+ if ( lwarn ) then
+ do 20 i=1,NMAX
+ if ( i .le. NMIN ) dpipj(i,i) = 0
+ do 10 j=1,min(i-1,NMIN)
+ dpipj(j,i) = xpi(j) - xpi(i)
+ if ( i .le. NMIN ) then
+ dpipj(i,j) = -dpipj(j,i)
+ endif
+* we do not need the differences of the u-like variables accurately
+ if ( i.gt.10 .and. j.gt.10 ) goto 10
+ if ( abs(dpipj(j,i)) .lt. xloss*abs(xpi(i))
+ + .and. xpi(i) .ne. xpi(j) ) then
+ call ffwarn(158,ier0,dpipj(j,i),xpi(i))
+ if ( lwrite ) print *,'between xpi(',i,
+ + ') and xpi(',j,')'
+ endif
+ 10 continue
+ 20 continue
+ else
+ do 40 i=1,NMAX
+ do 30 j=1,NMIN
+ dpipj(j,i) = xpi(j) - xpi(i)
+ 30 continue
+ 40 continue
+ endif
+* #] get differences:
+* #[ call ffxe0a:
+ call ffxe0a(ce0,cd0i,xpi,dpipj,ier)
+* #] call ffxe0a:
+* #[ clean up:
+ do 90 i=1,5
+ if ( lp5(i) ) then
+ xpi(i+NMIN) = 0
+ endif
+ 90 continue
+* #] clean up:
+*###] ffxe0:
+ end
+*###[ ffxe0a:
+ subroutine ffxe0a(ce0,cd0i,xpi,dpipj,ier)
+***#[*comment:***********************************************************
+* *
+* calculate *
+* *
+* 1 / / \-1*
+* e0= -----\dq |(q^2-m_1^2)((q+p_1)^2-m_2^2)...((q-p_5)^2-m_5^2| *
+* ipi^2/ \ / *
+* *
+* following the five four-point-function method in .... *
+* As an extra the five fourpoint function Di are also returned *
+* if ( ldot ) the dotproducts are left behind in fpij5(15,15) in *
+* /ffdot/ and the external determinants fdel4 and fdl3i(5) in *
+* /ffdel/. *
+* *
+* Input: xpi = m_i^2 (real) i=1,5 *
+* xpi = p_i.p_i (real) i=6,10 (note: B&D metric) *
+* xpi = (p_i+p_{i+1})^2 (r) i=11,15 *
+* xpi = (p_i+p_{i+2})^2 (r) i=16,20 *
+* dpipj(15,20) (real) = pi(i) - pi(j) *
+* *
+* Output: ce0 (complex) *
+* cd0i(5) (complex) D0 with s_i missing *
+* ier (integer) <50:lost # digits 100=error *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX ce0,cd0i(5)
+ DOUBLE PRECISION xpi(20),dpipj(15,20)
+*
+* local variables
+*
+ integer i,j,ii(10),ii4(6),ieri(5),ier0,imin,itype,ndiv,idone,
+ + ier1
+ logical lwsav,ldel2s
+ DOUBLE COMPLEX c,cfac,cs,csum
+ DOUBLE PRECISION dl5s,dl4p,xpi4(13),dpipj4(10,13),piDpj4(10,10),
+ + absc,xmax,piDpj(15,15),xqi4(13),dqiqj4(10,13),
+ + qiDqj4(10,10),del2s,xmx5(5),dl4ri(5)
+ save ii4
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data ii4 /5,6,7,8,9,10/
+*
+* #] declarations:
+* #[ initialisations:
+ ndiv = 0
+ idsub = 0
+ ce0 = 0
+ do 1 i=1,5
+ cd0i(i) = 0
+ 1 continue
+* #] initialisations:
+* #[ calculations:
+*
+ idsub = idsub + 1
+ call ffdot5(piDpj,xpi,dpipj,ier)
+ if ( ldot ) then
+ do 6 i=1,15
+ do 5 j=1,15
+ fpij5(j,i) = piDpj(j,i)
+ 5 continue
+ 6 continue
+ do 10 i=1,10
+ ii(i) = i+5
+ 10 continue
+ idsub = idsub + 1
+ ier0 = 0
+ call ffdl4p(dl4p,xpi,piDpj,15,ii,ier0)
+* if ( dl4p .lt. 0 ) then
+* call fferr(57,ier)
+* endif
+ fdel4 = dl4p
+ endif
+ idsub = idsub + 1
+ call ffdel5(dl5s,xpi,piDpj,15,ier)
+ if ( lwrite ) then
+ print *,'ffxe0: dl5s = ',dl5s
+ endif
+*
+ do 40 i=1,5
+ ieri(i) = ier
+ 40 continue
+*
+ do 100 i=1,5
+ if ( lwrite ) print *,'ffxe0a: fourpoint function nr ',i
+*
+* get the coefficient determinant
+*
+ idsub = idsub + 1
+ call ffdl4r(dl4ri(i),xpi,piDpj,15,i,ieri(i))
+*
+* get four-point momenta
+*
+ call ffpi54(xpi4,dpipj4,piDpj4,xpi,dpipj,piDpj,i,ieri(i))
+*
+* first try IR divergent function to avoid error messages from ffrot4
+*
+ ier1 = ieri(i)
+ call ffxdir(cs,cfac,idone,xpi4,dpipj4,6,ndiv,ier1)
+ if ( idone .gt. 0 ) then
+* done
+ xmax = abs(cs)*10d0**(-mod((ier1-ieri(i)),50))
+ else
+*
+* rotate to calculable posistion
+*
+ call ffrot4(irota4,del2s,xqi4,dqiqj4,qiDqj4,xpi4,dpipj4,
+ + piDpj4,5,itype,ieri(i))
+ if ( itype .lt. 0 ) then
+ print *,'ffxe0: error: Cannot handle this ',
+ + ' 4point masscombination yet:'
+ print *,(xpi(j),j=1,20)
+ return
+ endif
+ if ( itype .eq. 1 ) then
+ ldel2s = .TRUE.
+ isgnal = +1
+ print *,'ffxe0a: Cannot handle del2s = 0 yet'
+ stop
+ else
+ ldel2s = .FALSE.
+ endif
+ if ( itype .eq. 2 ) then
+ print *,'ffxe0a: no doubly IR divergent yet'
+ stop
+ endif
+*
+* get fourpoint function
+*
+ ier0 = ieri(i)
+ lwsav = lwrite
+ lwrite = .FALSE.
+ call ffxd0e(cs,cfac,xmax, .FALSE.,ndiv,xqi4,dqiqj4,
+ + qiDqj4,del2s,ldel2s,ieri(i))
+ if ( ieri(i).gt.10 ) then
+ if ( ltest ) then
+ print *,'ffxe0: id = ',id,', nevent = ',nevent
+ print *,'ffxe0: lost ',ieri(i),
+ + ' digits in D0 with isgnal ',isgnal,
+ + ', trying other roots, isgnal ',-isgnal
+ endif
+ isgnal = -isgnal
+ ieri(i) = ier0
+ call ffxd0e(cs,cfac,xmax, .TRUE.,ndiv,xqi4,dqiqj4,
+ + qiDqj4,del2s,ldel2s,ieri(i))
+ isgnal = -isgnal
+ endif
+ lwrite = lwsav
+ endif
+*
+* Finally ...
+*
+ cd0i(i) = cs*cfac
+ xmx5(i) = xmax*absc(cfac)
+ if ( ldot ) then
+ call ffdl3p(fdl3i(i),piDpj4,10,ii4,ii4,ieri(i))
+* let's hope tha tthese have been set by ffxd0e...
+ fdl4si(i) = fdel4s
+ if ( ltest ) then
+ ier0 = 0
+ call ffdel4(fdel4s,xpi4,piDpj4,10,ier0)
+ if ( xloss*10d0**(-ier0-1)*abs(fdl4si(i)-fdel4s)
+ + .gt. precx*abs(fdel4s) ) then
+ print *,'ffxe0a: error: Del4s was not correct',
+ + fdl4si(i),fdel4s,fdl4si(i)-fdel4s,ier0
+ endif
+ endif
+ if ( lwrite ) print *,'ffxe0: fdel4s = ',fdel4s
+ endif
+ 100 continue
+*
+* #] calculations:
+* #[ add all up:
+*
+ csum = 0
+ xmax = 0
+ imin = 1
+ do 200 i=1,5
+ imin = -imin
+ csum = csum + imin*DBLE(dl4ri(i))*cd0i(i)
+ if ( ieri(i) .gt. 50 ) then
+ ieri(i) = mod(ieri(i),50)
+ endif
+ xmax = max(xmax,dl4ri(i)*xmx5(i)*DBLE(10)**mod(ieri(i),50))
+ 200 continue
+*
+* Check for cancellations in the final adding up
+*
+ if ( lwarn .and. 2*absc(csum) .lt. xloss*xmax )
+ + call ffwarn(161,ier,absc(csum),xmax)
+*
+* Check for a sum close to the minimum of the range (underflow
+* problems)
+*
+ if ( lwarn .and. absc(csum).lt.xalogm/precc .and. csum.ne.0 )
+ + call ffwarn(162,ier,absc(csum),xalogm/precc)
+*
+* If the imaginary part is very small it most likely is zero
+* (can be removed, just esthetically more pleasing)
+*
+ if ( abs(DIMAG(csum)) .lt. precc*abs(DBLE(csum)) )
+ + csum = DCMPLX(DBLE(csum))
+*
+* Finally ...
+*
+ ce0 = csum*(1/DBLE(2*dl5s))
+*
+ if ( lwrite ) then
+ do i=1,5
+ print '(a,5e16.8,i6)','cs,del4r,D0 = ',
+ + DBLE(dl4ri(i))*cd0i(i)*(1/DBLE(2*dl5s)),
+ + dl4ri(i)/DBLE(2*dl5s),cd0i(i),ieri(i)
+ enddo
+ print '(a,2e24.16,i6)','ffxe0a: ce0 = ',ce0,ier
+ endif
+* #] add all up:
+*###] ffxe0a:
+ end
+*###[ ffxe00:
+ subroutine ffxe00(ce0,cd0i,dl4ri,xpi,piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* calculate *
+* *
+* 1 / / \-1*
+* e0= -----\dq |(q^2-m_1^2)((q+p_1)^2-m_2^2)...((q-p_5)^2-m_5^2| *
+* ipi^2/ \ / *
+* *
+* following the five four-point-function method in .... *
+* The four five fourpoint function Di are input in this version. *
+* *
+* Input: cd0i(5) (complex) D0 with s_i missing *
+* dl4ri(5) (real) coeff of D0 *
+* xpi = m_i^2 (real) i=1,5 *
+* xpi = p_i.p_i (real) i=6,10 (note: B&D metric) *
+* xpi = (p_i+p_{i+1})^2 (r) i=11,15 *
+* xpi = (p_i+p_{i+2})^2 (r) i=16,20 *
+* piDpj(15,15) (real) pi.pj *
+* *
+* Output: ce0 (complex) *
+* ier (integer) <50:lost # digits 100=error *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX ce0,cd0i(5)
+ DOUBLE PRECISION dl4ri(5),xpi(20),piDpj(15,15)
+*
+* local variables
+*
+ integer i,ii(10),imin,ier0
+ DOUBLE COMPLEX c,csum
+ DOUBLE PRECISION dl5s,dl4p,absc,xmax
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ initialisations:
+*
+ idsub = idsub + 1
+ ce0 = 0
+ if ( lwrite ) then
+ print *,'ffxe00: input:'
+ print *,' cd0i = ',cd0i
+ print *,' dl4ri = ',dl4ri
+ print *,' xpi = ',xpi
+ endif
+*
+* #] initialisations:
+* #[ calculations:
+*
+ if ( ldot ) then
+ do 10 i=1,10
+ ii(i) = i+5
+ 10 continue
+ idsub = idsub + 1
+ ier0 = 0
+ call ffdl4p(dl4p,xpi,piDpj,15,ii,ier0)
+ fdel4 = dl4p
+ endif
+ idsub = idsub + 1
+ call ffdel5(dl5s,xpi,piDpj,15,ier)
+ if ( lwrite ) then
+ print *,'ffxe00: dl5s = ',dl5s
+ endif
+*
+* #] calculations:
+* #[ add all up:
+*
+ csum = 0
+ xmax = 0
+ imin = 1
+ do 200 i=1,5
+ imin = -imin
+ csum = csum + imin*DBLE(dl4ri(i))*cd0i(i)
+ xmax = max(xmax,abs(dl4ri(i))*absc(cd0i(i)))
+ 200 continue
+*
+* Check for cancellations in the final adding up
+*
+ if ( lwarn .and. 2*absc(csum) .lt. xloss*xmax )
+ + call ffwarn(161,ier,absc(csum),xmax)
+*
+* Check for a sum close to the minimum of the range (underflow
+* problems)
+*
+ if ( lwarn .and. absc(csum).lt.xalogm/precc .and. csum.ne.0 )
+ + call ffwarn(162,ier,absc(csum),xalogm/precc)
+*
+* If the imaginary part is very small it most likely is zero
+* (can be removed, just esthetically more pleasing)
+*
+ if ( abs(DIMAG(csum)) .lt. precc*abs(DBLE(csum)) )
+ + csum = DCMPLX(DBLE(csum))
+*
+* Finally ...
+*
+ ce0 = csum*(1/DBLE(2*dl5s))
+*
+* #] add all up:
+*###] ffxe00:
+ end
+*###[ ffdot5:
+ subroutine ffdot5(piDpj,xpi,dpipj,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the dotproducts pi.pj with *
+* *
+* xpi(i) = s_i i=1,5 *
+* xpi(i) = p_i i=6,10 *
+* xpi(i) = p_i+p_{i+1} i=11,15 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xpi(20),dpipj(15,20),piDpj(15,15)
+*
+* local variables
+*
+ integer is1,is2,is3,is4,ip6,ip7,ip8,ip11,ip12,ip14,i,j,
+ + igehad(15,15),itel,i1,i2,i3,i4,i5,i6,ierin,ier0
+* werkt niet bij Absoft
+* parameter (locwrt=.TRUE.)
+ logical locwrt
+ DOUBLE PRECISION xheck,xmax
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data locwrt /.FALSE./
+* #] declarations:
+* #[ check input:
+ if ( ltest ) call ffxhck(xpi,dpipj,15,ier)
+ if ( locwrt ) then
+ do 2 i=1,15
+ do 1 j=1,15
+ igehad(j,i) = 0
+ 1 continue
+ 2 continue
+ endif
+* #] check input:
+* #[ indices:
+ ierin = ier
+ do 10 is1=1,5
+ is2 = is1 + 1
+ if ( is2 .eq. 6 ) is2 = 1
+ is3 = is2 + 1
+ if ( is3 .eq. 6 ) is3 = 1
+ ip6 = is1 + 5
+ ip7 = is2 + 5
+ ip11 = ip6 + 5
+*
+* we have now defined a 3point function
+*
+* | -p11
+* |
+* / \
+* s1/ \s3
+* ___/_____\___
+* p6 s2 p7
+*
+* #] indices:
+* #[ all in one vertex:
+*
+* pi.pi, si.si
+*
+ piDpj(is1,is1) = xpi(is1)
+ piDpj(ip6,ip6) = xpi(ip6)
+ piDpj(ip11,ip11) = xpi(ip11)
+ if ( locwrt ) then
+ igehad(is1,is1) = igehad(is1,is1) + 1
+ igehad(ip6,ip6) = igehad(ip6,ip6) + 1
+ igehad(ip11,ip11) = igehad(ip11,ip11) + 1
+ endif
+*
+* si.s(i+1)
+*
+ if ( xpi(is2) .le. xpi(is1) ) then
+ piDpj(is1,is2) = (dpipj(is1,ip6) + xpi(is2))/2
+ else
+ piDpj(is1,is2) = (dpipj(is2,ip6) + xpi(is1))/2
+ endif
+ piDpj(is2,is1) = piDpj(is1,is2)
+ if ( locwrt ) then
+ igehad(is1,is2) = igehad(is1,is2) + 1
+ igehad(is2,is1) = igehad(is2,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(is1,is2)) .lt.
+ + xloss*min(xpi(is1),xpi(is2)) ) then
+ ier0 = ierin
+ call ffwarn(105,ier0,piDpj(is1,is2),min(xpi(is1),
+ + xpi(is2)))
+ ier = max(ier,ier0)
+ endif
+*
+* si.s(i+2)
+*
+ if ( xpi(is1) .le. xpi(is3) ) then
+ piDpj(is3,is1) = (dpipj(is3,ip11) + xpi(is1))/2
+ else
+ piDpj(is3,is1) = (dpipj(is1,ip11) + xpi(is3))/2
+ endif
+ piDpj(is1,is3) = piDpj(is3,is1)
+ if ( locwrt ) then
+ igehad(is1,is3) = igehad(is1,is3) + 1
+ igehad(is3,is1) = igehad(is3,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(is1,is3)) .lt.
+ + xloss*min(xpi(is1),xpi(is3)) ) then
+ ier0 = ierin
+ call ffwarn(106,ier0,
+ + piDpj(is1,is3),min(xpi(is1),xpi(is3)))
+ ier = max(ier,ier0)
+ endif
+*
+* pi.si
+*
+ if ( abs(xpi(ip6)) .le. xpi(is1) ) then
+ piDpj(ip6,is1) = (dpipj(is2,is1) - xpi(ip6))/2
+ else
+ piDpj(ip6,is1) = (dpipj(is2,ip6) - xpi(is1))/2
+ endif
+ piDpj(is1,ip6) = piDpj(ip6,is1)
+ if ( locwrt ) then
+ igehad(is1,ip6) = igehad(is1,ip6) + 1
+ igehad(ip6,is1) = igehad(ip6,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip6,is1)) .lt.
+ + xloss*min(abs(xpi(ip6)),xpi(is1))) then
+ ier0 = ierin
+ call ffwarn(107,ier0,
+ + piDpj(ip6,is1),min( abs(xpi(ip6)),xpi(is1)))
+ ier = max(ier,ier0)
+ endif
+*
+* pi.s(i+1)
+*
+ if ( abs(xpi(ip6)) .le. xpi(is2) ) then
+ piDpj(ip6,is2) = (dpipj(is2,is1) + xpi(ip6))/2
+ else
+ piDpj(ip6,is2) = (dpipj(ip6,is1) + xpi(is2))/2
+ endif
+ if ( locwrt ) then
+ igehad(is2,ip6) = igehad(is2,ip6) + 1
+ igehad(ip6,is2) = igehad(ip6,is2) + 1
+ endif
+ piDpj(is2,ip6) = piDpj(ip6,is2)
+ if ( lwarn .and. abs(piDpj(ip6,is2)) .lt.
+ + xloss*min(abs(xpi(ip6)),xpi(is2))) then
+ ier0 = ierin
+ call ffwarn(108,ier0,
+ + piDpj(ip6,is2),min(abs(xpi(ip6)),xpi (is2)))
+ ier = max(ier,ier0)
+ endif
+*
+* p(i+2).s(i)
+*
+ if ( abs(xpi(ip11)) .le. xpi(is1) ) then
+ piDpj(ip11,is1) = -(dpipj(is1,is3) + xpi(ip11))/2
+ else
+ piDpj(ip11,is1) = -(dpipj(ip11,is3) + xpi(is1))/2
+ endif
+ piDpj(is1,ip11) = piDpj(ip11,is1)
+ if ( locwrt ) then
+ igehad(is1,ip11) = igehad(is1,ip11) + 1
+ igehad(ip11,is1) = igehad(ip11,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip11,is1)) .lt.
+ + xloss*min(abs(xpi(ip11)),xpi(is1))) then
+ ier0 = ierin
+ call ffwarn(109,ier0,
+ + piDpj(ip11,is1),min(abs(xpi(ip11)),xpi(is1)))
+ ier = max(ier,ier0)
+ endif
+*
+* p(i+2).s(i+2)
+*
+ if ( abs(xpi(ip11)) .le. xpi(is3) ) then
+ piDpj(ip11,is3) = -(dpipj(is1,is3) - xpi(ip11))/2
+ else
+ piDpj(ip11,is3) = -(dpipj(is1,ip11) - xpi(is3))/2
+ endif
+ piDpj(is3,ip11) = piDpj(ip11,is3)
+ if ( locwrt ) then
+ igehad(is3,ip11) = igehad(is3,ip11) + 1
+ igehad(ip11,is3) = igehad(ip11,is3) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip11,is3)) .lt.
+ + xloss*min(abs(xpi(ip11)),xpi(is3))) then
+ ier0 = ierin
+ call ffwarn(109,ier0,
+ + piDpj(ip11,is3),min(abs(xpi(ip11)),xpi(is3)))
+ ier = max(ier,ier0)
+ endif
+* #] all in one vertex:
+* #[ all in one 3point:
+*
+* pi.s(i+2)
+*
+ if ( min(abs(dpipj(is2,is1)),abs(dpipj(ip11,ip7))) .le.
+ + min(abs(dpipj(ip11,is1)),abs(dpipj(is2,ip7))) ) then
+ piDpj(ip6,is3) = (dpipj(ip11,ip7) + dpipj(is2,is1))/2
+ else
+ piDpj(ip6,is3) = (dpipj(ip11,is1) + dpipj(is2,ip7))/2
+ endif
+ piDpj(is3,ip6) = piDpj(ip6,is3)
+ if ( locwrt ) then
+ igehad(is3,ip6) = igehad(is3,ip6) + 1
+ igehad(ip6,is3) = igehad(ip6,is3) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip6,is3)) .lt.
+ + xloss*min(abs(dpipj(ip11,ip7)),abs(dpipj(ip11,is1))) )
+ + then
+ ier0 = ierin
+ call ffwarn(110,ier0,piDpj(ip6,is3),
+ + min(abs(dpipj(ip11,ip7)),abs(dpipj(ip11,is1))))
+ ier = max(ier,ier0)
+ endif
+*
+* p(i+1).s(i)
+*
+ if ( min(abs(dpipj(is3,is2)),abs(dpipj(ip6,ip11))) .le.
+ + min(abs(dpipj(ip6,is2)),abs(dpipj(is3,ip11))) ) then
+ piDpj(ip7,is1) = (dpipj(ip6,ip11) + dpipj(is3,is2))/2
+ else
+ piDpj(ip7,is1) = (dpipj(ip6,is2) + dpipj(is3,ip11))/2
+ endif
+ piDpj(is1,ip7) = piDpj(ip7,is1)
+ if ( locwrt ) then
+ igehad(is1,ip7) = igehad(is1,ip7) + 1
+ igehad(ip7,is1) = igehad(ip7,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip7,is1)) .lt.
+ + xloss*min(abs(dpipj(ip6,ip11)),abs(dpipj(ip6,is2))) )
+ + then
+ ier0 = ierin
+ call ffwarn(111,ier0,piDpj(ip7,is1),
+ + min(abs(dpipj(ip6,ip11)),abs(dpipj(ip6,is2))))
+ ier = max(ier,ier0)
+ endif
+*
+* p(i+2).s(i+1)
+*
+ if ( min(abs(dpipj(is1,is3)),abs(dpipj(ip7,ip6))) .le.
+ + min(abs(dpipj(ip7,is3)),abs(dpipj(is1,ip6))) ) then
+ piDpj(ip11,is2) = -(dpipj(ip7,ip6) + dpipj(is1,is3))/2
+ else
+ piDpj(ip11,is2) = -(dpipj(ip7,is3) + dpipj(is1,ip6))/2
+ endif
+ piDpj(is2,ip11) = piDpj(ip11,is2)
+ if ( locwrt ) then
+ igehad(is2,ip11) = igehad(is2,ip11) + 1
+ igehad(ip11,is2) = igehad(ip11,is2) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip11,is2)) .lt.
+ + xloss*min(abs(dpipj(ip7,ip6)),abs(dpipj(ip7,is3))) )
+ + then
+ ier0 = ierin
+ call ffwarn(112,ier0,piDpj(ip11,is2),
+ + min(abs(dpipj(ip7,ip6)),abs(dpipj(ip7,is3))))
+ ier = max(ier,ier0)
+ endif
+* #] all in one 3point:
+* #[ all external 3point:
+*
+* pi.p(i+1)
+*
+ if ( abs(xpi(ip7)) .le. abs(xpi(ip6)) ) then
+ piDpj(ip6,ip7) = (dpipj(ip11,ip6) - xpi(ip7))/2
+ else
+ piDpj(ip6,ip7) = (dpipj(ip11,ip7) - xpi(ip6))/2
+ endif
+ piDpj(ip7,ip6) = piDpj(ip6,ip7)
+ if ( locwrt ) then
+ igehad(ip7,ip6) = igehad(ip7,ip6) + 1
+ igehad(ip6,ip7) = igehad(ip6,ip7) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip6,ip7)) .lt.
+ + xloss*min(abs(xpi(ip6)),abs(xpi(ip7))) ) then
+ ier0 = ierin
+ call ffwarn(113,ier0,piDpj(ip6,ip7),
+ + min(abs(xpi(ip6)),abs(xpi(ip7))))
+ ier = max(ier,ier0)
+ endif
+*
+* p(i+1).p(i+2)
+*
+ if ( abs(xpi(ip11)) .le. abs(xpi(ip7)) ) then
+ piDpj(ip7,ip11) = -(dpipj(ip6,ip7) - xpi(ip11))/2
+ else
+ piDpj(ip7,ip11) = -(dpipj(ip6,ip11) - xpi(ip7))/2
+ endif
+ piDpj(ip11,ip7) = piDpj(ip7,ip11)
+ if ( locwrt ) then
+ igehad(ip11,ip7) = igehad(ip11,ip7) + 1
+ igehad(ip7,ip11) = igehad(ip7,ip11) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip7,ip11)) .lt.
+ + xloss*min(abs(xpi(ip7)),abs(xpi(ip11))) ) then
+ ier0 = ierin
+ call ffwarn(114,ier0,piDpj(ip7,ip11),
+ + min(abs(xpi(ip7)),abs(xpi(ip11))))
+ ier = max(ier,ier0)
+ endif
+*
+* p(i+2).p(i)
+*
+ if ( abs(xpi(ip6)) .le. abs(xpi(ip11)) ) then
+ piDpj(ip11,ip6) = -(dpipj(ip7,ip11) - xpi(ip6))/2
+ else
+ piDpj(ip11,ip6) = -(dpipj(ip7,ip6) - xpi(ip11))/2
+ endif
+ piDpj(ip6,ip11) = piDpj(ip11,ip6)
+ if ( locwrt ) then
+ igehad(ip6,ip11) = igehad(ip6,ip11) + 1
+ igehad(ip11,ip6) = igehad(ip11,ip6) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip11,ip6)) .lt.
+ + xloss*min(abs(xpi(ip11)),abs(xpi(ip6))) ) then
+ ier0 = ierin
+ call ffwarn(115,ier0,piDpj(ip11,ip6),
+ + min(abs(xpi(ip11)),abs(xpi(ip6))))
+ ier = max(ier,ier0)
+ endif
+* #] all external 3point:
+* #[ the other 3point:
+ is4 = is3 + 1
+ if ( is4 .eq. 6 ) is4 = 1
+ ip8 = is3 + 5
+ ip14 = is4 + 10
+*
+* we now work with the threepoint configuration
+*
+* | p14
+* |
+* / \
+* s1/ \s4
+* ___/_____\___
+* p11 s3 p8
+*
+* s1.p8
+*
+ do 11 itel = 1,3
+ if ( itel .eq. 1 ) then
+ i1 = is1
+ i2 = is3
+ i3 = is4
+ i4 = ip11
+ i5 = ip8
+ i6 = ip14
+ elseif ( itel .eq. 2 ) then
+ i1 = is3
+ i2 = is4
+ i3 = is1
+ i4 = ip8
+ i5 = ip14
+ i6 = ip11
+ else
+ i1 = is4
+ i2 = is1
+ i3 = is3
+ i4 = ip14
+ i5 = ip11
+ i6 = ip8
+ endif
+*
+* in one go: the opposite sides
+*
+ if ( min(abs(dpipj(i3,i2)),abs(dpipj(i4,i6))) .le.
+ + min(abs(dpipj(i4,i2)),abs(dpipj(i3,i6))) ) then
+ piDpj(i5,i1) = (dpipj(i3,i2) + dpipj(i4,i6))/2
+ else
+ piDpj(i5,i1) = (dpipj(i4,i2) + dpipj(i3,i6))/2
+ endif
+ piDpj(i1,i5) = piDpj(i5,i1)
+ if ( locwrt ) then
+ igehad(i1,i5) = igehad(i1,i5) + 1
+ igehad(i5,i1) = igehad(i5,i1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(i5,i1)) .lt. xloss*
+ + min(abs(dpipj(i4,i6)),abs(dpipj(i4,i2))) ) then
+ ier0 = ierin
+ call ffwarn(111,ier0,piDpj(i5,i1),
+ + min(abs(dpipj(i4,i6)),abs(dpipj(i4,i2))))
+ ier = max(ier,ier0)
+ endif
+*
+* and the remaining external ones
+*
+ if ( abs(xpi(i5)) .le. abs(xpi(i4)) ) then
+ piDpj(i4,i5) = (dpipj(i6,i4) - xpi(i5))/2
+ else
+ piDpj(i4,i5) = (dpipj(i6,i5) - xpi(i4))/2
+ endif
+ piDpj(i5,i4) = piDpj(i4,i5)
+ if ( locwrt ) then
+ igehad(i5,i4) = igehad(i5,i4) + 1
+ igehad(i4,i5) = igehad(i4,i5) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(i4,i5)) .lt.
+ + xloss*min(abs(xpi(i4)),abs(xpi(i5))) ) then
+ ier0 = ierin
+ call ffwarn(113,ier0,piDpj(i4,i5),
+ + min(abs(xpi(i4)),abs(xpi(i5))))
+ ier = max(ier,ier0)
+ endif
+ 11 continue
+* #] the other 3point:
+* #[ 4point indices:
+ ip12 = ip7+5
+*
+* we now have the fourpoint configuration
+*
+* \p14 /p8
+* \____/
+* | s4 |
+* s1| |s3
+* |____|
+* p6/ s2 \p7
+* / \
+*
+*
+*
+ do 12 itel = 1,2
+ if ( itel .eq. 1 ) then
+ i1 = ip6
+ i2 = ip8
+ i3 = ip7
+ i4 = ip14
+ else
+ i1 = ip7
+ i2 = ip14
+ i3 = ip6
+ i4 = ip8
+ endif
+ if ( min(abs(dpipj(i3,ip11)),abs(dpipj(i4,ip12))) .le.
+ + min(abs(dpipj(i4,ip11)),abs(dpipj(i3,ip12))) ) then
+ piDpj(i1,i2) = (dpipj(i3,ip11) + dpipj(i4,ip12))/2
+ else
+ piDpj(i1,i2) = (dpipj(i4,ip11) + dpipj(i3,ip12))/2
+ endif
+ piDpj(i2,i1) = piDpj(i1,i2)
+ if ( locwrt ) then
+ igehad(i1,i2) = igehad(i1,i2) + 1
+ igehad(i2,i1) = igehad(i2,i1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(i2,i1)) .lt. xloss*
+ + min(abs(dpipj(i4,ip12)),abs(dpipj(i4,ip11))))
+ + then
+ ier0 = ierin
+ call ffwarn(111,ier0,piDpj(i2,i1),
+ + min(abs(dpipj(i4,ip12)),abs(dpipj(i4,ip11))))
+ ier = max(ier,ier0)
+ endif
+ 12 continue
+*
+* we are only left with p11.p12 etc.
+*
+ if ( min(abs(dpipj(ip14,ip8)),abs(dpipj(ip7,ip6))) .le.
+ + min(abs(dpipj(ip7,ip8)),abs(dpipj(ip14,ip6))) ) then
+ piDpj(ip11,ip12) = (dpipj(ip7,ip6) + dpipj(ip14,ip8))/2
+ else
+ piDpj(ip11,ip12) = (dpipj(ip7,ip8) + dpipj(ip14,ip6))/2
+ endif
+ piDpj(ip12,ip11) = piDpj(ip11,ip12)
+ if ( locwrt ) then
+ igehad(ip12,ip11) = igehad(ip12,ip11) + 1
+ igehad(ip11,ip12) = igehad(ip11,ip12) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip11,ip12)) .lt. xloss*
+ + min(abs(dpipj(ip7,ip6)),abs(dpipj(ip7,ip8))) ) then
+ ier0 = ierin
+ call ffwarn(112,ier0,piDpj(ip11,ip12),
+ + min(abs(dpipj(ip7,ip6)),abs(dpipj(ip7,ip8))))
+ ier = max(ier,ier0)
+ endif
+ 10 continue
+* #] 4point indices:
+* #[ check:
+ if ( locwrt ) then
+ print *,'We hebben gehad:'
+ print '(15i2)',igehad
+ endif
+ if ( ltest ) then
+ do 40 i = 1,15
+*
+* sum over all (incoming) momenta => 0
+*
+ xheck = 0
+ xmax = 0
+ do 20 j=6,10
+ xheck = xheck + piDpj(j,i)
+ xmax = max(abs(piDpj(j,i)),xmax)
+ 20 continue
+ if ( xloss*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffdot5: error: dotproducts with p(',i,
+ + ') wrong: (som(.p(i))<>0) ',
+ + (piDpj(i,j),j=6,10),xheck
+*
+* sum over all (incoming) momentum pairs => 0
+*
+ xheck = 0
+ xmax = 0
+ do 25 j=11,15
+ xheck = xheck + piDpj(j,i)
+ xmax = max(abs(piDpj(j,i)),xmax)
+ 25 continue
+ if ( xloss*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffdot5: error: dotproducts with p(',i,
+ + ') wrong: (som(.(p(i)+p(i+1)))<>0) ',
+ + (piDpj(i,j),j=11,15),xheck
+*
+* check for symmetry
+*
+ do 30 j=1,15
+ if ( piDpj(i,j) .ne. piDpj(j,i) ) print *,
+ + 'ffdot5: error: piDpj(',i,j,') <> piDpj',j,i,')'
+ 30 continue
+*
+* check the diagonal
+*
+ if ( piDpj(i,i) .ne. xpi(i) ) print *,'ffdot5: error: ',
+ + 'piDpj(',i,i,') <> xpi(',i,')'
+ do 35 j=6,10
+ do 34 i5=1,2
+ if ( i5.eq.1 ) then
+*
+* see if indeed pi+p(i+1) = p(i+5)
+*
+ i2 = j+5
+ i1 = j+1
+ if ( i1 .eq. 11 ) i1 = 6
+ else
+*
+* check that si+p(i+5) = s(i+1)
+*
+ i2 = i1-5
+ i1 = j-5
+ endif
+ xheck = piDpj(j,i)+piDpj(i1,i)-piDpj(i2,i)
+ xmax = max(abs(piDpj(j,i)),abs(piDpj(i2,i)),
+ + abs(piDpj(i1,i)))
+ if ( xloss*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffdot5: error: piDpj(',j,i,')+piDpj(',
+ + i2,i,')-piDpj(',i1,i,') <> 0',xmax,xheck
+ 34 continue
+ 35 continue
+ 40 continue
+ endif
+* #] check:
+*###] ffdot5:
+ end
+*###[ ffpi54:
+ subroutine ffpi54(xpi4,dpipj4,piDpj4,xpi,dpipj,piDpj,inum,ier)
+***#[*comment:***********************************************************
+* *
+* Gets the dotproducts pertaining to the fourpoint function with *
+* s_i missing out of the five point function dotproduct array. *
+* *
+* Input: xpi real(20) si.si,pi.pi *
+* dpipj real(15,20) xpi(i) - xpi(j) *
+* piDpj real(15,15) pi(i).pi(j) *
+* inum integer 1--5 *
+* *
+* Output: xpi4 real(13) *
+* dpipj4 real(10,13) *
+* piDpj4 real(10,10) *
+* ier integer *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer inum,ier
+ DOUBLE PRECISION xpi(20),dpipj(15,20),piDpj(15,15),xpi4(13),
+ + dpipj4(10,13),piDpj4(10,10),qDq(10,10)
+*
+* local variables
+*
+ integer i,j,iplace(11,5),isigns(11,5),ier0
+ save iplace,isigns
+ DOUBLE PRECISION xmax
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data iplace /
+ + 2,3,4,5, 07,08,09,15, 12,13, 17,
+ + 1,3,4,5, 11,08,09,10, 14,13, 18,
+ + 1,2,4,5, 06,12,09,10, 14,15, 19,
+ + 1,2,3,5, 06,07,13,10, 11,15, 20,
+ + 1,2,3,4, 06,07,08,14, 11,12, 16/
+*
+ data isigns /
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +1,
+ + +1,+1,+1,+1, +1,+1,+1,+1, +1,+1, +1,
+ + +1,+1,+1,+1, +1,+1,+1,+1, +1,-1, +1,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,-1, +1,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +1/
+* #] declarations:
+* #[ distribute:
+*
+* copy p5-p11
+*
+ do 20 i=1,11
+ xpi4(i) = xpi(iplace(i,inum))
+ do 10 j=1,10
+ dpipj4(j,i) = dpipj(iplace(j,inum),iplace(i,inum))
+ 10 continue
+ 20 continue
+*
+* these cannot be simply copied I think
+*
+ xpi4(12) = -xpi4(5)+xpi4(6)-xpi4(7)+xpi4(8)+xpi4(9)+xpi4(10)
+ if ( lwarn ) then
+ xmax = max(abs(xpi4(5)),abs(xpi4(6)),abs(xpi4(7)),
+ + abs(xpi4(8)),abs(xpi4(9)),abs(xpi4(10)))
+ if ( abs(xpi4(12)) .lt. xloss*xmax )
+ + call ffwarn(154,ier,xpi4(12),xmax)
+ endif
+ xpi4(13) = xpi4(5)-xpi4(6)+xpi4(7)-xpi4(8)+xpi4(9)+xpi4(10)
+ if ( lwarn ) then
+ xmax = max(abs(xpi4(5)),abs(xpi4(6)),abs(xpi4(7)),
+ + abs(xpi4(8)),abs(xpi4(9)),abs(xpi4(10)))
+ if ( abs(xpi4(13)) .lt. xloss*xmax )
+ + call ffwarn(155,ier,xpi4(13),xmax)
+ endif
+*
+* and the differences
+*
+ do 40 i=12,13
+ do 30 j=1,10
+ dpipj4(j,i) = xpi4(j) - xpi4(i)
+ 30 continue
+ 40 continue
+*
+* copy the dotproducts (watch the signs of p9,p10!)
+*
+ do 60 i=1,10
+ do 50 j=1,10
+ piDpj4(j,i) = isigns(j,inum)*isigns(i,inum)*
+ + piDpj(iplace(j,inum),iplace(i,inum))
+ 50 continue
+ 60 continue
+* #] distribute:
+* #[ check:
+ if ( lwrite ) then
+ print *,'ffpi54: xpi4 = ',xpi4
+ endif
+ if ( ltest ) then
+ ier0 = 0
+ call ffxhck(xpi4,dpipj4,10,ier0)
+ call ffxuvw(xpi4,dpipj4,ier0)
+ if ( ier0 .ne. 0 ) print *,'ffpi54: error detected'
+*
+* check piDpj
+*
+ ier0 = ier
+ call ffdot4(qDq,xpi4,dpipj4,10,ier0)
+ do 190 i=1,10
+ do 180 j=1,10
+ if ( xloss*10d0**(-mod(ier0,50))*abs(qDq(j,i)-
+ + piDpj4(j,i)) .gt. precx*abs(qDq(j,i)) ) print *,
+ + 'ffpi54: error: piDpj4(',j,i,') not correct: ',
+ + piDpj4(j,i),qDq(j,i),piDpj4(j,i)-qDq(j,i),ier0
+ 180 continue
+ 190 continue
+ endif
+* #] check:
+*###] ffpi54:
+ end
+*###[ ffxe0r:
+ subroutine ffxe0r(ce0,cd0i,xpi,ier)
+***#[*comment:***********************************************************
+* *
+* Tries all 12 permutations of the 5pointfunction *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ier,nrot
+ parameter(nrot=12)
+ DOUBLE PRECISION xpi(20),xqi(20)
+ DOUBLE COMPLEX ce0,cd0i(5),ce0p,cd0ip(5),cd0ipp(5)
+ integer inew(20,nrot),irota,ier1,i,j,k,icon,ialsav,init
+ logical lcon
+ parameter (icon=3)
+ save inew,init,lcon
+ include 'ff.h'
+ data inew
+ + /1,2,3,4,5, 6,7,8,9,10,11,12,13,14,15, 16,17,18,19,20,
+ + 2,1,3,4,5, 6,11,8,9,15,7,14,13,12,10, 16,18,17,19,-20,
+ + 1,3,2,4,5, 11,7,12,9,10,6,8,15,14,13, -16,17,19,18,20,
+ + 1,2,4,3,5, 6,12,8,13,10,14,7,9,11,15, 16,-17,18,20,19,
+ + 1,2,3,5,4, 6,7,13,9,14,11,15,8,10,12, 20,17,-18,19,16,
+ + 5,2,3,4,1, 15,7,8,14,10,13,12,11,9,6, 17,16,18,-19,20,
+ + 2,1,4,3,5, 6,14,8,13,15,12,11,9,7,10, 16,-18,17,20,-19,
+ + 1,3,2,5,4, 11,7,15,9,14,6,13,12,10,8, -20,17,-19,18,16,
+ + 5,2,4,3,1, 15,12,8,11,10,9,7,14,13,6, 17,-16,18,-20,19,
+ + 2,1,3,5,4, 6,11,13,9,12,7,10,8,15,14, 20,18,-17,19,-16,
+ + 5,3,2,4,1, 13,7,12,14,10,15,8,6,9,11, -17,16,19,-18,20,
+ + 1,3,5,2,4, 11,13,15,12,14,10,7,9,6,8,-20,-17,-19,-16,-18/
+ data init /0/
+* #] declarations:
+* #[ open console for some activity on screen:
+ if ( init .eq. 0 ) then
+ init = 1
+ if ( lwrite ) then
+ open(icon,file='CON:',status='old',err=11)
+ lcon = .TRUE.
+ goto 13
+ endif
+ 11 continue
+ lcon = .FALSE.
+ 13 continue
+ endif
+* #] open console for some activity on screen:
+* #[ calculations:
+ ce0 = 0
+ ier = 999
+ ialsav = isgnal
+ do 30 j = -1,1,2
+ do 20 irota=1,nrot
+ do 10 i=1,20
+ if ( inew(i,irota) .lt. 0 ) then
+ xqi(-inew(i,irota)) = 0
+ else
+ xqi(inew(i,irota)) = xpi(i)
+ endif
+ 10 continue
+ print '(a,i2,a,i2)','---#[ rotation ',irota,': isgnal ',
+ + isgnal
+ if (lcon) write(icon,'(a,i2,a,i2)')'rotation ',irota,',
+ + isgnal ',isgnal
+ ier1 = 0
+ ner = 0
+ id = id + 1
+ isgnal = ialsav
+ call ffxe0(ce0p,cd0ip,xqi,ier1)
+ ier1 = ier1 + ner
+ print '(a,i1,a,i2)','---#] rotation ',irota,': isgnal ',
+ + isgnal
+ print '(a,2g28.16,i3)','e0 = ',ce0p,ier1
+ do 15 k=1,5
+ cd0ipp(k) = cd0ip(inew(k,irota))
+ print '(a,2g28.16,i3)','d0 = ',cd0ipp(k),k
+ 15 continue
+ if (lcon) write(icon,'(a,2g28.16,i3)')'e0 = ',ce0p,ier1
+ if ( ier1 .lt. ier ) then
+ ce0 = ce0p
+ do 19 k=1,5
+ cd0i(k) = cd0ipp(k)
+ 19 continue
+ ier = ier1
+ endif
+ 20 continue
+ ialsav = -ialsav
+ 30 continue
+* #] calculations:
+*###] ffxe0r:
+ end
+
diff --git a/ff-2.0/ffxe1.f b/ff-2.0/ffxe1.f
new file mode 100644
index 0000000..1fc9c14
--- /dev/null
+++ b/ff-2.0/ffxe1.f
@@ -0,0 +1,452 @@
+* $Id: ffxe1.f,v 1.6 1997/04/07 19:10:57 gj Exp $
+*###[ ffxe1:
+ subroutine ffxe1(ce1i,ce0,del3ij,del4i,cd0i,xpi,piDpj,del4,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the *
+* E1(mu) = E11*p1(mu) + E12*p2(mu) + E13*p3(mu) + E14*p4(mu) *
+* numerically *
+* *
+* Input: ce0 complex scalar fivepoint function *
+* cd0i(5) complex scalar fourpoint functions *
+* without s1,s2,s3,s4,s5 *
+* xpi(20) real masses (1-5), momenta^2 (6-20) *
+* piDpj(15,15) real dotproducts as in E0 *
+* del4 real delta_(p1p2p3p4)^(p1p2p3p4) *
+* ier integer digits lost so far *
+* Output: ce1i(4) complex E11,E12,E13,E14 *
+* del3ij(5,5) real delta(p(i+1),p(i+2),p(i+3); *
+* p(j+1),p(j+2),p(j+3)) *
+* del4i(4) real delta(s1,(p1,p2,p3,p4)-pi; *
+* p1,p2,p3,p4) *
+* ier integer number of dgits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION del3ij(5,5),del4i(4),xpi(20),piDpj(15,15),del4
+ DOUBLE COMPLEX ce1i(4),ce0,cd0i(5)
+*
+* local variables
+*
+ integer i,j,ii(6,5),ier0,ier1,jj(10),init
+ DOUBLE PRECISION xmax,absc,xheck,del4p,xlosn
+ DOUBLE COMPLEX cs(11,4),cc,cnul
+ save ii,init
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* data
+*
+ data init /0/
+*
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ do 1 i=1,10
+ jj(i) = i+5
+ 1 continue
+ ier0 = ier
+ call ffdl4p(del4p,xpi,piDpj,15,jj,ier0)
+ xheck = del4 - del4p
+ if ( xloss*abs(xheck) .gt. precx*abs(del4) ) print *,
+ + 'ffxe1: error: del4 wrong ',del4,del4p,xheck
+ endif
+* #] check input:
+* #[ work:
+*
+* See Form job e1.frm
+* #[ e1.log:
+* E1 =
+* + D(1)*p1(mu)*Del4^-1 * ( - 1/2*delta(p2,p3,p4,p2,p3,p4) )
+* + D(1)*p2(mu)*Del4^-1 * ( 1/2*delta(p2,p3,p4,p1,p3,p4) )
+* + D(1)*p3(mu)*Del4^-1 * ( - 1/2*delta(p2,p3,p4,p1,p2,p4) )
+* + D(1)*p4(mu)*Del4^-1 * ( 1/2*delta(p2,p3,p4,p1,p2,p3) )
+* + D(2)*p1(mu)*Del4^-1 * ( 1/2*delta(p1,p3,p4,p2,p3,p4) + 1/2*delta(p2,p3,p4,p2,p3,p4) )
+* + D(2)*p2(mu)*Del4^-1 * ( - 1/2*delta(p1,p3,p4,p1,p3,p4) - 1/2*delta(p2,p3,p4,p1,p3,p4) )
+* + D(2)*p3(mu)*Del4^-1 * ( 1/2*delta(p1,p3,p4,p1,p2,p4) + 1/2*delta(p2,p3,p4,p1,p2,p4) )
+* + D(2)*p4(mu)*Del4^-1 * ( - 1/2*delta(p1,p3,p4,p1,p2,p3) - 1/2*delta(p2,p3,p4,p1,p2,p3) )
+* + D(3)*p1(mu)*Del4^-1 * ( - 1/2*delta(p1,p2,p4,p2,p3,p4) - 1/2*delta(p1,p3,p4,p2,p3,p4) )
+* + D(3)*p2(mu)*Del4^-1 * ( 1/2*delta(p1,p2,p4,p1,p3,p4) + 1/2*delta(p1,p3,p4,p1,p3,p4) )
+* + D(3)*p3(mu)*Del4^-1 * ( - 1/2*delta(p1,p2,p4,p1,p2,p4) - 1/2*delta(p1,p3,p4,p1,p2,p4) )
+* + D(3)*p4(mu)*Del4^-1 * ( 1/2*delta(p1,p2,p4,p1,p2,p3) + 1/2*delta(p1,p3,p4,p1,p2,p3) )
+* + D(4)*p1(mu)*Del4^-1 * ( 1/2*delta(p1,p2,p3,p2,p3,p4) + 1/2*delta(p1,p2,p4,p2,p3,p4) )
+* + D(4)*p2(mu)*Del4^-1 * ( - 1/2*delta(p1,p2,p3,p1,p3,p4) - 1/2*delta(p1,p2,p4,p1,p3,p4) )
+* + D(4)*p3(mu)*Del4^-1 * ( 1/2*delta(p1,p2,p3,p1,p2,p4) + 1/2*delta(p1,p2,p4,p1,p2,p4) )
+* + D(4)*p4(mu)*Del4^-1 * ( - 1/2*delta(p1,p2,p3,p1,p2,p3) - 1/2*delta(p1,p2,p4,p1,p2,p3) )
+* + D(5)*p1(mu)*Del4^-1 * ( - 1/2*delta(p1,p2,p3,p2,p3,p4) )
+* + D(5)*p2(mu)*Del4^-1 * ( 1/2*delta(p1,p2,p3,p1,p3,p4) )
+* + D(5)*p3(mu)*Del4^-1 * ( - 1/2*delta(p1,p2,p3,p1,p2,p4) )
+* + D(5)*p4(mu)*Del4^-1 * ( 1/2*delta(p1,p2,p3,p1,p2,p3) )
+* + E*p1(mu)*Del4^-1 * ( - delta(p1,p2,p3,p2,p3,p4)*p4.s1 + delta(p1,p2,
+* p4,p2,p3,p4)*p3.s1 - delta(p1,p3,p4,p2,p3,p4)*p2.s1 + delta(p2,p3,p4,
+* p2,p3,p4)*p1.s1 )
+* + E*p2(mu)*Del4^-1 * ( delta(p1,p2,p3,p1,p3,p4)*p4.s1 - delta(p1,p2,p4,
+* p1,p3,p4)*p3.s1 + delta(p1,p3,p4,p1,p3,p4)*p2.s1 - delta(p2,p3,p4,p1,
+* p3,p4)*p1.s1 )
+* + E*p3(mu)*Del4^-1 * ( - delta(p1,p2,p3,p1,p2,p4)*p4.s1 + delta(p1,p2,
+* p4,p1,p2,p4)*p3.s1 - delta(p1,p3,p4,p1,p2,p4)*p2.s1 + delta(p2,p3,p4,
+* p1,p2,p4)*p1.s1 )
+* + E*p4(mu)*Del4^-1 * ( delta(p1,p2,p3,p1,p2,p3)*p4.s1 - delta(p1,p2,p4,
+* p1,p2,p3)*p3.s1 + delta(p1,p3,p4,p1,p2,p3)*p2.s1 - delta(p2,p3,p4,p1,
+* p2,p3)*p1.s1 );
+* #] e1.log:
+* All the contributions are quite similar. Note that we split
+* the non-four point determinants in 2 4point determinants, this
+* is not quick but easy.
+*
+* first the indices
+*
+ if ( init.eq.0 ) then
+ init = 1
+ do 10 i=1,5
+ ii(1,i) = i+6
+ if ( ii(1,i) .gt. 10 ) ii(1,i) = 6
+ ii(2,i) = ii(1,i) + 1
+ if ( ii(2,i) .gt. 10 ) ii(2,i) = 6
+ ii(3,i) = ii(2,i) + 1
+ if ( ii(3,i) .gt. 10 ) ii(3,i) = 6
+ ii(4,i) = ii(3,i) + 6
+ if ( ii(4,i) .gt. 15 ) ii(4,i) = 11
+ ii(5,i) = ii(1,i) + 5
+ ii(6,i) = ii(2,i) + 5
+ 10 continue
+ endif
+*
+* the determinants
+*
+ ier1 = ier
+ do 30 i=1,5
+ do 20 j=i,5
+* we do not need (3,3), but compute it anyway for export
+ ier0 = ier
+ idsub = idsub + 1
+ call ffdl3p(del3ij(i,j),piDpj,15,ii(1,i),ii(1,j),ier0)
+ del3ij(j,i) = del3ij(i,j)
+ ier1 = max(ier1,ier0)
+ 20 continue
+ 30 continue
+ do 40 i=1,4
+ ier0 = ier
+ idsub = idsub + 1
+ call ffdl4s(del4i(i),xpi,piDpj,15,1,i+5,10,ier0)
+ ier1 = max(ier1,ier0)
+ 40 continue
+ ier = ier1
+*
+* the terms with D0
+*
+ do 100 i=1,5
+ cs(i+5,1) = 0
+ cs(i ,1) = -cd0i(i)*DBLE(del3ij(i,1))
+ cs(i+5,2) = cs(i,1)
+ cs(i ,2) = -cd0i(i)*DBLE(del3ij(i,2))
+ cs(i+5,3) = +cd0i(i)*DBLE(del3ij(i,5))
+ cs(i ,3) = +cd0i(i)*DBLE(del3ij(i,4))
+ cs(i+5,4) = 0
+ cs(i ,4) = cs(i+5,3)
+ 100 continue
+*
+* the terms with E0
+*
+ do 110 i=1,4
+ cs(11,i) = 2*DBLE(del4i(i))*ce0
+ if ( mod(i,2) .eq. 0 ) cs(11,i) = -cs(11,i)
+ 110 continue
+*
+* sum
+*
+ ier1 = ier
+ do 130 i=1,4
+ ce1i(i) = 0
+ xmax = 0
+ do 120 j=1,11
+ ce1i(i) = ce1i(i) + cs(j,i)
+ xmax = max(xmax,absc(cs(j,i)))
+ 120 continue
+ if ( absc(ce1i(i)) .lt. xloss*xmax ) then
+ ier0 = ier
+ call ffwarn(171,ier0,absc(ce1i(i)),xmax)
+ ier1 = max(ier1,ier0)
+ endif
+ if ( lwrite ) then
+ do 125 j=1,11
+ print *,cs(j,i)
+ 125 continue
+ print *,'---------------- +'
+ print *,ce1i(i)
+ endif
+ ce1i(i) = ce1i(i)/DBLE(2*del4)
+ 130 continue
+ ier = ier1
+* #] work:
+* #[ test output:
+ if ( ltest ) then
+* test a few identities: 2pi.Q = N(i+1)-Ni+2s1.pi
+ xlosn = xloss*DBLE(10)**(-2-mod(ier,50))
+ do i=1,4
+ do j=1,4
+ cs(j,i) = 2*piDpj(j+5,i+5)*ce1i(j)
+ enddo
+ cs(5,i) = -cd0i(i+1)
+ cs(6,i) = +cd0i(i)
+ cs(7,i) = -2*piDpj(1,i+5)*ce0
+ cnul = 0
+ xmax = 0
+ do j=1,7
+ cnul = cnul + cs(j,i)
+ xmax = max(xmax,absc(cnul))
+ enddo
+ if ( lwrite ) print *,'ffxe1: checking E1.p(',i,'): ',
+ + cnul,xmax,ier
+ if ( xlosn*absc(cnul).gt.precc*xmax ) then
+ print *,'ffxe1: error: E1 fails consistency check',i
+ print '(i3,2g20.12)',(j,cs(j,i),j=1,7)
+ print *,'---- +'
+ print '(a3,2g20.12,i4)','som',cnul,ier
+ endif
+ enddo
+ endif
+* #] test output:
+*###] ffxe1:
+ end
+*###[ ffdl4s:
+ subroutine ffdl4s(del4,xpi,piDpj,ns,is,miss1,miss2,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the 4x4 determinant *
+* *
+* p1 p2 p3 p4 *
+* \delta *
+* si pi pj pk *
+* *
+* with pi pj pk given by p1,p2,p3,p4,p5 with miss1,miss2 missing. *
+* *
+* Input: xpi(ns) real diagonal dotproducts *
+* piDpj(ns,ns) real dotproducts *
+* ns integer *
+* is integer si=xpi(is) *
+* miss1,miss2 integer see above *
+* Output: del4 real *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ns,is,miss1,miss2,ier
+ DOUBLE PRECISION del4,piDpj(ns,ns),xpi(ns)
+*
+* local variables
+*
+ integer i,j,k,ii(4),jj(4),ipermp(4,60),mem
+ parameter(mem=10)
+ integer memarr(mem,4),inow,jnow,imem,jmem,memind
+ DOUBLE PRECISION s(24),som,xmax,smax
+ save ipermp,memarr,inow,jnow,memind
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data memind /0/
+ data memarr /mem*0,mem*0,mem*1,mem*1/
+ data inow,jnow /1,1/
+*
+* (the permutations with 2 from each (1-5) and (6-10) are
+* still lacking)
+*
+ data ((ipermp(j,i),j=1,4),i=1,35)
+ + /1,2,3,4, 2,3,4,5, 3,4,5,1, 4,5,1,2, 5,1,2,3,
+ + 6,2,3,4, 4,5,6,2, 5,6,2,3,
+ + 1,6,3,4, 4,5,1,6, 5,1,6,3,
+ + 1,7,3,4, 7,3,4,5, 5,1,7,3,
+ + 1,2,7,4, 2,7,4,5, 5,1,2,7,
+ + 1,2,8,4, 2,8,4,5, 8,4,5,1,
+ + 1,2,3,8, 2,3,8,5, 3,8,5,1,
+ + 2,3,9,5, 3,9,5,1, 9,5,1,2,
+ + 2,3,4,9, 3,4,9,1, 4,9,1,2,
+ + 3,4,10,1, 4,10,1,2, 10,1,2,3,
+ + 3,4,5,10, 4,5,10,2, 5,10,2,3/
+
+ data ((ipermp(j,i),j=1,4),i=36,60)
+ + / 8,9,1,6, 1,6,7,8,
+ + 8,9,10,1, 10,1,7,8,
+ + 2,7,8,9, 9,10,2,7,
+ + 6,2,8,9, 9,10,6,2,
+ + 3,8,9,10, 10,6,3,8,
+ + 7,3,9,10, 10,6,7,3,
+ + 6,7,4,9, 4,9,10,6,
+ + 6,7,8,4, 8,4,10,6,
+ + 7,8,5,10, 5,10,6,7,
+ + 7,8,9,5, 9,5,6,7,
+ + 6,7,8,9, 7,8,9,10, 8,9,10,6, 9,10,6,7, 10,6,7,8/
+* #] declarations:
+* #[ check input:
+ if ( lwrite ) then
+ print *,'ffdl4s: is,miss1,miss2 = ',is,miss1,miss2
+ endif
+ if ( ns.ne.15 ) then
+ print *,'ffdl4s: only for ns=15, not ',ns
+ stop
+ endif
+* #] check input:
+* #[ special case:
+*
+* the special case (miss1,miss2 adjacent, is not between them)
+* goes to ffdl4r
+*
+ i = abs(miss1-miss2)
+ if ( i.eq.1 .or. i.eq.4 ) then
+ if ( miss1+miss2 .ne. 16 ) then
+ j = min(miss1,miss2) - 4
+ else
+ j = 1
+ endif
+ if ( .not.( is .eq. j ) ) then
+ if ( lwrite ) print *,'ffdl4s: using ffdl4r'
+ call ffdl4r(del4,xpi,piDpj,ns,j,ier)
+ return
+ endif
+ endif
+* #] special case:
+* #[ out of memory:
+*
+* see if we know were to start, if not: go on as last time
+*
+ do 5 i=1,mem
+ if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
+ inow = memarr(i,3)
+ jnow = memarr(i,4)
+ if ( lwrite ) print *,'ffdel5: found in memory'
+ goto 6
+ endif
+ 5 continue
+ 6 continue
+* #] out of memory:
+* #[ big loop:
+*
+* loop over all permutations of the 1,2,3,4; leave the lower side
+* for the time being
+*
+ imem = inow
+ jmem = jnow
+ del4 = 0
+ xmax = 0
+*
+ do 110 i=1,1
+ ii(1) = is
+ j = 2
+ do 90 k=6,10
+ if ( k .ne. miss1 .and. k .ne. miss2 ) then
+ ii(j) = k
+ j = j+1
+ endif
+ 90 continue
+ if ( lwrite ) print *,' ii= ',ii
+ do 100 j=1,60
+ jj(1) = ipermp(1,jnow) + 5
+ jj(2) = ipermp(2,jnow) + 5
+ jj(3) = ipermp(3,jnow) + 5
+ jj(4) = ipermp(4,jnow) + 5
+ if ( lwrite ) print *,' jj= ',jj
+*
+ s( 1) = +piDpj(ii(1),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(4),jj(4))
+ s( 2) = +piDpj(ii(2),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(4),jj(4))
+ s( 3) = +piDpj(ii(3),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(4),jj(4))
+ s( 4) = -piDpj(ii(1),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(4),jj(4))
+ s( 5) = -piDpj(ii(3),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(4),jj(4))
+ s( 6) = -piDpj(ii(2),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(4),jj(4))
+*
+ s( 7) = -piDpj(ii(1),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(3),jj(4))
+ s( 8) = -piDpj(ii(2),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(3),jj(4))
+ s( 9) = -piDpj(ii(4),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(3),jj(4))
+ s(10) = +piDpj(ii(1),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(3),jj(4))
+ s(11) = +piDpj(ii(4),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(3),jj(4))
+ s(12) = +piDpj(ii(2),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(3),jj(4))
+*
+ s(13) = -piDpj(ii(1),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(2),jj(4))
+ s(14) = -piDpj(ii(4),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(2),jj(4))
+ s(15) = -piDpj(ii(3),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(2),jj(4))
+ s(16) = +piDpj(ii(1),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(2),jj(4))
+ s(17) = +piDpj(ii(3),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(1),jj(3))*piDpj(ii(2),jj(4))
+ s(18) = +piDpj(ii(4),jj(1))*piDpj(ii(1),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(2),jj(4))
+*
+ s(19) = -piDpj(ii(4),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(1),jj(4))
+ s(20) = -piDpj(ii(2),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(1),jj(4))
+ s(21) = -piDpj(ii(3),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(1),jj(4))
+ s(22) = +piDpj(ii(4),jj(1))*piDpj(ii(3),jj(2))*
+ + piDpj(ii(2),jj(3))*piDpj(ii(1),jj(4))
+ s(23) = +piDpj(ii(3),jj(1))*piDpj(ii(2),jj(2))*
+ + piDpj(ii(4),jj(3))*piDpj(ii(1),jj(4))
+ s(24) = +piDpj(ii(2),jj(1))*piDpj(ii(4),jj(2))*
+ + piDpj(ii(3),jj(3))*piDpj(ii(1),jj(4))
+*
+ som = 0
+ smax = 0
+ do 80 k=1,24
+ som = som + s(k)
+ smax = max(smax,abs(som))
+ 80 continue
+ if ( ( inow .eq. imem .and. jnow .eq. jmem ) .or.
+ + smax .lt. xmax ) then
+ del4 = som
+ xmax = smax
+ endif
+ if ( lwrite ) then
+ print *,'del4+',i-1,j-1,' = ',som,smax,ii,jj
+ endif
+ if ( abs(del4) .ge. xloss**2*smax ) goto 120
+ jnow = jnow + 1
+ if ( jnow .gt. 60 ) jnow = 1
+ 100 continue
+ 110 continue
+ if ( lwarn ) call ffwarn(169,ier,del4,xmax)
+ 120 continue
+* #[ into memory:
+ 800 continue
+ memind = memind + 1
+ if ( memind .gt. mem ) memind = 1
+ memarr(memind,1) = id
+ memarr(memind,2) = idsub
+ memarr(memind,3) = inow
+ memarr(memind,4) = jnow
+* #] into memory:
+* #] big loop:
+*###] ffdl4s:
+ end
+
diff --git a/ff-2.0/ffxf0.f b/ff-2.0/ffxf0.f
new file mode 100644
index 0000000..d3988c1
--- /dev/null
+++ b/ff-2.0/ffxf0.f
@@ -0,0 +1,508 @@
+* $Id: ffxf0.f,v 1.5 1996/02/07 09:28:49 gj Exp $
+*###[ ffxf0:
+ subroutine ffxf0(cf0,ce0i,cd0ij,xpi,ier)
+***#[*comment:***********************************************************
+* *
+* calculate *
+* *
+* 1 / / \-1*
+* f0= -----\dq |(q^2-m_1^2)((q+p_1)^2-m_2^2)...((q-p_6)^2-m_6^2| *
+* ipi^2/ \ / *
+* *
+* following the six five-point-function method in .... *
+* As an extra the ten fourpoint functions Dij are also returned *
+* plus the six fivepoint functions Ei. *
+* *
+* Input: xpi = m_i^2 (real) i=1,6 *
+* xpi = p_i.p_i (real) i=7,12 (note: B&D metric) *
+* xpi = (p_i+p_{i+1})^2 (r) i=13,18 *
+* xpi = (p_i+p_{i+1}+p_{i+3})^2 (r) i=19,21 *
+* *
+* Output: cf0 (complex) F0 *
+* ce0i(6) (complex) E0 with s_i missing *
+* cd0ij(6,6) (complex) D0 with s_i and s_j missing *
+* ier (integer) no of digits lost, >50 error *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE PRECISION xpi(21)
+ DOUBLE COMPLEX cf0,ce0i(6),cd0ij(6,6)
+ integer ier
+*
+* local variables
+*
+ integer i,j,ier0
+ DOUBLE PRECISION dpipj(21,21)
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ get differences:
+*
+* simulate the differences in the masses etc..
+*
+ if ( lwrite ) then
+ print *,'ffxf0: input xpi: '
+ print '(i3,e24.16)',(i,xpi(i),i=1,21)
+ endif
+*
+* no redundant input yet (may be necessary)
+*
+*
+* the differences
+*
+ ier0 = 0
+ if ( lwarn ) then
+ do 20 i=1,21
+ dpipj(i,i) = 0
+ do 10 j=1,i-1
+ dpipj(j,i) = xpi(j) - xpi(i)
+ dpipj(i,j) = -dpipj(j,i)
+ if ( abs(dpipj(j,i)) .lt. xloss*abs(xpi(i))
+ + .and. xpi(i) .ne. xpi(j) ) then
+ call ffwarn(193,ier0,dpipj(j,i),xpi(i))
+ if ( lwrite ) print *,'between xpi(',i,
+ + ') and xpi(',j,')'
+ endif
+ 10 continue
+ 20 continue
+ else
+ do 40 i=1,21
+ do 30 j=1,21
+ dpipj(j,i) = xpi(j) - xpi(i)
+ 30 continue
+ 40 continue
+ endif
+* #] get differences:
+* #[ call ffxf0a:
+ call ffxf0a(cf0,ce0i,cd0ij,xpi,dpipj,ier)
+* #] call ffxf0a:
+*###] ffxf0:
+ end
+*###[ ffxf0a:
+ subroutine ffxf0a(cf0,ce0i,cd0ij,xpi,dpipj,ier)
+***#[*comment:***********************************************************
+* *
+* calculate *
+* *
+* 1 / / \-1*
+* f0= -----\dq |(q^2-m_1^2)((q+p_1)^2-m_2^2)...((q-p_5)^2-m_5^2| *
+* ipi^2/ \ / *
+* *
+* following the five four-point-function method in .... *
+* As an extra the five fourpoint function Di are also reurned *
+* *
+* Input: xpi = m_i^2 (real) i=1,6 *
+* xpi = p_i.p_i (real) i=7,12 (note: B&D metric) *
+* xpi = (p_i+p_{i+1})^2 (r) i=13,18 *
+* xpi = (p_i+p_{i+1}+p_{i+2})^2 (r) i=19,21 *
+* dpipj(21,21) (real) = pi(i) - pi(j) *
+* *
+* Output: cf0 (complex) *
+* ce0i(6) (complex) E0 with s_i missing *
+* cd0ij(6,6) (complex) D0 with s_i,s_j missing *
+* ier (integer) <50:lost # digits 100=error *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cf0,ce0i(6),cd0ij(6,6)
+ DOUBLE PRECISION xpi(21),dpipj(21,21)
+*
+* local variables
+*
+ integer i,j,k,l,m,ii(10),ier2,ier1,ier0,irota,itype,ndiv,idum,
+ + idone,ii4(6),is
+ logical lwsav,ldel2s,lwhich
+ DOUBLE COMPLEX c,cfac,cs,cd0i(5),csum,csi(7)
+ DOUBLE PRECISION del6,xpi4(13),dpipj4(10,13),piDpj4(10,10),
+ + absc,xmax,piDpj(21,21),xqi4(13),dqiqj4(10,13),
+ + qiDqj4(10,10),del2s,xmx4(6,6),dl4rij(6,6),xpi5(20),
+ + dpipj5(15,20),piDpj5(15,15),dl4ri(5),dl5ri(6),xlosn,
+ + d5sp,dl4q(6),psum
+ save ii4
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* data
+*
+ data ii4 /5,6,7,8,9,10/
+*
+* #] declarations:
+* #[ initialisations:
+*
+ ndiv = 0
+ idsub = 0
+ cf0 = 0
+ do 2 i=1,6
+ ce0i(i) = 0
+ do 1 j=1,6
+ cd0ij(i,j) = 0
+ 1 continue
+ 2 continue
+*
+* #] initialisations:
+* #[ get dot products:
+*
+ idsub = idsub + 1
+ call ffdot6(piDpj,xpi,dpipj,ier)
+ if ( ldot ) then
+ do 6 i=1,21
+ do 5 j=1,21
+ fpij6(j,i) = piDpj(j,i)
+ 5 continue
+ 6 continue
+ continue
+ endif
+ if ( ltest ) then
+ ii(1) = 7
+ ii(2) = 8
+ ii(3) = 9
+ ii(4) = 10
+ ii(5) = 11
+ call ffdl5p(xpi,piDpj,21,ii,ier)
+ endif
+ if ( lwrite ) print *,'After dotproducts ier = ',ier
+*
+* #] get dot products:
+* #[ five and four point stuff:
+*
+ ier2 = ier
+ do 100 i=1,6
+*
+* get the five-point momenta
+*
+ ier1 = ier
+ call ffpi65(xpi5,dpipj5,piDpj5,xpi,dpipj,piDpj,i,ier1)
+*
+* get fourpoint functions
+*
+ do 90 k=1,5
+ j=k
+ if ( lwrite ) print '(a,2i2,a)',
+ + '####[ ffxf0a: fourpoint function nr ',i,j+1,': '
+ if ( k.lt.i ) then
+* we already have it
+ else
+ j = j+1
+ ier0 = ier
+*
+* get four-point momenta
+*
+ call ffpi54(xpi4,dpipj4,piDpj4,xpi5,dpipj5,piDpj5,k,
+ + ier0)
+ if ( ltest ) then
+ idum = ier
+ call ffpi64(xqi4,dqiqj4,qiDqj4,xpi,dpipj,piDpj,
+ + i,j,idum)
+ xlosn = xloss*DBLE(10)**(-mod(ier0,50))
+ do 12 l=1,13
+ if ( xlosn*abs(xpi4(l)-xqi4(l)).gt.precx*abs
+ + (xpi4(l)) ) print*,'ffxf0a: error: xpi4(',
+ + l,') != xqi4(',l,'): ',xpi4(l),xqi4(l)
+ do 11 m=1,10
+ if ( xlosn*abs(dpipj4(m,l)-dqiqj4(m,l))
+ + .gt.precx*abs(xpi4(l)) ) print *,
+ + 'ffxf0a: error: dpipj4(',m,l,') !=',
+ + ' dqiqj4(',m,l,'): ',dpipj4(m,l),
+ + dqiqj4(m,l),dpipj4(m,l)-dqiqj4(m,l)
+ 11 continue
+ 12 continue
+ do 14 l=1,10
+ do 13 m=1,10
+ if ( piDpj4(m,l).ne.qiDqj4(m,l) ) print
+ + *,'ffxf0a: error: piDpj4(',m,l,
+ + ') != qiDqj4(',m,l,'): ',piDpj4(m,
+ + l),qiDqj4(m,l)
+ 13 continue
+ 14 continue
+ endif
+ ier1 = ier0
+ call ffxdir(cs,cfac,idone,xpi4,dpipj4,6,ndiv,ier1)
+ if ( idone .gt. 0 ) then
+* done
+ xmax = abs(cs)*10d0**(-mod((ier1-ier0),50))
+ else
+ ier1 = ier0
+*
+* rotate to calculable posistion
+*
+ call ffrot4(irota,del2s,xqi4,dqiqj4,qiDqj4,xpi4,
+ + dpipj4,piDpj4,5,itype,ier0)
+ if ( itype .lt. 0 ) then
+ print *,'ffxf0: error: Cannot handle '//
+ + 'this 4point masscombination yet:'
+ print *,(xpi(j),j=1,20)
+ return
+ endif
+ if ( itype .eq. 1 ) then
+ ldel2s = .TRUE.
+ isgnal = +1
+ print *,'ffxf0a: Cannot handle del2s=0 yet'
+ stop
+ else
+ ldel2s = .FALSE.
+ endif
+ if ( itype .eq. 2 ) then
+ print *,'ffxf0a: Cannot handle doubly IR ',
+ + 'divergent function yet'
+ stop
+ endif
+*
+* get fourpoint function
+*
+ if ( lwrite ) then
+ print *,'xpi for ffxd0e: '
+ print '(i3,e24.16)',(m,xqi4(m),m=1,13)
+ endif
+ lwsav = lwrite
+ lwrite = .FALSE.
+ idsub = idsub + 1
+ call ffxd0e(cs,cfac,xmax, .FALSE.,ndiv,xqi4,
+ + dqiqj4,qiDqj4,del2s,ldel2s,ier0)
+ lwrite = lwsav
+ ier1 = max(ier1,ier0)
+ endif
+ cd0ij(i,j) = cs*cfac
+ cd0ij(j,i) = cd0ij(i,j)
+ xmx4(i,j) = xmax*absc(cfac)
+ xmx4(j,i) = xmx4(i,j)
+ if ( ldot ) then
+ call ffdl3p(fdl3ij(i,j),qiDqj4,10,ii4,ii4,
+ + ier0)
+ fdl3ij(j,i) = fdl3ij(i,j)
+ fd4sij(i,j) = fdel4s
+ fd4sij(j,i) = fdel4s
+* let's check that these have been set by ffxd0e...
+ if ( ltest ) then
+ ier0 = 0
+ call ffdel4(fdel4s,xpi4,piDpj4,10,ier0)
+ if ( xloss*10d0**(-ier0-1)*abs(fd4sij(i,j)-
+ + fdel4s).gt.precx*abs(fdel4s) ) then
+ print *,'ffxf0a: error: Del4s was not'//
+ + ' correct',fd4sij(i,j),fdel4s,
+ + fd4sij(i,j)-fdel4s,ier0
+ endif
+ endif
+ endif
+ endif
+*
+* get the coefficient determinant (not symmetric!)
+*
+ idsub = idsub + 1
+ ier0 = ier
+ call ffdl4r(dl4rij(i,j),xpi5,piDpj5,15,k,ier0)
+ ier1 = max(ier1,ier0)
+*
+* and fill the five-point linear arrays
+*
+ cd0i(k) = cd0ij(i,j)
+ dl4ri(k) = dl4rij(i,j)
+ if ( lwrite ) then
+ print '(a,2i2,a)',
+ + '####] ffxf0a: fourpoint function nr ',i,j,': '
+ print *,'dl4rij(',i,j,') = ',dl4rij(i,j)
+ print *,'cd0ij(',i,j,') = ',cd0ij(i,j),xmx4(i,j),
+ + ier0
+ endif
+ 90 continue
+*
+* call ffxe00
+*
+ if ( lwrite ) print '(a,i2,a)',
+ + '####[ ffxf0a: fivepoint function nr ',i,': '
+ call ffxe00(ce0i(i),cd0i,dl4ri,xpi5,piDpj5,ier1)
+ if ( lwrite ) print '(a,i2,a)',
+ + '####] ffxf0a: fivepoint function nr ',i,': '
+ if ( lwrite ) print *,'ce0i(',i,') = ',ce0i(i),ier1
+ if ( ldot ) fdl4i(i) = fdel4
+ ier2 = max(ier2,ier1)
+ 100 continue
+ ier = ier2
+ if ( lwrite ) print *,'after E0s ier = ',ier
+*
+* #] five and four point stuff:
+* #[ six point stuff:
+*
+ ier1 = 0
+ call ffdel6(del6,xpi,piDpj,21,ier1)
+ csum = 0
+ xmax = 0
+ do i=1,6
+ if ( ce0i(i) .ne. 0 ) then
+ ier0 = 0
+ call ffdl5r(dl5ri(i),xpi,piDpj,21,i,ier0)
+ csum = csum + DBLE(dl5ri(i))*ce0i(i)
+ xmax = max(xmax,absc(csum))
+ ier1 = max(ier1,ier0)
+ endif
+ enddo
+ ier = max(ier,ier1)
+*
+* Check for cancellations in the final adding up
+*
+ if ( lwarn .and. 2*absc(csum) .lt. xloss*xmax )
+ + call ffwarn(191,ier,absc(csum),xmax)
+*
+* Check for a sum close to the minimum of the range (underflow
+* problems)
+*
+ if ( lwarn .and. absc(csum).lt.xalogm/precc .and. csum.ne.0 )
+ + call ffwarn(192,ier,absc(csum),xalogm/precc)
+*
+* If the imaginary part is very small it most likely is zero
+* (can be removed, just esthetically more pleasing)
+*
+ if ( abs(DIMAG(csum)) .lt. precc*abs(DBLE(csum)) )
+ + csum = DCMPLX(DBLE(csum))
+*
+* Finally ...
+*
+ cf0 = csum*DBLE(-1/(2*del6))
+*
+* #] six point stuff:
+* #[ print output:
+ if ( lwrite ) then
+ print *,'ffxf0a: cf0 = ',cf0,ier
+ endif
+ if ( .FALSE. ) then
+ do i=1,6
+ if ( xpi(i).eq.0 ) then
+* assume it's a photon
+ psum = 0
+ do j=1,5
+ k = i+j-1
+ if ( k.gt.6 ) k = k-6
+ psum = psum + xpi(k+6)
+ do l=1,j-1
+ m = i+l-1
+ if ( m.gt.6 ) m = m-6
+ psum = psum + 2*piDpj(k+6,m+6)
+ enddo
+ k = i+j
+ if ( k.gt.6 ) k = k-6
+ if ( abs(piDpj(i,k)).gt.xloss*abs(xpi(k)) ) then
+ print *,'ratio coeffs ',k,' is ',dl5ri(k)/
+ + (-2*del6)
+ print *,'propagator ',k,' is ',1/(psum-xpi
+ + (k))
+ endif
+ enddo
+ endif
+ enddo
+ endif
+* #] print output:
+*###] ffxf0a:
+ end
+*###[ ffxf0r:
+ subroutine ffxf0r(cf0,ce0i,cd0ij,xpi,ier)
+***#[*comment:***********************************************************
+* *
+* Tries all 12 easy permutations of the 6pointfunction *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ integer ier,nrot
+ parameter(nrot=12)
+ DOUBLE PRECISION xpi(21),xqi(21)
+ DOUBLE COMPLEX cf0,ce0i(6),cd0ij(6,6),cf0p,ce0ip(6),cd0ijp(6,6),
+ + ce0iq(6),cd0ijq(6,6)
+ integer inew(21,nrot),irota,ier1,i,j,k,l,icon,ialsav,init
+ parameter(icon=3)
+ logical lcon
+ save inew,init,lcon
+ include 'ff.h'
+ data inew
+ + /1,2,3,4,5,6, 7,8,9,10,11,12, 13,14,15,16,17,18, 19,20,21,
+ + 2,3,4,5,6,1, 8,9,10,11,12,7, 14,15,16,17,18,13, 20,21,19,
+ + 3,4,5,6,1,2, 9,10,11,12,7,8, 15,16,17,18,13,14, 21,19,20,
+ + 4,5,6,1,2,3, 10,11,12,7,8,9, 16,17,18,13,14,15, 19,20,21,
+ + 5,6,1,2,3,4, 11,12,7,8,9,10, 17,18,13,14,15,16, 20,21,19,
+ + 6,1,2,3,4,5, 12,7,8,9,10,11, 18,13,14,15,16,17, 21,19,20,
+ + 6,5,4,3,2,1, 11,10,9,8,7,12, 16,15,14,13,18,17, 21,20,19,
+ + 5,4,3,2,1,6, 10,9,8,7,12,11, 15,14,13,18,17,16, 20,19,21,
+ + 4,3,2,1,6,5, 9,8,7,12,11,10, 14,13,18,17,16,15, 19,21,20,
+ + 3,2,1,6,5,4, 8,7,12,11,10,9, 13,18,17,16,15,14, 21,20,19,
+ + 2,1,6,5,4,3, 7,12,11,10,9,8, 18,17,16,15,14,13, 20,19,21,
+ + 1,6,5,4,3,2, 12,11,10,9,8,7, 17,16,15,14,13,18, 19,21,20/
+ data init /0/
+* #] declarations:
+* #[ open console for some activity on screen:
+ if ( init .eq. 0 ) then
+ init = 1
+ if ( lwrite ) then
+ open(icon,file='CON:',status='old',err=11)
+ lcon = .TRUE.
+ goto 13
+ endif
+ 11 continue
+ lcon = .FALSE.
+ 13 continue
+ endif
+* #] open console for some activity on screen:
+* #[ calculations:
+ cf0 = 0
+ ier = 999
+ ialsav = isgnal
+ do 20 irota=1,nrot
+ do 10 i=1,21
+ xqi(inew(i,irota)) = xpi(i)
+ 10 continue
+ print '(a,i2,a,i2)','---#[ rotation ',irota,': isgnal ',
+ + isgnal
+ if (lcon) write(icon,'(a,i2,a,i2)')'rotation ',irota,',
+ + isgnal ',isgnal
+ ier1 = 0
+ ner = 0
+ id = id + 1
+ isgnal = ialsav
+ call ffxf0(cf0p,ce0ip,cd0ijp,xqi,ier1)
+ ier1 = ier1 + ner
+ if ( ier.gt.5 ) call ffwarn(998,ier,x0,x0)
+ print '(a,i2,a,i2)','---#] rotation ',irota,': isgnal ',
+ + isgnal
+ print '(a,2g28.16,i3)','f0 = ',cf0p,ier1
+ do 15 k=1,6
+ ce0iq(k) = ce0ip(inew(k,irota))
+ print '(a,2g28.16,i3)','e0 = ',ce0iq(k),k
+ 15 continue
+ do 17 k=1,6
+ do 16 l=k+1,6
+ cd0ijq(l,k)=cd0ijp(inew(l,irota),inew(k,irota))
+ print '(a,2g28.16,2i3)','d0 = ',cd0ijq(l,k),l,k
+ 16 continue
+ 17 continue
+ if (lcon) write(icon,'(a,2g28.16,i3)')'f0 = ',cf0p,ier1
+ if ( ier1 .lt. ier ) then
+ cf0 = cf0p
+ do 19 k=1,6
+ ce0i(k) = ce0iq(k)
+ do 18 l=k+1,6
+ cd0ij(l,k) =
+ + cd0ijp(inew(l,irota),inew(k,irota))
+ cd0ij(k,l) = cd0ij(l,k)
+ 18 continue
+ 19 continue
+ ier = ier1
+ endif
+ 20 continue
+* #] calculations:
+*###] ffxf0r:
+ end
diff --git a/ff-2.0/ffxf0h.f b/ff-2.0/ffxf0h.f
new file mode 100644
index 0000000..9758134
--- /dev/null
+++ b/ff-2.0/ffxf0h.f
@@ -0,0 +1,1071 @@
+* $Id: ffxf0h.f,v 1.2 1995/12/08 10:47:53 gj Exp $
+*###[ ffdot6:
+ subroutine ffdot6(piDpj,xpi,dpipj,ier)
+***#[*comment:***********************************************************
+* *
+* calculate the dotproducts pi.pj with *
+* *
+* xpi(i) = s_i i=1,6 *
+* xpi(i) = p_i i=7,12 *
+* xpi(i) = p_i+p_{i+1} i=13,18 *
+* xpi(i) = p_i+p_{i+1}+p_{i+2 i=19,21 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xpi(21),dpipj(21,21),piDpj(21,21)
+*
+* local variables
+*
+ integer is1,is2,is3,is4,is5,ip7,ip8,ip9,ip10,ip13,ip14,ip15,
+ + ip17,ip19,ip20,i,j,igehad(21,21),itel,i1,i2,i3,i4,i5,i6,
+ + i8,i9,i13,i14,i19,n,jtel,ii1,ii2,ii3,ii4,sgn19,sgn20,
+ + sgn21,s4,s5,s13,s14,s19,ss2,ier0,ier1
+* werkt niet bij Absoft
+* parameter (locwrt=.FALSE.)
+ logical locwrt
+ DOUBLE PRECISION xheck,xmax
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data locwrt /.FALSE./
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ ier0 = 0
+ call ffxhck(xpi,dpipj,21,ier0)
+ if ( ier0 .ne. 0 ) print *,'Checked by ffdot6'
+ endif
+ if ( locwrt ) then
+ do 2 i=1,21
+ do 1 j=1,21
+ igehad(j,i) = 0
+ 1 continue
+ 2 continue
+ endif
+* #] check input:
+* #[ indices:
+ ier1 = ier
+ do 10 is1=1,6
+ is2 = is1 + 1
+ if ( is2 .eq. 7 ) is2 = 1
+ is3 = is2 + 1
+ if ( is3 .eq. 7 ) is3 = 1
+ ip7 = is1 + 6
+ ip8 = is2 + 6
+ ip13= ip7 + 6
+*
+* we have now defined a 3point function
+*
+* | -p13
+* |
+* / \
+* s1/ \s3
+* ___/_____\___
+* p7 s2 p8
+*
+* #] indices:
+* #[ all in one vertex:
+*
+* pi.pi, si.si
+*
+ piDpj(is1,is1) = xpi(is1)
+ piDpj(ip7,ip7) = xpi(ip7)
+ piDpj(ip13,ip13) = xpi(ip13)
+ if ( locwrt ) then
+ igehad(is1,is1) = igehad(is1,is1) + 1
+ igehad(ip7,ip7) = igehad(ip7,ip7) + 1
+ igehad(ip13,ip13) = igehad(ip13,ip13) + 1
+ endif
+*
+* si.s(i+1)
+*
+ if ( xpi(is2) .le. xpi(is1) ) then
+ piDpj(is1,is2) = (dpipj(is1,ip7) + xpi(is2))/2
+ else
+ piDpj(is1,is2) = (dpipj(is2,ip7) + xpi(is1))/2
+ endif
+ piDpj(is2,is1) = piDpj(is1,is2)
+ if ( locwrt ) then
+ igehad(is1,is2) = igehad(is1,is2) + 1
+ igehad(is2,is1) = igehad(is2,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(is1,is2)) .lt.
+ + xloss*min(xpi(is1),xpi(is2)) ) then
+ ier0 = ier
+ call ffwarn(195,ier0,piDpj(is1,is2),min(xpi(is1),
+ + xpi(is2)))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is1),xpi(is2),xpi(ip7)
+ endif
+*
+* si.s(i+2)
+*
+ if ( xpi(is1) .le. xpi(is3) ) then
+ piDpj(is3,is1) = (dpipj(is3,ip13) + xpi(is1))/2
+ else
+ piDpj(is3,is1) = (dpipj(is1,ip13) + xpi(is3))/2
+ endif
+ piDpj(is1,is3) = piDpj(is3,is1)
+ if ( locwrt ) then
+ igehad(is1,is3) = igehad(is1,is3) + 1
+ igehad(is3,is1) = igehad(is3,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(is1,is3)) .lt.
+ + xloss*min(xpi(is1),xpi(is3)) ) then
+ ier0 = ier
+ call ffwarn(196,ier0,piDpj(is1,is3),min(xpi(is1),
+ + xpi(is3)))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is1),xpi(is3),xpi(ip13)
+ endif
+*
+* pi.si
+*
+ if ( abs(xpi(ip7)) .le. xpi(is1) ) then
+ piDpj(ip7,is1) = (dpipj(is2,is1) - xpi(ip7))/2
+ else
+ piDpj(ip7,is1) = (dpipj(is2,ip7) - xpi(is1))/2
+ endif
+ piDpj(is1,ip7) = piDpj(ip7,is1)
+ if ( locwrt ) then
+ igehad(is1,ip7) = igehad(is1,ip7) + 1
+ igehad(ip7,is1) = igehad(ip7,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip7,is1)) .lt.
+ + xloss*min(abs(xpi(ip7)),xpi(is1))) then
+ ier0 = ier
+ call ffwarn(197,ier0,piDpj(ip7,is1),min( abs(xpi(ip7)),
+ + xpi(is1)))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is1),xpi(is2),xpi(ip7)
+ endif
+*
+* pi.s(i+1)
+*
+ if ( abs(xpi(ip7)) .le. xpi(is2) ) then
+ piDpj(ip7,is2) = (dpipj(is2,is1) + xpi(ip7))/2
+ else
+ piDpj(ip7,is2) = (dpipj(ip7,is1) + xpi(is2))/2
+ endif
+ if ( locwrt ) then
+ igehad(is2,ip7) = igehad(is2,ip7) + 1
+ igehad(ip7,is2) = igehad(ip7,is2) + 1
+ endif
+ piDpj(is2,ip7) = piDpj(ip7,is2)
+ if ( lwarn .and. abs(piDpj(ip7,is2)) .lt.
+ + xloss*min(abs(xpi(ip7)),xpi(is2))) then
+ ier0 = ier
+ call ffwarn(198,ier0,piDpj(ip7,is2),min(abs(xpi(ip7)),
+ + xpi(is2)))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is1),xpi(is2),xpi(ip7)
+ endif
+*
+* p(i+2).s(i)
+*
+ if ( abs(xpi(ip13)) .le. xpi(is1) ) then
+ piDpj(ip13,is1) = -(dpipj(is1,is3) + xpi(ip13))/2
+ else
+ piDpj(ip13,is1) = -(dpipj(ip13,is3) + xpi(is1))/2
+ endif
+ piDpj(is1,ip13) = piDpj(ip13,is1)
+ if ( locwrt ) then
+ igehad(is1,ip13) = igehad(is1,ip13) + 1
+ igehad(ip13,is1) = igehad(ip13,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip13,is1)) .lt.
+ + xloss*min(abs(xpi(ip13)),xpi(is1))) then
+ ier0 = ier
+ call ffwarn(199,ier0,piDpj(ip13,is1),min(abs(xpi(ip13)),
+ + xpi(is1)))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is1),xpi(is3),xpi(ip13)
+ endif
+*
+* p(i+2).s(i+2)
+*
+ if ( abs(xpi(ip13)) .le. xpi(is3) ) then
+ piDpj(ip13,is3) = -(dpipj(is1,is3) - xpi(ip13))/2
+ else
+ piDpj(ip13,is3) = -(dpipj(is1,ip13) - xpi(is3))/2
+ endif
+ piDpj(is3,ip13) = piDpj(ip13,is3)
+ if ( locwrt ) then
+ igehad(is3,ip13) = igehad(is3,ip13) + 1
+ igehad(ip13,is3) = igehad(ip13,is3) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip13,is3)) .lt.
+ + xloss*min(abs(xpi(ip13)),xpi(is3))) then
+ ier0 = ier
+ call ffwarn(206,ier0,piDpj(ip13,is3),min(abs(xpi(ip13)),
+ + xpi(is3)))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is1),xpi(is3),xpi(ip13)
+ endif
+* #] all in one vertex:
+* #[ all in one 3point:
+*
+* pi.s(i+2)
+*
+ if ( min(abs(dpipj(is2,is1)),abs(dpipj(ip13,ip8))) .le.
+ + min(abs(dpipj(ip13,is1)),abs(dpipj(is2,ip8))) ) then
+ piDpj(ip7,is3) = (dpipj(ip13,ip8) + dpipj(is2,is1))/2
+ else
+ piDpj(ip7,is3) = (dpipj(ip13,is1) + dpipj(is2,ip8))/2
+ endif
+ piDpj(is3,ip7) = piDpj(ip7,is3)
+ if ( locwrt ) then
+ igehad(is3,ip7) = igehad(is3,ip7) + 1
+ igehad(ip7,is3) = igehad(ip7,is3) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip7,is3)) .lt. xloss*
+ + min(abs(dpipj(ip13,ip8)),abs(dpipj(ip13,is1)))) then
+ ier0 = ier
+ call ffwarn(200,ier0,piDpj(ip7,is3),
+ + min(abs(dpipj(ip13,ip8)),abs(dpipj(ip13,is1))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is1),xpi(is2),xpi(ip8),
+ + xpi(ip13)
+ endif
+*
+* p(i+1).s(i)
+*
+ if ( min(abs(dpipj(is3,is2)),abs(dpipj(ip7,ip13))) .le.
+ + min(abs(dpipj(ip7,is2)),abs(dpipj(is3,ip13))) ) then
+ piDpj(ip8,is1) = (dpipj(ip7,ip13) + dpipj(is3,is2))/2
+ else
+ piDpj(ip8,is1) = (dpipj(ip7,is2) + dpipj(is3,ip13))/2
+ endif
+ piDpj(is1,ip8) = piDpj(ip8,is1)
+ if ( locwrt ) then
+ igehad(is1,ip8) = igehad(is1,ip8) + 1
+ igehad(ip8,is1) = igehad(ip8,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip8,is1)) .lt. xloss*
+ + min(abs(dpipj(ip7,ip13)),abs(dpipj(ip7,is2))) ) then
+ ier0 = ier
+ call ffwarn(201,ier0,piDpj(ip8,is1),
+ + min(abs(dpipj(ip7,ip13)),abs(dpipj(ip7,is2))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is2),xpi(is3),xpi(ip7),
+ + xpi(ip13)
+ endif
+*
+* p(i+2).s(i+1)
+*
+ if ( min(abs(dpipj(is1,is3)),abs(dpipj(ip8,ip7))) .le.
+ + min(abs(dpipj(ip8,is3)),abs(dpipj(is1,ip7))) ) then
+ piDpj(ip13,is2) = -(dpipj(ip8,ip7) + dpipj(is1,is3))/2
+ else
+ piDpj(ip13,is2) = -(dpipj(ip8,is3) + dpipj(is1,ip7))/2
+ endif
+ piDpj(is2,ip13) = piDpj(ip13,is2)
+ if ( locwrt ) then
+ igehad(is2,ip13) = igehad(is2,ip13) + 1
+ igehad(ip13,is2) = igehad(ip13,is2) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip13,is2)) .lt. xloss*
+ + min(abs(dpipj(ip8,ip7)),abs(dpipj(ip8,is3))) ) then
+ ier0 = ier
+ call ffwarn(202,ier0,piDpj(ip13,is2),
+ + min(abs(dpipj(ip8,ip7)),abs(dpipj(ip8,is3))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is2),xpi(is3),xpi(ip7),
+ + xpi(ip8)
+ endif
+* #] all in one 3point:
+* #[ all external 3point:
+*
+* pi.p(i+1)
+*
+ if ( abs(xpi(ip8)) .le. abs(xpi(ip7)) ) then
+ piDpj(ip7,ip8) = (dpipj(ip13,ip7) - xpi(ip8))/2
+ else
+ piDpj(ip7,ip8) = (dpipj(ip13,ip8) - xpi(ip7))/2
+ endif
+ piDpj(ip8,ip7) = piDpj(ip7,ip8)
+ if ( locwrt ) then
+ igehad(ip8,ip7) = igehad(ip8,ip7) + 1
+ igehad(ip7,ip8) = igehad(ip7,ip8) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip7,ip8)) .lt.
+ + xloss*min(abs(xpi(ip7)),abs(xpi(ip8))) ) then
+ ier0 = ier
+ call ffwarn(203,ier0,piDpj(ip7,ip8),min(abs(xpi(ip7)),
+ + abs(xpi(ip8))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(ip7),xpi(ip8),xpi(ip13)
+ endif
+*
+* p(i+1).p(i+2)
+*
+ if ( abs(xpi(ip13)) .le. abs(xpi(ip8)) ) then
+ piDpj(ip8,ip13) = -(dpipj(ip7,ip8) - xpi(ip13))/2
+ else
+ piDpj(ip8,ip13) = -(dpipj(ip7,ip13) - xpi(ip8))/2
+ endif
+ piDpj(ip13,ip8) = piDpj(ip8,ip13)
+ if ( locwrt ) then
+ igehad(ip13,ip8) = igehad(ip13,ip8) + 1
+ igehad(ip8,ip13) = igehad(ip8,ip13) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip8,ip13)) .lt.
+ + xloss*min(abs(xpi(ip8)),abs(xpi(ip13))) ) then
+ ier0 = ier
+ call ffwarn(204,ier0,piDpj(ip8,ip13),min(abs(xpi(ip8)),
+ + abs(xpi(ip13))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(ip7),xpi(ip8),xpi(ip13)
+ endif
+*
+* p(i+2).p(i)
+*
+ if ( abs(xpi(ip7)) .le. abs(xpi(ip13)) ) then
+ piDpj(ip13,ip7) = -(dpipj(ip8,ip13) - xpi(ip7))/2
+ else
+ piDpj(ip13,ip7) = -(dpipj(ip8,ip7) - xpi(ip13))/2
+ endif
+ piDpj(ip7,ip13) = piDpj(ip13,ip7)
+ if ( locwrt ) then
+ igehad(ip7,ip13) = igehad(ip7,ip13) + 1
+ igehad(ip13,ip7) = igehad(ip13,ip7) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip13,ip7)) .lt.
+ + xloss*min(abs(xpi(ip13)),abs(xpi(ip7))) ) then
+ ier0 = ier
+ call ffwarn(205,ier0,piDpj(ip13,ip7),min(abs(xpi(ip13)),
+ + abs(xpi(ip7))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(ip7),xpi(ip8),xpi(ip13)
+ endif
+* #] all external 3point:
+* #[ the other 3point:
+ is4 = is3 + 1
+ if ( is4 .eq. 7 ) is4 = 1
+ ip9 = is3 + 6
+ ip19 = is1 + 18
+ if ( ip19.gt.21 ) then
+ ip19 = ip19 - 3
+ sgn19 = -1
+ else
+ sgn19 = +1
+ endif
+*
+* we now work with the threepoint configuration
+*
+* |p19
+* |
+* / \
+* s1/ \s4
+* ___/_____\___
+* p13 s3 p8
+*
+ is5 = is4 + 1
+ if ( is5.gt.6 ) is5 = 1
+ ip14 = is2 + 12
+ ip15 = is3 + 12
+ ip17 = is5 + 12
+*
+* and the threepoint configuration
+*
+* |p19
+* |
+* / \
+* s1/ \s4
+* ___/_____\___
+* p7 s2 p14
+*
+*
+* and the threepoint configuration (only twice!)
+*
+* |p17
+* |
+* / \
+* s1/ \s5
+* ___/_____\___
+* p13 s3 p15
+*
+* we forgot one s1.s4, but not too often!
+*
+ if ( is1.le.3 ) then
+ piDpj(ip19,ip19) = xpi(ip19)
+ if ( xpi(is1).lt.xpi(is4) ) then
+ piDpj(is1,is4) = (xpi(is1) + dpipj(is4,ip19))/2
+ else
+ piDpj(is1,is4) = (xpi(is4) + dpipj(is1,ip19))/2
+ endif
+ piDpj(is4,is1) = piDpj(is1,is4)
+ if ( locwrt ) then
+ igehad(ip19,ip19) = igehad(ip19,ip19) + 1
+ igehad(is1,is4) = igehad(is1,is4) + 1
+ igehad(is4,is1) = igehad(is4,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(is4,is1)) .lt.
+ + xloss*min(abs(xpi(is4)),abs(xpi(is1))) ) then
+ ier0 = ier
+ call ffwarn(207,ier0,piDpj(is4,is1),
+ + min(abs(xpi(is4)),abs(xpi(is1))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is1),xpi(is4),
+ + xpi(ip19)
+ endif
+ endif
+*
+* another missing simple one
+*
+ if ( xpi(is1).lt.abs(xpi(ip19)) ) then
+ piDpj(is1,ip19) = (xpi(is1) + dpipj(ip19,is4))/2
+ else
+ piDpj(is1,ip19) = (xpi(ip19) + dpipj(is1,is4))/2
+ endif
+ if ( sgn19.eq.+1 ) piDpj(is1,ip19) = -piDpj(is1,ip19)
+ piDpj(ip19,is1) = piDpj(is1,ip19)
+ if ( locwrt ) then
+ igehad(is1,ip19) = igehad(is1,ip19) + 1
+ igehad(ip19,is1) = igehad(ip19,is1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ip19,is1)) .lt.
+ + xloss*min(abs(xpi(is1)),abs(xpi(ip19))) ) then
+ ier0 = ier
+ call ffwarn(207,ier0,piDpj(is1,ip19),
+ + min(abs(xpi(is1)),abs(xpi(ip19))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(is1),xpi(is4),xpi(ip19)
+ endif
+*
+* and a series in one go
+*
+ do 11 itel = 1,7
+ if ( itel .eq. 1 ) then
+ i1 = is1
+ i2 = is3
+ i3 = is4
+ i4 = ip13
+ s4 = 1
+ i5 = ip9
+ s5 = 1
+ i6 = ip19
+ elseif ( itel .eq. 2 ) then
+ i1 = is3
+ i2 = is4
+ i3 = is1
+ i4 = ip9
+ s4 = 1
+ i5 = ip19
+ s5 = -sgn19
+ i6 = ip13
+ elseif ( itel .eq. 3 ) then
+ i1 = is4
+ i2 = is1
+ i3 = is3
+ i4 = ip19
+ s4 = -sgn19
+ i5 = ip13
+ s5 = 1
+ i6 = ip9
+ elseif ( itel .eq. 4 ) then
+ i1 = is1
+ i2 = is2
+ i3 = is4
+ i4 = ip7
+ s4 = 1
+ i5 = ip14
+ s5 = 1
+ i6 = ip19
+ elseif ( itel .eq. 5 ) then
+ i1 = is2
+ i2 = is4
+ i3 = is1
+ i4 = ip14
+ s4 = 1
+ i5 = ip19
+ s5 = -sgn19
+ i6 = ip7
+ elseif ( itel .eq. 6 ) then
+ i1 = is4
+ i2 = is1
+ i3 = is2
+ i4 = ip19
+ s4 = -sgn19
+ i5 = ip7
+ s5 = 1
+ i6 = ip14
+ else
+ i1 = is1
+ i2 = is3
+ i3 = is5
+ i4 = ip13
+ s4 = 1
+ i5 = ip15
+ s5 = 1
+ i6 = ip17
+ endif
+*
+* in one go: the opposite sides
+*
+ if ( min(abs(dpipj(i3,i2)),abs(dpipj(i4,i6))) .le.
+ + min(abs(dpipj(i4,i2)),abs(dpipj(i3,i6))) ) then
+ piDpj(i5,i1) = (dpipj(i3,i2) + dpipj(i4,i6))/2
+ else
+ piDpj(i5,i1) = (dpipj(i4,i2) + dpipj(i3,i6))/2
+ endif
+ if ( s5.eq.-1 ) piDpj(i5,i1) = -piDpj(i5,i1)
+ piDpj(i1,i5) = piDpj(i5,i1)
+ if ( locwrt ) then
+ igehad(i1,i5) = igehad(i1,i5) + 1
+ igehad(i5,i1) = igehad(i5,i1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(i5,i1)) .lt. xloss*
+ + min(abs(dpipj(i4,i6)),abs(dpipj(i4,i2)))) then
+ ier0 = ier
+ call ffwarn(201,ier0,piDpj(i5,i1),min(abs(dpipj(i4,
+ + i6)),abs(dpipj(i4,i2))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(i3),xpi(i2),
+ + xpi(i4),xpi(i6)
+ endif
+*
+* and the remaining external ones
+*
+ if ( abs(xpi(i5)) .le. abs(xpi(i4)) ) then
+ piDpj(i4,i5) = (dpipj(i6,i4) - xpi(i5))/2
+ else
+ piDpj(i4,i5) = (dpipj(i6,i5) - xpi(i4))/2
+ endif
+ if ( s4.ne.s5 ) piDpj(i4,i5) = -piDpj(i4,i5)
+ piDpj(i5,i4) = piDpj(i4,i5)
+ if ( locwrt ) then
+ igehad(i5,i4) = igehad(i5,i4) + 1
+ igehad(i4,i5) = igehad(i4,i5) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(i4,i5)) .lt. xloss*
+ + min(abs(xpi(i4)),abs(xpi(i5))) ) then
+ ier0 = ier
+ call ffwarn(203,ier0,piDpj(i4,i5),
+ + min(abs(xpi(i4)),abs(xpi(i5))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(i4),xpi(i5),xpi(i6)
+ endif
+ 11 continue
+* #] the other 3point:
+* #[ 4point indices:
+ ip10 = is4+6
+ ip20 = is2+18
+ if ( ip20.gt.21 ) then
+ ip20 = ip20 - 3
+ sgn20 = -1
+ else
+ sgn20 = +1
+ endif
+ if ( is1.le.3 ) then
+ n = 3
+ else
+ n = 2
+ endif
+ do 13 jtel=1,n
+ if ( jtel.eq.1 ) then
+ i3 = is3
+ i4 = is4
+ i8 = ip8
+ i9 = ip9
+ i13 = ip13
+ s13 = 1
+ i14 = ip14
+ s14 = 1
+ i19 = ip19
+ s19 = -sgn19
+ elseif ( jtel.eq.2 ) then
+ i3 = is3
+ i4 = is5
+ i8 = ip8
+ i9 = ip15
+ i13 = ip13
+ s13 = 1
+ i14 = ip20
+ s14 = sgn20
+ i19 = ip17
+ s19 = 1
+ else
+ i3 = is4
+ i4 = is5
+ i8 = ip14
+ i9 = ip10
+ i13 = ip19
+ s13 = sgn19
+ i14 = ip20
+ s14 = sgn20
+ i19 = ip17
+ s19 = 1
+ endif
+*
+* we now have the fourpoint configuration
+*
+* \i19 /i9
+* \____/
+* | i4 | \
+* s1| |i3 |i14
+* |____| /
+* p7/ s2 \i8
+* / \__/ \
+* i13
+*
+ do 12 itel = 1,2
+ if ( itel .eq. 1 ) then
+ ii1 = ip7
+ ii2 = i9
+ ss2 = 1
+ ii3 = i8
+ ii4 = i19
+ else
+ ii1 = i8
+ ii2 = i19
+ ss2 = s19
+ ii3 = ip7
+ ii4 = i9
+ endif
+ if ( min(abs(dpipj(ii3,i13)),abs(dpipj(ii4,i14)))
+ + .le. min(abs(dpipj(ii4,i13)),abs(dpipj(ii3,i14))) )
+ + then
+ piDpj(ii1,ii2)=(dpipj(ii3,i13)+dpipj(ii4,i14))/2
+ else
+ piDpj(ii1,ii2)=(dpipj(ii4,i13)+dpipj(ii3,i14))/2
+ endif
+ if ( ss2.eq.-1 ) piDpj(ii1,ii2) = -piDpj(ii1,ii2)
+ piDpj(ii2,ii1) = piDpj(ii1,ii2)
+ if ( locwrt ) then
+ igehad(ii1,ii2) = igehad(ii1,ii2) + 1
+ igehad(ii2,ii1) = igehad(ii2,ii1) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(ii2,ii1)) .lt. xloss*min(
+ + abs(dpipj(ii4,i14)),abs(dpipj(ii4,i13)))) then
+ ier0 = ier
+ call ffwarn(208,ier0,piDpj(ii2,ii1),min(abs(
+ + dpipj(ii4,i14)),abs(dpipj(ii4,i13))))
+ ier1 = max(ier1,ier0)
+ if (lwrite) print *,'among ',xpi(ii3),xpi(i13),
+ + xpi(ii4),xpi(i14)
+ endif
+ 12 continue
+*
+* we are only left with p11.p12 etc.
+*
+ if ( min(abs(dpipj(i19,i9)),abs(dpipj(i8,ip7))) .le.
+ + min(abs(dpipj(i8,i9)),abs(dpipj(i19,ip7))) ) then
+ piDpj(i13,i14) = (dpipj(i8,ip7) + dpipj(i19,i9))/2
+ else
+ piDpj(i13,i14) = (dpipj(i8,i9) + dpipj(i19,ip7))/2
+ endif
+ if ( s13.ne.s14 ) piDpj(i13,i14) = -piDpj(i13,i14)
+ piDpj(i14,i13) = piDpj(i13,i14)
+ if ( locwrt ) then
+ igehad(i14,i13) = igehad(i14,i13) + 1
+ igehad(i13,i14) = igehad(i13,i14) + 1
+ endif
+ if ( lwarn .and. abs(piDpj(i13,i14)) .lt. xloss*min(
+ + abs(dpipj(i8,ip7)),abs(dpipj(i8,i9))) ) then
+ ier0 = ier
+ call ffwarn(202,ier0,piDpj(i13,i14),
+ + min(abs(dpipj(i8,ip7)),abs(dpipj(i8,i9))))
+ if (lwrite) print *,'among ',xpi(i8),xpi(ip7),
+ + xpi(i19),xpi(i9)
+ ier1 = max(ier1,ier0)
+ endif
+ 13 continue
+ 10 continue
+ ier = ier1
+* #] 4point indices:
+* #[ check:
+ if ( locwrt ) then
+ print *,'We hebben gehad:'
+ print '(21i2)',igehad
+ endif
+ if ( ltest ) then
+ do 40 i = 1,21
+*
+* sum over all (incoming) momenta => 0
+*
+ xheck = 0
+ xmax = 0
+ do 20 j=7,12
+ xheck = xheck + piDpj(j,i)
+ xmax = max(abs(piDpj(j,i)),xmax)
+ 20 continue
+ if ( xloss*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffdot6: error: dotproducts with p(',i,
+ + ') wrong: (som(.p(i))<>0) ',
+ + (piDpj(i,j),j=6,10),xheck
+*
+* sum over all (incoming) momentum pairs => 0
+*
+ xheck = 0
+ xmax = 0
+ do 25 j=13,18
+ xheck = xheck + piDpj(j,i)
+ xmax = max(abs(piDpj(j,i)),xmax)
+ 25 continue
+ if ( xloss*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffdot6: error: dotproducts with p(',i,
+ + ') wrong: (som(.(p(i)+p(i+1)))<>0) ',
+ + (piDpj(i,j),j=11,15),xheck
+*
+* check for symmetry
+*
+ do 30 j=1,21
+ if ( piDpj(i,j) .ne. piDpj(j,i) ) print *,
+ + 'ffdot6: error: piDpj(',i,j,') <> piDpj',j,i,')'
+ 30 continue
+*
+* check the diagonal
+*
+ if ( piDpj(i,i) .ne. xpi(i) ) print *,'ffdot6: error: ',
+ + 'piDpj(',i,i,') <> xpi(',i,')'
+ do 35 j=7,12
+ do 34 i6=1,2
+ if ( i6.eq.1 ) then
+*
+* see if indeed pi+p(i+1) = p(i+5)
+*
+ i2 = j+6
+ i1 = j+1
+ if ( i1 .eq. 13 ) i1 = 7
+ else
+*
+* check that si+p(i+5) = s(i+1)
+*
+ i2 = i1-6
+ i1 = j-6
+ endif
+ xheck = piDpj(j,i)+piDpj(i1,i)-piDpj(i2,i)
+ xmax = max(abs(piDpj(j,i)),abs(piDpj(i2,i)),
+ + abs(piDpj(i1,i)))
+ if ( xloss*abs(xheck) .gt. precx*xmax ) print *,
+ + 'ffdot6: error: piDpj(',j,i,')+piDpj(',
+ + i2,i,')-piDpj(',i1,i,') <> 0',xmax,xheck
+ 34 continue
+ 35 continue
+ 40 continue
+ endif
+* #] check:
+*###] ffdot6:
+ end
+*###[ ffpi65:
+ subroutine ffpi65(xpi5,dpipj5,piDpj5,xpi,dpipj,piDpj,inum,ier)
+***#[*comment:***********************************************************
+* *
+* Gets the dotproducts pertaining to the five point function with *
+* s_i missing out of the six point function dotproduct array. *
+* *
+* Input: xpi real(21) si.si,pi.pi *
+* dpipj real(21,21) xpi(i) - xpi(j) *
+* piDpj real(21,21) pi(i).pi(j) *
+* inum integer 1--6 *
+* *
+* Output: xpi5 real(20) five-point momenta *
+* dpipj5 real(15,20) *
+* piDpj5 real(15,15) *
+* ier integer *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer inum,ier
+ DOUBLE PRECISION xpi(21),dpipj(21,21),piDpj(21,21),xpi5(20),
+ + dpipj5(15,20),piDpj5(15,15),qDq(15,15)
+*
+* local variables
+*
+ integer i,j,iplace(15,6),isigns(15,6),ier0,i6,i7,i8,i9
+ save iplace,isigns
+ DOUBLE PRECISION xmax
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data iplace /
+ + 2,3,4,5,6, 08,09,10,11,18, 14,15,16,20,21,
+ + 1,3,4,5,6, 13,09,10,11,12, 19,15,16,17,21,
+ + 1,2,4,5,6, 07,14,10,11,12, 19,20,16,17,18,
+ + 1,2,3,5,6, 07,08,15,11,12, 13,20,21,17,18,
+ + 1,2,3,4,6, 07,08,09,16,12, 13,14,21,19,18,
+ + 1,2,3,4,5, 07,08,09,10,17, 13,14,15,19,20/
+*
+ data isigns /
+ + +1,+1,+1,+1,+1, +1,+1,+1,+1,+1, +1,+1,+1,-1,-1,
+ + +1,+1,+1,+1,+1, +1,+1,+1,+1,+1, +1,+1,+1,+1,-1,
+ + +1,+1,+1,+1,+1, +1,+1,+1,+1,+1, +1,+1,+1,+1,+1,
+ + +1,+1,+1,+1,+1, +1,+1,+1,+1,+1, +1,+1,+1,+1,+1,
+ + +1,+1,+1,+1,+1, +1,+1,+1,+1,+1, +1,+1,+1,-1,+1,
+ + +1,+1,+1,+1,+1, +1,+1,+1,+1,+1, +1,+1,+1,-1,-1/
+*
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ ier0 = 0
+ call ffxhck(xpi,dpipj,21,ier0)
+ if ( ier0 .ne. 0 ) print *,'ffpi65: input corrupted'
+ endif
+* #] check input:
+* #[ distribute:
+*
+* copy xpi(1-15)
+*
+ do 20 i=1,15
+ xpi5(i) = xpi(iplace(i,inum))
+ do 10 j=1,15
+ dpipj5(j,i) = dpipj(iplace(j,inum),iplace(i,inum))
+ 10 continue
+ 20 continue
+*
+* these cannot be simply right now (maybe later when I add the
+* redundant pi to F0 as well)
+*
+ do 15 i=1,5
+ i6 = i+5
+ i7 = i6+1
+ if ( i7 .ge. 11 ) i7 = 6
+ i8 = i7+1
+ if ( i8 .ge. 11 ) i8 = 6
+ i9 = i8+1
+ if ( i9 .ge. 11 ) i9 = 6
+ xpi5(i+15) = xpi5(i6)+xpi5(i7)+xpi5(i8)-xpi5(i6+5)-
+ + xpi5(i7+5)+xpi5(i9+5)
+ xmax = max(abs(xpi5(i6)),abs(xpi5(i7)),abs(xpi5(i8)),abs(
+ + xpi5(i6+5)),abs(xpi5(i7+5)),abs(xpi5(i9+5)))
+ if ( abs(xpi5(i+15)) .lt. xloss*xmax )
+ + call ffwarn(168,ier,xpi5(i+15),xmax)
+ 15 continue
+*
+* and the differences
+*
+ do 40 i=16,20
+ do 30 j=1,15
+ dpipj5(j,i) = xpi5(j) - xpi5(i)
+ 30 continue
+ 40 continue
+*
+* copy the dotproducts (watch the signs of p10-p15!)
+*
+ do 60 i=1,15
+ do 50 j=1,15
+ piDpj5(j,i) = isigns(j,inum)*isigns(i,inum)*
+ + piDpj(iplace(j,inum),iplace(i,inum))
+ 50 continue
+ 60 continue
+* #] distribute:
+* #[ check:
+ if ( lwrite ) then
+ print *,'ffpi65: xpi5 = ',xpi5
+ endif
+ if ( ltest ) then
+ ier0 = 0
+ call ffxhck(xpi5,dpipj5,15,ier0)
+ if ( ier0 .ne. 0 ) print *,'ffpi65: error detected'
+*
+* check piDpj
+*
+ ier0 = 0
+ call ffdot5(qDq,xpi5,dpipj5,ier0)
+ do 190 i=1,15
+ do 180 j=1,15
+ if ( xloss*abs(qDq(j,i)-piDpj5(j,i)) .gt. precx*
+ + abs(qDq(j,i)) ) print *,'ffpi65: error: ',
+ + 'piDpj5(',j,i,') not correct: ',piDpj5(j,i),
+ + qDq(j,i),piDpj5(j,i)-qDq(j,i)
+ 180 continue
+ 190 continue
+ endif
+* #] check:
+*###] ffpi65:
+ end
+*###[ ffpi64:
+ subroutine ffpi64(xpi4,dpipj4,piDpj4,xpi,dpipj,piDpj,inum,jnum,
+ + ier)
+***#[*comment:***********************************************************
+* *
+* Gets the dotproducts pertaining to the fourpoint function with *
+* s_i,s_j missing out of the six point function dotproduct array. *
+* *
+* Input: xpi real(21) si.si,pi.pi *
+* dpipj real(21,21) xpi(i) - xpi(j) *
+* piDpj real(21,21) pi(i).pi(j) *
+* inum,jnum integer 1--6, unequal *
+* *
+* Output: xpi4 real(13) *
+* dpipj4 real(10,13) *
+* piDpj4 real(10,10) *
+* ier integer *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer inum,jnum,ier
+ DOUBLE PRECISION xpi(21),dpipj(21,21),piDpj(21,21),xpi4(13),
+ + dpipj4(10,13),piDpj4(10,10)
+*
+* local variables
+*
+ integer i,j,knum,iplace(11,15),isigns(11,15),ij2k(6,6),ier0
+ save iplace,isigns,ij2k
+ DOUBLE PRECISION xmax,qDq(10,10),xlosn
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data iplace /
+ + 3,4,5,6, 09,10,11,21, 15,16, 00,
+ + 2,4,5,6, 14,10,11,18, 20,16, 00,
+ + 2,3,5,6, 08,15,11,18, 20,21, 00,
+ + 2,3,4,6, 08,09,16,18, 14,21, 00,
+ + 2,3,4,5, 08,09,10,20, 14,15, 00,
+ + 1,4,5,6, 19,10,11,12, 17,16, 00,
+ + 1,3,5,6, 13,15,11,12, 17,21, 00,
+ + 1,3,4,6, 13,09,16,12, 19,21, 00,
+ + 1,3,4,5, 13,09,10,17, 19,15, 00,
+ + 1,2,5,6, 07,20,11,12, 17,18, 00,
+ + 1,2,4,6, 07,14,16,12, 19,18, 00,
+ + 1,2,4,5, 07,14,10,17, 19,20, 00,
+ + 1,2,3,6, 07,08,21,12, 13,18, 00,
+ + 1,2,3,5, 07,08,15,17, 13,20, 00,
+ + 1,2,3,4, 07,08,09,19, 13,14, 00/
+*
+ data isigns /
+ + +1,+1,+1,+1, +1,+1,+1,-1, -1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,-1, -1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, +1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, +1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, +1,-1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,-1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,-1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +0,
+ + +1,+1,+1,+1, +1,+1,+1,-1, -1,+1, +0/
+*
+ data ij2k /
+ + 0, 1, 2, 3, 4, 5,
+ + 1, 0, 6, 7, 8, 9,
+ + 2, 6, 0,10,11,12,
+ + 3, 7,10, 0,13,14,
+ + 4, 8,11,13, 0,15,
+ + 5, 9,12,14,15, 0/
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ if ( inum.eq.jnum ) print *,'ffpi64: undefined for i=j ',
+ + inum,jnum
+ if ( inum.lt.1 .or. inum.gt.6 .or. jnum.lt.1 .or. jnum.gt.6
+ + ) print *,'ffpi84: i or j out of range ',inum,jnum
+ ier0 = 0
+ call ffxhck(xpi,dpipj,21,ier0)
+ if ( ier0 .ne. 0 ) print *,'ffpi64: dpipj corrupted'
+ endif
+* #] check input:
+* #[ distribute:
+ knum = ij2k(inum,jnum)
+*
+* copy p5-p11
+*
+ do 20 i=1,10
+ xpi4(i) = xpi(iplace(i,knum))
+ do 10 j=1,10
+ dpipj4(j,i) = dpipj(iplace(j,knum),iplace(i,knum))
+ 10 continue
+ 20 continue
+*
+* these cannot be simply copied I think
+*
+ xpi4(11) = xpi4(5)+xpi4(6)+xpi4(7)+xpi4(8)-xpi4(9)-xpi4(10)
+ if ( lwarn ) then
+ xmax = max(abs(xpi4(5)),abs(xpi4(6)),abs(xpi4(7)),
+ + abs(xpi4(8)),abs(xpi4(9)),abs(xpi4(10)))
+ if ( abs(xpi4(11)) .lt. xloss*xmax )
+ + call ffwarn(153,ier,xpi4(11),xmax)
+ endif
+ xpi4(12) = -xpi4(5)+xpi4(6)-xpi4(7)+xpi4(8)+xpi4(9)+xpi4(10)
+ if ( lwarn ) then
+ xmax = max(abs(xpi4(5)),abs(xpi4(6)),abs(xpi4(7)),
+ + abs(xpi4(8)),abs(xpi4(9)),abs(xpi4(10)))
+ if ( abs(xpi4(12)) .lt. xloss*xmax )
+ + call ffwarn(154,ier,xpi4(12),xmax)
+ endif
+ xpi4(13) = xpi4(5)-xpi4(6)+xpi4(7)-xpi4(8)+xpi4(9)+xpi4(10)
+ if ( lwarn ) then
+ xmax = max(abs(xpi4(5)),abs(xpi4(6)),abs(xpi4(7)),
+ + abs(xpi4(8)),abs(xpi4(9)),abs(xpi4(10)))
+ if ( abs(xpi4(13)) .lt. xloss*xmax )
+ + call ffwarn(155,ier,xpi4(13),xmax)
+ endif
+*
+* and the differences
+*
+ do 40 i=11,13
+ do 30 j=1,10
+ dpipj4(j,i) = xpi4(j) - xpi4(i)
+ 30 continue
+ 40 continue
+*
+* copy the dotproducts (watch the signs of p9,p10!)
+*
+ do 60 i=1,10
+ do 50 j=1,10
+ piDpj4(j,i) = isigns(j,knum)*isigns(i,knum)*
+ + piDpj(iplace(j,knum),iplace(i,knum))
+ 50 continue
+ 60 continue
+* #] distribute:
+* #[ check:
+ if ( lwrite ) then
+ print *,'ffpi64: '
+ print *,' knum = ',knum
+ print *,' iplace = ',(iplace(i,knum),i=1,10)
+ print *,' isigns = ',(isigns(i,knum),i=1,10)
+ print *,' xpi4 = ',xpi4
+ endif
+ if ( ltest ) then
+ ier0 = 0
+ call ffxhck(xpi4,dpipj4,10,ier0)
+ call ffxuvw(xpi4,dpipj4,ier0)
+ if ( ier0 .ne. 0 ) print *,'ffpi64: error detected'
+*
+* check piDpj
+*
+ ier0 = 0
+ call ffdot4(qDq,xpi4,dpipj4,10,ier0)
+ xlosn = xloss**2*DBLE(10)**(-mod(ier0,50))
+ do 190 i=1,10
+ do 180 j=1,10
+ if ( xlosn*abs(qDq(j,i)-piDpj4(j,i)) .gt. precx*
+ + abs(qDq(j,i)) ) print *,'ffpi64: error: ',
+ + 'piDpj4(',j,i,') not correct: ',piDpj4(j,i),
+ + qDq(j,i),piDpj4(j,i)-qDq(j,i)
+ 180 continue
+ 190 continue
+ endif
+* #] check:
+*###] ffpi64:
+ end
diff --git a/ff-2.0/ffxli2.f b/ff-2.0/ffxli2.f
new file mode 100644
index 0000000..e7bf7f8
--- /dev/null
+++ b/ff-2.0/ffxli2.f
@@ -0,0 +1,640 @@
+*###[ ffxli2:
+ subroutine ffxli2(xdilog,xlog,x,ier)
+***#[*comment:***********************************************************
+* *
+* Computes the dilogarithm (Li2, Sp) for (real) x to precision *
+* precx. It is assumed that -1<=x<=1/2. As it is available anyway*
+* log(1-x) = -Li1(x) is also passed. *
+* *
+* Input: x (real) *
+* *
+* Output: xdilog (real) Li2(x) *
+* xlog (real) log(1-x) = -Li1(x) *
+* ier (integer) 0=OK, 1=num prob, 2=error *
+* *
+* Calls: log,dfflo1 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE PRECISION xdilog,xlog,x
+*
+* local variables
+*
+ integer ipi12
+ DOUBLE PRECISION dfflo1,u,u2,a,ffbnd,
+ + xprec,bdn02,bdn05,bdn10,bdn15,bdn20
+ DOUBLE COMPLEX zxdilo,zlog
+ save xprec,bdn02,bdn05,bdn10,bdn15,bdn20
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ initialisations:
+ data xprec /-1./
+ if ( xprec .ne. precx ) then
+ xprec = precx
+ bdn02 = ffbnd(1,2,bf)
+ bdn05 = ffbnd(1,5,bf)
+ bdn10 = ffbnd(1,10,bf)
+ bdn15 = ffbnd(1,15,bf)
+ bdn20 = ffbnd(1,19,bf)
+ endif
+* #] initialisations:
+* #[ if the argument is too large...
+ if ( x .lt. -1.5 .or. x .gt. .75 ) then
+ if ( ltest ) call fferr(29,ier)
+ call ffzxdl(zxdilo,ipi12,zlog,x,0,ier)
+ if ( DIMAG(zxdilo) .ne. 0 ) then
+ call fferr(52,ier)
+ endif
+ xdilog = DBLE(zxdilo) + ipi12*pi12
+ xlog = DBLE(zlog)
+ return
+ endif
+* #] if the argument is too large...
+* #[ exceptional cases:
+ if ( x .eq. -1 ) then
+ xdilog = -pi12
+ xlog = log(x2)
+ return
+ elseif ( x .eq. x05 ) then
+ xdilog = - xlg2**2/2 + pi12
+ xlog = - xlg2
+ return
+ elseif ( abs(x) .lt. precx ) then
+ xdilog = x
+ xlog = -x
+ return
+ endif
+* #] exceptional cases:
+* #[ calculate dilog:
+ if ( abs(x) .lt. xloss ) then
+ xlog = dfflo1(x,ier)
+ else
+ xlog = log(1-x)
+ endif
+ u = -xlog
+ u2 = u*u
+ a = abs(u2)
+ if ( lwarn .and. a .gt. bdn20 ) then
+ call ffwarn(60,ier,precx,bf(20)*a**20)
+ endif
+ if ( a .gt. bdn15 ) then
+ xdilog = u2*(bf(16) + u2*(bf(17) + u2*(bf(18) +
+ + u2*(bf(19) + u2*(bf(20))))))
+ else
+ xdilog = 0
+ endif
+ if ( a .gt. bdn10 ) then
+ xdilog = u2*(bf(11) + u2*(bf(12) + u2*(bf(13) +
+ + u2*(bf(14) + u2*(bf(15) + xdilog)))))
+ endif
+ if ( a .gt. bdn05 ) then
+ xdilog = u2*(bf(6) + u2*(bf(7) + u2*(bf(8) +
+ + u2*(bf(9) + u2*(bf(10) + xdilog)))))
+ endif
+ if ( a .gt. bdn02 ) then
+ xdilog = u2*(bf(3) + u2*(bf(4) + u2*(bf(5) + xdilog)))
+ endif
+* watch the powers of u.
+ xdilog = u + u2*(bf(1) + u*(bf(2) + xdilog))
+* #] calculate dilog:
+*###] ffxli2:
+ end
+*###[ ffzxdl:
+ subroutine ffzxdl(zxdilo,ipi12,zlog,x,ieps,ier)
+***#[*comment:***************************************************
+* Computes the dilogarithm (Li2, Sp) for any (real) x *
+* to precision precx. If an error message is given add *
+* more bf's. For x > 1 the imaginary part is *
+* -/+i*pi*log(x), corresponding to x+ieps. *
+* The number of factors pi^2/12 is passed separately in *
+* ipi12 for accuracy. We also calculate log(1-x) *
+* which is likely to be needed. *
+* *
+* Input: x (real) *
+* ieps (integer,+/-1) *
+* *
+* Output: zxdilo (complex) the dilog mod factors pi2/12 *
+* ipi12 (integer) these factors *
+* zlog (complex) log(1-x) *
+* *
+* Calls: log,dfflo1 *
+* *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ipi12,ieps,ier
+ DOUBLE PRECISION x
+ DOUBLE COMPLEX zxdilo,zlog
+*
+* local variables
+*
+ integer jsgn
+ DOUBLE PRECISION fact,u,u2,dfflo1,ffbnd,a,xdilo,
+ + xprec,bdn02,bdn05,bdn10,bdn15,bdn20
+ DOUBLE COMPLEX cy,cfact
+ save xprec,bdn02,bdn05,bdn10,bdn15,bdn20
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ initialisations:
+ data xprec /-1./
+ if ( xprec .ne. precx ) then
+ xprec = precx
+ bdn02 = ffbnd(1,2,bf)
+ bdn05 = ffbnd(1,5,bf)
+ bdn10 = ffbnd(1,10,bf)
+ bdn15 = ffbnd(1,15,bf)
+ bdn20 = ffbnd(1,19,bf)
+ endif
+* #] initialisations:
+* #[ exceptional cases:
+ if ( x .eq. 1) then
+ zxdilo = 0
+ zlog = -99999
+ ipi12 = 2
+ return
+ elseif (x .eq. -1) then
+ zxdilo = 0
+ zlog = xlg2
+ ipi12 = -1
+ return
+ elseif (x .eq. x05) then
+ zxdilo = - xlg2**2/2
+ zlog = -xlg2
+ ipi12 = 1
+ return
+ elseif ( abs(x) .lt. precx ) then
+ zxdilo = x
+ zlog = -x
+ ipi12 = 0
+ return
+ endif
+* #] exceptional cases:
+* #[ transform to (-1,.5):
+ if (x .lt. -1) then
+ fact = log(-x)
+ cy = - fact**2/2
+ ipi12 = -2
+ if ( -x*xloss .gt. 1 ) then
+ u = -dfflo1(1/x,ier)
+ else
+ u = -log(1-1/x)
+ endif
+ zlog = log(1-x)
+ jsgn = -1
+ elseif ( x .lt. x05) then
+ cy = 0
+ ipi12 = 0
+ if ( abs(x) .lt. xloss ) then
+ zlog = dfflo1(x,ier)
+ else
+ zlog = log(1-x)
+ endif
+ u = -DBLE(zlog)
+ jsgn = 1
+ elseif ( x .le. 2 ) then
+ u = -log(x)
+ if ( abs(1-x) .lt. xalogm ) then
+ if ( lwarn ) call ffwarn(64,ier,1-x,xalogm)
+ cy = 0
+ elseif ( x .lt. 1 ) then
+ zlog = log(1-x)
+ cy = DBLE(u)*zlog
+ elseif ( ieps .gt. 0 ) then
+ zlog = DCMPLX(log(x-1),-pi)
+ cy = DBLE(u)*zlog
+ else
+ zlog = DCMPLX(log(x-1),+pi)
+ cy = DBLE(u)*zlog
+ endif
+ ipi12 = 2
+ jsgn = -1
+ else
+ if ( ieps .gt. 0 ) then
+ cfact = DCMPLX(log(x),-pi)
+ zlog = DCMPLX(log(x-1),-pi)
+ else
+ cfact = DCMPLX(log(x),+pi)
+ zlog = DCMPLX(log(x-1),+pi)
+ endif
+ cy = - cfact**2/2
+ ipi12 = -2
+ if ( x*xloss .gt. 1 ) then
+ u = -dfflo1(1/x,ier)
+ else
+ u = -log(1-1/x)
+ endif
+ jsgn = -1
+ endif
+* #] transform to (-1,.5):
+* #[ calculate dilog:
+ if ( abs(u) .lt. xalog2 ) then
+ xdilo = u
+ else
+ u2 = u**2
+ a = abs(u2)
+ if ( lwarn .and. a .gt. bdn20 ) then
+ call ffwarn(66,ier,precx,bf(20)*a**20)
+ endif
+ if ( a .gt. bdn15 ) then
+ xdilo = u2*(bf(16) + u2*(bf(17) + u2*(bf(18) +
+ + u2*(bf(19) + u2*(bf(20))))))
+ else
+ xdilo = 0
+ endif
+ if ( a .gt. bdn10 ) then
+ xdilo = u2*(bf(11) + u2*(bf(12) + u2*(bf(13) +
+ + u2*(bf(14) + u2*(bf(15) + xdilo)))))
+ endif
+ if ( a .gt. bdn05 ) then
+ xdilo = u2*(bf(6) + u2*(bf(7) + u2*(bf(8) +
+ + u2*(bf(9) + u2*(bf(10) + xdilo)))))
+ endif
+ if ( a .gt. bdn02 ) then
+ xdilo = u2*(bf(3) + u2*(bf(4) + u2*(bf(5) + xdilo)))
+ endif
+* watch the powers of u.
+ xdilo = u + u2*(bf(1) + u*(bf(2) + xdilo))
+ endif
+ if(jsgn.eq.1)then
+ zxdilo = DBLE(xdilo) + cy
+ else
+ zxdilo = -DBLE(xdilo) + cy
+ endif
+* #] calculate dilog:
+*###] ffzxdl:
+ end
+*###[ zxfflg:
+ DOUBLE COMPLEX function zxfflg(x,ieps,y,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate the complex logarithm of x. The following cases *
+* are treted separately: *
+* |x| too small: give warning and return 0 *
+* (for Absoft, Apollo DN300) *
+* |x| < 0: take sign according to ieps *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+*
+* arguments
+*
+ implicit none
+ integer ieps,ier
+ DOUBLE PRECISION x,y
+*
+* local variables
+*
+ DOUBLE PRECISION xlog
+*
+* common blocks
+*
+ include 'ff.h'
+* #] declarations:
+* #[ check input:
+ if ( lwarn .and. abs(x-1) .lt. xloss ) then
+ call ffwarn(129,ier,abs(x-1),x1)
+ endif
+* #] check input:
+* #[ calculations:
+ if ( abs(x) .lt. xalogm ) then
+ if ( lwarn .and. x .ne. 0 ) call ffwarn(53,ier,x,xalogm)
+ zxfflg = 0
+ elseif ( x .gt. 0 ) then
+ zxfflg = log(x)
+ else
+ xlog = log(-x)
+* checked imaginary parts 19-May-1988
+ if ( abs(ieps) .eq. 1 ) then
+ if ( y*ieps .lt. 0 ) then
+ zxfflg = DCMPLX(xlog,-pi)
+ else
+ zxfflg = DCMPLX(xlog,pi)
+ endif
+ elseif ( ieps .eq. 2 ) then
+ zxfflg = DCMPLX(xlog,-pi)
+ elseif ( ieps .eq. -2 ) then
+ zxfflg = DCMPLX(xlog,+pi)
+ else
+ call fferr(52,ier)
+ zxfflg = DCMPLX(xlog,pi)
+ endif
+ endif
+* #] calculations:
+*###] zxfflg:
+ end
+*###[ dfflo1:
+ DOUBLE PRECISION function dfflo1(x,ier)
+***#[*comment:***************************************************
+* calculates log(1-x) for |x|<.14 in a faster way to ~15 *
+* significant figures. *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+ integer ier
+ DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,bdn19,xprec,
+ + xa,d1,xheck,ffbnd
+ DOUBLE COMPLEX zxfflg
+ save xprec,bdn01,bdn05,bdn10,bdn15,bdn19
+ include 'ff.h'
+* #] declarations:
+* #[ initialisation:
+ data xprec /-1./
+ if ( xprec .ne. precx ) then
+ xprec = precx
+* determine the boundaries for 1,5,10,15 terms
+ bdn01 = ffbnd(1,1,xninv)
+ bdn05 = ffbnd(1,5,xninv)
+ bdn10 = ffbnd(1,10,xninv)
+ bdn15 = ffbnd(1,15,xninv)
+ bdn19 = ffbnd(1,19,xninv)
+ endif
+* #] initialisation:
+* #[ calculations:
+ xa = abs(x)
+ if ( xa .gt. bdn19 ) then
+ if ( lwarn .and. xa .lt. xloss ) call ffwarn(62,ier,x,x1)
+ if ( lwarn .and. 1-x.lt. xloss ) call ffwarn(132,ier,1-x,x1)
+ dfflo1 = DBLE(zxfflg(1-x,0,x0,ier))
+ return
+ endif
+ if ( xa .gt. bdn15 ) then
+ dfflo1 = x*( xninv(16) + x*( xninv(17) + x*( xninv(18) +
+ + x*( xninv(19) + x*( xninv(20) )))))
+ else
+ dfflo1 = 0
+ endif
+ if ( xa .gt. bdn10 ) then
+ dfflo1 = x*( xninv(11) + x*( xninv(12) + x*( xninv(13) +
+ + x*( xninv(14) + x*( xninv(15) + dfflo1 )))))
+ endif
+ if ( xa .gt. bdn05 ) then
+ dfflo1 = x*( xninv(6) + x*( xninv(7) + x*( xninv(8) +
+ + x*( xninv(9) + x*( xninv(10) + dfflo1 )))))
+ endif
+ if ( xa .gt. bdn01 ) then
+ dfflo1 = x*( xninv(2) + x*( xninv(3) + x*( xninv(4) +
+ + x*( xninv(5) + dfflo1 ))))
+ endif
+ dfflo1 = - x*( xninv(1) + dfflo1 )
+* #] calculations:
+* #[ check output:
+ if ( ltest ) then
+ d1 = log(1-x)
+ xheck = d1-dfflo1
+ if ( xloss*abs(xheck) .gt. precx ) print *,'dfflo1: error:',
+ + ' answer is not OK',d1,dfflo1,xheck
+ endif
+* #] check output:
+*###] dfflo1:
+ end
+*###[ dfflo2:
+ DOUBLE PRECISION function dfflo2(x,ier)
+***#[*comment:***************************************************
+* calculates log(1-x)+x for |x|<.14 in a faster way to *
+* ~15 significant figures. *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+ integer ier,ier0
+ DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,bdn18,xprec,
+ + xa,d1,xheck,ffbnd,dfflo1
+ save xprec,bdn01,bdn05,bdn10,bdn15,bdn18
+ include 'ff.h'
+* #] declarations:
+* #[ initialisation:
+ data xprec /-1./
+ if ( xprec .ne. precx ) then
+ xprec = precx
+* determine the boundaries for 1,5,10,15 terms
+ bdn01 = ffbnd(1,1,xninv(2))
+ bdn05 = ffbnd(1,5,xninv(2))
+ bdn10 = ffbnd(1,10,xninv(2))
+ bdn15 = ffbnd(1,15,xninv(2))
+ bdn18 = ffbnd(1,18,xninv(2))
+ endif
+* #] initialisation:
+* #[ calculations:
+ xa = abs(x)
+ if ( xa .gt. bdn18 ) then
+ dfflo2 = dfflo1(x,ier) + x
+ if ( lwarn .and. abs(dfflo2).lt.xloss*abs(x) ) then
+ call ffwarn(231,ier,dfflo2,x)
+ if ( lwrite ) print *,'dfflo2: not enough terms, x = ',x
+ endif
+ return
+ endif
+ if ( xa .gt. bdn15 ) then
+ dfflo2 = x*( xninv(17) + x*( xninv(18) + x*( xninv(19) +
+ + x*( xninv(20) ))))
+ else
+ dfflo2 = 0
+ endif
+ if ( xa .gt. bdn10 ) then
+ dfflo2 = x*( xninv(12) + x*( xninv(13) + x*( xninv(14) +
+ + x*( xninv(15) + x*( xninv(16) + dfflo2 )))))
+ endif
+ if ( xa .gt. bdn05 ) then
+ dfflo2 = x*( xninv(7) + x*( xninv(8) + x*( xninv(9) +
+ + x*( xninv(10) + x*( xninv(11) + dfflo2 )))))
+ endif
+ if ( xa .gt. bdn01 ) then
+ dfflo2 = x*( xninv(3) + x*( xninv(4) + x*( xninv(5) +
+ + x*( xninv(6) + dfflo2 ))))
+ endif
+ dfflo2 = - x**2*( xninv(2) + dfflo2 )
+* #] calculations:
+* #[ check output:
+ if ( ltest ) then
+ ier0 = ier
+ d1 = dfflo1(x,ier0) + x
+ xheck = d1-dfflo2
+ if ( xloss*abs(xheck) .gt. precx ) print *,'dfflo2: error:',
+ + ' answer is not OK',d1,dfflo2,xheck
+ endif
+* #] check output:
+*###] dfflo2:
+ end
+*###[ dfflo3:
+ DOUBLE PRECISION function dfflo3(x,ier)
+***#[*comment:***************************************************
+* calculates log(1-x)+x+x^2/2 for |x|<.14 in a faster *
+* way to ~15 significant figures. *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+ integer ier,ier0
+ DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,xprec,
+ + xa,d1,xheck,ffbnd,dfflo2
+ save xprec,bdn01,bdn05,bdn10,bdn15
+ include 'ff.h'
+* #] declarations:
+* #[ initialisation:
+ data xprec /-1./
+ if ( xprec .ne. precx ) then
+ xprec = precx
+* determine the boundaries for 1,5,10,15 terms
+ bdn01 = ffbnd(1,1,xninv(3))
+ bdn05 = ffbnd(1,5,xninv(3))
+ bdn10 = ffbnd(1,10,xninv(3))
+ bdn15 = ffbnd(1,15,xninv(3))
+ endif
+* #] initialisation:
+* #[ calculations:
+ xa = abs(x)
+ if ( xa .gt. bdn15 ) then
+ dfflo3 = dfflo2(x,ier) + x**2/2
+ if ( lwarn .and. abs(dfflo3).lt.xloss*x**2/2 ) then
+ call ffwarn(232,ier,dfflo3,x**2/2)
+ if ( lwrite ) print *,'dfflo3: not enough terms, x = ',x
+ endif
+ return
+ endif
+ if ( xa .gt. bdn10 ) then
+ dfflo3 = x*( xninv(13) + x*( xninv(14) + x*( xninv(15) +
+ + x*( xninv(16) + x*( xninv(17) )))))
+ else
+ dfflo3 = 0
+ endif
+ if ( xa .gt. bdn05 ) then
+ dfflo3 = x*( xninv(8) + x*( xninv(9) + x*( xninv(10) +
+ + x*( xninv(11) + x*( xninv(12) + dfflo3 )))))
+ endif
+ if ( xa .gt. bdn01 ) then
+ dfflo3 = x*( xninv(4) + x*( xninv(5) + x*( xninv(6) +
+ + x*( xninv(7) + dfflo3 ))))
+ endif
+ dfflo3 = - x**3*( xninv(3) + dfflo3 )
+* #] calculations:
+* #[ check output:
+ if ( ltest ) then
+ ier0 = ier
+ d1 = dfflo2(x,ier0) + x**2/2
+ xheck = d1-dfflo3
+ if ( xloss*abs(xheck) .gt. precx ) print *,'dfflo3: error:',
+ + ' answer is not OK',d1,dfflo3,xheck
+ endif
+* #] check output:
+*###] dfflo3:
+ end
+*###[ ffxl22:
+ subroutine ffxl22(xl22,x,ier)
+***#[*comment:***************************************************
+* calculates Li2(2-x) for |x|<.14 in a faster way to ~15 *
+* significant figures. *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+ integer ier,ier0,ipi12p,init
+ DOUBLE COMPLEX zli2,zdum
+ DOUBLE PRECISION xl22,x,bdn01,bdn05,bdn10,bdn15,bdn20,bdn25,
+ + xprec,xa,xheck,ffbnd,dilog2(29)
+ save xprec,bdn01,bdn05,bdn10,bdn15,bdn20,bdn25,init,dilog2
+ include 'ff.h'
+ data xprec /-1./
+ data init /0/
+ if ( init .eq. 0 ) then
+ init = 1
+* taylor(dilog(x-1),x,30);
+ dilog2( 1) = 0.d0
+ dilog2( 2) = 1/4.d0
+ dilog2( 3) = 1/6.d0
+ dilog2( 4) = 5/48.d0
+ dilog2( 5) = 1/15.d0
+ dilog2( 6) = 2/45.d0
+ dilog2( 7) = 13/420.d0
+ dilog2( 8) = 151/6720.d0
+ dilog2( 9) = 16/945.d0
+ dilog2(10) = 83/6300.d0
+ dilog2(11) = 73/6930.d0
+ dilog2(12) = 1433/166320.d0
+ dilog2(13) = 647/90090.d0
+ dilog2(14) = 15341/2522520.d0
+ dilog2(15) = 28211/5405400.d0
+ dilog2(16) = 10447/2306304.d0
+ dilog2(17) = 608/153153.d0
+ dilog2(18) = 19345/5513508.d0
+ dilog2(19) = 18181/5819814.d0
+ dilog2(20) = 130349/46558512.d0
+ dilog2(21) = 771079/305540235.d0
+ dilog2(22) = 731957/320089770.d0
+ dilog2(23) = 2786599/1338557220.d0
+ dilog2(24) = 122289917/64250746560.d0
+ dilog2(25) = 14614772/8365982625.d0
+ dilog2(26) = 140001721/87006219300.d0
+ dilog2(27) = 134354573/90352612350.d0
+ dilog2(28) = 774885169/562194032400.d0
+ dilog2(29) = 745984697/582272390700.d0
+ endif
+* #] declarations:
+* #[ initialisation:
+ if ( xprec .ne. precx ) then
+ xprec = precx
+* determine the boundaries for 1,5,10,15,20 terms
+ bdn01 = ffbnd(2,1,dilog2)
+ bdn05 = ffbnd(2,5,dilog2)
+ bdn10 = ffbnd(2,10,dilog2)
+ bdn15 = ffbnd(2,15,dilog2)
+ bdn20 = ffbnd(2,20,dilog2)
+ bdn25 = ffbnd(2,25,dilog2)
+* print *,'bdn01 = ',bdn01
+* print *,'bdn25 = ',bdn25
+* print *,'dilog2 = ',dilog2
+ endif
+* #] initialisation:
+* #[ calculations:
+ xa = abs(x)
+ if ( xa .gt. bdn25 ) then
+ call ffwarn(230,ier,precx,dilog2(27)*xa**25)
+ endif
+ if ( xa .gt. bdn20 ) then
+ xl22 = x*( dilog2(22) + x*( dilog2(23) + x*( dilog2(24) +
+ + x*( dilog2(25) + x*( dilog2(26) )))))
+ else
+ xl22 = 0
+ endif
+ if ( xa .gt. bdn15 ) then
+ xl22 = x*( dilog2(17) + x*( dilog2(18) + x*( dilog2(19) +
+ + x*( dilog2(20) + x*( dilog2(21) )))))
+ endif
+ if ( xa .gt. bdn10 ) then
+ xl22 = x*( dilog2(12) + x*( dilog2(13) + x*( dilog2(14) +
+ + x*( dilog2(15) + x*( dilog2(16) )))))
+ endif
+ if ( xa .gt. bdn05 ) then
+ xl22 = x*( dilog2(7) + x*( dilog2(8) + x*( dilog2(9) +
+ + x*( dilog2(10) + x*( dilog2(11) + xl22 )))))
+ endif
+ if ( xa .gt. bdn01 ) then
+ xl22 = x*( dilog2(3) + x*( dilog2(4) + x*( dilog2(5) +
+ + x*( dilog2(6) + xl22 ))))
+ endif
+ xl22 = - x**2*( dilog2(2) + xl22 )
+* #] calculations:
+* #[ check output:
+ if ( ltest ) then
+ ier0 = 0
+ ipi12p = 0
+ call ffzxdl(zli2,ipi12p,zdum,2-x,1,ier0)
+ xheck = DBLE(zli2)-xl22 + (ipi12p-3)*pi12
+ if ( xloss*abs(xheck) .gt. precc*2.5 ) then
+ print *,'xl22: error: answer is not OK',
+ + DBLE(zli2)+ipi12p*pi12,xl22+3*pi12,xheck
+ endif
+ endif
+* #] check output:
+*###] ffxl22:
+ end
diff --git a/ff-2.0/ffxxyz.f b/ff-2.0/ffxxyz.f
new file mode 100644
index 0000000..e9bd707
--- /dev/null
+++ b/ff-2.0/ffxxyz.f
@@ -0,0 +1,856 @@
+*###[ ffxxyz:
+ subroutine ffxxyz(y,z,dyz,d2yzz,dy2z,ivert,sdel2p,sdel2s,etalam,
+ + etami,delps,xpi,dpipj,piDpj,isoort,ldel2s,ns,ier)
+***#[*comment:***********************************************************
+* *
+* calculate in a numerically stable way *
+* *
+* z(1,2) = (-p(ip1).p(is2) +/- sdel2s)/xpi(ip1) *
+* y(1,2) = (-p(ip1).p(is2) +/- sdisc)/xpi(ip1) *
+* disc = del2s + etaslam*xpi(ip1) *
+* *
+* y(3,4) = 1-y(1,2) *
+* z(3,4) = 1-z(1,2) *
+* dyz(i,j) = y(i) - z(j) *
+* d2yzz = y(2) - z(1) - z(2) *
+* dy2z(j) = y(2) - 2*z(j) *
+* *
+* Input: ivert (integer) defines the vertex *
+* sdel2p (real) sqrt(lam(p1,p2,p3))/2 *
+* sdel2s (real) sqrt(lam(p,ma,mb))/2 *
+* etalam (real) det(si.sj)/det(pi.pj) *
+* etami(6) (real) si.si - etalam *
+* xpi(ns) (real) standard *
+* piDpj(ns,ns) (real) standard *
+* ns (integer) dim of xpi,piDpj *
+* *
+* Output: y(4),z(4),dyz(4,4) (real) see above *
+* *
+* Calls: fferr,ffroot *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ivert,ns,ier,isoort(2)
+ logical ldel2s
+ DOUBLE PRECISION y(4),z(4),dyz(2,2),d2yzz,dy2z(4),
+ + sdel2p,sdel2s,etalam,etami(6),delps,xpi(ns),
+ + dpipj(ns,ns),piDpj(ns,ns)
+*
+* local variables:
+*
+ integer i,j,n,ip1,ip2,ip3,is1,is2,is3,iwarn,ier0,ier1
+ DOUBLE PRECISION delps1,disc,xheck,xlosn,hulp,s,smax,som(51),
+ + xmax
+ DOUBLE PRECISION t1,t2,t4,t5,t8,t3,t7,t9,t12,t14,t21,t23,t24,
+ + t28,t6,t35,t44,t42,t36,t55,t41,t19,t59,t25,t69,t82,t75,t84,t92,
+ + t31,t98,t74,t101,t89,t106,t112,t113,t13,t117,t126,t127,t129,
+ + t130,t133,t128,t132,t134,t137,t139,t146,t148,t149,t153,t131,
+ + t160,t171,t169,t161,t182,t168,t144,t186,t150,t208,t201,t210,
+ + t219,t156,t225,t200,t228,t215,t233,t239,t240,t138,t244
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ set up pointers:
+ if ( ldel2s .and. ivert .ne. 1 ) goto 100
+ is1 = ivert
+ is2 = ivert+1
+ if ( is2 .eq. 4 ) is2 = 1
+ is3 = ivert-1
+ if ( is3 .eq. 0 ) is3 = 3
+ ip1 = is1 + 3
+ ip2 = is2 + 3
+ ip3 = is3 + 3
+* #] set up pointers:
+* #[ xk = 0:
+ if ( xpi(ip1) .eq. 0 ) then
+ isoort(2) = 0
+ if ( piDpj(is1,ip1) .eq. 0 ) then
+ isoort(1) = 0
+ if ( lwrite ) print *,'ffxxyz: xk=0, ma=mb -> S3 =0'
+ return
+ endif
+ isoort(1) = 1
+ y(1) = etami(is2) / piDpj(is1,ip1) /2
+ y(2) = y(1)
+ y(3) = - etami(is1) / piDpj(is1,ip1) /2
+ y(4) = y(3)
+ z(1) = xpi(is2) / piDpj(is1,ip1) /2
+ z(2) = z(1)
+ z(3) = - xpi(is1) / piDpj(is1,ip1) /2
+ z(4) = z(3)
+ dyz(1,1) = - etalam / piDpj(is1,ip1) /2
+ dyz(1,2) = dyz(1,1)
+ dyz(2,1) = dyz(1,1)
+ dyz(2,2) = dyz(1,1)
+ if ( ltest ) then
+* check whether we have the correct root ...
+ ier0 = ier
+ call ffdl2p(delps1,xpi,dpipj,piDpj,
+ + ip1,ip2,ip3,is1,is2,is3,ns,ier0)
+ disc = delps1/sdel2p
+ xheck = piDpj(ip1,is2) + disc
+ if ( xloss*abs(xheck) .gt. precx*max(abs(piDpj(ip1,
+ + is2)),abs(disc)) ) call fferr(37,ier)
+ endif
+ ier1 = ier
+ do 10 i=1,3,2
+ dy2z(i) = y(i) - 2*z(i)
+ smax = abs(y(i))
+ if ( lwarn .and. abs(dy2z(i)) .lt. xloss*smax ) then
+ ier0 = ier
+ call ffwarn(152,ier0,dy2z(i),smax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'special case xk = 0'
+ endif
+ dy2z(i+1) = dy2z(i)
+ 10 continue
+ ier = ier1
+ return
+ endif
+* #] xk = 0:
+* #[ get y(1,2),z(1,2):
+ if ( sdel2s .eq. 0 ) then
+ isoort(1) = 2
+ isoort(2) = 2
+ z(1) = piDpj(ip1,is2)/xpi(ip1)
+ z(2) = z(1)
+ else
+ isoort(1) = 1
+ isoort(2) = 1
+ call ffroot(z(1),z(2),xpi(ip1),piDpj(ip1,is2),xpi(is2),
+ + sdel2s,ier)
+ endif
+* if ( ltest ) then
+* call ffdl2p(delps1,xpi,dpipj,piDpj,
+* + ip1,ip2,ip3,is1,is2,is3,ns,ier)
+* if ( delps .ne. delps1 ) print *,'ffxxyz: error: delps != ',
+* + 'delps1: ',delps,delps1
+* endif
+ disc = delps/sdel2p
+ ier0 = ier
+ call ffroot(y(1),y(2),xpi(ip1),piDpj(ip1,is2),etami(is2),disc,
+ + ier)
+* #] get y(1,2),z(1,2):
+* #[ get y(3,4),z(3,4):
+* if ( xpi(is1) .eq. xpi(is2) ) then
+* y(4) = y(1)
+* y(3) = y(2)
+* z(4) = z(1)
+* z(3) = z(2)
+* else
+ if ( isoort(1) .eq. 2 ) then
+ z(3) = -piDpj(ip1,is1)/xpi(ip1)
+ z(4) = z(3)
+ else
+ z(3) = 1-z(1)
+ z(4) = 1-z(2)
+ if ( abs(z(3)) .lt. xloss .or. abs(z(4)) .lt. xloss )
+ + call ffroot(z(4),z(3),xpi(ip1),-piDpj(ip1,is1),
+ + xpi(is1),sdel2s,ier)
+ endif
+ y(3) = 1-y(1)
+ y(4) = 1-y(2)
+ if ( abs(y(3)) .lt. xloss .or. abs(y(4)) .lt. xloss ) then
+ call ffroot(y(4),y(3),xpi(ip1),-piDpj(ip1,is1),
+ + etami(is1),disc,ier)
+ endif
+* endif
+* #] get y(3,4),z(3,4):
+* #[ get dyz:
+* Note that dyz(i,j) only exists for i,j=1,2!
+ if ( isoort(1) .eq. 2 ) then
+ dyz(2,1) = disc/xpi(ip1)
+ dyz(2,2) = dyz(2,1)
+ elseif ( disc .gt. 0 .eqv. sdel2s .gt. 0 ) then
+ dyz(2,1) = ( disc + sdel2s )/xpi(ip1)
+ dyz(2,2) = etalam/(xpi(ip1)*dyz(2,1))
+ else
+ dyz(2,2) = ( disc - sdel2s )/xpi(ip1)
+ dyz(2,1) = etalam/(xpi(ip1)*dyz(2,2))
+ endif
+ dyz(1,1) = -dyz(2,2)
+ dyz(1,2) = -dyz(2,1)
+ d2yzz = 2*disc/xpi(ip1)
+*
+* these are very rarely needed, but ...
+*
+ iwarn = 0
+ ier1 = ier
+ do 20 i=1,4
+ j = 2*((i+1)/2)
+ dy2z(i) = y(j) - 2*z(i)
+ smax = abs(y(j))
+ if ( abs(dy2z(i)) .lt. xloss*smax ) then
+ if ( lwrite ) print *,' dy2z(',i,') = ',dy2z(i),smax
+ if ( i/2 .eq. 1 ) then
+ s = -y(j-1) - 2*sdel2s/xpi(ip1)
+ else
+ s = -y(j-1) + 2*sdel2s/xpi(ip1)
+ endif
+ if ( lwrite ) print *,' dy2z(',i,')+= ',s,y(j-1)
+ if ( abs(y(j-1)) .lt. smax ) then
+ dy2z(i) = s
+ smax = abs(y(j-1))
+ endif
+ if ( abs(dy2z(i)) .lt. xloss*smax ) then
+ if ( iwarn .ne. 0 ) then
+ if ( lwarn ) then
+ ier0 = ier
+ call ffwarn(152,ier0,dy2z(i),smax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) print *,'iwarn = ',i
+ endif
+ else
+ iwarn = i
+ xmax = smax
+ endif
+ endif
+ endif
+ 20 continue
+ if ( iwarn .ne. 0 ) then
+*
+* we should import the differences, but later...
+*
+ if ( abs(dpipj(is3,ip1)) .lt. xloss*xpi(is3)
+ + .and. abs(dpipj(is1,is2)) .lt. xloss*abs(xpi(ip1))) then
+*
+* give it another try - multiply roots (see dy2z.frm)
+*
+ if ( iwarn.lt.3 ) then
+*prod1=
+* som(1)=+160*xpi(ip1)*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2*
+* + dpipj(is2,is1)**2
+* som(2)=-40*xpi(ip1)*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is2)*dpipj(is2,is1)**3
+* som(3)=-32*xpi(ip1)*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
+* + is1)**3
+* som(4)=+9*xpi(ip1)*xpi(ip2)**2*dpipj(is2,is1)**4
+* som(5)=-128*xpi(ip1)*xpi(is2)*piDpj(ip1,ip2)**3*piDpj(ip2,
+* + is2)*dpipj(is2,is1)
+* som(6)=-128*xpi(ip1)*xpi(is2)*piDpj(ip1,ip2)**4*dpipj(is2,
+* + is1)
+* som(7)=+256*xpi(ip1)*xpi(is2)**2*piDpj(ip1,ip2)**4
+* som(8)=-16*xpi(ip1)*piDpj(ip1,ip2)**2*piDpj(ip2,is2)**2*
+* + dpipj(is2,is1)**2
+* som(9)=+96*xpi(ip1)*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*dpipj(is2,
+* + is1)**2
+* som(10)=+128*xpi(ip1)**2*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)*piDpj(
+* + ip2,is2)*dpipj(is2,is1)
+* som(11)=+320*xpi(ip1)**2*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2*
+* + dpipj(is2,is1)
+* som(12)=-512*xpi(ip1)**2*xpi(ip2)*xpi(is2)**2*piDpj(ip1,ip2)**2
+* som(13)=-120*xpi(ip1)**2*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is2)*dpipj(is2,is1)**2
+* som(14)=-48*xpi(ip1)**2*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
+* + is1)**2
+* som(15)=+40*xpi(ip1)**2*xpi(ip2)*piDpj(ip2,is2)**2*dpipj(is2,
+* + is1)**2
+* som(16)=-96*xpi(ip1)**2*xpi(ip2)**2*xpi(is2)*dpipj(is2,is1)**2
+* som(17)=+36*xpi(ip1)**2*xpi(ip2)**2*dpipj(is2,is1)**3
+* som(18)=+128*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**2*piDpj(ip2,
+* + is2)**2
+* som(19)=-128*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**3*piDpj(ip2,
+* + is2)
+* som(20)=-64*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**4
+* som(21)=-32*xpi(ip1)**2*piDpj(ip1,ip2)*piDpj(ip2,is2)**3*
+* + dpipj(is2,is1)
+* som(22)=-32*xpi(ip1)**2*piDpj(ip1,ip2)**2*piDpj(ip2,is2)**2*
+* + dpipj(is2,is1)
+* som(23)=+96*xpi(ip1)**2*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*
+* + dpipj(is2,is1)
+* som(24)=+128*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)*piDpj(
+* + ip2,is2)
+* som(25)=+160*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2
+* som(26)=-128*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip2,is2)**2
+* som(27)=+32*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is1)*piDpj(ip2,is2)
+* som(28)=-120*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is2)*dpipj(is2,is1)
+* som(29)=-32*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
+* + is1)
+* som(30)=-16*xpi(ip1)**3*xpi(ip2)*piDpj(ip2,is1)*piDpj(ip2,
+* + is2)**2
+* som(31)=+80*xpi(ip1)**3*xpi(ip2)*piDpj(ip2,is2)**2*dpipj(is2,
+* + is1)
+* som(32)=-192*xpi(ip1)**3*xpi(ip2)**2*xpi(is2)*dpipj(is2,is1)
+* som(33)=+256*xpi(ip1)**3*xpi(ip2)**2*xpi(is2)**2
+* som(34)=+54*xpi(ip1)**3*xpi(ip2)**2*dpipj(is2,is1)**2
+* som(35)=-16*xpi(ip1)**3*xpi(ip3)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is1)*piDpj(ip2,is2)
+* som(36)=+8*xpi(ip1)**3*xpi(ip3)*piDpj(ip2,is1)*piDpj(ip2,is2)**2
+* som(37)=+16*xpi(ip1)**3*xpi(is2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is1)*piDpj(ip2,is2)
+* som(38)=-8*xpi(ip1)**3*xpi(is2)*piDpj(ip2,is1)*piDpj(ip2,is2)**2
+* som(39)=-16*xpi(ip1)**3*piDpj(ip1,ip2)*piDpj(ip2,is1)*piDpj(ip2,
+* + is2)*dpipj(is3,ip1)
+* som(40)=+8*xpi(ip1)**3*piDpj(ip2,is1)*piDpj(ip2,is2)**2*
+* + dpipj(is3,ip1)
+* som(41)=-40*xpi(ip1)**4*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,is2)
+* som(42)=-8*xpi(ip1)**4*xpi(ip2)*piDpj(ip1,ip2)**2
+* som(43)=+40*xpi(ip1)**4*xpi(ip2)*piDpj(ip2,is2)**2
+* som(44)=-96*xpi(ip1)**4*xpi(ip2)**2*xpi(is2)
+* som(45)=+36*xpi(ip1)**4*xpi(ip2)**2*dpipj(is2,is1)
+* som(46)=+9*xpi(ip1)**5*xpi(ip2)**2
+* som(47)=-8*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,is1)**4
+* som(48)=-64*xpi(is2)*piDpj(ip1,ip2)**4*dpipj(is2,is1)**2
+* som(49)=+32*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*dpipj(is2,is1)**3
+* print '(7g20.12)',(som(i),i=1,49)
+*
+* optimized by Maple (see ffxxyz.map)
+*
+ t1 = xpi(ip1)
+ t2 = xpi(ip2)
+ t3 = t1*t2
+ t4 = xpi(is2)
+ t5 = piDpj(ip1,ip2)
+ t6 = t5**2
+ t7 = t4*t6
+ t8 = dpipj(is2,is1)
+ t9 = t8**2
+ som(1) = 160*t3*t7*t9
+ t12 = piDpj(ip2,is2)
+ t13 = t5*t12
+ t14 = t9*t8
+ som(2) = -40*t3*t13*t14
+ som(3) = -32*t3*t6*t14
+ t19 = t2**2
+ t21 = t9**2
+ som(4) = 9*t1*t19*t21
+ t23 = t1*t4
+ t24 = t6*t5
+ t25 = t24*t12
+ som(5) = -128*t23*t25*t8
+ t28 = t6**2
+ som(6) = -128*t23*t28*t8
+ t31 = t4**2
+ som(7) = 256*t1*t31*t28
+ t35 = t12**2
+ t36 = t35*t9
+ som(8) = -16*t1*t6*t36
+ som(9) = 96*t1*t24*t12*t9
+ t41 = t1**2
+ t42 = t41*t2
+ t44 = t13*t8
+ som(10) = 128*t42*t4*t44
+ som(11) = 320*t42*t7*t8
+ som(12) = -512*t42*t31*t6
+ som(13) = -120*t42*t13*t9
+ som(14) = -48*t42*t6*t9
+ som(15) = 40*t42*t36
+ t55 = t41*t19
+ som(16) = -96*t55*t4*t9
+ som(17) = 36*t55*t14
+ t59 = t41*t4
+ som(18) = 128*t59*t6*t35
+ som(19) = -128*t59*t25
+ som(20) = -64*t59*t28
+ som(21) = -32*t41*t5*t35*t12*t8
+ t69 = t35*t8
+ som(22) = -32*t41*t6*t69
+ som(23) = 96*t41*t24*t12*t8
+ t74 = t41*t1
+ t75 = t74*t2
+ som(24) = 128*t75*t4*t5*t12
+ som(25) = 160*t75*t7
+ som(26) = -128*t75*t4*t35
+ t82 = piDpj(ip2,is1)
+ t84 = t5*t82*t12
+ som(27) = 32*t75*t84
+ som(28) = -120*t75*t44
+ som(29) = -32*t75*t6*t8
+ t89 = t82*t35
+ som(30) = -16*t75*t89
+ som(31) = 80*t75*t69
+ t92 = t74*t19
+ som(32) = -192*t92*t4*t8
+ som(33) = 256*t92*t31
+ som(34) = 54*t92*t9
+ t98 = t74*xpi(ip3)
+ som(35) = -16*t98*t84
+ som(36) = 8*t98*t89
+ t101 = t74*t4
+ som(37) = 16*t101*t84
+ som(38) = -8*t101*t89
+ t106 = dpipj(is3,ip1)
+ som(39) = -16*t74*t5*t82*t12*t106
+ som(40) = 8*t74*t82*t35*t106
+ t112 = t41**2
+ t113 = t112*t2
+ som(41) = -40*t113*t13
+ som(42) = -8*t113*t6
+ som(43) = 40*t113*t35
+ t117 = t112*t19
+ som(44) = -96*t117*t4
+ som(45) = 36*t117*t8
+ som(46) = 9*t112*t1*t19
+ som(47) = -8*t2*t6*t21
+ som(48) = -64*t4*t28*t9
+ som(49) = 32*t25*t14
+* print '(7g20.12)',(som(i),i=1,49)
+ n=49
+ else
+*prod3=
+* som(1)=+160*xpi(ip1)*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2*
+* + dpipj(is2,is1)**2
+* som(2)=-40*xpi(ip1)*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is2)*dpipj(is2,is1)**3
+* som(3)=-88*xpi(ip1)*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
+* + is1)**3
+* som(4)=+9*xpi(ip1)*xpi(ip2)**2*dpipj(is2,is1)**4
+* som(5)=-128*xpi(ip1)*xpi(is2)*piDpj(ip1,ip2)**3*piDpj(ip2,
+* + is2)*dpipj(is2,is1)
+* som(6)=-256*xpi(ip1)*xpi(is2)*piDpj(ip1,ip2)**4*dpipj(is2,is1)
+* som(7)=+256*xpi(ip1)*xpi(is2)**2*piDpj(ip1,ip2)**4
+* som(8)=-16*xpi(ip1)*piDpj(ip1,ip2)**2*piDpj(ip2,is2)**2*dpipj(
+* + is2,is1)**2
+* som(9)=+64*xpi(ip1)*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*dpipj(is2,
+* + is1)**2
+* som(10)=+80*xpi(ip1)*piDpj(ip1,ip2)**4*dpipj(is2,is1)**2
+* som(11)=+128*xpi(ip1)**2*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)*piDpj(
+* + ip2,is2)*dpipj(is2,is1)
+* som(12)=+576*xpi(ip1)**2*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2*
+* + dpipj(is2,is1)
+* som(13)=-512*xpi(ip1)**2*xpi(ip2)*xpi(is2)**2*piDpj(ip1,ip2)**2
+* som(14)=-88*xpi(ip1)**2*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is2)*dpipj(is2,is1)**2
+* som(15)=-192*xpi(ip1)**2*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
+* + is1)**2
+* som(16)=+40*xpi(ip1)**2*xpi(ip2)*piDpj(ip2,is2)**2*dpipj(is2,
+* + is1)**2
+* som(17)=-96*xpi(ip1)**2*xpi(ip2)**2*xpi(is2)*dpipj(is2,is1)**2
+* som(18)=+60*xpi(ip1)**2*xpi(ip2)**2*dpipj(is2,is1)**3
+* som(19)=+128*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**2*piDpj(ip2,
+* + is2)**2
+* som(20)=-128*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**3*piDpj(ip2,
+* + is2)
+* som(21)=-64*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**4
+* som(22)=-32*xpi(ip1)**2*piDpj(ip1,ip2)*piDpj(ip2,is2)**3*
+* + dpipj(is2,is1)
+* som(23)=+64*xpi(ip1)**2*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*
+* + dpipj(is2,is1)
+* som(24)=+32*xpi(ip1)**2*piDpj(ip1,ip2)**4*dpipj(is2,is1)
+* som(25)=+128*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)*piDpj(
+* + ip2,is2)
+* som(26)=+160*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2
+* som(27)=-128*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip2,is2)**2
+* som(28)=+32*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is1)*piDpj(ip2,is2)
+* som(29)=-88*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is2)*dpipj(is2,is1)
+* som(30)=-88*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
+* + is1)
+* som(31)=-16*xpi(ip1)**3*xpi(ip2)*piDpj(ip2,is1)*piDpj(ip2,
+* + is2)**2
+* som(32)=+48*xpi(ip1)**3*xpi(ip2)*piDpj(ip2,is2)**2*dpipj(is2,
+* + is1)
+* som(33)=-320*xpi(ip1)**3*xpi(ip2)**2*xpi(is2)*dpipj(is2,is1)
+* som(34)=+256*xpi(ip1)**3*xpi(ip2)**2*xpi(is2)**2
+* som(35)=+118*xpi(ip1)**3*xpi(ip2)**2*dpipj(is2,is1)**2
+* som(36)=-16*xpi(ip1)**3*xpi(ip3)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is1)*piDpj(ip2,is2)
+* som(37)=+8*xpi(ip1)**3*xpi(ip3)*piDpj(ip2,is1)*piDpj(ip2,is2)**2
+* som(38)=+16*xpi(ip1)**3*xpi(is2)*piDpj(ip1,ip2)*piDpj(ip2,
+* + is1)*piDpj(ip2,is2)
+* som(39)=-8*xpi(ip1)**3*xpi(is2)*piDpj(ip2,is1)*piDpj(ip2,is2)**2
+* som(40)=-16*xpi(ip1)**3*piDpj(ip1,ip2)*piDpj(ip2,is1)*piDpj(ip2,
+* + is2)*dpipj(is3,ip1)
+* som(41)=+8*xpi(ip1)**3*piDpj(ip2,is1)*piDpj(ip2,is2)**2*
+* + dpipj(is3,ip1)
+* som(42)=-40*xpi(ip1)**4*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,is2)
+* som(43)=-8*xpi(ip1)**4*xpi(ip2)*piDpj(ip1,ip2)**2
+* som(44)=+40*xpi(ip1)**4*xpi(ip2)*piDpj(ip2,is2)**2
+* som(45)=-96*xpi(ip1)**4*xpi(ip2)**2*xpi(is2)
+* som(46)=+60*xpi(ip1)**4*xpi(ip2)**2*dpipj(is2,is1)
+* som(47)=+9*xpi(ip1)**5*xpi(ip2)**2
+* som(48)=-8*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,is1)**4
+* som(49)=-64*xpi(is2)*piDpj(ip1,ip2)**4*dpipj(is2,is1)**2
+* som(50)=+32*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*dpipj(is2,is1)**3
+* som(51)=+32*piDpj(ip1,ip2)**4*dpipj(is2,is1)**3
+* print '(7g20.12)',(som(i),i=1,51)
+*
+* optimized by Maple (see ffxxyz.map)
+*
+ t126 = xpi(ip1)
+ t127 = xpi(ip2)
+ t128 = t126*t127
+ t129 = xpi(is2)
+ t130 = piDpj(ip1,ip2)
+ t131 = t130**2
+ t132 = t129*t131
+ t133 = dpipj(is2,is1)
+ t134 = t133**2
+ som(1) = 160*t128*t132*t134
+ t137 = piDpj(ip2,is2)
+ t138 = t130*t137
+ t139 = t134*t133
+ som(2) = -40*t128*t138*t139
+ som(3) = -88*t128*t131*t139
+ t144 = t127**2
+ t146 = t134**2
+ som(4) = 9*t126*t144*t146
+ t148 = t126*t129
+ t149 = t131*t130
+ t150 = t149*t137
+ som(5) = -128*t148*t150*t133
+ t153 = t131**2
+ som(6) = -256*t148*t153*t133
+ t156 = t129**2
+ som(7) = 256*t126*t156*t153
+ t160 = t137**2
+ t161 = t160*t134
+ som(8) = -16*t126*t131*t161
+ som(9) = 64*t126*t149*t137*t134
+ som(10) = 80*t126*t153*t134
+ t168 = t126**2
+ t169 = t168*t127
+ t171 = t138*t133
+ som(11) = 128*t169*t129*t171
+ som(12) = 576*t169*t132*t133
+ som(13) = -512*t169*t156*t131
+ som(14) = -88*t169*t138*t134
+ som(15) = -192*t169*t131*t134
+ som(16) = 40*t169*t161
+ t182 = t168*t144
+ som(17) = -96*t182*t129*t134
+ som(18) = 60*t182*t139
+ t186 = t168*t129
+ som(19) = 128*t186*t131*t160
+ som(20) = -128*t186*t150
+ som(21) = -64*t186*t153
+ som(22) = -32*t168*t130*t160*t137*t133
+ som(23) = 64*t168*t149*t137*t133
+ som(24) = 32*t168*t153*t133
+ t200 = t168*t126
+ t201 = t200*t127
+ som(25) = 128*t201*t129*t130*t137
+ som(26) = 160*t201*t132
+ som(27) = -128*t201*t129*t160
+ t208 = piDpj(ip2,is1)
+ t210 = t130*t208*t137
+ som(28) = 32*t201*t210
+ som(29) = -88*t201*t171
+ som(30) = -88*t201*t131*t133
+ t215 = t208*t160
+ som(31) = -16*t201*t215
+ som(32) = 48*t201*t160*t133
+ t219 = t200*t144
+ som(33) = -320*t219*t129*t133
+ som(34) = 256*t219*t156
+ som(35) = 118*t219*t134
+ t225 = t200*xpi(ip3)
+ som(36) = -16*t225*t210
+ som(37) = 8*t225*t215
+ t228 = t200*t129
+ som(38) = 16*t228*t210
+ som(39) = -8*t228*t215
+ t233 = dpipj(is3,ip1)
+ som(40) = -16*t200*t130*t208*t137*t233
+ som(41) = 8*t200*t208*t160*t233
+ t239 = t168**2
+ t240 = t239*t127
+ som(42) = -40*t240*t138
+ som(43) = -8*t240*t131
+ som(44) = 40*t240*t160
+ t244 = t239*t144
+ som(45) = -96*t244*t129
+ som(46) = 60*t244*t133
+ som(47) = 9*t239*t126*t144
+ som(48) = -8*t127*t131*t146
+ som(49) = -64*t129*t153*t134
+ som(50) = 32*t150*t139
+ som(51) = 32*t153*t139
+* print '(7g20.12)',(som(i),i=1,51)
+ n=51
+ endif
+*
+ s = 0
+ smax = 0
+ do 30 j=1,n
+ s = s + som(j)
+ smax = max(smax,som(j))
+ 30 continue
+ if ( iwarn .lt. 3 ) then
+ hulp = 1/(16*xpi(ip1)**3*sdel2p**4*dy2z(3-iwarn)*
+ + (y(1)-2*z(1))*(y(1)-2*z(2)))
+ else
+ hulp = 1/(16*xpi(ip1)**3*sdel2p**4*dy2z(7-iwarn)*
+ + (y(3)-2*z(3))*(y(3)-2*z(4)))
+ endif
+ s = s*hulp
+ smax = smax*hulp
+ if ( lwrite ) print *,' dy2z(',iwarn,')++=',s,smax
+ if ( smax .lt. xmax ) then
+ dy2z(iwarn) = s
+ xmax = smax
+ endif
+ else
+ n=0
+ endif
+ if ( lwarn .and. abs(dy2z(iwarn)) .lt. xloss*xmax ) then
+ ier0 = ier
+ call ffwarn(152,ier0,dy2z(iwarn),xmax)
+ ier1 = max(ier1,ier0)
+ if ( lwrite ) then
+ print *,'n = ',n
+ print *,'xpi = ',xpi
+ print *,'cs = '
+ print '(i3,g24.12)',(i,som(i),i=1,n)
+ endif
+ endif
+ endif
+ ier = ier1
+*
+ goto 200
+* #] get dyz:
+* #[ special case, get indices:
+ 100 continue
+ if ( ivert.eq.2 ) then
+ is1 = 2
+ ip1 = 5
+ else
+ is1 = 1
+ ip1 = 6
+ endif
+* #] special case, get indices:
+* #[ xk = 0:
+ if ( xpi(ip1) .eq. 0 ) then
+ call fferr(88,ier)
+ endif
+* #] xk = 0:
+* #[ get ypm,zpm:
+*
+* special case del2s = 0, hence the roots are not the real roots
+* but z_2'' = (z_2'-1)/delta, z''_3 = -z'_3/delta
+*
+ hulp = sdel2s
+ disc = delps/sdel2p
+ if ( ivert .eq. 3 ) then
+ hulp = -hulp
+ disc = -disc
+ endif
+ if ( sdel2s .eq. 0 ) then
+ isoort(1) = 102
+ isoort(2) = 102
+ z(1) = piDpj(is1,3)/xpi(3)
+ z(2) = z(1)
+ else
+ isoort(1) = 101
+ isoort(2) = 101
+ call ffroot(z(1),z(2),xpi(3),piDpj(is1,3),xpi(is1),hulp,ier)
+ endif
+ call ffroot(y(1),y(2),xpi(3),piDpj(is1,3),etami(is1),disc,ier)
+* #] get ypm,zpm:
+* #[ get ypm1,zpm1:
+ z(3) = 1 - z(1)
+ z(4) = 1 - z(2)
+ if ( abs(z(3)).lt.xloss .or. abs(z(4)).lt.xloss ) then
+ if ( lwrite ) print *,'z(3,4) = ',z(3),z(4)
+ if ( ivert.eq.2 ) then
+ call ffroot(z(4),z(3),xpi(3),piDpj(ip1,3),xpi(ip1),hulp,
+ + ier)
+ else
+ call ffroot(z(4),z(3),xpi(3),-piDpj(ip1,3),xpi(ip1),hulp
+ + ,ier)
+ endif
+ if ( lwrite ) print *,'z(3,4)+= ',z(3),z(4)
+ endif
+ y(3) = 1 - y(1)
+ y(4) = 1 - y(2)
+ if ( abs(y(3)) .lt. xloss .or. abs(y(4)) .lt. xloss ) then
+ if ( lwrite ) print *,'y(3,4) = ',y(3),y(4)
+ if ( ivert .eq. 2 ) then
+ call ffroot(y(4),y(3),xpi(3),piDpj(ip1,3),etami(ip1),
+ + disc,ier)
+ else
+ call ffroot(y(4),y(3),xpi(3),-piDpj(ip1,3),etami(ip1),
+ + disc,ier)
+ endif
+ if ( lwrite ) print *,'y(3,4)+= ',y(3),y(4)
+ endif
+* #] get ypm1,zpm1:
+* #[ get dypzp, dypzm:
+ if ( isoort(1) .eq. 2 ) then
+ dyz(2,1) = disc/xpi(3)
+ dyz(2,2) = dyz(2,1)
+ elseif ( disc .gt. 0 .eqv. sdel2s .gt. 0 ) then
+ dyz(2,1) = ( disc + hulp )/xpi(3)
+ dyz(2,2) = etalam/(xpi(3)*dyz(2,1))
+ else
+ dyz(2,2) = ( disc - hulp )/xpi(3)
+ dyz(2,1) = etalam/(xpi(3)*dyz(2,2))
+ endif
+ dyz(1,1) = -dyz(2,2)
+ dyz(1,2) = -dyz(2,1)
+ d2yzz = 2*disc/xpi(3)
+*
+* these are very rarely needed, but ...
+*
+ do 220 i=1,4
+ j = 2*((i+1)/2)
+ dy2z(i) = y(j) - 2*z(i)
+ smax = abs(y(j))
+* do not know whether this is correct! 29-mar-1990
+* if ( abs(dy2z(i)) .lt. xloss*smax ) then
+* if ( lwrite ) print *,' dy2z(',i,') = ',dy2z(i),smax
+* if ( i/2 .eq. 1 ) then
+* s = -y(j-1) - 2*hulp/xpi(3)
+* else
+* s = -y(j-1) + 2*hulp/xpi(3)
+* endif
+* if ( abs(y(j-1)) .lt. smax ) then
+* dy2z(i) = s
+* smax = abs(y(j-1))
+* endif
+* if ( lwrite ) print *,' dy2z(',i,')+= ',s,y(j-1)
+ if ( lwarn .and. abs(dy2z(i)) .lt. xloss*smax ) then
+ call ffwarn(152,ier,dy2z(i),abs(y(j-1)))
+ endif
+* endif
+ 220 continue
+* #] get dypzp, dypzm:
+* #[ test output:
+ 200 continue
+ if ( ltest ) then
+ xlosn = xloss**2*DBLE(10)**(-mod(ier,50))
+ do 99 i=1,2
+ xheck = y(i)+y(i+2)-1
+ if ( xlosn*abs(xheck) .gt. precx*max(abs(y(i)),
+ + abs(y(i+2)),x1) ) print *,'ffxxyz: error: ',
+ + 'y(',i+2,')<>1-y(',i,'):',y(i+2),y(i),xheck
+ xheck = z(i)+z(i+2)-1
+ if ( xlosn*abs(xheck) .gt. precx*max(abs(z(i)),
+ + abs(z(i+2)),x1) ) print *,'ffxxyz: error: ',
+ + 'z(',i+2,')<>1-z(',i,'):',z(i+2),z(i),xheck
+ xheck = dy2z(i)-y(2)+2*z(i)
+ if ( xlosn*abs(xheck) .gt. precx*max(abs(y(2)),
+ + abs(2*z(i))) ) print *,'ffxxyz: error: ',
+ + 'dy2z(',i,')<>y(2)-2*z(',i,'):',dy2z(i),y(2),2*z(i),
+ + xheck
+ xheck = dy2z(i+2)-y(4)+2*z(i+2)
+ if ( xlosn*abs(xheck) .gt. precx*max(abs(y(4)),
+ + abs(2*z(i+2)))) print *,'ffxxyz: error: ',
+ + 'dy2z(',i+2,')<>y(4)-2*z(',i+2,'):',dy2z(i+2),y(4),
+ + 2*z(i+2),xheck
+ do 98 j=1,2
+ if ( xlosn*abs(dyz(i,j)-y(i)+z(j)) .gt. precx*max(
+ + abs(dyz(i,j)),abs(y(i)),abs(z(j))) ) print *,
+ + 'ffxxyz: error: dyz(',i,j,') <> y(',i,')-z(',j,
+ + '):',dyz(i,j),y(i),z(j),dyz(i,j)-y(i)+z(j)
+ 98 continue
+ 99 continue
+ if ( xlosn*abs(d2yzz-2*y(2)+z(1)+z(2)) .gt. precx*max(abs(
+ + d2yzz),2*abs(y(2)),abs(z(1)),abs(z(2))) ) print *,
+ + 'ffxxyz: error: d2yzz <> 2*y(2)+z(1)+z(2):',d2yzz,2*
+ + y(2),z(1),z(2),d2yzz-2*y(2)+z(1)+z(2)
+ endif
+* #] test output:
+*###] ffxxyz:
+ end
+*###[ ffdwz:
+ subroutine ffdwz(dwz,w,z,i1,j1,l,alpha,alph1,xpi,dpipj,piDpj,
+ + sdel2i,ns,ier)
+***#[*comment:***********************************************************
+* *
+* Recalculate dwz(i1,j1) = w(i1) - z(j1) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer i1,j1,l,ns,ier
+ DOUBLE PRECISION dwz(2,2),w(4),z(4)
+ DOUBLE PRECISION alpha,alph1,xpi(ns),dpipj(ns,ns),piDpj(ns,ns),
+ + sdel2i(3)
+*
+* local variables:
+*
+ DOUBLE PRECISION s(8),sum,fac,xmax
+ integer i
+*
+* common blocks:
+*
+ include 'ff.h'
+* #] declarations:
+* #[ calculations:
+ if ( l .eq. 1 ) then
+ if ( lwrite ) print *,'ffdwz: warning: cannot handle',
+ + ' this case dwz(',i1,j1,l,') yet'
+ ier = ier + 100
+ elseif ( l .eq. 3 ) then
+ if ( (i1.eq.2 .and. j1.eq.1) .or. (i1.eq.1 .and. j1.eq.2) )
+ + then
+ fac = x1/(sdel2i(2) + sdel2i(3))
+ s(1) = dpipj(6,5)*z(j1)
+ s(2) = -alph1*xpi(5)*z(j1+2)
+ if ( max(abs(dpipj(2,1)),abs(dpipj(5,6))) .lt.
+ + max(abs(dpipj(2,6)),abs(dpipj(5,1))) ) then
+ s(3) = x05*dpipj(2,1)
+ s(4) = x05*dpipj(5,6)
+ else
+ s(3) = x05*dpipj(2,6)
+ s(4) = x05*dpipj(5,1)
+ endif
+ s(5) = piDpj(4,3)*piDpj(5,3)*fac
+ s(6) = -piDpj(4,3)*piDpj(6,3)*fac
+ s(7) = xpi(3)*dpipj(5,6)*fac
+ if ( i1 .eq. 1 ) then
+ sum = s(1)+s(2)+s(3)+s(4) - (s(5)+s(6)+s(7))
+ else
+ sum = s(1)+s(2)+s(3)+s(4) + s(5)+s(6)+s(7)
+ endif
+ xmax = abs(s(1))
+ do 10 i=2,7
+ xmax = max(xmax,abs(s(i)))
+ 10 continue
+ if ( abs(sum) .lt. xloss*xmax ) then
+* this result is not used if it is not accurate (see
+* ffxc0p)
+ if ( lwrite ) then
+ call ffwarn(79,ier,sum,xmax)
+ else
+ ier = ier + 1
+ endif
+ xmax = xmax/abs(alpha*xpi(5))
+* if ( xmax .lt. min(abs(z(j1)),abs(z(j1+2))) ) then
+ if (lwrite) print *,' dwz(',i1,j1,l,') = ',
+ + dwz(i1,j1),min(abs(z(j1)),abs(z(j1+2)))
+ dwz(i1,j1) = sum/(alpha*xpi(5))
+ if (lwrite) print *,' dwz(',i1,j1,l,')+ = ',
+ + dwz(i1,j1),xmax/(alpha*xpi(5))
+* endif
+ else
+ if (lwrite) print *,' dwz(',i1,j1,l,') = ',
+ + dwz(i1,j1)
+ dwz(i1,j1) = sum/(alpha*xpi(5))
+ if (lwrite) print *,' dwz(',i1,j1,l,')+ = ',
+ + dwz(i1,j1)
+ endif
+ else
+ if ( lwrite ) print *,'ffdwz: warning: cannot handle',
+ + ' this case dwz(',i1,j1,l,') yet'
+ ier = ier + 100
+ endif
+ endif
+* #] calculations:
+* #[ test output:
+ if ( ltest .and. ier .eq. 0 ) then
+ if ( xloss*abs(dwz(i1,j1)-w(i1)+z(j1)) .gt. precx*max(
+ + abs(dwz(i1,j1)),abs(w(i1)),abs(z(j1))) ) print *,
+ + 'ffdwz: error: dwz(',i1,j1,l,') <> w - z :',
+ + dwz(i1,j1),w(i1),z(j1),dwz(i1,j1)-w(i1)+z(j1)
+ if ( xloss*abs(dwz(i1,j1)+w(i1+2)-z(j1+2)) .gt. precx*max(
+ + abs(dwz(i1,j1)),abs(w(i1+2)),abs(z(j1+2))) ) print *,
+ + 'ffdwz: error: dwz(',i1,j1,l,') <> z1 - w1 :',
+ + dwz(i1,j1),z(i1+2),w(j1+2),dwz(i1,j1)+w(i1+2)-z(j1+2)
+ endif
+* #] test output:
+*###] ffdwz:
+ end
diff --git a/ff-2.0/npoin.f b/ff-2.0/npoin.f
new file mode 100644
index 0000000..6856bdb
--- /dev/null
+++ b/ff-2.0/npoin.f
@@ -0,0 +1,208 @@
+*###[ NPOIN:
+ subroutine NPOIN(npoint)
+***#[*comment:***********************************************************
+* *
+* entry point to the AA and FF routines compatible with Veltman's *
+* NPOIN for FormF. *
+* *
+* Input: npoin integer specifies which function *
+* DEL real infinity *
+* PX(1-6) real momenta squared (Pauli metric) *
+* RM(2-4) real masses squared *
+* *
+* Output: B0,B0PM,B1,B1PM,B2 complex if npoint=2 *
+* C0,C1,C2,C3 complex if npoint=3 *
+* D0,D1,D2,D3,D4 complex if npoint=4 *
+* (all in blank common) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer npoint
+*
+* local variables
+*
+ integer init,i,l2,l3,l4,ier
+ DOUBLE PRECISION xmu,xpc(6),xpd(13)
+ DOUBLE COMPLEX cab(2),cbi(4),acbi(2),cac(3),cbc(12),cci(13),
+ + cbd(12),ccd(28),cdi(24)
+ save init,l2,l3,l4
+*
+* common blocks
+*
+ DOUBLE COMPLEX B0,B0PM,B1,B1PM,B2,CC0,CC1,CC2,CC3,D0,D1,D2,D3,D4
+ DOUBLE PRECISION PX(6),RM(4),DEL
+ common PX,RM,DEL,
+ + B0,B0PM,B1,B1PM,B2(2),CC0,CC1(2),CC2(4),CC3(6),
+ + D0,D1(3),D2(7),D3(13),D4(22)
+ include 'ff.h'
+ include 'aa.h'
+*
+* data
+*
+ data xmu /0.D0/
+ data l2,l3,l4 /2,3,3/
+ data init /0/
+* #] declarations:
+* #[ initialisations:
+ if ( init.eq.0 ) then
+ init = 1
+ do 10 i=1,22
+ D4(i) = 0
+ 10 continue
+ print *,'NPOIN: warning: D4 is not yet supported'
+ print *,'NPOIN: warning: B1'' seems also not yet supported'
+ call ffini
+ endif
+ ier = 0
+ nevent = nevent + 1
+* #] initialisations:
+* #[ 2point:
+ if ( npoint.eq.2 ) then
+ aderiv = .TRUE.
+ call aaxbx(cab,cbi,acbi,del,xmu,-PX(1),RM(1),RM(2),l2,ier)
+ B0 = cipi2*cbi(1)
+ B1 = cipi2*cbi(2)
+ B2(1) = cipi2*cbi(3)
+ B2(2) =-cipi2*cbi(4)
+ B0PM = cipi2*acbi(1)
+ B1PM = cipi2*acbi(2)
+* #] 2point:
+* #[ 3point:
+ elseif ( npoint.eq.3 ) then
+ xpc(1) = RM(1)
+ xpc(2) = RM(2)
+ xpc(3) = RM(3)
+ xpc(4) =-PX(1)
+ xpc(5) =-PX(2)
+ xpc(6) =-PX(5)
+ call aaxcx(cac,cbc,cci,del,xmu,xpc,l3,ier)
+ CC0 =-cipi2*cci(1)
+ CC1(1) =-cipi2*cci(2)
+ CC1(2) =-cipi2*cci(3)
+ CC2(1) =-cipi2*cci(4)
+ CC2(2) =-cipi2*cci(5)
+ CC2(3) =-cipi2*cci(6)
+ CC2(4) =+cipi2*cci(7)
+ CC3(1) =-cipi2*cci(8)
+ CC3(2) =-cipi2*cci(9)
+ CC3(3) =-cipi2*cci(10)
+ CC3(4) =-cipi2*cci(11)
+ CC3(5) =+cipi2*cci(12)
+ CC3(6) =+cipi2*cci(13)
+* #] 3point:
+* #[ 4point:
+ elseif ( npoint.eq.4 ) then
+ xpd(1) = RM(1)
+ xpd(2) = RM(2)
+ xpd(3) = RM(3)
+ xpd(4) = RM(4)
+ xpd(5) =-PX(1)
+ xpd(6) =-PX(2)
+ xpd(7) =-PX(3)
+ xpd(8) =-PX(4)
+ xpd(9) =-PX(5)
+ xpd(10)=-PX(6)
+ xpd(11)= 0.D0
+ xpd(12)= 0.D0
+ xpd(13)= 0.D0
+ call aaxdx(cbd,ccd,cdi,del,xmu,xpd,l4,ier)
+ D0 = cipi2*cdi(1)
+ D1(1) = cipi2*cdi(2)
+ D1(2) = cipi2*cdi(3)
+ D1(3) = cipi2*cdi(4)
+ D2(1) = cipi2*cdi(5)
+ D2(2) = cipi2*cdi(6)
+ D2(3) = cipi2*cdi(7)
+ D2(4) = cipi2*cdi(8)
+ D2(5) = cipi2*cdi(9)
+ D2(6) = cipi2*cdi(10)
+ D2(7) =-cipi2*cdi(11)
+ D3(1) = cipi2*cdi(12)
+ D3(2) = cipi2*cdi(13)
+ D3(3) = cipi2*cdi(14)
+ D3(4) = cipi2*cdi(15)
+ D3(5) = cipi2*cdi(16)
+ D3(6) = cipi2*cdi(17)
+ D3(7) = cipi2*cdi(18)
+ D3(8) = cipi2*cdi(19)
+ D3(9) = cipi2*cdi(20)
+ D3(10) = cipi2*cdi(21)
+ D3(11) =-cipi2*cdi(22)
+ D3(12) =-cipi2*cdi(23)
+ D3(13) =-cipi2*cdi(24)
+* #] 4point:
+* #[ finish:
+ else
+ print *,'NPOIN: error: npoint should be 2,3 or 4; not ',
+ + npoint
+ stop
+ endif
+ if ( ier .gt. 10 ) then
+ print *,'NPOIN: warning: more than 10 digits lost: ',ier
+ print *,'npoint = ',npoint
+ print *,'RM = ',RM
+ print *,'PX = ',PX
+ if ( ltest ) call ffwarn(998,ier,x0,x0)
+ endif
+* #] finish:
+*###] NPOIN:
+ end
+*###[ AA0:
+ DOUBLE COMPLEX function AA0(XM,DEL)
+***#[*comment:***********************************************************
+* *
+* provides an interface to FF compatible with FormF by M. Veltman *
+* *
+* Input: XM real mass *
+* DEL real infinity *
+* *
+* Output: A0 complex *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE PRECISION XM,DEL
+*
+* my variables
+*
+ DOUBLE COMPLEX ca0
+ integer ier,init
+ save init
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* data
+*
+ data init /0/
+* #] declarations:
+* #[ initialisations:
+ if ( init .eq. 0 ) then
+ init = 1
+ call ffini
+ endif
+* #] initialisations:
+* #[ calculations:
+ nevent = nevent + 1
+ ier = 0
+ call ffxa0(ca0,DEL,x0,XM,ier)
+ AA0 = -ca0*cipi2
+* #] calculations:
+*###] AA0:
+ end
+*###[ ALIJ:
+ DOUBLE PRECISION function ALIJ(P22,P12,P1P2,P20,P10,DELE,PM2)
+ DOUBLE PRECISION P22,P12,P1P2,P20,P10,DELE,PM2
+ print *,'ALIJ: error: not implemented'
+* stupid fort!
+ ALIJ = 0
+*###] ALIJ:
+ end
diff --git a/ff-2.0/spence.f b/ff-2.0/spence.f
new file mode 100644
index 0000000..e0b281f
--- /dev/null
+++ b/ff-2.0/spence.f
@@ -0,0 +1,48 @@
+*###[ SPENCE:
+ DOUBLE COMPLEX function SPENCE(z)
+***#[*comment:***********************************************************
+* *
+* Interface to the FF dilogarithms compatible with the FormF *
+* SPENCE function. All error propagation is lost and the terms *
+* pi^2/12 are added. *
+* *
+* Input: z complex cannot lie on the real axis for *
+* Re(z)>1 *
+* Output: SPENCE complex Sp(z) = Li2(z) = \sum z^n/n^2 *
+* = \int_0^z log(1-x)/x dx *
+* Calls: ffzzdl *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX z
+*
+* local variables
+*
+ integer init,ipi12,ier
+ DOUBLE COMPLEX zdilog,zdum
+ save init
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ initialisations:
+ data init /0/
+ if ( init .eq. 0 ) then
+ init = 1
+ call ffini
+ endif
+* #] initialisations:
+* #[ work:
+ ier = 0
+ call ffzzdl(zdilog,ipi12,zdum,z,ier)
+ SPENCE = zdilog + ipi12*pi12
+* #] work:
+*###] SPENCE:
+ end
+
diff --git a/golem95c-1.2.1/Makefile.am b/golem95c-1.2.1/Makefile.am
new file mode 100644
index 0000000..37497d2
--- /dev/null
+++ b/golem95c-1.2.1/Makefile.am
@@ -0,0 +1,22 @@
+SUBDIRS = module kinematic numerical integrals form_factor interface
+
+lib_LTLIBRARIES= libgolem.la
+libgolem_la_SOURCES=
+libgolem_la_LIBADD=\
+ $(builddir)/interface/libgolem95_interface.la \
+ $(builddir)/form_factor/libgolem95_formfactor.la \
+ $(builddir)/integrals/four_point/libgolem95_integrals_four_point.la \
+ $(builddir)/integrals/three_point/libgolem95_integrals_three_point.la \
+ $(builddir)/integrals/two_point/libgolem95_integrals_two_point.la \
+ $(builddir)/integrals/one_point/libgolem95_integrals_one_point.la \
+ $(builddir)/numerical/libgolem95_numerical.la \
+ $(builddir)/kinematic/libgolem95_kinematics.la \
+ $(builddir)/module/libgolem95_module.la \
+ -L$(builddir)/../avh_olo-2.2.1 -lavh_olo \
+ $(LIBLOOPTOOLS)
+
+AM_FCFLAGS= \
+ -I$(builddir)/../avh_olo-2.2.1
+
+%.mod: %.o %.f90
+ @true
diff --git a/golem95c-1.2.1/Makefile.in b/golem95c-1.2.1/Makefile.in
new file mode 100644
index 0000000..e48ead1
--- /dev/null
+++ b/golem95c-1.2.1/Makefile.in
@@ -0,0 +1,709 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+subdir = golem95c-1.2.1
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(libdir)"
+LTLIBRARIES = $(lib_LTLIBRARIES)
+am__DEPENDENCIES_1 =
+libgolem_la_DEPENDENCIES = \
+ $(builddir)/interface/libgolem95_interface.la \
+ $(builddir)/form_factor/libgolem95_formfactor.la \
+ $(builddir)/integrals/four_point/libgolem95_integrals_four_point.la \
+ $(builddir)/integrals/three_point/libgolem95_integrals_three_point.la \
+ $(builddir)/integrals/two_point/libgolem95_integrals_two_point.la \
+ $(builddir)/integrals/one_point/libgolem95_integrals_one_point.la \
+ $(builddir)/numerical/libgolem95_numerical.la \
+ $(builddir)/kinematic/libgolem95_kinematics.la \
+ $(builddir)/module/libgolem95_module.la $(am__DEPENDENCIES_1)
+am_libgolem_la_OBJECTS =
+libgolem_la_OBJECTS = $(am_libgolem_la_OBJECTS)
+DEFAULT_INCLUDES = -I.@am__isrc@
+COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
+LTCOMPILE = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \
+ $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
+CCLD = $(CC)
+LINK = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem_la_SOURCES)
+DIST_SOURCES = $(libgolem_la_SOURCES)
+RECURSIVE_TARGETS = all-recursive check-recursive dvi-recursive \
+ html-recursive info-recursive install-data-recursive \
+ install-dvi-recursive install-exec-recursive \
+ install-html-recursive install-info-recursive \
+ install-pdf-recursive install-ps-recursive install-recursive \
+ installcheck-recursive installdirs-recursive pdf-recursive \
+ ps-recursive uninstall-recursive
+RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \
+ distclean-recursive maintainer-clean-recursive
+AM_RECURSIVE_TARGETS = $(RECURSIVE_TARGETS:-recursive=) \
+ $(RECURSIVE_CLEAN_TARGETS:-recursive=) tags TAGS ctags CTAGS \
+ distdir
+ETAGS = etags
+CTAGS = ctags
+DIST_SUBDIRS = $(SUBDIRS)
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+am__relativize = \
+ dir0=`pwd`; \
+ sed_first='s,^\([^/]*\)/.*$$,\1,'; \
+ sed_rest='s,^[^/]*/*,,'; \
+ sed_last='s,^.*/\([^/]*\)$$,\1,'; \
+ sed_butlast='s,/*[^/]*$$,,'; \
+ while test -n "$$dir1"; do \
+ first=`echo "$$dir1" | sed -e "$$sed_first"`; \
+ if test "$$first" != "."; then \
+ if test "$$first" = ".."; then \
+ dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \
+ dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \
+ else \
+ first2=`echo "$$dir2" | sed -e "$$sed_first"`; \
+ if test "$$first2" = "$$first"; then \
+ dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \
+ else \
+ dir2="../$$dir2"; \
+ fi; \
+ dir0="$$dir0"/"$$first"; \
+ fi; \
+ fi; \
+ dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \
+ done; \
+ reldir="$$dir2"
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+SUBDIRS = module kinematic numerical integrals form_factor interface
+lib_LTLIBRARIES = libgolem.la
+libgolem_la_SOURCES =
+libgolem_la_LIBADD = \
+ $(builddir)/interface/libgolem95_interface.la \
+ $(builddir)/form_factor/libgolem95_formfactor.la \
+ $(builddir)/integrals/four_point/libgolem95_integrals_four_point.la \
+ $(builddir)/integrals/three_point/libgolem95_integrals_three_point.la \
+ $(builddir)/integrals/two_point/libgolem95_integrals_two_point.la \
+ $(builddir)/integrals/one_point/libgolem95_integrals_one_point.la \
+ $(builddir)/numerical/libgolem95_numerical.la \
+ $(builddir)/kinematic/libgolem95_kinematics.la \
+ $(builddir)/module/libgolem95_module.la \
+ -L$(builddir)/../avh_olo-2.2.1 -lavh_olo \
+ $(LIBLOOPTOOLS)
+
+AM_FCFLAGS = \
+ -I$(builddir)/../avh_olo-2.2.1
+
+all: all-recursive
+
+.SUFFIXES:
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+install-libLTLIBRARIES: $(lib_LTLIBRARIES)
+ @$(NORMAL_INSTALL)
+ test -z "$(libdir)" || $(MKDIR_P) "$(DESTDIR)$(libdir)"
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ list2=; for p in $$list; do \
+ if test -f $$p; then \
+ list2="$$list2 $$p"; \
+ else :; fi; \
+ done; \
+ test -z "$$list2" || { \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \
+ }
+
+uninstall-libLTLIBRARIES:
+ @$(NORMAL_UNINSTALL)
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ for p in $$list; do \
+ $(am__strip_dir) \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \
+ done
+
+clean-libLTLIBRARIES:
+ -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES)
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem.la: $(libgolem_la_OBJECTS) $(libgolem_la_DEPENDENCIES)
+ $(LINK) -rpath $(libdir) $(libgolem_la_OBJECTS) $(libgolem_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+
+# This directory's subdirectories are mostly independent; you can cd
+# into them and run `make' without going through this Makefile.
+# To change the values of `make' variables: instead of editing Makefiles,
+# (1) if the variable is set in `config.status', edit `config.status'
+# (which will cause the Makefiles to be regenerated when you run `make');
+# (2) otherwise, pass the desired values on the `make' command line.
+$(RECURSIVE_TARGETS):
+ @fail= failcom='exit 1'; \
+ for f in x $$MAKEFLAGS; do \
+ case $$f in \
+ *=* | --[!k]*);; \
+ *k*) failcom='fail=yes';; \
+ esac; \
+ done; \
+ dot_seen=no; \
+ target=`echo $@ | sed s/-recursive//`; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ echo "Making $$target in $$subdir"; \
+ if test "$$subdir" = "."; then \
+ dot_seen=yes; \
+ local_target="$$target-am"; \
+ else \
+ local_target="$$target"; \
+ fi; \
+ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+ || eval $$failcom; \
+ done; \
+ if test "$$dot_seen" = "no"; then \
+ $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \
+ fi; test -z "$$fail"
+
+$(RECURSIVE_CLEAN_TARGETS):
+ @fail= failcom='exit 1'; \
+ for f in x $$MAKEFLAGS; do \
+ case $$f in \
+ *=* | --[!k]*);; \
+ *k*) failcom='fail=yes';; \
+ esac; \
+ done; \
+ dot_seen=no; \
+ case "$@" in \
+ distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \
+ *) list='$(SUBDIRS)' ;; \
+ esac; \
+ rev=''; for subdir in $$list; do \
+ if test "$$subdir" = "."; then :; else \
+ rev="$$subdir $$rev"; \
+ fi; \
+ done; \
+ rev="$$rev ."; \
+ target=`echo $@ | sed s/-recursive//`; \
+ for subdir in $$rev; do \
+ echo "Making $$target in $$subdir"; \
+ if test "$$subdir" = "."; then \
+ local_target="$$target-am"; \
+ else \
+ local_target="$$target"; \
+ fi; \
+ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+ || eval $$failcom; \
+ done && test -z "$$fail"
+tags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test "$$subdir" = . || ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \
+ done
+ctags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test "$$subdir" = . || ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) ctags); \
+ done
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \
+ include_option=--etags-include; \
+ empty_fix=.; \
+ else \
+ include_option=--include; \
+ empty_fix=; \
+ fi; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ test ! -f $$subdir/TAGS || \
+ set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \
+ fi; \
+ done; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: ctags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+ @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ test -d "$(distdir)/$$subdir" \
+ || $(MKDIR_P) "$(distdir)/$$subdir" \
+ || exit 1; \
+ fi; \
+ done
+ @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ dir1=$$subdir; dir2="$(distdir)/$$subdir"; \
+ $(am__relativize); \
+ new_distdir=$$reldir; \
+ dir1=$$subdir; dir2="$(top_distdir)"; \
+ $(am__relativize); \
+ new_top_distdir=$$reldir; \
+ echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \
+ echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \
+ ($(am__cd) $$subdir && \
+ $(MAKE) $(AM_MAKEFLAGS) \
+ top_distdir="$$new_top_distdir" \
+ distdir="$$new_distdir" \
+ am__remove_distdir=: \
+ am__skip_length_check=: \
+ am__skip_mode_fix=: \
+ distdir) \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-recursive
+all-am: Makefile $(LTLIBRARIES)
+installdirs: installdirs-recursive
+installdirs-am:
+ for dir in "$(DESTDIR)$(libdir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-recursive
+install-exec: install-exec-recursive
+install-data: install-data-recursive
+uninstall: uninstall-recursive
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-recursive
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-recursive
+
+clean-am: clean-generic clean-libLTLIBRARIES clean-libtool \
+ mostlyclean-am
+
+distclean: distclean-recursive
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-recursive
+
+dvi-am:
+
+html: html-recursive
+
+html-am:
+
+info: info-recursive
+
+info-am:
+
+install-data-am:
+
+install-dvi: install-dvi-recursive
+
+install-dvi-am:
+
+install-exec-am: install-libLTLIBRARIES
+
+install-html: install-html-recursive
+
+install-html-am:
+
+install-info: install-info-recursive
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-recursive
+
+install-pdf-am:
+
+install-ps: install-ps-recursive
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-recursive
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-recursive
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-recursive
+
+pdf-am:
+
+ps: ps-recursive
+
+ps-am:
+
+uninstall-am: uninstall-libLTLIBRARIES
+
+.MAKE: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) ctags-recursive \
+ install-am install-strip tags-recursive
+
+.PHONY: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) CTAGS GTAGS \
+ all all-am check check-am clean clean-generic \
+ clean-libLTLIBRARIES clean-libtool ctags ctags-recursive \
+ distclean distclean-compile distclean-generic \
+ distclean-libtool distclean-tags distdir dvi dvi-am html \
+ html-am info info-am install install-am install-data \
+ install-data-am install-dvi install-dvi-am install-exec \
+ install-exec-am install-html install-html-am install-info \
+ install-info-am install-libLTLIBRARIES install-man install-pdf \
+ install-pdf-am install-ps install-ps-am install-strip \
+ installcheck installcheck-am installdirs installdirs-am \
+ maintainer-clean maintainer-clean-generic mostlyclean \
+ mostlyclean-compile mostlyclean-generic mostlyclean-libtool \
+ pdf pdf-am ps ps-am tags tags-recursive uninstall uninstall-am \
+ uninstall-libLTLIBRARIES
+
+
+%.mod: %.o %.f90
+ @true
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/form_factor/Makefile.am b/golem95c-1.2.1/form_factor/Makefile.am
new file mode 100644
index 0000000..e6de167
--- /dev/null
+++ b/golem95c-1.2.1/form_factor/Makefile.am
@@ -0,0 +1,21 @@
+noinst_LTLIBRARIES=libgolem95_formfactor.la
+
+libgolem95_formfactor_la_SOURCES= form_factor_1p.f90 form_factor_2p.f90 \
+ form_factor_3p.f90 form_factor_4p.f90 form_factor_5p.f90 \
+ form_factor_6p.f90
+libgolem95_formfactor_la_FCFLAGS=\
+ -I$(builddir)/../module \
+ -I$(builddir)/../kinematic \
+ -I$(builddir)/../numerical \
+ -I$(builddir)/../interface \
+ -I$(builddir)/../integrals/one_point \
+ -I$(builddir)/../integrals/two_point \
+ -I$(builddir)/../integrals/three_point \
+ -I$(builddir)/../integrals/four_point \
+ -I$(builddir)/../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS= form_factor_5p.mod form_factor_6p.mod form_factor_4p.mod \
+ form_factor_3p.mod form_factor_2p.mod form_factor_1p.mod
+CLEANFILES=*.mod
+
+include Makefile.dep
diff --git a/golem95c-1.2.1/form_factor/Makefile.dep b/golem95c-1.2.1/form_factor/Makefile.dep
new file mode 100644
index 0000000..75555d0
--- /dev/null
+++ b/golem95c-1.2.1/form_factor/Makefile.dep
@@ -0,0 +1,4 @@
+# Module dependencies
+form_factor_6p.o: form_factor_5p.o
+form_factor_6p.lo: form_factor_5p.lo
+form_factor_6p.obj: form_factor_5p.obj
diff --git a/golem95c-1.2.1/form_factor/Makefile.in b/golem95c-1.2.1/form_factor/Makefile.in
new file mode 100644
index 0000000..e5e4cdf
--- /dev/null
+++ b/golem95c-1.2.1/form_factor/Makefile.in
@@ -0,0 +1,588 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.dep \
+ $(srcdir)/Makefile.in
+subdir = golem95c-1.2.1/form_factor
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+LTLIBRARIES = $(noinst_LTLIBRARIES)
+libgolem95_formfactor_la_LIBADD =
+am_libgolem95_formfactor_la_OBJECTS = \
+ libgolem95_formfactor_la-form_factor_1p.lo \
+ libgolem95_formfactor_la-form_factor_2p.lo \
+ libgolem95_formfactor_la-form_factor_3p.lo \
+ libgolem95_formfactor_la-form_factor_4p.lo \
+ libgolem95_formfactor_la-form_factor_5p.lo \
+ libgolem95_formfactor_la-form_factor_6p.lo
+libgolem95_formfactor_la_OBJECTS = \
+ $(am_libgolem95_formfactor_la_OBJECTS)
+libgolem95_formfactor_la_LINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=link $(FCLD) \
+ $(libgolem95_formfactor_la_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem95_formfactor_la_SOURCES)
+DIST_SOURCES = $(libgolem95_formfactor_la_SOURCES)
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgincludedir)"
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+noinst_LTLIBRARIES = libgolem95_formfactor.la
+libgolem95_formfactor_la_SOURCES = form_factor_1p.f90 form_factor_2p.f90 \
+ form_factor_3p.f90 form_factor_4p.f90 form_factor_5p.f90 \
+ form_factor_6p.f90
+
+libgolem95_formfactor_la_FCFLAGS = \
+ -I$(builddir)/../module \
+ -I$(builddir)/../kinematic \
+ -I$(builddir)/../numerical \
+ -I$(builddir)/../interface \
+ -I$(builddir)/../integrals/one_point \
+ -I$(builddir)/../integrals/two_point \
+ -I$(builddir)/../integrals/three_point \
+ -I$(builddir)/../integrals/four_point \
+ -I$(builddir)/../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS = form_factor_5p.mod form_factor_6p.mod form_factor_4p.mod \
+ form_factor_3p.mod form_factor_2p.mod form_factor_1p.mod
+
+CLEANFILES = *.mod
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/form_factor/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/form_factor/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+
+clean-noinstLTLIBRARIES:
+ -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+ @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem95_formfactor.la: $(libgolem95_formfactor_la_OBJECTS) $(libgolem95_formfactor_la_DEPENDENCIES)
+ $(libgolem95_formfactor_la_LINK) $(libgolem95_formfactor_la_OBJECTS) $(libgolem95_formfactor_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+libgolem95_formfactor_la-form_factor_1p.lo: form_factor_1p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_formfactor_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_formfactor_la-form_factor_1p.lo $(FCFLAGS_f90) `test -f 'form_factor_1p.f90' || echo '$(srcdir)/'`form_factor_1p.f90
+
+libgolem95_formfactor_la-form_factor_2p.lo: form_factor_2p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_formfactor_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_formfactor_la-form_factor_2p.lo $(FCFLAGS_f90) `test -f 'form_factor_2p.f90' || echo '$(srcdir)/'`form_factor_2p.f90
+
+libgolem95_formfactor_la-form_factor_3p.lo: form_factor_3p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_formfactor_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_formfactor_la-form_factor_3p.lo $(FCFLAGS_f90) `test -f 'form_factor_3p.f90' || echo '$(srcdir)/'`form_factor_3p.f90
+
+libgolem95_formfactor_la-form_factor_4p.lo: form_factor_4p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_formfactor_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_formfactor_la-form_factor_4p.lo $(FCFLAGS_f90) `test -f 'form_factor_4p.f90' || echo '$(srcdir)/'`form_factor_4p.f90
+
+libgolem95_formfactor_la-form_factor_5p.lo: form_factor_5p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_formfactor_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_formfactor_la-form_factor_5p.lo $(FCFLAGS_f90) `test -f 'form_factor_5p.f90' || echo '$(srcdir)/'`form_factor_5p.f90
+
+libgolem95_formfactor_la-form_factor_6p.lo: form_factor_6p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_formfactor_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_formfactor_la-form_factor_6p.lo $(FCFLAGS_f90) `test -f 'form_factor_6p.f90' || echo '$(srcdir)/'`form_factor_6p.f90
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libtool clean-noinstLTLIBRARIES ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+form_factor_6p.o: form_factor_5p.o
+form_factor_6p.lo: form_factor_5p.lo
+form_factor_6p.obj: form_factor_5p.obj
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/form_factor/form_factor_1p.f90 b/golem95c-1.2.1/form_factor/form_factor_1p.f90
new file mode 100644
index 0000000..958c995
--- /dev/null
+++ b/golem95c-1.2.1/form_factor/form_factor_1p.f90
@@ -0,0 +1,153 @@
+!
+!****h* src/form_factor/form_factor_1p
+! NAME
+!
+! Module form_factor_1p
+!
+! USAGE
+!
+! use form_factor_1p
+!
+! DESCRIPTION
+!
+! This module contains the form factor for tadpoles.
+!
+! OUTPUT
+!
+! It exports the functions:
+! * a10 -- a function to compute A^{1,0}
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * generic_function_1p (src/integrals/one_point/generic_function_1p.f90)
+! * matrice_s (src/kinematic/matrice_s.f90)
+! * array (src/module/array.f90)
+! * form_factor_type (src/module/form_factor_type.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+!
+module form_factor_1p
+ !
+ use precision_golem
+ use generic_function_1p
+ use matrice_s
+ use array
+ use form_factor_type
+ use constante, only: czero
+ implicit none
+ !
+ private
+ !
+ interface a10
+ !
+ module procedure a10_b, a10_s
+ !
+ end interface
+ !
+ !
+ public :: a10
+ !
+ contains
+ !
+ !****f* src/form_factor/form_factor_1p/a10_b
+ ! NAME
+ !
+ ! Function a10_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a10_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{1,0}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a10_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a10_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp(:) = czero
+ temp(2:3) = f1p(s_mat_p,b_pro)
+ a10_b = temp
+ !
+ end function a10_b
+ !
+ !****f* src/form_factor/form_factor_1p/a10_s
+ ! NAME
+ !
+ ! Function a10_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a10_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{1,0}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a10_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a10_s
+ !
+ a10_s = a10_b(packb(set))
+ !
+ end function a10_s
+ !
+ !
+end module form_factor_1p
diff --git a/golem95c-1.2.1/form_factor/form_factor_2p.f90 b/golem95c-1.2.1/form_factor/form_factor_2p.f90
new file mode 100644
index 0000000..7f10704
--- /dev/null
+++ b/golem95c-1.2.1/form_factor/form_factor_2p.f90
@@ -0,0 +1,482 @@
+!
+!****h* src/form_factor/form_factor_2p
+! NAME
+!
+! Module form_factor_2p
+!
+! USAGE
+!
+! use form_factor_2p
+!
+! DESCRIPTION
+!
+! This module contains the different form factors for two point amplitudes.
+!
+! OUTPUT
+!
+! It exports four functions:
+! * a20 -- a function to compute A^{2,0}
+! * a21 -- a function to compute A^{2,1}
+! * a22 -- a function to compute A^{2,2}
+! * b22 -- a function to compute B^{2,2}
+!
+! Note that a2xx and b2xx are generic functions which can be called either with a
+! set of integers or with an integer whose bits represents the set
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * generic_function_2p (src/integrals/two_point/generic_function_2p.f90)
+! * matrice_s (src/kinematic/matrice_s.f90)
+! * array (src/module/array.f90)
+! * form_factor_type (src/module/form_factor_type.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+module form_factor_2p
+ !
+ use precision_golem
+ use matrice_s
+ use form_factor_type
+ use generic_function_2p
+ use array
+ use constante, only: czero
+ !
+ implicit none
+ !
+ private
+ !
+ interface a20
+ !
+ module procedure a20_b, a20_s
+ !
+ end interface
+ !
+ interface a21
+ !
+ module procedure a21_b, a21_s
+ !
+ end interface
+ !
+ interface a22
+ !
+ module procedure a22_b, a22_s
+ !
+ end interface
+ !
+ interface b22
+ !
+ module procedure b22_b, b22_s
+ !
+ end interface
+ !
+ public :: a20,a21,a22,b22
+ !
+ contains
+ !
+ !****f* src/form_factor/form_factor_2p/a20_b
+ ! NAME
+ !
+ ! Function a20_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a20_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{2,0}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a20_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a20_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp(:) = czero
+ temp(2:3) = f2p(s_mat_p,b_pro)
+ a20_b = temp
+ !
+ end function a20_b
+ !
+ !****f* src/form_factor/form_factor_2p/a20_s
+ ! NAME
+ !
+ ! Function a20_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a20_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{2,0}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a20_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a20_s
+ !
+ a20_s = a20_b(packb(set))
+ !
+ end function a20_s
+ !
+ !****f* src/form_factor/form_factor_2p/a21_b
+ ! NAME
+ !
+ ! Function a21_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a21_b(l1,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{2,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a21_b(l1,b_pin)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a21_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp(:) = czero
+ temp(2:3) = -f2p(s_mat_p,b_pro,l1)
+ a21_b = temp
+ !
+ end function a21_b
+ !
+ !****f* src/form_factor/form_factor_2p/a21_s
+ ! NAME
+ !
+ ! Function a21_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a21_s(l1,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{2,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a21_s(l1,set)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a21_s
+ !
+ a21_s = a21_b(l1,packb(set))
+ !
+ end function a21_s
+ !
+ !****f* src/form_factor/form_factor_2p/a22_b
+ ! NAME
+ !
+ ! Function a22_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a22_b(l1,l2,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{2,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a22_b(l1,l2,b_pin)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a22_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp(:) = czero
+ temp(2:3) = f2p(s_mat_p,b_pro,l1,l2)
+ a22_b = temp
+ !
+ end function a22_b
+ !
+ !****f* src/form_factor/form_factor_2p/a22_s
+ ! NAME
+ !
+ ! Function a22_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a22_s(l1,l2,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{2,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a22_s(l1,l2,set)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a22_s
+ !
+ a22_s = a22_b(l1,l2,packb(set))
+ !
+ end function a22_s
+ !
+ !****f* src/form_factor/form_factor_2p/b22_b
+ ! NAME
+ !
+ ! Function b22_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b22_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{2,2}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b22_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b22_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp(:) = czero
+ temp(2:3) = -f2p_np2(s_mat_p,b_pro)/2._ki
+ b22_b = temp
+ !
+ end function b22_b
+ !
+ !****f* src/form_factor/form_factor_2p/b22_s
+ ! NAME
+ !
+ ! Function b22_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b22_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{2,2}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ !
+ !*****
+ function b22_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b22_s
+ !
+ b22_s = b22_b(packb(set))
+ !
+ end function b22_s
+ !
+end module form_factor_2p
diff --git a/golem95c-1.2.1/form_factor/form_factor_3p.f90 b/golem95c-1.2.1/form_factor/form_factor_3p.f90
new file mode 100644
index 0000000..80e4f1b
--- /dev/null
+++ b/golem95c-1.2.1/form_factor/form_factor_3p.f90
@@ -0,0 +1,703 @@
+!
+!****h* src/form_factor/form_factor_3p
+! NAME
+!
+! Module form_factor_3p
+!
+! USAGE
+!
+! use form_factor_3p
+!
+! DESCRIPTION
+!
+! This module contains the different form factors for three point amplitudes.
+!
+! OUTPUT
+!
+! It exports six functions:
+! * a30 -- a function to compute A^{3,0}
+! * a31 -- a function to compute A^{3,1}
+! * a32 -- a function to compute A^{3,2}
+! * a33 -- a function to compute A^{3,3}
+! * b32 -- a function to compute B^{3,2}
+! * b33 -- a function to compute B^{3,3}
+!
+! Note that a3xx and b3xx are generic functions which can be called either with a
+! set of integers or with an integer whose bits represents the set
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * matrice_s (src/kinematic/matrice_s.f90)
+! * array (src/module/array.f90)
+! * form_factor_type (src/module/form_factor_type.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+module form_factor_3p
+ !
+ use precision_golem
+ use generic_function_3p
+ use matrice_s
+ use array
+ use form_factor_type
+ use constante, only: czero
+ !
+ implicit none
+ !
+ private
+ !
+ interface a30
+ !
+ module procedure a30_b, a30_s
+ !
+ end interface
+ !
+ interface a31
+ !
+ module procedure a31_b, a31_s
+ !
+ end interface
+ !
+ interface a32
+ !
+ module procedure a32_b, a32_s
+ !
+ end interface
+ !
+ interface a33
+ !
+ module procedure a33_b, a33_s
+ !
+ end interface
+ !
+ interface b32
+ !
+ module procedure b32_b, b32_s
+ !
+ end interface
+ !
+ interface b33
+ !
+ module procedure b33_b, b33_s
+ !
+ end interface
+ !
+ public :: a30,a31,a32,a33,b32,b33
+ !
+ contains
+ !
+ !****f* src/form_factor/form_factor_3p/a30_b
+ ! NAME
+ !
+ ! Function a30_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a30_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{3,0}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a30_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a30_b
+ !
+ integer :: b_pro
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ a30_b = f3p(s_mat_p,b_pro)
+ !
+ end function a30_b
+ !
+ !****f* src/form_factor/form_factor_3p/a30_s
+ ! NAME
+ !
+ ! Function a30_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a30_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{3,0}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a30_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a30_s
+ !
+ a30_s = a30_b(packb(set))
+ !
+ end function a30_s
+ !
+ !****f* src/form_factor/form_factor_3p/a31_b
+ ! NAME
+ !
+ ! Function a31_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a31_b(l1,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{3,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a31_b(l1,b_pin)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a31_b
+ !
+ integer :: b_pro
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ a31_b = -f3p(s_mat_p,b_pro,l1)
+ !
+ end function a31_b
+ !
+ !****f* src/form_factor/form_factor_3p/a31_s
+ ! NAME
+ !
+ ! Function a31_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a31_s(l1,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{3,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a31_s(l1,set)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a31_s
+ !
+ a31_s = a31_b(l1,packb(set))
+ !
+ end function a31_s
+ !
+ !****f* src/form_factor/form_factor_3p/a32_b
+ ! NAME
+ !
+ ! Function a32_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a32_b(l1,l2,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{3,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a32_b(l1,l2,b_pin)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a32_b
+ !
+ integer :: b_pro
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ a32_b = f3p(s_mat_p,b_pro,l1,l2)
+ !
+ end function a32_b
+ !
+ !****f* src/form_factor/form_factor_3p/a32_s
+ ! NAME
+ !
+ ! Function a32_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a32_s(l1,l2,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{3,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a32_s(l1,l2,set)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a32_s
+ !
+ a32_s = a32_b(l1,l2,packb(set))
+ !
+ end function a32_s
+ !
+ !****f* src/form_factor/form_factor_3p/a33_b
+ ! NAME
+ !
+ ! Function a33_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a33_b(l1,l2,l3,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{3,3}(l1,l2,l3).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a33_b(l1,l2,l3,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a33_b
+ !
+ integer :: b_pro
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ a33_b = -f3p(s_mat_p,b_pro,l1,l2,l3)
+ !
+ end function a33_b
+ !
+ !****f* src/form_factor/form_factor_3p/a33_s
+ ! NAME
+ !
+ ! Function a33_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a33_s(l1,l2,l3,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{3,3}(l1,l2,l3).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a33_s(l1,l2,l3,set)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a33_s
+ !
+ a33_s = a33_b(l1,l2,l3,packb(set))
+ !
+ end function a33_s
+ !
+ !****f* src/form_factor/form_factor_3p/b32_b
+ ! NAME
+ !
+ ! Function b32_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b32_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{3,2}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b32_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b32_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp(:) = czero
+ temp(2:3) = -f3p_np2(s_mat_p,b_pro)/2._ki
+ b32_b = temp
+ !
+ end function b32_b
+ !
+ !****f* src/form_factor/form_factor_3p/b32_s
+ ! NAME
+ !
+ ! Function b32_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b32_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{3,2}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b32_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b32_s
+ !
+ b32_s = b32_b(packb(set))
+ !
+ end function b32_s
+ !
+ !****f* src/form_factor/form_factor_3p/b33_b
+ ! NAME
+ !
+ ! Function b33_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b33_b(l1,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{3,3}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b33_b(l1,b_pin)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b33_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp(:) = czero
+ temp(2:3) = f3p_np2(s_mat_p,b_pro,l1)/2._ki
+ b33_b = temp
+ !
+ end function b33_b
+ !
+ !****f* src/form_factor/form_factor_3p/b33_s
+ ! NAME
+ !
+ ! Function b33_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b33_s(l1,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{3,3}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b33_s(l1,set)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b33_s
+ !
+ b33_s = b33_b(l1,packb(set))
+ !
+ end function b33_s
+ !
+end module form_factor_3p
diff --git a/golem95c-1.2.1/form_factor/form_factor_4p.f90 b/golem95c-1.2.1/form_factor/form_factor_4p.f90
new file mode 100644
index 0000000..2ad9d5d
--- /dev/null
+++ b/golem95c-1.2.1/form_factor/form_factor_4p.f90
@@ -0,0 +1,1482 @@
+!
+!****h* src/form_factor/form_factor_4p
+! NAME
+!
+! Module form_factor_4p
+!
+! USAGE
+!
+! use form_factor_4p
+!
+! DESCRIPTION
+!
+! This module contains the different form factors for four point amplitudes.
+!
+! OUTPUT
+!
+! It exports nine functions:
+! * a40 -- a function to compute A^{4,0}
+! * a41 -- a function to compute A^{4,1}
+! * a42 -- a function to compute A^{4,2}
+! * a43 -- a function to compute A^{4,3}
+! * a44 -- a function to compute A^{4,4}
+! * b42 -- a function to compute B^{4,2}
+! * b43 -- a function to compute B^{4,3}
+! * b44 -- a function to compute B^{4,4}
+! * c44 -- a function to compute C^{4,4}
+!
+! Note that a4xx, b4xx and c4xx are generic functions which can be called either with a
+! set of integers or with an integer whose bits represents the set
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * generic_function_4p (src/integrals/four_point/generic_function_4p.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * matrice_s (src/kinematic/matrice_s.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * form_factor_type (src/module/form_factor_type.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+!
+module form_factor_4p
+ !
+ use precision_golem
+ use generic_function_4p
+ use generic_function_3p
+ use matrice_s
+ use array
+ use sortie_erreur
+ use form_factor_type
+ use constante, only: czero
+ !
+ implicit none
+ !
+ private
+ !
+ integer :: b_pin_glob,b_pro_glob
+ !
+ interface a40
+ !
+ module procedure a40_b, a40_s
+ !
+ end interface
+ !
+ interface a41
+ !
+ module procedure a41_b, a41_s
+ !
+ end interface
+ !
+ interface a42
+ !
+ module procedure a42_b, a42_s
+ !
+ end interface
+ !
+ interface a43
+ !
+ module procedure a43_b, a43_s
+ !
+ end interface
+ !
+ interface a44
+ !
+ module procedure a44_b, a44_s
+ !
+ end interface
+ !
+ interface b42
+ !
+ module procedure b42_b, b42_s
+ !
+ end interface
+ !
+ interface b43
+ !
+ module procedure b43_b, b43_s
+ !
+ end interface
+ !
+ interface b44
+ !
+ module procedure b44_b, b44_s
+ !
+ end interface
+ !
+ interface c44
+ !
+ module procedure c44_b, c44_s
+ !
+ end interface
+ !
+ !
+ public :: a40,a41,a42,a43,a44,b42,b43,b44,c44
+ !
+ !
+ contains
+ !
+ !
+ !****f* src/form_factor/form_factor_4p/a40_b
+ ! NAME
+ !
+ ! Function a40_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a40_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,0}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a40_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a40_b
+ !
+ integer :: j
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ !real(ki) :: m1s,m2s,m3s,m4s
+ integer :: ib
+ integer :: b_pro,b_pro_mj
+ !integer :: m1,m2,m3,m4
+ integer, dimension(4) :: s
+ !
+ if (dim_s >= 4) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ s = unpackb(b_pro,countb(b_pro))
+ !
+ !
+ ! test if no internal masses are present
+ !
+ no_masses: if (iand(s_mat_p%b_zero, b_pro) .eq. b_pro ) then !case no-internal masses
+ !
+ temp1 = sumb(b_pin)*f4p_np2(s_mat_p,b_pro,b_pin)
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ temp2 = temp2 + b(j,b_pin)*f3p(s_mat_p,b_pro_mj)
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(3) = temp2(3) + temp1
+ a40_b = temp2
+ !
+ else ! internal masses are present: use 4-dim boxes
+ !
+ temp2(1:3) = f4p(s_mat_p,b_pro,b_pin)
+ a40_b = temp2
+ !
+ end if no_masses ! end test if internal masses are present
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a40'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 4: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a40_b
+ !
+ !****f* src/form_factor/form_factor_4p/a40_s
+ ! NAME
+ !
+ ! Function a40_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a40_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,0}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a40_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a40_s
+ !
+ a40_s = a40_b(packb(set))
+ !
+ end function a40_s
+ !
+ !****f* src/form_factor/form_factor_4p/a41_b
+ ! NAME
+ !
+ ! Function a41_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a41_b(l1,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a41_b(l1,b_pin)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a41_b
+ !
+ integer :: j
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib
+ integer :: b_pro,b_pro_mj
+ !
+ if (dim_s >= 4) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = -b(l1,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin)
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ temp2 = temp2 - inv_s(j,l1,b_pin)*f3p(s_mat_p,b_pro_mj)
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(3) = temp2(3) + temp1
+ a41_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a41'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 4: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a41_b
+ !
+ !****f* src/form_factor/form_factor_4p/a41_s
+ ! NAME
+ !
+ ! Function a41_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a41_s(l1,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a41_s(l1,set)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a41_s
+ !
+ a41_s = a41_b(l1,packb(set))
+ !
+ end function a41_s
+ !
+ !****f* src/form_factor/form_factor_4p/a42_b
+ ! NAME
+ !
+ ! Function a42_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a42_b(l1,l2,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a42_b(l1,l2,b_pin)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a42_b
+ !
+ integer :: j
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib
+ integer :: b_pro,b_pro_mj
+ !
+ if (dim_s >= 4) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = b(l1,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,l2) &
+ + b(l2,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,l1) &
+ - inv_s(l1,l2,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin)
+ !
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ temp2 = temp2 + ( inv_s(j,l1,b_pin)*f3p(s_mat_p,b_pro_mj,l2) &
+ &+ inv_s(j,l2,b_pin)*f3p(s_mat_p,b_pro_mj,l1) )/2._ki
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(3) = temp2(3) + temp1
+ a42_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a42'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 4: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a42_b
+ !
+ !****f* src/form_factor/form_factor_4p/a42_s
+ ! NAME
+ !
+ ! Function a42_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a42_s(l1,l2,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a42_s(l1,l2,set)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a42_s
+ !
+ a42_s = a42_b(l1,l2,packb(set))
+ !
+ end function a42_s
+ !
+ !****f* src/form_factor/form_factor_4p/a43_b
+ ! NAME
+ !
+ ! Function a43_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a43_b(l1,l2,l3,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,3}(l1,l2,l3).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a43_b(l1,l2,l3,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a43_b
+ !
+ complex(ki), dimension(3) :: t43
+ !
+ if (dim_s >= 4) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ t43 = f43(l1,l2,l3) + f43(l2,l1,l3) + f43(l3,l2,l1)
+ a43_b = t43
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a43'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 4: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a43_b
+ !
+ !****f* src/form_factor/form_factor_4p/a43_s
+ ! NAME
+ !
+ ! Function a43_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a43_s(l1,l2,l3,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,3}(l1,l2,l3).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a43_s(l1,l2,l3,set)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a43_s
+ !
+ a43_s = a43_b(l1,l2,l3,packb(set))
+ !
+ end function a43_s
+ !
+ !****if* src/form_factor/form_factor_4p/f43
+ ! NAME
+ !
+ ! Function f43
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f43(k1,k2,k3)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a43
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in a43
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f43(k1,k2,k3)
+ !
+ integer, intent(in) :: k1,k2,k3
+ complex(ki), dimension(3) :: f43
+ !
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: j
+ integer :: ib
+ integer :: b_pro_mj
+ !
+ temp1 = 2._ki/3._ki*inv_s(k2,k3,b_pin_glob)*f4p_np2(s_mat_p,b_pro_glob,b_pin_glob,k1) &
+ - b(k1,b_pin_glob)*f4p_np2(s_mat_p,b_pro_glob,b_pin_glob,k2,k3)
+ temp2(:) = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ !
+ temp2 = temp2 - inv_s(j,k1,b_pin_glob) &
+ *f3p(s_mat_p,b_pro_mj,k2,k3)/3._ki
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ f43 = temp2
+ f43(3) = f43(3) + temp1
+ !
+ end function f43
+ !
+ !****f* src/form_factor/form_factor_4p/a44_b
+ ! NAME
+ !
+ ! Function a44_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a44_b(l1,l2,l3,l4,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,4}(l1,l2,l3,l4).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a44_b(l1,l2,l3,l4,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3,l4
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a44_b
+ !
+ complex(ki), dimension(3) :: t44
+ !
+ if (dim_s >= 4) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ t44 = f44(l1,l2,l3,l4) + f44(l1,l3,l2,l4) + f44(l1,l4,l3,l2) &
+ + f44(l3,l2,l1,l4) + f44(l4,l2,l3,l1) + f44(l3,l4,l1,l2) &
+ + g44(l1,l2,l3,l4) + g44(l2,l1,l3,l4) + g44(l3,l1,l2,l4) &
+ + g44(l4,l1,l2,l3)
+ a44_b = t44
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a44'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 4: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a44_b
+ !
+ !****f* src/form_factor/form_factor_4p/a44_s
+ ! NAME
+ !
+ ! Function a44_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a44_s(l1,l2,l3,l4,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{4,4}(l1,l2,l3,l4).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a44_s(l1,l2,l3,l4,set)
+ !
+ integer, intent (in) :: l1,l2,l3,l4
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a44_s
+ !
+ a44_s = a44_b(l1,l2,l3,l4,packb(set))
+ !
+ end function a44_s
+ !
+ !****if* src/form_factor/form_factor_4p/f44
+ ! NAME
+ !
+ ! Function f44
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f44(k1,k2,k3,k4)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a44
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ ! * k4 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in a44
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f44(k1,k2,k3,k4)
+ !
+ integer, intent(in) :: k1,k2,k3,k4
+ complex(ki), dimension(3) :: f44
+ !
+ complex(ki) :: temp1
+ !
+ temp1 = -1._ki/2._ki*inv_s(k1,k2,b_pin_glob) &
+ *f4p_np2(s_mat_p,b_pro_glob,b_pin_glob,k3,k4)
+ f44(:) = czero
+ f44(3) = temp1
+ !
+ end function f44
+ !
+ !****if* src/form_factor/form_factor_4p/g44
+ ! NAME
+ !
+ ! Function g44
+ !
+ ! USAGE
+ !
+ ! real_dim6 = g44(k1,k2,k3,k4)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a44
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ ! * k4 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in a44
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function g44(k1,k2,k3,k4)
+ !
+ integer, intent(in) :: k1,k2,k3,k4
+ complex(ki), dimension(3) :: g44
+ !
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: j
+ integer :: ib
+ integer :: b_pro_mj
+ !
+ temp1 = b(k1,b_pin_glob)*f4p_np2(s_mat_p,b_pro_glob,b_pin_glob,k2,k3,k4)
+ temp2(:) = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ !
+ if ( (j /= k2) .and. (j /= k3) .and. (j /= k4) ) then
+ !
+ temp2 = temp2 + inv_s(j,k1,b_pin_glob) &
+ *f3p(s_mat_p,b_pro_mj,k2,k3,k4)/4._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ g44 = temp2
+ g44(3) = g44(3) + temp1
+ !
+ end function g44
+ !
+ !****f* src/form_factor/form_factor_4p/b42_b
+ ! NAME
+ !
+ ! Function b42_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b42_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{4,2}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b42_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b42_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp2
+ !
+ if (dim_s >= 4) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp2(:) = czero
+ temp2(3) = -f4p_np2(s_mat_p,b_pro,b_pin)/2._ki
+ b42_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function b42'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 4: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function b42_b
+ !
+ !****f* src/form_factor/form_factor_4p/b42_s
+ ! NAME
+ !
+ ! Function b42_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b42_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{4,2}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b42_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b42_s
+ !
+ b42_s = b42_b(packb(set))
+ !
+ end function b42_s
+ !
+ !****f* src/form_factor/form_factor_4p/b43_b
+ ! NAME
+ !
+ ! Function b43_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b43_b(l1,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{4,3}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b43_b(l1,b_pin)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b43_b
+ !
+ integer :: b_pro
+ !~ real(ki), dimension(2) :: temp1
+ complex(ki), dimension(3) :: temp2
+ !
+ if (dim_s >= 4) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp2(:) = czero
+ temp2(3) = f4p_np2(s_mat_p,b_pro,b_pin,l1)/2._ki
+ b43_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function b43'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 4: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function b43_b
+ !
+ !****f* src/form_factor/form_factor_4p/b43_s
+ ! NAME
+ !
+ ! Function b43_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b43_s(l1,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{4,3}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b43_s(l1,set)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b43_s
+ !
+ b43_s = b43_b(l1,packb(set))
+ !
+ end function b43_s
+ !
+ !****f* src/form_factor/form_factor_4p/b44_b
+ ! NAME
+ !
+ ! Function b44_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b44_b(l1,l2,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{4,4}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b44_b(l1,l2,b_pin)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b44_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp2
+ !
+ if (dim_s >= 4) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp2(:) = czero
+ temp2(3) = -f4p_np2(s_mat_p,b_pro,b_pin,l1,l2)/2._ki
+ b44_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function b44'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 4: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function b44_b
+ !
+ !****f* src/form_factor/form_factor_4p/b44_s
+ ! NAME
+ !
+ ! Function b44_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b44_s(l1,l2,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{4,4}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b44_s(l1,l2,set)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b44_s
+ !
+ b44_s = b44_b(l1,l2,packb(set))
+ !
+ end function b44_s
+ !
+ !****f* src/form_factor/form_factor_4p/c44_b
+ ! NAME
+ !
+ ! Function c44_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = c44_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor C^{4,4}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function c44_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: c44_b
+ !
+ integer :: b_pro
+ complex(ki), dimension(3) :: temp3
+ !
+ if (dim_s >= 4) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp3(:) = czero
+ !
+ temp3(2:3) = f4p_np4(s_mat_p,b_pro,b_pin)/4._ki
+ c44_b = temp3
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function c44'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 4: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function c44_b
+ !
+ !****f* src/form_factor/form_factor_4p/c44_s
+ ! NAME
+ !
+ ! Function c44_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = c44_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor C^{4,4}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function c44_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: c44_s
+ !
+ c44_s = c44_b(packb(set))
+ !
+ end function c44_s
+ !
+end module form_factor_4p
diff --git a/golem95c-1.2.1/form_factor/form_factor_5p.f90 b/golem95c-1.2.1/form_factor/form_factor_5p.f90
new file mode 100644
index 0000000..a3f7768
--- /dev/null
+++ b/golem95c-1.2.1/form_factor/form_factor_5p.f90
@@ -0,0 +1,2548 @@
+!
+!****h* src/form_factor/form_factor_5p
+! NAME
+!
+! Module form_factor_5p
+!
+! USAGE
+!
+! use form_factor_5p
+!
+! DESCRIPTION
+!
+! This module contains the different form factors for five point amplitudes.
+!
+! OUTPUT
+!
+! It exports twelve functions:
+! * a50 -- a function to compute A^{5,0}
+! * a51 -- a function to compute A^{5,1}
+! * a52 -- a function to compute A^{5,2}
+! * a53 -- a function to compute A^{5,3}
+! * a54 -- a function to compute A^{5,4}
+! * a55 -- a function to compute A^{5,5}
+! * b52 -- a function to compute B^{5,2}
+! * b53 -- a function to compute B^{5,3}
+! * b54 -- a function to compute B^{5,4}
+! * b55 -- a function to compute B^{5,5}
+! * c54 -- a function to compute C^{5,4}
+! * c55 -- a function to compute C^{5,5}
+!
+! Note that a5xx, b5xx and c5xx are generic functions which can be called either with a
+! set of integers or with an integer whose bits represents the set
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * generic_function_4p (src/integrals/four_point/generic_function_4p.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * matrice_s (src/kinematic/matrice_s.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * multiply_div (src/module/multiply_div.f90)
+! * form_factor_type (src/module/form_factor_type.f90)
+!
+!*****
+module form_factor_5p
+ !
+ use precision_golem
+ use generic_function_4p
+ use generic_function_3p
+ use array
+ use matrice_s
+ use sortie_erreur
+ use multiply_div
+ use form_factor_type
+ use constante, only: czero
+ implicit none
+ !
+ private
+ integer :: b_pin_glob,b_pro_glob
+ !
+ interface a50
+ !
+ module procedure a50_b, a50_s
+ !
+ end interface
+ !
+ interface a51
+ !
+ module procedure a51_b, a51_s
+ !
+ end interface
+ !
+ interface a52
+ !
+ module procedure a52_b, a52_s
+ !
+ end interface
+ !
+ interface a53
+ !
+ module procedure a53_b, a53_s
+ !
+ end interface
+ !
+ interface a54
+ !
+ module procedure a54_b, a54_s
+ !
+ end interface
+ !
+ interface a55
+ !
+ module procedure a55_b, a55_s
+ !
+ end interface
+ !
+ interface b52
+ !
+ module procedure b52_b, b52_s
+ !
+ end interface
+ !
+ interface b53
+ !
+ module procedure b53_b, b53_s
+ !
+ end interface
+ !
+ interface b54
+ !
+ module procedure b54_b, b54_s
+ !
+ end interface
+ !
+ interface b55
+ !
+ module procedure b55_b, b55_s
+ !
+ end interface
+ !
+ interface c54
+ !
+ module procedure c54_b, c54_s
+ !
+ end interface
+ !
+ interface c55
+ !
+ module procedure c55_b, c55_s
+ !
+ end interface
+ !
+ public :: a50,a51,a52,a53,a54,a55,b52,b53,b54,b55,c54,c55
+ !
+ contains
+ !
+ !****f* src/form_factor/form_factor_5p/a50_b
+ ! NAME
+ !
+ ! Function a50_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a50_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,0}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a50_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a50_b
+ !
+ integer :: j,k
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib,ibj
+ integer :: b_pro,b_pro_mj,b_pro_mjk
+ integer :: b_pin_pj
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ temp1 = temp1 + b(j,b_pin)*sumb(b_pin_pj)*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj)
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ !
+ temp2 = temp2 + b(j,b_pin)*b(k,b_pin_pj)*f3p(s_mat_p,b_pro_mjk)
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(3) = temp2(3) + temp1
+ a50_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a50'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a50_b
+ !
+ !****f* src/form_factor/form_factor_5p/a50_s
+ ! NAME
+ !
+ ! Function a50_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a50_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,0}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a50_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a50_s
+ !
+ a50_s = a50_b(packb(set))
+ !
+ end function a50_s
+ !
+ !****f* src/form_factor/form_factor_5p/a51_b
+ ! NAME
+ !
+ ! Function a51_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a51_b(l1,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a51_b(l1,b_pin)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a51_b
+ !
+ integer :: j,k
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib,ibj
+ integer :: b_pro,b_pro_mj,b_pro_mjk
+ integer :: b_pin_pj
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ temp1 = temp1 - inv_s(j,l1,b_pin)*sumb(b_pin_pj)*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj)
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ !
+ temp2 = temp2 - inv_s(j,l1,b_pin)*b(k,b_pin_pj)*f3p(s_mat_p,b_pro_mjk)
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(3) = temp2(3) + temp1
+ a51_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a51'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a51_b
+ !
+ !****f* src/form_factor/form_factor_5p/a51_s
+ ! NAME
+ !
+ ! Function a51_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a51_s(l1,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a51_s(l1,set)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a51_s
+ !
+ a51_s = a51_b(l1,packb(set))
+ !
+ end function a51_s
+ !
+ !****f* src/form_factor/form_factor_5p/a52_b
+ ! NAME
+ !
+ ! Function a52_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a52_b(l1,l2,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a52_b(l1,l2,b_pin)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a52_b
+ !
+ integer :: j,k
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib,ibj
+ integer :: b_pro,b_pro_mj,b_pro_mjk
+ integer :: b_pin_pj
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ temp1 = temp1 + ( inv_s(j,l1,b_pin)*b(l2,b_pin) + inv_s(j,l2,b_pin)*b(l1,b_pin) &
+ - 2._ki*inv_s(l1,l2,b_pin)*b(j,b_pin) &
+ + b(j,b_pin)*inv_s(l1,l2,b_pin_pj) )*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj)
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ !
+ temp2 = temp2 + ( inv_s(j,l2,b_pin)*inv_s(k,l1,b_pin_pj) &
+ + inv_s(j,l1,b_pin)*inv_s(k,l2,b_pin_pj) ) &
+ *f3p(s_mat_p,b_pro_mjk)/2._ki
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(3) = temp2(3) + temp1
+ a52_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a52'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a52_b
+ !
+ !****f* src/form_factor/form_factor_5p/a52_s
+ ! NAME
+ !
+ ! Function a52_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a52_s(l1,l2,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a52_s(l1,l2,set)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a52_s
+ !
+ a52_s = a52_b(l1,l2,packb(set))
+ !
+ end function a52_s
+ !
+ !****f* src/form_factor/form_factor_5p/a53_b
+ ! NAME
+ !
+ ! Function a53_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a53_b(l1,l2,l3,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,3}(l1,l2,l3).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a53_b(l1,l2,l3,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a53_b
+ !
+ complex(ki), dimension(3) :: t53
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ t53 = f53(l1,l2,l3) + f53(l1,l3,l2) + f53(l3,l2,l1)
+ a53_b = t53
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a53'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a53_b
+ !
+ !****f* src/form_factor/form_factor_5p/a53_s
+ ! NAME
+ !
+ ! Function a53_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a53_s(l1,l2,l3,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,3}(l1,l2,l3).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a53_s(l1,l2,l3,set)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a53_s
+ !
+ a53_s = a53_b(l1,l2,l3,packb(set))
+ !
+ end function a53_s
+ !
+ !****if* src/form_factor/form_factor_5p/f53
+ ! NAME
+ !
+ ! Function f53
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f53(k1,k2,k3)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a53
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in a53
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f53(k1,k2,k3)
+ !
+ integer, intent(in) :: k1,k2,k3
+ complex(ki), dimension(3) :: f53
+ !
+ integer :: j,k
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ complex(ki) :: bk1_cache, bk2_cache, invsk1k2_cache
+ complex(ki) :: invsjk1_cache, invsjk2_cache
+ integer :: ib,ibj
+ integer :: b_pro_mj,b_pro_mjk
+ integer :: b_pin_pj
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+
+ bk1_cache = b(k1,b_pin_glob)
+ bk2_cache = b(k2,b_pin_glob)
+ invsk1k2_cache = inv_s(k1,k2,b_pin_glob)
+
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ b_pin_pj = ibset(b_pin_glob,j)
+ !
+ invsjk1_cache = inv_s(j,k1,b_pin_glob)
+ invsjk2_cache = inv_s(j,k2,b_pin_glob)
+
+ temp1 = temp1 - ( invsjk1_cache*bk2_cache &
+ + invsjk2_cache*bk1_cache &
+ - 2._ki*invsk1k2_cache*b(j,b_pin_glob) &
+ + b(j,b_pin_glob)*inv_s(k1,k2,b_pin_pj) ) &
+ *f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,k3)*2._ki/3._ki &
+ + inv_s(j,k3,b_pin_glob)*inv_s(k1,k2,b_pin_pj) &
+ *f4p_np2(s_mat_p,b_pro_mj,b_pin_pj)/3._ki
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ !
+ temp2 = temp2 - ( invsjk1_cache*inv_s(k,k2,b_pin_pj) &
+ + invsjk2_cache*inv_s(k,k1,b_pin_pj) ) &
+ *f3p(s_mat_p,b_pro_mjk,k3)/6._ki
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ f53 = temp2
+ f53(3) = f53(3) + temp1
+ !
+ end function f53
+ !
+ !****f* src/form_factor/form_factor_5p/a54_b
+ ! NAME
+ !
+ ! Function a54_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a54_b(l1,l2,l3,l4,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,4}(l1,l2,l3,l4).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a54_b(l1,l2,l3,l4,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3,l4
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a54_b
+ !
+ complex(ki), dimension(3) :: t54
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ t54 = ( f54(l1,l2,l3,l4) + f54(l1,l3,l2,l4) + f54(l1,l4,l3,l2) &
+ + f54(l3,l2,l1,l4) + f54(l4,l2,l3,l1) + f54(l3,l4,l1,l2) &
+ + g54(l1,l2,l3,l4) + g54(l2,l1,l3,l4) + g54(l3,l2,l1,l4) &
+ + g54(l4,l2,l3,l1) )/4._ki
+ a54_b = t54
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a54'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a54_b
+ !
+ !****f* src/form_factor/form_factor_5p/a54_s
+ ! NAME
+ !
+ ! Function a54_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a54_s(l1,l2,l3,l4,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,4}(l1,l2,l3,l4).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a54_s(l1,l2,l3,l4,set)
+ !
+ integer, intent (in) :: l1,l2,l3,l4
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a54_s
+ !
+ a54_s = a54_b(l1,l2,l3,l4,packb(set))
+ !
+ end function a54_s
+ !
+ !****if* src/form_factor/form_factor_5p/f54
+ ! NAME
+ !
+ ! Function f54
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f54(k1,k2,k3,k4)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a54
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ ! * k4 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in a54
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f54(k1,k2,k3,k4)
+ !
+ integer, intent(in) :: k1,k2,k3,k4
+ complex(ki), dimension(3) :: f54
+ !
+ integer :: j,k
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib,ibj
+ integer :: b_pro_mj,b_pro_mjk
+ integer :: b_pin_pj
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp1 = temp1 - 2._ki*( 2._ki*inv_s(k3,k4,b_pin_glob)*b(j,b_pin_glob) &
+ - inv_s(j,k4,b_pin_glob)*b(k3,b_pin_glob) &
+ - inv_s(j,k3,b_pin_glob)*b(k4,b_pin_glob) &
+ - b(j,b_pin_glob)*inv_s(k3,k4,b_pin_pj) ) &
+ *f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,k1,k2)
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ !
+ temp2 = temp2 + ( inv_s(j,k3,b_pin_glob)*inv_s(k,k4,b_pin_pj) &
+ + inv_s(j,k4,b_pin_glob)*inv_s(k,k3,b_pin_pj) ) &
+ *f3p(s_mat_p,b_pro_mjk,k1,k2)/3._ki
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ f54 = temp2
+ f54(3) = f54(3) + temp1
+ !
+ end function f54
+ !
+ !****if* src/form_factor/form_factor_5p/g54
+ ! NAME
+ !
+ ! Function g54
+ !
+ ! USAGE
+ !
+ ! real_dim6 = g54(k1,k2,k3,k4)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a54
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ ! * k4 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in a54
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function g54(k1,k2,k3,k4)
+ !
+ integer, intent(in) :: k1,k2,k3,k4
+ complex(ki), dimension(3) :: g54
+ !
+ integer :: j
+ complex(ki) :: temp1
+ integer :: ib
+ integer :: b_pro_mj
+ integer :: b_pin_pj
+ !
+ temp1 = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp1 = temp1 - 2._ki*( inv_s(j,k4,b_pin_glob)*inv_s(k2,k3,b_pin_pj) &
+ + inv_s(j,k3,b_pin_glob)*inv_s(k2,k4,b_pin_pj) &
+ + inv_s(j,k2,b_pin_glob)*inv_s(k3,k4,b_pin_pj) ) &
+ *f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,k1)/3._ki
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ g54(:) = czero
+ g54(3) = g54(3) + temp1
+ !
+ end function g54
+ !
+ !****f* src/form_factor/form_factor_5p/a55_b
+ ! NAME
+ !
+ ! Function a55_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a55_b(l1,l2,l3,l4,l5,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,5}(l1,l2,l3,l4,l5).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l5 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a55_b(l1,l2,l3,l4,l5,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3,l4,l5
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a55_b
+ !
+ complex(ki), dimension(3) :: t55
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ t55 = ( f55(l1,l2,l3,l4,l5) + f55(l1,l2,l4,l3,l5) &
+ + f55(l1,l2,l5,l4,l3) + f55(l1,l4,l3,l2,l5) &
+ + f55(l1,l5,l3,l4,l2) + f55(l4,l2,l3,l1,l5) &
+ + f55(l5,l2,l3,l4,l1) + f55(l1,l4,l5,l2,l3) &
+ + f55(l4,l2,l5,l1,l3) + f55(l4,l5,l3,l1,l2) &
+ + g55(l1,l2,l3,l4,l5) + g55(l1,l3,l2,l4,l5) &
+ + g55(l3,l2,l1,l4,l5) + g55(l4,l2,l3,l1,l5) &
+ + g55(l1,l4,l3,l2,l5) + g55(l5,l2,l3,l4,l1) &
+ + g55(l1,l5,l3,l4,l2) + g55(l3,l4,l1,l2,l5) &
+ + g55(l3,l5,l1,l4,l2) + g55(l4,l5,l3,l1,l2) )/5._ki
+ a55_b = t55
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a55'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a55_b
+ !
+ !****f* src/form_factor/form_factor_5p/a55_s
+ ! NAME
+ !
+ ! Function a55_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a55_s(l1,l2,l3,l4,l5,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{5,5}(l1,l2,l3,l4,l5).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l5 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a55_s(l1,l2,l3,l4,l5,set)
+ !
+ integer, intent (in) :: l1,l2,l3,l4,l5
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a55_s
+ !
+ a55_s = a55_b(l1,l2,l3,l4,l5,packb(set))
+ !
+ end function a55_s
+ !
+ !****if* src/form_factor/form_factor_5p/f55
+ ! NAME
+ !
+ ! Function f55
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f55(k1,k2,k3,k4,k5)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a55
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ ! * k4 -- an integer
+ ! * k5 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in a55
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f55(k1,k2,k3,k4,k5)
+ !
+ integer, intent(in) :: k1,k2,k3,k4,k5
+ complex(ki), dimension(3) :: f55
+ !
+ integer :: j,k
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib,ibj
+ integer :: b_pro_mj,b_pro_mjk
+ integer :: b_pin_pj
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp1 = temp1 + 2._ki*( 2._ki*inv_s(k4,k5,b_pin_glob)*b(j,b_pin_glob) &
+ - inv_s(j,k4,b_pin_glob)*b(k5,b_pin_glob) &
+ - inv_s(j,k5,b_pin_glob)*b(k4,b_pin_glob) &
+ - b(j,b_pin_glob)*inv_s(k4,k5,b_pin_pj) ) &
+ *f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,parf1=k1,parf2=k2,parf3=k3)
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ !
+ temp2 = temp2 - ( inv_s(j,k5,b_pin_glob)*inv_s(k,k4,b_pin_pj) &
+ + inv_s(j,k4,b_pin_glob)*inv_s(k,k5,b_pin_pj) ) &
+ *f3p(s_mat_p,b_pro_mjk,parf1=k1,parf2=k2,parf3=k3)/4._ki
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ f55 = temp2
+ f55(3) = f55(3) + temp1
+ !
+ end function f55
+ !
+ !****if* src/form_factor/form_factor_5p/g55
+ ! NAME
+ !
+ ! Function g55
+ !
+ ! USAGE
+ !
+ ! real_dim6 = g55(k1,k2,k3,k4,k5)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a55
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ ! * k4 -- an integer
+ ! * k5 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in a55
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function g55(k1,k2,k3,k4,k5)
+ !
+ integer, intent(in) :: k1,k2,k3,k4,k5
+ complex(ki), dimension(3) :: g55
+ !
+ integer :: j
+ complex(ki) :: temp1
+ integer :: ib
+ integer :: b_pro_mj
+ integer :: b_pin_pj
+ !
+ temp1 = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp1 = temp1 + ( inv_s(j,k4,b_pin_glob)*inv_s(k3,k5,b_pin_pj) &
+ + inv_s(j,k3,b_pin_glob)*inv_s(k4,k5,b_pin_pj) &
+ + inv_s(j,k5,b_pin_glob)*inv_s(k3,k4,b_pin_pj) ) &
+ *f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,parf1=k1,parf2=k2)/2._ki
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ g55(:) = czero
+ g55(3) = g55(3) + temp1
+ !
+ end function g55
+ !
+ !****f* src/form_factor/form_factor_5p/b52_b
+ ! NAME
+ !
+ ! Function b52_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b52_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{5,2}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b52_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b52_b
+ !
+ integer :: j
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib
+ integer :: b_pro,b_pro_mj
+ integer :: b_pin_pj
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ temp1 = temp1 - b(j,b_pin)*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj)/2._ki
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(:) = czero
+ temp2(3) = temp1
+ b52_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function b52'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function b52_b
+ !
+ !****f* src/form_factor/form_factor_5p/b52_s
+ ! NAME
+ !
+ ! Function b52_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b52_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{5,2}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b52_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b52_s
+ !
+ b52_s = b52_b(packb(set))
+ !
+ end function b52_s
+ !
+ !****f* src/form_factor/form_factor_5p/b53_b
+ ! NAME
+ !
+ ! Function b53_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b53_b(l1,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{5,3}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b53_b(l1,b_pin)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b53_b
+ !
+ integer :: j
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib
+ integer :: b_pro,b_pro_mj
+ integer :: b_pin_pj
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = ibset(b_pin,j)
+ !
+ temp1 = temp1 + ( b(j,b_pin)*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,l1) &
+ + inv_s(j,l1,b_pin)*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj)/2._ki )/3._ki
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(:) = czero
+ temp2(3) = temp1
+ b53_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function b53'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function b53_b
+ !
+ !****f* src/form_factor/form_factor_5p/b53_s
+ ! NAME
+ !
+ ! Function b53_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b53_s(l1,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{5,3}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b53_s(l1,set)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b53_s
+ !
+ b53_s = b53_b(l1,packb(set))
+ !
+ end function b53_s
+ !
+ !****f* src/form_factor/form_factor_5p/b54_b
+ ! NAME
+ !
+ ! Function b54_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b54_b(l1,l2,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{5,4}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b54_b(l1,l2,b_pin)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b54_b
+ !
+ integer :: j,k
+ complex(ki) :: temp1
+ complex(ki), dimension(2) :: temp2
+ complex(ki), dimension(3) :: temp3
+ integer :: ib,ibj
+ integer :: b_pro,b_pro_mj,b_pro_mjk
+ integer :: b_pin_pj
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ temp1 = temp1 - b(j,b_pin)*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,l1,l2) &
+ - ( inv_s(j,l1,b_pin)*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,l2) &
+ + inv_s(j,l2,b_pin)*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,l1) &
+ )/3._ki
+ temp2 = temp2 + mult_div(-2._ki/3._ki,f4p_np4(s_mat_p,b_pro_mj,b_pin_pj)) &
+ *( 2._ki*inv_s(l1,l2,b_pin)*b(j,b_pin) &
+ - inv_s(j,l1,b_pin)*b(l2,b_pin) &
+ - inv_s(j,l2,b_pin)*b(l1,b_pin) &
+ - b(j,b_pin)*inv_s(l1,l2,b_pin_pj) )
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ !
+ temp2 = temp2 - ( inv_s(j,l1,b_pin)*inv_s(k,l2,b_pin_pj) &
+ + inv_s(j,l2,b_pin)*inv_s(k,l1,b_pin_pj) ) &
+ *f3p_np2(s_mat_p,b_pro_mjk)/6._ki
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp3(:) = czero
+ temp3(2:3) = temp2
+ temp3(3) = temp3(3) + temp1
+ temp3 = temp3/4._ki
+ b54_b = temp3
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function b54'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function b54_b
+ !
+ !****f* src/form_factor/form_factor_5p/b54_s
+ ! NAME
+ !
+ ! Function b54_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b54_s(l1,l2,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{5,4}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b54_s(l1,l2,set)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b54_s
+ !
+ b54_s = b54_b(l1,l2,packb(set))
+ !
+ end function b54_s
+ !
+ !****f* src/form_factor/form_factor_5p/b55_b
+ ! NAME
+ !
+ ! Function b55_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b55_b(l1,l2.l3,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{5,5}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b55_b(l1,l2,l3,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in) :: b_pin
+ type(form_factor) :: b55_b
+ !
+ integer :: j
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib
+ integer :: b_pro_mj
+ integer :: b_pin_pj
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ temp1 = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp1 = temp1 + b(j,b_pin_glob)*f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,l1,l2,l3)
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(:) = czero
+ temp2(2:3) = fb55(l1,l2,l3) + fb55(l1,l3,l2) + fb55(l3,l2,l1) &
+ + gb55(l1,l2,l3) + gb55(l2,l1,l3) + gb55(l3,l2,l1)
+ temp2(3) = temp2(3) + temp1
+ temp2 = temp2/5._ki
+ b55_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function b55'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function b55_b
+ !
+ !****f* src/form_factor/form_factor_5p/b55_s
+ ! NAME
+ !
+ ! Function b55_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = b55_s(l1,l2.l3,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor B^{5,5}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function b55_s(l1,l2,l3,set)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: b55_s
+ !
+ b55_s = b55_b(l1,l2,l3,packb(set))
+ !
+ end function b55_s
+ !
+ !****if* src/form_factor/form_factor_5p/fb55
+ ! NAME
+ !
+ ! Function fb55
+ !
+ ! USAGE
+ !
+ ! real_dim6 = fb55(k1,k2,k3)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function b55
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in b55
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function fb55(k1,k2,k3)
+ !
+ integer, intent(in) :: k1,k2,k3
+ complex(ki), dimension(2) :: fb55
+ !
+ integer :: j
+ complex(ki) :: temp1
+ integer :: ib
+ integer :: b_pro_mj
+ integer :: b_pin_pj
+ !
+ temp1 = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp1 = temp1 + inv_s(j,k3,b_pin_glob) &
+ *f4p_np2(s_mat_p,b_pro_mj,b_pin_pj,k1,k2) &
+ /4._ki
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ fb55(:) = czero
+ fb55(2) = fb55(2) + temp1
+ !
+ end function fb55
+ !
+ !****if* src/form_factor/form_factor_5p/gb55
+ ! NAME
+ !
+ ! Function gb55
+ !
+ ! USAGE
+ !
+ ! real_dim6 = gb55(k1,k2,k3)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function b55
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in b55
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function gb55(k1,k2,k3)
+ !
+ integer, intent(in) :: k1,k2,k3
+ complex(ki), dimension(2) :: gb55
+ !
+ integer :: j,k
+ complex(ki), dimension(2) :: temp2
+ integer :: ib,ibj
+ integer :: b_pro_mj,b_pro_mjk
+ integer :: b_pin_pj
+ !
+ temp2(:) = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp2 = temp2 + mult_div(-1._ki/2._ki,f4p_np4(s_mat_p,b_pro_mj,b_pin_pj,k1)) &
+ *( inv_s(j,k2,b_pin_glob)*b(k3,b_pin_glob) &
+ + inv_s(j,k3,b_pin_glob)*b(k2,b_pin_glob) &
+ - 2._ki*inv_s(k2,k3,b_pin_glob)*b(j,b_pin_glob) &
+ + b(j,b_pin_glob)*inv_s(k2,k3,b_pin_pj) ) &
+ - inv_s(j,k1,b_pin_glob)*inv_s(k2,k3,b_pin_pj) &
+ *f4p_np4(s_mat_p,b_pro_mj,b_pin_pj)/4._ki
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ !
+ temp2 = temp2 + ( inv_s(j,k3,b_pin_glob)*inv_s(k,k2,b_pin_pj) &
+ + inv_s(j,k2,b_pin_glob)*inv_s(k,k3,b_pin_pj) ) &
+ *f3p_np2(s_mat_p,b_pro_mjk,k1)/8._ki
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ gb55 = temp2
+ !
+ end function gb55
+ !
+ !****f* src/form_factor/form_factor_5p/c54_b
+ ! NAME
+ !
+ ! Function c54_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = c54_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor C^{5,4}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function c54_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: c54_b
+ !
+ integer :: j
+ complex(ki), dimension(2) :: temp2
+ complex(ki), dimension(3) :: temp3
+ integer :: ib
+ integer :: b_pro,b_pro_mj
+ integer :: b_pin_pj
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ temp2 = temp2 + mult_div(-2._ki/3._ki,f4p_np4(s_mat_p,b_pro_mj,b_pin_pj)) &
+ *b(j,b_pin)
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp3(:) = czero
+ temp3(2:3) = temp2/4._ki
+ c54_b = temp3
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function c54'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function c54_b
+ !
+ !****f* src/form_factor/form_factor_5p/c54_s
+ ! NAME
+ !
+ ! Function c54_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = c54_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor C^{5,4}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function c54_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: c54_s
+ !
+ c54_s = c54_b(packb(set))
+ !
+ end function c54_s
+ !
+ !****f* src/form_factor/form_factor_5p/c55_b
+ ! NAME
+ !
+ ! Function c55_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = c55_b(l1,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor C^{5,5}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function c55_b(l1,b_pin)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in) :: b_pin
+ type(form_factor) :: c55_b
+ !
+ integer :: j
+ complex(ki), dimension(2) :: temp2
+ complex(ki), dimension(3) :: temp3
+ integer :: ib
+ integer :: b_pro,b_pro_mj
+ integer :: b_pin_pj
+ !
+ if (dim_s >= 5) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ temp2 = temp2 - mult_div(-1._ki/2._ki,f4p_np4(s_mat_p,b_pro_mj,b_pin_pj,l1)) &
+ *b(j,b_pin) - inv_s(j,l1,b_pin)*f4p_np4(s_mat_p,b_pro_mj,b_pin_pj)/4._ki
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp3(:) = czero
+ temp3(2:3) = temp2/5._ki
+ c55_b = temp3
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function c55'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 5: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function c55_b
+ !
+ !****f* src/form_factor/form_factor_5p/c55_s
+ ! NAME
+ !
+ ! Function c55_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = c55_s(l1,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor C^{5,5}.
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function c55_s(l1,set)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: c55_s
+ !
+ c55_s = c55_b(l1,packb(set))
+ !
+ end function c55_s
+ !
+end module form_factor_5p
diff --git a/golem95c-1.2.1/form_factor/form_factor_6p.f90 b/golem95c-1.2.1/form_factor/form_factor_6p.f90
new file mode 100644
index 0000000..88f13fc
--- /dev/null
+++ b/golem95c-1.2.1/form_factor/form_factor_6p.f90
@@ -0,0 +1,1539 @@
+!
+!****h* src/form_factor/form_factor_6p
+! NAME
+!
+! Module form_factor_6p
+!
+! USAGE
+!
+! use form_factor_6p
+!
+! DESCRIPTION
+!
+! This module contains the different form factors for six point amplitudes.
+!
+! OUTPUT
+!
+! It exports seven functions:
+! * a60 -- a function to compute A^{6,0}
+! * a61 -- a function to compute A^{6,1}
+! * a62 -- a function to compute A^{6,2}
+! * a63 -- a function to compute A^{6,3}
+! * a64 -- a function to compute A^{6,4}
+! * a65 -- a function to compute A^{6,5}
+! * a66 -- a function to compute A^{6,6}
+!
+! Note that a6xx are generic functions which can be called either with a
+! set of integers or with an integer whose bits represents the set
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * generic_function_4p (src/integrals/four_point/generic_function_4p.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * form_factor_5p (src/form_factor/form_factor_5p.f90)
+! * array (src/module/array.f90)
+! * matrice_s (src/kinematic/matrice_s.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * form_factor_type (src/module/form_factor_type.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+module form_factor_6p
+ !
+ use precision_golem
+ use generic_function_4p
+ use generic_function_3p
+ use form_factor_5p
+ use array
+ use matrice_s
+ use sortie_erreur
+ use form_factor_type
+ use constante, only: czero
+ !
+ implicit none
+ !
+ private
+ !
+ integer :: b_pin_glob,b_pro_glob
+ !
+ interface a60
+ !
+ module procedure a60_b, a60_s
+ !
+ end interface
+ !
+ interface a61
+ !
+ module procedure a61_b, a61_s
+ !
+ end interface
+ !
+ interface a62
+ !
+ module procedure a62_b, a62_s
+ !
+ end interface
+ !
+ interface a63
+ !
+ module procedure a63_b, a63_s
+ !
+ end interface
+ !
+ interface a64
+ !
+ module procedure a64_b, a64_s
+ !
+ end interface
+ !
+ interface a65
+ !
+ module procedure a65_b, a65_s
+ !
+ end interface
+ !
+ interface a66
+ !
+ module procedure a66_b, a66_s
+ !
+ end interface
+ !
+ !
+ public :: a60,a61,a62,a63,a64,a65,a66
+ !
+ !
+ contains
+ !
+ !
+ !****f* src/form_factor/form_factor_6p/a60_b
+ ! NAME
+ !
+ ! Function a60_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a60_b(b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,0}.
+ !
+ ! INPUTS
+ !
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a60_b(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a60_b
+ !
+ integer :: j,k,l
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib,ibj,ibjk
+ integer :: b_pro,b_pro_mj,b_pro_mjk,b_pro_mjkl
+ integer :: b_pin_pj,b_pin_pjk
+ !
+ if (dim_s >= 6) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ b_pin_pjk = punion( b_pin_pj,ibset(0,k) )
+ temp1 = temp1 + b(j,b_pin)*b(k,b_pin_pj)*sumb(b_pin_pjk)*f4p_np2(s_mat_p,b_pro_mjk,b_pin_pjk)
+ !
+ ibjk = b_pro_mjk
+ l = 0
+ !
+ third_pinch: do while (ibjk /= 0)
+ !
+ if (modulo(ibjk,2) == 1) then
+ !
+ b_pro_mjkl = ibclr(b_pro_mjk,l)
+ temp2 = temp2 + b(j,b_pin)*b(k,b_pin_pj)*b(l,b_pin_pjk) &
+ *f3p(s_mat_p,b_pro_mjkl)
+ !
+ end if
+ !
+ l = l + 1
+ ibjk = ishft(ibjk,-1)
+ !
+ end do third_pinch
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(3) = temp2(3) + temp1
+ a60_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a60'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 6: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a60_b
+ !
+ !****f* src/form_factor/form_factor_6p/a60_s
+ ! NAME
+ !
+ ! Function a60_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a60_s(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,0}.
+ !
+ ! INPUTS
+ !
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a60_s(set)
+ !
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a60_s
+ !
+ a60_s = a60_b(packb(set))
+ !
+ end function a60_s
+ !
+ !****f* src/form_factor/form_factor_5p/a61_b
+ ! NAME
+ !
+ ! Function a61_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a61_b(l1,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a61_b(l1,b_pin)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a61_b
+ !
+ integer :: j,k,l
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib,ibj,ibjk
+ integer :: b_pro,b_pro_mj,b_pro_mjk,b_pro_mjkl
+ integer :: b_pin_pj,b_pin_pjk
+ !
+ if (dim_s >= 6) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ b_pin_pjk = punion( b_pin_pj,ibset(0,k) )
+ temp1 = temp1 - inv_s(j,l1,b_pin)*b(k,b_pin_pj)*sumb(b_pin_pjk) &
+ *f4p_np2(s_mat_p,b_pro_mjk,b_pin_pjk)
+ !
+ ibjk = b_pro_mjk
+ l = 0
+ !
+ third_pinch: do while (ibjk /= 0)
+ !
+ if (modulo(ibjk,2) == 1) then
+ !
+ b_pro_mjkl = ibclr(b_pro_mjk,l)
+ temp2 = temp2 - inv_s(j,l1,b_pin)*b(k,b_pin_pj)*b(l,b_pin_pjk) &
+ *f3p(s_mat_p,b_pro_mjkl)
+ !
+ end if
+ !
+ l = l + 1
+ ibjk = ishft(ibjk,-1)
+ !
+ end do third_pinch
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(3) = temp2(3) + temp1
+ a61_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a61'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 6: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a61_b
+ !
+ !****f* src/form_factor/form_factor_5p/a61_s
+ ! NAME
+ !
+ ! Function a61_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a61_s(l1,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,1}(l_1).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a61_s(l1,set)
+ !
+ integer, intent (in) :: l1
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a61_s
+ !
+ a61_s = a61_b(l1,packb(set))
+ !
+ end function a61_s
+ !
+ !****f* src/form_factor/form_factor_5p/a62_b
+ ! NAME
+ !
+ ! Function a62_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a62_b(l1,l2,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a62_b(l1,l2,b_pin)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a62_b
+ !
+ integer :: j,k,l
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib,ibj,ibjk
+ integer :: b_pro,b_pro_mj,b_pro_mjk,b_pro_mjkl
+ integer :: b_pin_pj,b_pin_pjk
+ !
+ if (dim_s >= 6) then
+ !
+ b_pro = pminus(b_ref,b_pin)
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ b_pin_pj = punion( b_pin,ibset(0,j) )
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ b_pin_pjk = punion( b_pin_pj,ibset(0,k) )
+ temp1 = temp1 + ( inv_s(j,l1,b_pin)*inv_s(k,l2,b_pin_pj) &
+ + inv_s(j,l2,b_pin)*inv_s(k,l1,b_pin_pj) ) &
+ *sumb(b_pin_pjk)*f4p_np2(s_mat_p,b_pro_mjk,b_pin_pjk)/2._ki
+ !
+ ibjk = b_pro_mjk
+ l = 0
+ !
+ third_pinch: do while (ibjk /= 0)
+ !
+ if (modulo(ibjk,2) == 1) then
+ !
+ b_pro_mjkl = ibclr(b_pro_mjk,l)
+ temp2 = temp2 + ( inv_s(j,l1,b_pin)*inv_s(k,l2,b_pin_pj) &
+ + inv_s(j,l2,b_pin)*inv_s(k,l1,b_pin_pj) ) &
+ *b(l,b_pin_pjk)*f3p(s_mat_p,b_pro_mjkl)/2._ki
+ !
+ end if
+ !
+ l = l + 1
+ ibjk = ishft(ibjk,-1)
+ !
+ end do third_pinch
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ temp2(3) = temp2(3) + temp1
+ a62_b = temp2
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a62'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 6: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a62_b
+ !
+ !****f* src/form_factor/form_factor_5p/a62_s
+ ! NAME
+ !
+ ! Function a62_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a62_s(l1,l2,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,2}(l1,l2).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a62_s(l1,l2,set)
+ !
+ integer, intent (in) :: l1,l2
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a62_s
+ !
+ a62_s = a62_b(l1,l2,packb(set))
+ !
+ end function a62_s
+ !
+ !****f* src/form_factor/form_factor_5p/a63_b
+ ! NAME
+ !
+ ! Function a63_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a63_b(l1,l2,l3,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,3}(l1,l2,l3).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a63_b(l1,l2,l3,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a63_b
+ !
+ complex(ki), dimension(3) :: t63
+ !
+ if (dim_s >= 6) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ t63 = f63(l1,l2,l3) + f63(l1,l3,l2) + f63(l3,l2,l1)
+ a63_b = t63
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a63'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 6: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a63_b
+ !
+ !****f* src/form_factor/form_factor_5p/a63_s
+ ! NAME
+ !
+ ! Function a63_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a63_s(l1,l2,l3,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,3}(l1,l2,l3).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a63_s(l1,l2,l3,set)
+ !
+ integer, intent (in) :: l1,l2,l3
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a63_s
+ !
+ a63_s = a63_b(l1,l2,l3,packb(set))
+ !
+ end function a63_s
+ !
+ !****if* src/form_factor/form_factor_6p/f63
+ ! NAME
+ !
+ ! Function f63
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f63(k1,k2,k3)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a63
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pin_glob,b_pro_glob
+ ! defined in a63
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f63(k1,k2,k3)
+ !
+ integer, intent(in) :: k1,k2,k3
+ complex(ki), dimension(3) :: f63
+ !
+ integer :: j,k,l
+ complex(ki) :: temp1
+ complex(ki), dimension(3) :: temp2
+ integer :: ib,ibj,ibjk
+ integer :: b_pro_mj,b_pro_mjk,b_pro_mjkl
+ integer :: b_pin_pj,b_pin_pjk
+ !
+ temp1 = czero
+ temp2(:) = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro_glob,j)
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ ibj = b_pro_mj
+ k = 0
+ !
+ second_pinch: do while (ibj /= 0)
+ !
+ if (modulo(ibj,2) == 1) then
+ !
+ b_pro_mjk = ibclr(b_pro_mj,k)
+ b_pin_pjk = punion( b_pin_pj,ibset(0,k) )
+ temp1 = temp1 - inv_s(k1,k2,b_pin_glob)*inv_s(j,k3,b_pin_glob)*b(k,b_pin_pj) &
+ *f4p_np2(s_mat_p,b_pro_mjk,b_pin_pjk)/3._ki &
+ - inv_s(j,k3,b_pin_glob)*( inv_s(k,k1,b_pin_pj)*b(k2,b_pin_pj) &
+ + inv_s(k,k2,b_pin_pj)*b(k1,b_pin_pj) &
+ - 2._ki*inv_s(k1,k2,b_pin_pj)*b(k,b_pin_pj) &
+ + b(k,b_pin_pj)*inv_s(k1,k2,b_pin_pjk) ) &
+ *f4p_np2(s_mat_p,b_pro_mjk,b_pin_pjk)/3._ki
+ !
+ ibjk = b_pro_mjk
+ l = 0
+ !
+ third_pinch: do while (ibjk /= 0)
+ !
+ if (modulo(ibjk,2) == 1) then
+ !
+ b_pro_mjkl = ibclr(b_pro_mjk,l)
+ temp2 = temp2 - inv_s(j,k3,b_pin_glob)*( &
+ inv_s(k,k2,b_pin_pj)*inv_s(l,k1,b_pin_pjk) &
+ + inv_s(k,k1,b_pin_pj)*inv_s(l,k2,b_pin_pjk) ) &
+ *f3p(s_mat_p,b_pro_mjkl)/6._ki
+ !
+ end if
+ !
+ l = l + 1
+ ibjk = ishft(ibjk,-1)
+ !
+ end do third_pinch
+ !
+ end if
+ !
+ k = k+1
+ ibj = ishft(ibj,-1)
+ !
+ end do second_pinch
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ f63 = temp2
+ f63(3) = f63(3) + temp1
+ !
+ end function f63
+ !
+ !****f* src/form_factor/form_factor_6p/a64_b
+ ! NAME
+ !
+ ! Function a64_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a64_b(l1,l2,l3,l4,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,4}(l1,l2,l3,l4).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a64_b(l1,l2,l3,l4,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3,l4
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a64_b
+ !
+ if (dim_s >= 6) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ a64_b= - ( f64(l1,l2,l3,l4) + f64(l2,l1,l3,l4) + f64(l3,l2,l1,l4) &
+ + f64(l4,l2,l3,l1) )/4._ki
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a64'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 6: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a64_b
+ !
+ !****f* src/form_factor/form_factor_6p/a64_s
+ ! NAME
+ !
+ ! Function a64_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a64_s(l1,l2,l3,l4,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,4}(l1,l2,l3,l4).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a64_s(l1,l2,l3,l4,set)
+ !
+ integer, intent (in) :: l1,l2,l3,l4
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a64_s
+ !
+ a64_s = a64_b(l1,l2,l3,l4,packb(set))
+ !
+ end function a64_s
+ !
+ !****if* src/form_factor/form_factor_6p/f64
+ ! NAME
+ !
+ ! Function f64
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f64(k1,k2,k3,k4)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a64
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ ! * k4 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pro_glob, b_pin_glob
+ ! defined in a64
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f64(k1,k2,k3,k4)
+ !
+ integer, intent(in) :: k1,k2,k3,k4
+ type(form_factor) :: f64
+ !
+ integer :: j
+ type(form_factor) :: temp1,temp2
+ integer :: ib
+ integer :: b_pin_pj
+ !
+ temp1 = czero
+ temp2 = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp1 = temp1 - 2._ki*inv_s(j,k1,b_pin_glob)*( inv_s(k2,k3,b_pin_glob)*b53(k4,b_pin_pj) &
+ + inv_s(k2,k4,b_pin_glob)*b53(k3,b_pin_pj) &
+ + inv_s(k3,k4,b_pin_glob)*b53(k2,b_pin_pj) )
+ temp2 = temp2 + inv_s(j,k1,b_pin_glob)*a53(k2,k3,k4,b_pin_pj)
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ f64 = temp1 + temp2
+ !
+ end function f64
+ !
+ !****f* src/form_factor/form_factor_6p/a65_b
+ ! NAME
+ !
+ ! Function a65_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a65_b(l1,l2,l3,l4,l5,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,5}(l1,l2,l3,l4,l5).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l5 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables b_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a65_b(l1,l2,l3,l4,l5,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3,l4,l5
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a65_b
+ !
+ if (dim_s >= 6) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ a65_b = - ( f65(l1,l2,l3,l4,l5) + f65(l2,l1,l3,l4,l5) + f65(l3,l2,l1,l4,l5) &
+ + f65(l4,l2,l3,l1,l5) + f65(l5,l2,l3,l4,l1) )/5._ki
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a65'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 6: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a65_b
+ !
+ !****f* src/form_factor/form_factor_6p/a65_s
+ ! NAME
+ !
+ ! Function a65_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a65_s(l1,l2,l3,l4,l5,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,5}(l1,l2,l3,l4,l5).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l5 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a65_s(l1,l2,l3,l4,l5,set)
+ !
+ integer, intent (in) :: l1,l2,l3,l4,l5
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a65_s
+ !
+ a65_s = a65_b(l1,l2,l3,l4,l5,packb(set))
+ !
+ end function a65_s
+ !
+ !****if* src/form_factor/form_factor_6p/f65
+ ! NAME
+ !
+ ! Function f65
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f65(k1,k2,k3,k4,k5)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a65
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ ! * k4 -- an integer
+ ! * k5 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pro_glob,b_pin_glob
+ ! defined in a65
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f65(k1,k2,k3,k4,k5)
+ !
+ integer, intent(in) :: k1,k2,k3,k4,k5
+ type(form_factor) :: f65
+ !
+ integer :: j
+ type(form_factor) :: temp1,temp2
+ integer :: ib
+ integer :: b_pin_pj
+ !
+ temp1 = czero
+ temp2 = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp1 = temp1 + inv_s(j,k1,b_pin_glob)*( &
+ -2._ki*inv_s(k2,k3,b_pin_glob)*b54(k4,k5,b_pin_pj) &
+ -2._ki*inv_s(k2,k4,b_pin_glob)*b54(k3,k5,b_pin_pj) &
+ -2._ki*inv_s(k2,k5,b_pin_glob)*b54(k3,k4,b_pin_pj) &
+ -2._ki*inv_s(k3,k4,b_pin_glob)*b54(k2,k5,b_pin_pj) &
+ -2._ki*inv_s(k3,k5,b_pin_glob)*b54(k2,k4,b_pin_pj) &
+ -2._ki*inv_s(k4,k5,b_pin_glob)*b54(k2,k3,b_pin_pj) )
+ temp1 = temp1 + inv_s(j,k1,b_pin_glob)*( &
+ +4._ki*inv_s(k2,k3,b_pin_glob)*inv_s(k4,k5,b_pin_glob) &
+ +4._ki*inv_s(k2,k4,b_pin_glob)*inv_s(k3,k5,b_pin_glob) &
+ +4._ki*inv_s(k2,k5,b_pin_glob)*inv_s(k3,k4,b_pin_glob) ) &
+ *c54(b_pin_pj)
+ temp2 = temp2 + inv_s(j,k1,b_pin_glob)*a54(k2,k3,k4,k5,b_pin_pj)
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ f65 = temp1 + temp2
+ !
+ end function f65
+ !
+ !****f* src/form_factor/form_factor_6p/a66_b
+ ! NAME
+ !
+ ! Function a66_b
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a66_b(l1,l2,l3,l4,l5,l6,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,6}(l1,l2,l3,l4,l5,l6).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l5 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l6 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * b_pin -- an integer whose bits represent an array of integers of rank 1 corresponding
+ ! to the label of the propagators pinched (removed from the original set
+ ! which is in the global variable b_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of the global variables set_ref
+ ! and s_mat_p
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a66_b(l1,l2,l3,l4,l5,l6,b_pin)
+ !
+ integer, intent (in) :: l1,l2,l3,l4,l5,l6
+ integer, intent (in) :: b_pin
+ type(form_factor) :: a66_b
+ !
+ if (dim_s >= 6) then
+ !
+ b_pro_glob = pminus(b_ref,b_pin)
+ b_pin_glob = b_pin
+ !
+ a66_b = - ( f66(l1,l2,l3,l4,l5,l6) + f66(l2,l1,l3,l4,l5,l6) &
+ + f66(l3,l2,l1,l4,l5,l6) + f66(l4,l2,l3,l1,l5,l6) &
+ + f66(l5,l2,l3,l4,l1,l6) + f66(l6,l2,l3,l4,l5,l1) )/6._ki
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a66'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of dim_s is less than 6: %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a66_b
+ !
+ !****f* src/form_factor/form_factor_6p/a66_s
+ ! NAME
+ !
+ ! Function a66_s
+ !
+ ! USAGE
+ !
+ ! type(form_factor) = a66_s(l1,l2,l3,l4,l5,l6,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function defines the form factor A^{6,6}(l1,l2,l3,l4,l5,l6).
+ !
+ ! INPUTS
+ !
+ ! * l1 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l2 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l3 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l4 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l5 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * l6 -- an integer corresponding to a label in the set of the three
+ ! remaining propagators
+ ! * set -- an array of integers of rank 1 corresponding to the label
+ ! of the propagators pinched (removed from the original set
+ ! which is in the global variable set_ref)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! The result returned is of the type form_factor
+ ! It returns an array of three complex (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function a66_s(l1,l2,l3,l4,l5,l6,set)
+ !
+ integer, intent (in) :: l1,l2,l3,l4,l5,l6
+ integer, intent (in), dimension(:) :: set
+ type(form_factor) :: a66_s
+ !
+ a66_s = a66_b(l1,l2,l3,l4,l5,l6,packb(set))
+ !
+ end function a66_s
+ !
+ !****if* src/form_factor/form_factor_6p/f66
+ ! NAME
+ !
+ ! Function f66
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f66(k1,k2,k3,k4,k5,k6)
+ !
+ ! DESCRIPTION
+ !
+ ! A function to simplify the writting of the function a66
+ !
+ ! INPUTS
+ !
+ ! * k1 -- an integer
+ ! * k2 -- an integer
+ ! * k3 -- an integer
+ ! * k4 -- an integer
+ ! * k5 -- an integer
+ ! * k6 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global (to this module) variable b_pro_glob,b_pin_glob
+ ! defined in a66
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an array of six reals (type ki) corresponding
+ ! to the real part, imaginary part of the coefficient in front 1/epsilon^2,
+ ! the real part, imaginary part of the 1/epsilon term and the real part,
+ ! imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f66(k1,k2,k3,k4,k5,k6)
+ !
+ integer, intent(in) :: k1,k2,k3,k4,k5,k6
+ type(form_factor) :: f66
+ !
+ integer :: j
+ type(form_factor) :: temp1,temp2
+ integer :: ib
+ integer :: b_pin_pj
+ !
+ temp1 = czero
+ temp2 = czero
+ !
+ ib = b_pro_glob
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pin_pj = punion( b_pin_glob,ibset(0,j) )
+ !
+ temp1 = temp1 + inv_s(j,k1,b_pin_glob)*( &
+ -2._ki*inv_s(k2,k3,b_pin_glob)*b55(k4,k5,k6,b_pin_pj) &
+ -2._ki*inv_s(k2,k4,b_pin_glob)*b55(k3,k5,k6,b_pin_pj) &
+ -2._ki*inv_s(k2,k5,b_pin_glob)*b55(k3,k4,k6,b_pin_pj) &
+ -2._ki*inv_s(k2,k6,b_pin_glob)*b55(k3,k4,k5,b_pin_pj) &
+ -2._ki*inv_s(k3,k4,b_pin_glob)*b55(k2,k5,k6,b_pin_pj) &
+ -2._ki*inv_s(k3,k5,b_pin_glob)*b55(k2,k4,k6,b_pin_pj) &
+ -2._ki*inv_s(k3,k6,b_pin_glob)*b55(k2,k4,k5,b_pin_pj) &
+ -2._ki*inv_s(k4,k5,b_pin_glob)*b55(k2,k3,k6,b_pin_pj) &
+ -2._ki*inv_s(k4,k6,b_pin_glob)*b55(k2,k3,k5,b_pin_pj) &
+ -2._ki*inv_s(k5,k6,b_pin_glob)*b55(k2,k3,k4,b_pin_pj) )
+ !
+ temp1 = temp1 + inv_s(j,k1,b_pin_glob)*( &
+ ( 4._ki*inv_s(k2,k3,b_pin_glob)*inv_s(k4,k5,b_pin_glob) &
+ +4._ki*inv_s(k2,k4,b_pin_glob)*inv_s(k3,k5,b_pin_glob) &
+ +4._ki*inv_s(k2,k5,b_pin_glob)*inv_s(k3,k4,b_pin_glob) ) &
+ *c55(k6,b_pin_pj) &
+ + ( 4._ki*inv_s(k2,k3,b_pin_glob)*inv_s(k4,k6,b_pin_glob) &
+ +4._ki*inv_s(k2,k4,b_pin_glob)*inv_s(k3,k6,b_pin_glob) &
+ +4._ki*inv_s(k2,k6,b_pin_glob)*inv_s(k3,k4,b_pin_glob) ) &
+ *c55(k5,b_pin_pj) &
+ + ( 4._ki*inv_s(k2,k3,b_pin_glob)*inv_s(k5,k6,b_pin_glob) &
+ +4._ki*inv_s(k2,k6,b_pin_glob)*inv_s(k3,k5,b_pin_glob) &
+ +4._ki*inv_s(k2,k5,b_pin_glob)*inv_s(k3,k6,b_pin_glob) ) &
+ *c55(k4,b_pin_pj) &
+ + ( 4._ki*inv_s(k2,k6,b_pin_glob)*inv_s(k4,k5,b_pin_glob) &
+ +4._ki*inv_s(k2,k4,b_pin_glob)*inv_s(k6,k5,b_pin_glob) &
+ +4._ki*inv_s(k2,k5,b_pin_glob)*inv_s(k6,k4,b_pin_glob) ) &
+ *c55(k3,b_pin_pj) &
+ + ( 4._ki*inv_s(k6,k3,b_pin_glob)*inv_s(k4,k5,b_pin_glob) &
+ +4._ki*inv_s(k6,k4,b_pin_glob)*inv_s(k3,k5,b_pin_glob) &
+ +4._ki*inv_s(k6,k5,b_pin_glob)*inv_s(k3,k4,b_pin_glob) ) &
+ *c55(k2,b_pin_pj) )
+ !
+ temp2 = temp2 + inv_s(j,k1,b_pin_glob)*a55(k2,k3,k4,k5,k6,b_pin_pj)
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ f66 = temp1 + temp2
+ !
+ end function f66
+ !
+end module form_factor_6p
diff --git a/golem95c-1.2.1/integrals/Makefile.am b/golem95c-1.2.1/integrals/Makefile.am
new file mode 100644
index 0000000..02a42fd
--- /dev/null
+++ b/golem95c-1.2.1/integrals/Makefile.am
@@ -0,0 +1 @@
+SUBDIRS= one_point two_point three_point four_point
diff --git a/golem95c-1.2.1/integrals/Makefile.in b/golem95c-1.2.1/integrals/Makefile.in
new file mode 100644
index 0000000..7f304fd
--- /dev/null
+++ b/golem95c-1.2.1/integrals/Makefile.in
@@ -0,0 +1,594 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+subdir = golem95c-1.2.1/integrals
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+SOURCES =
+DIST_SOURCES =
+RECURSIVE_TARGETS = all-recursive check-recursive dvi-recursive \
+ html-recursive info-recursive install-data-recursive \
+ install-dvi-recursive install-exec-recursive \
+ install-html-recursive install-info-recursive \
+ install-pdf-recursive install-ps-recursive install-recursive \
+ installcheck-recursive installdirs-recursive pdf-recursive \
+ ps-recursive uninstall-recursive
+RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \
+ distclean-recursive maintainer-clean-recursive
+AM_RECURSIVE_TARGETS = $(RECURSIVE_TARGETS:-recursive=) \
+ $(RECURSIVE_CLEAN_TARGETS:-recursive=) tags TAGS ctags CTAGS \
+ distdir
+ETAGS = etags
+CTAGS = ctags
+DIST_SUBDIRS = $(SUBDIRS)
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+am__relativize = \
+ dir0=`pwd`; \
+ sed_first='s,^\([^/]*\)/.*$$,\1,'; \
+ sed_rest='s,^[^/]*/*,,'; \
+ sed_last='s,^.*/\([^/]*\)$$,\1,'; \
+ sed_butlast='s,/*[^/]*$$,,'; \
+ while test -n "$$dir1"; do \
+ first=`echo "$$dir1" | sed -e "$$sed_first"`; \
+ if test "$$first" != "."; then \
+ if test "$$first" = ".."; then \
+ dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \
+ dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \
+ else \
+ first2=`echo "$$dir2" | sed -e "$$sed_first"`; \
+ if test "$$first2" = "$$first"; then \
+ dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \
+ else \
+ dir2="../$$dir2"; \
+ fi; \
+ dir0="$$dir0"/"$$first"; \
+ fi; \
+ fi; \
+ dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \
+ done; \
+ reldir="$$dir2"
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+SUBDIRS = one_point two_point three_point four_point
+all: all-recursive
+
+.SUFFIXES:
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+
+# This directory's subdirectories are mostly independent; you can cd
+# into them and run `make' without going through this Makefile.
+# To change the values of `make' variables: instead of editing Makefiles,
+# (1) if the variable is set in `config.status', edit `config.status'
+# (which will cause the Makefiles to be regenerated when you run `make');
+# (2) otherwise, pass the desired values on the `make' command line.
+$(RECURSIVE_TARGETS):
+ @fail= failcom='exit 1'; \
+ for f in x $$MAKEFLAGS; do \
+ case $$f in \
+ *=* | --[!k]*);; \
+ *k*) failcom='fail=yes';; \
+ esac; \
+ done; \
+ dot_seen=no; \
+ target=`echo $@ | sed s/-recursive//`; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ echo "Making $$target in $$subdir"; \
+ if test "$$subdir" = "."; then \
+ dot_seen=yes; \
+ local_target="$$target-am"; \
+ else \
+ local_target="$$target"; \
+ fi; \
+ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+ || eval $$failcom; \
+ done; \
+ if test "$$dot_seen" = "no"; then \
+ $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \
+ fi; test -z "$$fail"
+
+$(RECURSIVE_CLEAN_TARGETS):
+ @fail= failcom='exit 1'; \
+ for f in x $$MAKEFLAGS; do \
+ case $$f in \
+ *=* | --[!k]*);; \
+ *k*) failcom='fail=yes';; \
+ esac; \
+ done; \
+ dot_seen=no; \
+ case "$@" in \
+ distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \
+ *) list='$(SUBDIRS)' ;; \
+ esac; \
+ rev=''; for subdir in $$list; do \
+ if test "$$subdir" = "."; then :; else \
+ rev="$$subdir $$rev"; \
+ fi; \
+ done; \
+ rev="$$rev ."; \
+ target=`echo $@ | sed s/-recursive//`; \
+ for subdir in $$rev; do \
+ echo "Making $$target in $$subdir"; \
+ if test "$$subdir" = "."; then \
+ local_target="$$target-am"; \
+ else \
+ local_target="$$target"; \
+ fi; \
+ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+ || eval $$failcom; \
+ done && test -z "$$fail"
+tags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test "$$subdir" = . || ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \
+ done
+ctags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test "$$subdir" = . || ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) ctags); \
+ done
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \
+ include_option=--etags-include; \
+ empty_fix=.; \
+ else \
+ include_option=--include; \
+ empty_fix=; \
+ fi; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ test ! -f $$subdir/TAGS || \
+ set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \
+ fi; \
+ done; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: ctags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+ @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ test -d "$(distdir)/$$subdir" \
+ || $(MKDIR_P) "$(distdir)/$$subdir" \
+ || exit 1; \
+ fi; \
+ done
+ @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ dir1=$$subdir; dir2="$(distdir)/$$subdir"; \
+ $(am__relativize); \
+ new_distdir=$$reldir; \
+ dir1=$$subdir; dir2="$(top_distdir)"; \
+ $(am__relativize); \
+ new_top_distdir=$$reldir; \
+ echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \
+ echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \
+ ($(am__cd) $$subdir && \
+ $(MAKE) $(AM_MAKEFLAGS) \
+ top_distdir="$$new_top_distdir" \
+ distdir="$$new_distdir" \
+ am__remove_distdir=: \
+ am__skip_length_check=: \
+ am__skip_mode_fix=: \
+ distdir) \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-recursive
+all-am: Makefile
+installdirs: installdirs-recursive
+installdirs-am:
+install: install-recursive
+install-exec: install-exec-recursive
+install-data: install-data-recursive
+uninstall: uninstall-recursive
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-recursive
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-recursive
+
+clean-am: clean-generic clean-libtool mostlyclean-am
+
+distclean: distclean-recursive
+ -rm -f Makefile
+distclean-am: clean-am distclean-generic distclean-tags
+
+dvi: dvi-recursive
+
+dvi-am:
+
+html: html-recursive
+
+html-am:
+
+info: info-recursive
+
+info-am:
+
+install-data-am:
+
+install-dvi: install-dvi-recursive
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-recursive
+
+install-html-am:
+
+install-info: install-info-recursive
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-recursive
+
+install-pdf-am:
+
+install-ps: install-ps-recursive
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-recursive
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-recursive
+
+mostlyclean-am: mostlyclean-generic mostlyclean-libtool
+
+pdf: pdf-recursive
+
+pdf-am:
+
+ps: ps-recursive
+
+ps-am:
+
+uninstall-am:
+
+.MAKE: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) ctags-recursive \
+ install-am install-strip tags-recursive
+
+.PHONY: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) CTAGS GTAGS \
+ all all-am check check-am clean clean-generic clean-libtool \
+ ctags ctags-recursive distclean distclean-generic \
+ distclean-libtool distclean-tags distdir dvi dvi-am html \
+ html-am info info-am install install-am install-data \
+ install-data-am install-dvi install-dvi-am install-exec \
+ install-exec-am install-html install-html-am install-info \
+ install-info-am install-man install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs installdirs-am maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-generic \
+ mostlyclean-libtool pdf pdf-am ps ps-am tags tags-recursive \
+ uninstall uninstall-am
+
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/integrals/four_point/Makefile.am b/golem95c-1.2.1/integrals/four_point/Makefile.am
new file mode 100644
index 0000000..55f0694
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/Makefile.am
@@ -0,0 +1,26 @@
+noinst_LTLIBRARIES=libgolem95_integrals_four_point.la
+
+libgolem95_integrals_four_point_la_SOURCES= \
+ function_4p1m.f90 function_4p2m_3mi_onshell.f90 function_4p2m_adj.f90 \
+ function_4p2m_opp.f90 function_4p3m.f90 function_4p4m.f90 \
+ function_4p_ql10.f90 function_4p_ql11.f90 function_4p_ql12.f90 \
+ function_4p_ql13.f90 function_4p_ql14.f90 function_4p_ql15.f90 \
+ function_4p_ql16.f90 function_4p_ql6.f90 function_4p_ql7.f90 \
+ function_4p_ql8.f90 function_4p_ql9.f90 generic_function_4p.f90
+libgolem95_integrals_four_point_la_FCFLAGS=\
+ -I$(builddir)/../../module \
+ -I$(builddir)/../../kinematic \
+ -I$(builddir)/../../numerical \
+ -I$(builddir)/../one_point \
+ -I$(builddir)/../two_point \
+ -I$(builddir)/../three_point \
+ -I$(builddir)/../../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS= function_4p4m.mod function_4p_ql7.mod \
+ generic_function_4p.mod function_4p2m_adj.mod function_4p_ql14.mod \
+ function_4p_ql13.mod function_4p_ql15.mod function_4p_ql10.mod \
+ function_4p_ql9.mod function_4p_ql8.mod \
+ function_4p2m_3mi_onshell.mod function_4p_ql11.mod \
+ function_4p_ql12.mod function_4p2m_opp.mod function_4p3m.mod \
+ function_4p1m.mod function_4p_ql16.mod function_4p_ql6.mod
+CLEANFILES=*.mod
diff --git a/golem95c-1.2.1/integrals/four_point/Makefile.in b/golem95c-1.2.1/integrals/four_point/Makefile.in
new file mode 100644
index 0000000..259b73f
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/Makefile.in
@@ -0,0 +1,640 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+subdir = golem95c-1.2.1/integrals/four_point
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in \
+ $(srcdir)/generic_function_4p.f90.in
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES = generic_function_4p.f90
+CONFIG_CLEAN_VPATH_FILES =
+LTLIBRARIES = $(noinst_LTLIBRARIES)
+libgolem95_integrals_four_point_la_LIBADD =
+am_libgolem95_integrals_four_point_la_OBJECTS = \
+ libgolem95_integrals_four_point_la-function_4p1m.lo \
+ libgolem95_integrals_four_point_la-function_4p2m_3mi_onshell.lo \
+ libgolem95_integrals_four_point_la-function_4p2m_adj.lo \
+ libgolem95_integrals_four_point_la-function_4p2m_opp.lo \
+ libgolem95_integrals_four_point_la-function_4p3m.lo \
+ libgolem95_integrals_four_point_la-function_4p4m.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql10.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql11.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql12.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql13.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql14.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql15.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql16.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql6.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql7.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql8.lo \
+ libgolem95_integrals_four_point_la-function_4p_ql9.lo \
+ libgolem95_integrals_four_point_la-generic_function_4p.lo
+libgolem95_integrals_four_point_la_OBJECTS = \
+ $(am_libgolem95_integrals_four_point_la_OBJECTS)
+libgolem95_integrals_four_point_la_LINK = $(LIBTOOL) --tag=FC \
+ $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(FCLD) \
+ $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) \
+ $(AM_LDFLAGS) $(LDFLAGS) -o $@
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem95_integrals_four_point_la_SOURCES)
+DIST_SOURCES = $(libgolem95_integrals_four_point_la_SOURCES)
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgincludedir)"
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+noinst_LTLIBRARIES = libgolem95_integrals_four_point.la
+libgolem95_integrals_four_point_la_SOURCES = \
+ function_4p1m.f90 function_4p2m_3mi_onshell.f90 function_4p2m_adj.f90 \
+ function_4p2m_opp.f90 function_4p3m.f90 function_4p4m.f90 \
+ function_4p_ql10.f90 function_4p_ql11.f90 function_4p_ql12.f90 \
+ function_4p_ql13.f90 function_4p_ql14.f90 function_4p_ql15.f90 \
+ function_4p_ql16.f90 function_4p_ql6.f90 function_4p_ql7.f90 \
+ function_4p_ql8.f90 function_4p_ql9.f90 generic_function_4p.f90
+
+libgolem95_integrals_four_point_la_FCFLAGS = \
+ -I$(builddir)/../../module \
+ -I$(builddir)/../../kinematic \
+ -I$(builddir)/../../numerical \
+ -I$(builddir)/../one_point \
+ -I$(builddir)/../two_point \
+ -I$(builddir)/../three_point \
+ -I$(builddir)/../../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS = function_4p4m.mod function_4p_ql7.mod \
+ generic_function_4p.mod function_4p2m_adj.mod function_4p_ql14.mod \
+ function_4p_ql13.mod function_4p_ql15.mod function_4p_ql10.mod \
+ function_4p_ql9.mod function_4p_ql8.mod \
+ function_4p2m_3mi_onshell.mod function_4p_ql11.mod \
+ function_4p_ql12.mod function_4p2m_opp.mod function_4p3m.mod \
+ function_4p1m.mod function_4p_ql16.mod function_4p_ql6.mod
+
+CLEANFILES = *.mod
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/four_point/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/four_point/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+generic_function_4p.f90: $(top_builddir)/config.status $(srcdir)/generic_function_4p.f90.in
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
+
+clean-noinstLTLIBRARIES:
+ -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+ @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem95_integrals_four_point.la: $(libgolem95_integrals_four_point_la_OBJECTS) $(libgolem95_integrals_four_point_la_DEPENDENCIES)
+ $(libgolem95_integrals_four_point_la_LINK) $(libgolem95_integrals_four_point_la_OBJECTS) $(libgolem95_integrals_four_point_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+libgolem95_integrals_four_point_la-function_4p1m.lo: function_4p1m.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p1m.lo $(FCFLAGS_f90) `test -f 'function_4p1m.f90' || echo '$(srcdir)/'`function_4p1m.f90
+
+libgolem95_integrals_four_point_la-function_4p2m_3mi_onshell.lo: function_4p2m_3mi_onshell.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p2m_3mi_onshell.lo $(FCFLAGS_f90) `test -f 'function_4p2m_3mi_onshell.f90' || echo '$(srcdir)/'`function_4p2m_3mi_onshell.f90
+
+libgolem95_integrals_four_point_la-function_4p2m_adj.lo: function_4p2m_adj.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p2m_adj.lo $(FCFLAGS_f90) `test -f 'function_4p2m_adj.f90' || echo '$(srcdir)/'`function_4p2m_adj.f90
+
+libgolem95_integrals_four_point_la-function_4p2m_opp.lo: function_4p2m_opp.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p2m_opp.lo $(FCFLAGS_f90) `test -f 'function_4p2m_opp.f90' || echo '$(srcdir)/'`function_4p2m_opp.f90
+
+libgolem95_integrals_four_point_la-function_4p3m.lo: function_4p3m.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p3m.lo $(FCFLAGS_f90) `test -f 'function_4p3m.f90' || echo '$(srcdir)/'`function_4p3m.f90
+
+libgolem95_integrals_four_point_la-function_4p4m.lo: function_4p4m.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p4m.lo $(FCFLAGS_f90) `test -f 'function_4p4m.f90' || echo '$(srcdir)/'`function_4p4m.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql10.lo: function_4p_ql10.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql10.lo $(FCFLAGS_f90) `test -f 'function_4p_ql10.f90' || echo '$(srcdir)/'`function_4p_ql10.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql11.lo: function_4p_ql11.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql11.lo $(FCFLAGS_f90) `test -f 'function_4p_ql11.f90' || echo '$(srcdir)/'`function_4p_ql11.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql12.lo: function_4p_ql12.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql12.lo $(FCFLAGS_f90) `test -f 'function_4p_ql12.f90' || echo '$(srcdir)/'`function_4p_ql12.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql13.lo: function_4p_ql13.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql13.lo $(FCFLAGS_f90) `test -f 'function_4p_ql13.f90' || echo '$(srcdir)/'`function_4p_ql13.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql14.lo: function_4p_ql14.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql14.lo $(FCFLAGS_f90) `test -f 'function_4p_ql14.f90' || echo '$(srcdir)/'`function_4p_ql14.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql15.lo: function_4p_ql15.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql15.lo $(FCFLAGS_f90) `test -f 'function_4p_ql15.f90' || echo '$(srcdir)/'`function_4p_ql15.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql16.lo: function_4p_ql16.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql16.lo $(FCFLAGS_f90) `test -f 'function_4p_ql16.f90' || echo '$(srcdir)/'`function_4p_ql16.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql6.lo: function_4p_ql6.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql6.lo $(FCFLAGS_f90) `test -f 'function_4p_ql6.f90' || echo '$(srcdir)/'`function_4p_ql6.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql7.lo: function_4p_ql7.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql7.lo $(FCFLAGS_f90) `test -f 'function_4p_ql7.f90' || echo '$(srcdir)/'`function_4p_ql7.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql8.lo: function_4p_ql8.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql8.lo $(FCFLAGS_f90) `test -f 'function_4p_ql8.f90' || echo '$(srcdir)/'`function_4p_ql8.f90
+
+libgolem95_integrals_four_point_la-function_4p_ql9.lo: function_4p_ql9.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-function_4p_ql9.lo $(FCFLAGS_f90) `test -f 'function_4p_ql9.f90' || echo '$(srcdir)/'`function_4p_ql9.f90
+
+libgolem95_integrals_four_point_la-generic_function_4p.lo: generic_function_4p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_four_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_four_point_la-generic_function_4p.lo $(FCFLAGS_f90) `test -f 'generic_function_4p.f90' || echo '$(srcdir)/'`generic_function_4p.f90
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libtool clean-noinstLTLIBRARIES ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-nodist_pkgincludeHEADERS
+
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p1m.f90 b/golem95c-1.2.1/integrals/four_point/function_4p1m.f90
new file mode 100644
index 0000000..cc745af
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p1m.f90
@@ -0,0 +1,1717 @@
+!
+!****h* src/integrals/four_point/function_4p1m
+! NAME
+!
+! Module function_4p1m
+!
+! USAGE
+!
+! use function_4p1m
+!
+! DESCRIPTION
+!
+! This module computes the six-dimensional and eight dimensional
+! one mass four point function with or without Feynman parameters
+! in the numerator.
+!
+! OUTPUT
+!
+! This module exports three functions f4p1m,f4p1m_c and f1
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+!
+!*****
+module function_4p1m
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ implicit none
+ !
+ private
+ !
+ real(ki) :: s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=3) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ !
+ public :: f4p1m,f1,f4p1m_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p1m/f4p1m
+ ! NAME
+ !
+ ! Function f4p1m
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p1m(dim,s24,s13,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the six dimensional/eight dimensional
+ ! one mass four point function with or without Feynman parameters
+ ! in the numerator, Note that it also computes the zero mass four
+ ! point function
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! one mass four point function, dim="n+4" eight dimensional
+ ! one mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! If the user wants to compute:
+ ! * a six dimensional one mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p1m("n+2",s24,s13,s34,0,0,0,0)
+ ! * a eight dimensional one mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p1m("n+4",s24,s13,s34,0,0,0,0)
+ ! * a six dimensional zero mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p1m("n+2",s24,s13,0._ki,0,0,0,0)
+ ! * a six dimensional one mass four point function
+ ! with the Feynman parameter z1 in the numerator:
+ ! real_dim_4 = f4p1m("n+2",s24,s13,s34,0,0,0,1)
+ ! * a six dimensional one mass four point function
+ ! with the Feynman parameters z1^2*z2 in the numerator:
+ ! real_dim_4 = f4p1m("n+2",s24,s13,s34,0,2,1,1)
+ !
+ !*****
+ function f4p1m(dim,s24,s13,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: f4p1m
+ !
+ integer :: nb_par
+ real(ki) :: lamb
+ real(ki) :: plus_grand
+ real(ki) :: norma
+ complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/0._ki,0._ki,s13,0._ki/)
+ s_mat(2,:) = (/0._ki,0._ki,0._ki,s24/)
+ s_mat(3,:) = (/s13,0._ki,0._ki,s34/)
+ s_mat(4,:) = (/0._ki,s24,s34,0._ki/)
+ !
+ ! on redefinit la matrice S de telle facon a ce que ces elements
+ ! soient entre -1 et 1
+ !
+ plus_grand = maxval(array=abs(s_mat))
+ s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(2,4)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = 1._ki/s_mat(2,4)
+ !
+ sumb = 2._ki*(s_mat(1,3)+s_mat(2,4)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ !
+ invs(1,1) = 0._ki
+ invs(1,2) = -s_mat(3,4)/(s_mat(1,3)*s_mat(2,4))
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = 0._ki
+ invs(2,1) = -s_mat(3,4)/(s_mat(1,3)*s_mat(2,4))
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = 0._ki
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)+s_mat(2,4)-s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ !
+ norma = 1._ki/6._ki
+ !
+ else if (nb_par == 1) then
+ !
+ norma = 1._ki/24._ki
+ !
+ else
+ !
+ norma = 0._ki
+ !
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p1m = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p1m) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p1m (in file function_4p1m.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p1m'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p1m) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n+2") then
+ !
+ f4p1m(3:4)= a4p1m_np2(s_mat(2,4),s_mat(1,3),s_mat(3,4),&
+ &par1,par2,par3,par4)/plus_grand
+ !
+ else if (dim == "n+4") then
+ !
+ f4p1m = a4p1m_np4(s_mat(2,4),s_mat(1,3),s_mat(3,4),&
+ &par1,par2,par3,par4)
+ f4p1m(3) = f4p1m(3)-log(plus_grand)*norma
+ !
+ end if
+ !
+ else
+ !
+ ! numerical computation
+ !
+ dim_glob = dim
+ par1_glob = par1
+ par2_glob = par2
+ par3_glob = par3
+ par4_glob = par4
+ !
+ s13_glob = s_mat(1,3)
+ s24_glob = s_mat(2,4)
+ s34_glob = s_mat(3,4)
+ !
+ resto = 0._ki
+ abserro = 0._ki
+ !
+ ! on pose z = x - i*eps*y (avec x et y > 0)
+ ! z*s24+(1-z)*s34 = s34+x*(s24-s34)-i*eps*y*(s24-s34)
+ ! on veut la partie imaginaire du meme signe que i*lambda
+ ! => eps*(s24-s34) < 0
+ !
+ ! faire attention que suivant le signe de eps_glob, on tourne dans le
+ ! sens des aiguilles d'une montre ou inversement
+ ! eps_glob = 1, on ferme le contour vers le bas --> -2 i Pi residu
+ ! eps_glob = -1, on ferme le contour vers le haut --> +2 i Pi residu
+ !
+ eps_glob = sign(1._ki,s34_glob-s24_glob)
+ !
+ origine_info_par = "f4p1m, dimension "//dim
+ num_grand_b_info_par = lamb
+ denom_grand_b_info_par = (s_mat(1,3)*s_mat(2,4))
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,resto,abserro)
+ !
+ if (dim == "n+2") then
+ resto = resto/plus_grand
+ else if (dim == "n+4") then
+ f4p1m(1) = norma
+ f4p1m(2) = 0._ki
+ resto = resto-log(plus_grand/mu2_scale_par)*norma
+ end if
+ !
+ f4p1m(3) = real(resto,ki)
+ f4p1m(4) = aimag(resto)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p1m
+ !
+ !****f* src/integrals/four_point/function_4p1m/f4p1m_c
+ ! NAME
+ !
+ ! Function f4p1m_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_2 = f4p1m_c(dim,s24,s13,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the same thing that the fucntion f4p1m
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! one mass four point function, dim="n+4" eight dimensional
+ ! one mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p1m
+ !
+ !*****
+ function f4p1m_c(dim,s24,s13,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(2) :: f4p1m_c
+ !
+ real(ki), dimension(4) :: res4
+ !
+ res4 = f4p1m(dim,s24,s13,s34,par1,par2,par3,par4)
+ call to_complex(res4,f4p1m_c)
+ !
+ end function f4p1m_c
+ !
+ !****if* src/integrals/four_point/function_4p1m/a4p1m_np2
+ ! NAME
+ !
+ ! recursive function a4p1m_np2
+ !
+ ! USAGE
+ !
+ ! real_dim_2 = a4p1m_np2(s24,s13,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the six dimensional
+ ! one/zero mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two reals (type ki) corresponding to the
+ ! real and imaginary part of the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p1m_np2(s24,s13,s34,par1,par2,par3,par4) result(res_4p1m_np2)
+ !
+ real(ki), intent (in) :: s13,s24,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(2) :: res_4p1m_np2
+ !
+ integer, dimension(3) :: smj
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(6) :: truc1,truc2,truc3
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(6) :: temp1,temp2,temp3,temp4
+ real(ki), dimension(2) :: temp10,temp11,temp12,temp13,temp14,temp15
+ complex(ki) :: ctemp
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ ctemp = -1._ki*f1(s13,s24,s34)/(s13+s24-s34)
+ res_4p1m_np2(1) = real(ctemp,ki)
+ res_4p1m_np2(2) = aimag(ctemp)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p1m_np2(s24,s13,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp0 = b(par4)*temp0
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3(j,1)) then
+ truc1 = resultat3(j,1,:)
+ else
+ truc1 = f3p_sc(s_mat,smj)
+ resultat3(j,1,:) = truc1
+ deja_calcule3(j,1) = .true.
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/2._ki
+ !
+ if (j /= par4) then
+ !
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 - b(j)*truc2/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p1m_np2(1) = (temp0(1) + temp1(5) + temp2(5))/sumb
+ res_4p1m_np2(2) = (temp0(2) + temp1(6) + temp2(6))/sumb
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ if (deja_calcule(par_plus(4))) then
+ !
+ temp10 = resultat(par_plus(4),:)
+ !
+ else
+ !
+ temp10 = a4p1m_np2(s24,s13,s34,0,0,0,par4)
+ resultat(par_plus(4),:) = temp10
+ deja_calcule(par_plus(4)) = .true.
+ !
+ end if
+ !
+ if (deja_calcule(par_plus(3))) then
+ !
+ temp11 = resultat(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a4p1m_np2(s24,s13,s34,0,0,0,par3)
+ resultat(par_plus(3),:) = temp11
+ deja_calcule(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp12 = resultat(1,:)
+ temp0 = b(par3)*temp10+b(par4)*temp11 - invs(par3,par4)*temp12/2._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule3(j,par_plus(3))) then
+ !
+ truc1 = resultat3(j,par_plus(3),:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj))
+ resultat3(j,par_plus(3),:) = truc1
+ deja_calcule3(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/4._ki
+ !
+ end if
+ !
+ if (j /= par4) then
+ !
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + invs(j,par3)*truc2/4._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ if (deja_calcule33(j,par_plus(3),par_plus(4))) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ !
+ else
+ !
+ truc3 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))
+ resultat33(j,par_plus(3),par_plus(4),:) = truc3
+ deja_calcule33(j,par_plus(3),par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp3 = temp3 - b(j)*truc3/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p1m_np2(1) = (temp0(1) + temp1(5) + temp2(5) + temp3(5)) &
+ *2._ki/3._ki/sumb
+ res_4p1m_np2(2) = (temp0(2) + temp1(6) + temp2(6) + temp3(6)) &
+ *2._ki/3._ki/sumb
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ temp10 = a4p1m_np2(s24,s13,s34,0,0,par2,par3)
+ temp11 = a4p1m_np2(s24,s13,s34,0,0,par2,par4)
+ temp12 = a4p1m_np2(s24,s13,s34,0,0,par3,par4)
+ !
+ temp13 = resultat(par_plus(4),:)
+ temp14 = resultat(par_plus(3),:)
+ temp15 = resultat(par_plus(2),:)
+ !
+ temp0 = b(par4)*temp10+b(par3)*temp11+b(par2)*temp12 &
+ - ( invs(par2,par3)*temp13+invs(par2,par4)*temp14&
+ +invs(par3,par4)*temp15 )/3._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ temp4 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if ( (j /= par2) .and. (j /= par3) ) then
+ !
+ truc1 = resultat33(j,par_plus(2),par_plus(3),:)
+ temp1 = temp1 + invs(j,par4)*truc1/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par4) ) then
+ !
+ truc2 = resultat33(j,par_plus(2),par_plus(4),:)
+ temp2 = temp2 + invs(j,par3)*truc2/6._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ temp3 = temp3 + invs(j,par2)*truc3/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par3) .and. (j /= par4) ) then
+ !
+ temp4 = temp4 - b(j)*f3p_sc(s_mat,smj,locateb(par2,b_pro_mj), &
+ locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p1m_np2(1) = ( temp0(1) + temp1(5) + temp2(5) + temp3(5) &
+ + temp4(5) )/2._ki/sumb
+ res_4p1m_np2(2) = ( temp0(2) + temp1(6) + temp2(6) + temp3(6) &
+ + temp4(6) )/2._ki/sumb
+ !
+ end if
+ !
+ end function a4p1m_np2
+ !
+ !****if* src/integrals/four_point/function_4p1m/a4p1m_np4
+ ! NAME
+ !
+ ! recursive function a4p1m_np4
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p1m_np4(s24,s13,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the eight dimensional
+ ! one/zero mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p1m_np4(s24,s13,s34,par1,par2,par3,par4) result(res_4p1m_np4)
+ !
+ real(ki), intent (in) :: s13,s24,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: res_4p1m_np4
+ !
+ integer, dimension(3) :: smj
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(4) :: truc1
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(4) :: temp1,temp2,temp3
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p1m_np2(s24,s13,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp1 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3_np2(j,1)) then
+ !
+ truc1 = resultat3_np2(j,1,:)
+ !
+ else
+ !
+ truc1 = f3p_np2_sc(s_mat,smj)
+ resultat3_np2(j,1,:) = truc1
+ deja_calcule3_np2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b(j)*truc1
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p1m_np4(1) = (-temp1(1))/(3._ki*sumb)
+ res_4p1m_np4(2) = (-temp1(2))/(3._ki*sumb)
+ res_4p1m_np4(3) = (temp0(1)-temp1(3)-2._ki/3._ki*temp1(1))/(3._ki*sumb)
+ res_4p1m_np4(4) = (temp0(2)-temp1(4)-2._ki/3._ki*temp1(2))/(3._ki*sumb)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ temp0 = a4p1m_np2(s24,s13,s34,0,0,0,par4)/3._ki
+ temp1 = b(par4)*a4p1m_np4(s24,s13,s34,0,0,0,0)
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ truc1 = resultat3_np2(j,1,:)
+ temp2 = temp2 + invs(j,par4)*truc1/6._ki
+ !
+ if (j /= par4) then
+ !
+ temp3 = temp3 - b(j)*f3p_np2_sc(s_mat,smj,locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p1m_np4(1) = ( temp1(1)+temp2(1)+temp3(1) )/(2._ki*sumb)
+ res_4p1m_np4(2) = ( temp1(2)+temp2(2)+temp3(2) )/(2._ki*sumb)
+ res_4p1m_np4(3) = ( temp1(3)+temp1(1)/6._ki+temp2(3)+temp2(1)/2._ki &
+ +temp3(3)+temp3(1)/2._ki+temp0(1) )/(2._ki*sumb)
+ res_4p1m_np4(4) = ( temp1(4)+temp1(2)/6._ki+temp2(4)+temp2(2)/2._ki &
+ +temp3(4)+temp3(2)/2._ki+temp0(2) )/(2._ki*sumb)
+ !
+ ! cas avec plus de un parametre de feynman au numerateur
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a4p1m_np4:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of four-point integrals in n+4 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb(par),4/)
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p1m_np4
+ !
+ !****f* src/integrals/four_point/function_4p1m/f1
+ ! NAME
+ !
+ ! function f1
+ !
+ ! USAGE
+ !
+ ! complex = f1(a,b,c)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the "finite part" of the scalar four dimensional one/zero mass
+ ! four point function. The expression has been taken in
+ ! Nucl. Phys. {\bf B615} (2001) , 385
+ !
+ !
+ ! INPUTS
+ !
+ ! * a -- a real (type ki), (p1+p2)^2
+ ! * b -- a real (type ki), (p2+p3)^2
+ ! * c -- a real (type ki), p4^2
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ ! Affected by the variable rat_or_tot_par (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! attention f1 modifiee pour tenir compte de 4-point 0-masse
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ function f1(a,b,c)
+ !
+ real(ki), intent(in) :: a,b,c
+ complex(ki) :: f1
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f1 = zdilog(1._ki-c/a,sign(un,c-a)) &
+ + zdilog(1._ki-c/b,sign(un,c-b)) &
+ - zdilog(-a/b,sign(un,a-b)) &
+ - zdilog(-b/a,sign(un,b-a))
+ !
+ else ! if (rat_or_tot_par%rat_selected) then
+ !
+ f1 = 0._ki
+ !
+ end if
+ !
+ end function f1
+ !
+ !****if* src/integrals/four_point/function_4p1m/eval_numer_gi
+ ! NAME
+ !
+ ! function eval_numer_gi
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_gi(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This function contains the integrand for the numerical computation in phase
+ ! space region where det(G) ~ 0
+ !
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), between 0 and 1
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki). It is called by
+ ! the routine adapt_gauss1 in the function f4p1m
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_gi(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_gi
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ z = x - eps_glob*i_*y
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ !
+ eval_numer_gi = fg(z,s24_glob,s13_glob,s34_glob,&
+ & par1_glob,par2_glob,par3_glob,par4_glob,&
+ & dim_glob)
+ eval_numer_gi = eval_numer_gi*jacob
+ !
+ end function eval_numer_gi
+ !
+ !****if* src/integrals/four_point/function_4p1m/fg
+ ! NAME
+ !
+ ! function fg
+ !
+ ! USAGE
+ !
+ ! complex = fg(z,s24,s13,s34,par1,par2,par3,par4,dim)
+ !
+ ! DESCRIPTION
+ !
+ ! This function contains the one dimensional integral representation of
+ ! the six/eight dimensional one/zero mass four point function
+ !
+ !
+ ! INPUTS
+ !
+ ! * z -- a real (type ki), integration variable
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! one mass four point function, dim="n+4" eight dimensional
+ ! one mass four point function
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki) corresponding to the
+ ! one dimensional integral representation of the six/eight dimensional
+ ! one/zero mass four point function
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function fg(z,s24,s13,s34,par1,par2,par3,par4,dim)
+ !
+ complex(ki), intent (in) :: z
+ real(ki), intent (in) :: s24,s13,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ character (len=3) :: dim
+ complex(ki) :: fg
+ !
+ integer, dimension(4) :: par
+ integer :: nb_par
+ complex(ki) :: c_var,e_var,f_var
+ !
+ par = (/par1,par2,par3,par4/)
+ nb_par = count(mask=par/=0)
+ !
+ c_var = (1._ki-z)*s13
+ !
+ f_var = z*s24+(1._ki-z)*(s34-s13)
+ !
+ e_var = z*s24+(1._ki-z)*s34
+ !
+ if (dim == "n+2") then
+ if (nb_par == 0) then
+ !
+ fg=-(log(e_var)-log(1._ki-z)-z_log(s13,1._ki))/f_var
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ fg=1._ki/2._ki*(e_var*log(1._ki-z)+e_var*z_log(s13,1._ki)-e_var*log(e&
+ &_var)+f_var)/f_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/2._ki*z*(-log(e_var)+log(1._ki-z)+z_log(s13,1._ki))/f_var
+ !
+ case(3)
+ !
+ fg=-1._ki/2._ki*(-1._ki+z)*(-log(e_var)+log(1._ki-z)+z_log(s13,1._ki))&
+ &/f_var
+ !
+ case(4)
+ !
+ fg=-1._ki/2._ki*(-log(e_var)*c_var+c_var*log(1._ki-z)+c_var*z_log(s1&
+ &3,1._ki)+f_var)/f_var**2
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 2) then
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ fg=-1._ki/6._ki*(-2._ki*e_var**2*log(1._ki-z)-2._ki*e_var**2*z_log(s13&
+ &,1._ki)+2._ki*e_var**2*log(e_var)+c_var*f_var-3._ki*e_var*f_var)/f&
+ &_var**3
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*z*(e_var*log(1._ki-z)+e_var*z_log(s13,1._ki)-e_var*log&
+ &(e_var)+f_var)/f_var**2
+ !
+ case(3)
+ !
+ fg=-1._ki/6._ki*(e_var*log(1._ki-z)+e_var*z_log(s13,1._ki)-e_var*log(&
+ &e_var)+f_var)*(-1._ki+z)/f_var**2
+ !
+ case(4)
+ !
+ fg=-1._ki/6._ki*(2._ki*c_var*e_var*log(1._ki-z)+2._ki*c_var*e_var*z_lo&
+ &g(s13,1._ki)-2._ki*e_var*log(e_var)*c_var+c_var*f_var+e_var*f_var&
+ &)/f_var**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ fg=1._ki/3._ki*z**2*(-log(e_var)+log(1._ki-z)+z_log(s13,1._ki))/f_var
+ !
+ case(3)
+ !
+ fg=-1._ki/3._ki*z*(-1._ki+z)*(-log(e_var)+log(1._ki-z)+z_log(s13,1._ki&
+ &))/f_var
+ !
+ case(4)
+ !
+ fg=-1._ki/6._ki*z*(-log(e_var)*c_var+c_var*log(1._ki-z)+c_var*z_log(&
+ &s13,1._ki)+f_var)/f_var**2
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ fg=1._ki/3._ki*(-1._ki+z)**2*(-log(e_var)+log(1._ki-z)+z_log(s13,1._ki&
+ &))/f_var
+ !
+ case(4)
+ !
+ fg=1._ki/6._ki*(-log(e_var)*c_var+c_var*log(1._ki-z)+c_var*z_log(s13&
+ &,1._ki)+f_var)*(-1._ki+z)/f_var**2
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=-1._ki/6._ki*(2._ki*log(e_var)*e_var*c_var**2*f_var+2._ki*log(e_va&
+ &r)*c_var**2*f_var**2+2._ki*log(e_var)*e_var**2*c_var**2+4._ki*log&
+ &(e_var)*c_var*f_var**3-2._ki*log(e_var)*f_var**2*e_var*c_var-2._k&
+ &i*log(e_var)*e_var**2*c_var*f_var+2._ki*log(e_var)*f_var**4-4._ki&
+ &*log(e_var)*f_var**3*e_var+2._ki*log(e_var)*f_var**2*e_var**2-2.&
+ &_ki*e_var**2*c_var**2*log(1._ki-z)-2._ki*e_var**2*c_var**2*z_log(s&
+ &13,1._ki)-3._ki*e_var**2*c_var*f_var+e_var**3*f_var)/e_var**2/f_v&
+ &ar**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 3) then
+ !
+ select case(par2)
+ !
+ case(1)
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ fg=1._ki/24._ki*(6._ki*e_var**3*log(1._ki-z)+6._ki*e_var**3*z_log(s13,&
+ &1._ki)-6._ki*e_var**3*log(e_var)+2._ki*c_var**2*f_var-7._ki*c_var*e&
+ &_var*f_var+11._ki*e_var**2*f_var)/f_var**4
+ !
+ case(2)
+ !
+ fg=1._ki/24._ki*z*(2._ki*e_var**2*log(1._ki-z)+2._ki*e_var**2*z_log(s1&
+ &3,1._ki)-2._ki*e_var**2*log(e_var)-f_var*c_var+3._ki*e_var*f_var)/&
+ &f_var**3
+ !
+ case(3)
+ !
+ fg=-1._ki/24._ki*(2._ki*e_var**2*log(1._ki-z)+2._ki*e_var**2*z_log(s13&
+ &,1._ki)-2._ki*e_var**2*log(e_var)-f_var*c_var+3._ki*e_var*f_var)*(&
+ &-1._ki+z)/f_var**3
+ !
+ case(4)
+ !
+ fg=-1._ki/24._ki*(6._ki*c_var*e_var**2*log(1._ki-z)+6._ki*c_var*e_var*&
+ &*2*z_log(s13,1._ki)-6._ki*e_var**2*log(e_var)*c_var-c_var**2*f_va&
+ &r+5._ki*c_var*e_var*f_var+2._ki*e_var**2*f_var)/f_var**4
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*z**2*(e_var*log(1._ki-z)+e_var*z_log(s13,1._ki)-e_var&
+ &*log(e_var)+f_var)/f_var**2
+ !
+ case(3)
+ !
+ fg=-1._ki/12._ki*z*(e_var*log(1._ki-z)+e_var*z_log(s13,1._ki)-e_var*l&
+ &og(e_var)+f_var)*(-1._ki+z)/f_var**2
+ !
+ case(4)
+ !
+ fg=-1._ki/24._ki*z*(2._ki*c_var*e_var*log(1._ki-z)+2._ki*c_var*e_var*z&
+ &_log(s13,1._ki)-2._ki*e_var*log(e_var)*c_var+f_var*c_var+e_var*f_&
+ &var)/f_var**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ fg=1._ki/12._ki*(-1._ki+z)**2*(e_var*log(1._ki-z)+e_var*z_log(s13,1._k&
+ &i)-e_var*log(e_var)+f_var)/f_var**2
+ !
+ case(4)
+ !
+ fg=1._ki/24._ki*(2._ki*c_var*e_var*log(1._ki-z)+2._ki*c_var*e_var*z_lo&
+ &g(s13,1._ki)-2._ki*e_var*log(e_var)*c_var+f_var*c_var+e_var*f_var&
+ &)*(-1._ki+z)/f_var**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=1._ki/24._ki*(6._ki*c_var**2*e_var**2*log(1._ki-z)+6._ki*c_var**2*e&
+ &_var**2*z_log(s13,1._ki)-4._ki*log(e_var)*c_var**2*f_var*e_var-2.&
+ &_ki*log(e_var)*c_var**2*f_var**2-6._ki*log(e_var)*c_var**2*e_var*&
+ &*2+4._ki*log(e_var)*c_var*f_var*e_var**2-4._ki*log(e_var)*c_var*f&
+ &_var**3-2._ki*log(e_var)*f_var**4+4._ki*log(e_var)*f_var**3*e_var&
+ &-2._ki*log(e_var)*f_var**2*e_var**2-e_var**3*f_var+2._ki*c_var**2&
+ &*f_var*e_var+5._ki*c_var*f_var*e_var**2)/e_var/f_var**4
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ fg=1._ki/4._ki*z**3*(-log(e_var)+log(1._ki-z)+z_log(s13,1._ki))/f_var
+ !
+ case(3)
+ !
+ fg=-1._ki/4._ki*z**2*(-1._ki+z)*(-log(e_var)+log(1._ki-z)+z_log(s13,1&
+ &._ki))/f_var
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki*z**2*(-log(e_var)*c_var+c_var*log(1._ki-z)+c_var*z_&
+ &log(s13,1._ki)+f_var)/f_var**2
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ fg=1._ki/4._ki*z*(-1._ki+z)**2*(-log(e_var)+log(1._ki-z)+z_log(s13,1.&
+ &_ki))/f_var
+ !
+ case(4)
+ !
+ fg=1._ki/12._ki*z*(-log(e_var)*c_var+c_var*log(1._ki-z)+c_var*z_log(&
+ &s13,1._ki)+f_var)*(-1._ki+z)/f_var**2
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=1._ki/24._ki*z*(-2._ki*log(e_var)*c_var**2*e_var**2-6._ki*log(e_va&
+ &r)*c_var**2*f_var**2-4._ki*log(e_var)*c_var**2*f_var*e_var-12._ki&
+ &*log(e_var)*c_var*f_var**3+4._ki*log(e_var)*c_var*f_var*e_var**2&
+ &+8._ki*log(e_var)*c_var*f_var**2*e_var+12._ki*log(e_var)*f_var**3&
+ &*e_var-6._ki*log(e_var)*f_var**4-6._ki*log(e_var)*f_var**2*e_var*&
+ &*2+2._ki*c_var**2*e_var**2*log(1._ki-z)+2._ki*c_var**2*e_var**2*z_&
+ &log(s13,1._ki)+3._ki*c_var*f_var*e_var**2-e_var**3*f_var)/e_var**&
+ &2/f_var**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ fg=-1._ki/4._ki*(-1._ki+z)**3*(-log(e_var)+log(1._ki-z)+z_log(s13,1._k&
+ &i))/f_var
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki*(-1._ki+z)**2*(-log(e_var)*c_var+c_var*log(1._ki-z)+&
+ &c_var*z_log(s13,1._ki)+f_var)/f_var**2
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=-1._ki/24._ki*(-2._ki*log(e_var)*c_var**2*e_var**2-6._ki*log(e_var&
+ &)*c_var**2*f_var**2-4._ki*log(e_var)*c_var**2*f_var*e_var-12._ki*&
+ &log(e_var)*c_var*f_var**3+4._ki*log(e_var)*c_var*f_var*e_var**2+&
+ &8._ki*log(e_var)*c_var*f_var**2*e_var+12._ki*log(e_var)*f_var**3*&
+ &e_var-6._ki*log(e_var)*f_var**4-6._ki*log(e_var)*f_var**2*e_var**&
+ &2+2._ki*c_var**2*e_var**2*log(1._ki-z)+2._ki*c_var**2*e_var**2*z_l&
+ &og(s13,1._ki)+3._ki*c_var*f_var*e_var**2-e_var**3*f_var)*(-1._ki+z&
+ &)/e_var**2/f_var**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par3)
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=-1._ki/24._ki*(6._ki*log(e_var)*c_var*f_var**2*e_var**2-6._ki*log(&
+ &e_var)*c_var*f_var**4-6._ki*log(e_var)*c_var**3*f_var**2-12._ki*l&
+ &og(e_var)*c_var**2*f_var**3-6._ki*log(e_var)*c_var**3*e_var**2+6&
+ &._ki*c_var**3*e_var**2*log(1._ki-z)+6._ki*c_var**3*e_var**2*z_log(&
+ &s13,1._ki)+2._ki*e_var**4*f_var+11._ki*c_var**2*e_var**2*f_var-7._k&
+ &i*c_var*e_var**3*f_var)/e_var**2/f_var**4
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par2 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Unexpected value for nb_par = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else if (dim == "n+4") then
+ !
+ if (nb_par == 0) then
+ !
+ fg=1._ki/18._ki*(-3._ki*e_var*log(-e_var)+3._ki*c_var*log(1._ki-z)+3._k&
+ &i*c_var*z_log(-s13,-1._ki)+8._ki*f_var)/f_var
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ fg=1._ki/144._ki*(6._ki*c_var**2*log(1._ki-z)+6._ki*c_var**2*z_log(-s1&
+ &3,-1._ki)+12._ki*c_var*f_var*log(1._ki-z)+12._ki*c_var*f_var*z_log(&
+ &-s13,-1._ki)-6._ki*e_var**2*log(-e_var)-13._ki*c_var*f_var+19._ki*e&
+ &_var*f_var)/f_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/36._ki*z*(-3._ki*e_var*log(-e_var)+3._ki*c_var*log(1._ki-z)+3&
+ &._ki*c_var*z_log(-s13,-1._ki)+8._ki*f_var)/f_var
+ !
+ case(3)
+ !
+ fg=-1._ki/36._ki*(-3._ki*e_var*log(-e_var)+3._ki*c_var*log(1._ki-z)+3.&
+ &_ki*c_var*z_log(-s13,-1._ki)+8._ki*f_var)*(-1._ki+z)/f_var
+ !
+ case(4)
+ !
+ fg=-1._ki/144._ki*(6._ki*e_var*log(-e_var)*f_var-6._ki*e_var*log(-e_v&
+ &ar)*c_var+6._ki*c_var**2*log(1._ki-z)+6._ki*c_var**2*z_log(-s13,-1&
+ &._ki)+19._ki*c_var*f_var-13._ki*e_var*f_var)/f_var**2
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Unexpected value for nb_par = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fg (function_4p1m.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Unexpected value for nb_dim = %c0"
+ tab_erreur_par(2)%arg_char = dim
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ end function fg
+ !
+end module function_4p1m
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p2m_3mi_onshell.f90 b/golem95c-1.2.1/integrals/four_point/function_4p2m_3mi_onshell.f90
new file mode 100644
index 0000000..c50a62c
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p2m_3mi_onshell.f90
@@ -0,0 +1,459 @@
+!
+!****h* src/integrals/four_point/function_4p2m_3mi_onshell
+! NAME
+!
+! Module function_4p2m_3mi_onshell
+!
+! USAGE
+!
+! use function_4p2m_3mi_onshell
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional
+! two adjacent massive on-shell legs four point function with 3 internal masses,
+! all masses equal, the only massless internal line connects the two on-shell legs
+! => corresponding n-dim box is IR div
+! only without Feynman parameters in the numerator.
+!
+! OUTPUT
+!
+! This module exports the functions f4p2m_3mi_onshell, f4p2m_3mi_onshell_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p2m_3mi_onshell
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ !
+ use equal
+ implicit none
+ !
+ private
+ !
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p2m_3mi_onshell,f4p2m_3mi_onshell_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p2m_3mi_onshell/f4p2m_3mi_onshell
+ ! NAME
+ !
+ ! Function f4p2m_3mi_onshell
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p2m_3mi_onshell(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional
+ ! two adjacent massive on-shell legs four point function with 3 internal masses,
+ ! all masses equal, the only massless internal line connects the two on-shell legs
+ ! => corresponding n-dim box is IR div
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n": (4-2*eps)- dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p2m_3mi_onshell(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p2m_3mi_onshell
+ !
+ integer :: nb_par
+ real(ki) :: coupure_4p2m_3mi_onshell
+ ! real(ki) :: plus_grand
+ real(ki) :: norma
+ ! complex(ki), dimension(4) :: tri
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p2m_3mi_onshell = 0._ki
+ coupure_4p2m_3mi_onshell = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p2m_3mi_onshell) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p2m_3mi_onshell (in file f4p2m_3mi_onshell.f90):&
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p2m_3mi_onshell'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p2m_3mi_onshell) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p2m_3mi_onshell_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p2m_3mi_onshell= a4p2m_3mi_onshell_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p2m_3mi_onshell: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p2m_3mi_onshell: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p2m_3mi_onshell not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p2m_3mi_onshell not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p2m_3mi_onshell
+ !
+ !****f* src/integrals/four_point/function_4p2m_3mi_onshell/f4p2m_3mi_onshell_c
+ ! NAME
+ !
+ ! Function f4p2m_3mi_onshell_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p2m_3mi_onshell_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p2m_3mi_onshell
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p2m_3mi_onshell
+ !
+ !*****
+ function f4p2m_3mi_onshell_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p2m_3mi_onshell_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p2m_3mi_onshell(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p2m_3mi_onshell_c)
+ !
+ end function f4p2m_3mi_onshell_c
+ !
+ !****if* src/integrals/four_point/function_4p2m_3mi_onshell/a4p2m_3mi_onshell_n
+ ! NAME
+ !
+ ! recursive function a4p2m_3mi_onshell_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p2m_3mi_onshell_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! mass four point function eq.(2.9) of Denner/Beenakker Nucl.Phys.B338:349-370,1990
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p2m_3mi_onshell_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p2m_3mi_onshell_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p2m_3mi_onshell_n
+ !
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki) :: del
+ complex(ki) :: beta1,beta2,beta34,xs,x1,x2,prefac,logm0,brack,res
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! warning, mu2 has been set to one in formula below
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ !
+ beta34=Sqrt(1._ki-4*m1s/(s12+i_*del))
+ xs=-(1._ki-beta34)/(1._ki+beta34)
+ if ( equal_real(s1,zero) ) then
+ beta1=0._ki
+ x1=1._ki
+ else
+ beta1=Sqrt(1._ki-4*m1s/(s1+i_*del))
+ x1=-(1._ki-beta1)/(1._ki+beta1)
+ end if
+ if ( equal_real(s2,zero) ) then
+ beta2=0._ki
+ x2=1._ki
+ else
+ beta2=Sqrt(1._ki-4*m2s/(s2+i_*del))
+ x2=-(1._ki-beta2)/(1._ki+beta2)
+ end if
+ prefac=-xs/m1s/(m1s-s23)/(1-xs**2)
+ logm0=z_log(m1s,-1._ki)-2*Log(m1s-s23-i_*del)
+!
+ brack=Log(xs)*(-logm0+2*log(1-xs**2))+ &
+ & Pi**2/2+cdilog(xs**2)+log(x1)**2+log(x2)**2- &
+ & (cdilog(xs*x2*x1)+cdilog(xs*x2/x1)+ &
+ & cdilog(xs/x2*x1)+cdilog(xs/x2/x1)+ &
+ & log(1._ki-xs*x2*x1)*(log(xs)+log(x2)+log(x1))+ &
+ & log(1._ki-xs*x2/x1)*(log(xs)+log(x2)+log(1/x1))+ &
+ & log(1._ki-xs/x2*x1)*(log(xs)+log(1/x2)+log(x1))+ &
+ & log(1._ki-xs/x2/x1)*(log(xs)+log(1/x2)+log(1/x1)))
+ !
+ res=prefac*brack
+ !
+ res_4p2m_3mi_onshell_n(1) = 0._ki
+ res_4p2m_3mi_onshell_n(2) = 0._ki
+ res_4p2m_3mi_onshell_n(3) = real(-prefac*Log(xs))
+ res_4p2m_3mi_onshell_n(4) = aimag(-prefac*Log(xs))
+ res_4p2m_3mi_onshell_n(5) = real(res)+log(mu2)*res_4p2m_3mi_onshell_n(3)
+ res_4p2m_3mi_onshell_n(6) = aimag(res)+log(mu2)*res_4p2m_3mi_onshell_n(4)
+ !
+ !
+ else
+ !
+ !~ call print_error('In function f4p2m_3mi_onshell: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p2m_3mi_onshell: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p2m_3mi_onshell_n
+ !
+ !
+end module function_4p2m_3mi_onshell
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p2m_adj.f90 b/golem95c-1.2.1/integrals/four_point/function_4p2m_adj.f90
new file mode 100644
index 0000000..7b84992
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p2m_adj.f90
@@ -0,0 +1,2102 @@
+!
+!****h* src/integrals/four_point/function_4p2m_adj
+! NAME
+!
+! Module function_4p2m_adj
+!
+! USAGE
+!
+! use function_4p2m_adj
+!
+! DESCRIPTION
+!
+! This module computes the six-dimensional and eight dimensional
+! two adjacent mass four point function with or without Feynman parameters
+! in the numerator.
+!
+! OUTPUT
+!
+! This module exports three functions f4p2m_adj, f4p2m_adj_c and f2a
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+!
+!*****
+module function_4p2m_adj
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ implicit none
+ !
+ private
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=3) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ !
+ public :: f4p2m_adj,f2a,f4p2m_adj_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p2m_adj/f4p2m_adj
+ ! NAME
+ !
+ ! Function f4p2m_adj
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p2m_adj(dim,s24,s13,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the six dimensional/eight dimensional
+ ! two adjacent mass four point function with or without Feynman parameters
+ ! in the numerator.
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! two adjacent mass four point function, dim="n+4" eight dimensional
+ ! two adjacent mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! If the user wants to compute:
+ ! * a six dimensional two adjacent mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p2m_adj("n+2",s24,s13,s23,s34,0,0,0,0)
+ ! * a eight dimensional two adjacent mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p2m_adj("n+4",s24,s13,s23,s34,0,0,0,0)
+ ! * a six dimensional two adjacent mass four point function
+ ! with the Feynman parameter z1 in the numerator:
+ ! real_dim_4 = f4p2m_adj("n+2",s24,s13,s23,s34,0,0,0,1)
+ ! * a six dimensional two adjacent mass four point function
+ ! with the Feynman parameters z1^2*z2 in the numerator:
+ ! real_dim_4 = f4p2m_adj("n+2",s24,s13,s23,s34,0,2,1,1)
+ !
+ !*****
+ function f4p2m_adj(dim,s24,s13,s23,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: f4p2m_adj
+ !
+ integer :: nb_par
+ real(ki) :: plus_grand
+ real(ki) :: norma
+ complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/0._ki,0._ki,s13,0._ki/)
+ s_mat(2,:) = (/0._ki,0._ki,s23,s24/)
+ s_mat(3,:) = (/s13,s23,0._ki,s34/)
+ s_mat(4,:) = (/0._ki,s24,s34,0._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ plus_grand = maxval(array=abs(s_mat))
+ s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p2m_adj = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p2m_adj) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p2m_adj (in file f4p2m_adj.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p2m_adj'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p2m_adj) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n+2") then
+ !
+ f4p2m_adj(3:4)= a4p2m_adj_np2(s_mat(2,4),s_mat(1,3),&
+ &s_mat(2,3),s_mat(3,4),&
+ &par1,par2,par3,par4)/plus_grand
+ !
+ else if (dim == "n+4") then
+ !
+ f4p2m_adj = a4p2m_adj_np4(s_mat(2,4),s_mat(1,3),&
+ &s_mat(2,3),s_mat(3,4),&
+ &par1,par2,par3,par4)
+ f4p2m_adj(3) = f4p2m_adj(3)-log(plus_grand)*norma
+ !
+ end if
+ !
+ else
+ !
+ ! numerical computation
+ !
+ dim_glob = dim
+ par1_glob = par1
+ par2_glob = par2
+ par3_glob = par3
+ par4_glob = par4
+ !
+ s13_glob = s_mat(1,3)
+ s23_glob = s_mat(2,3)
+ s24_glob = s_mat(2,4)
+ s34_glob = s_mat(3,4)
+ !
+ ! on pose z = x - i*eps*y (avec x et y > 0)
+ ! z*s24+(1-z)*s34 = s34+x*(s24-s34)-i*eps*y*(s24-s34)
+ ! on veut la partie imaginaire du meme signe que i*lambda
+ ! => eps*(s24-s34) < 0
+ !
+ ! faire attention que suivant le signe de eps_glob, on tourne dans le
+ ! sens des aiguilles d'une montre ou inversement
+ ! eps_glob = 1, on ferme le contour vers le bas --> -2 i Pi residu
+ ! eps_glob = -1, on ferme le contour vers le haut --> +2 i Pi residu
+ !
+ eps_glob = sign(1._ki,s34_glob-s24_glob)
+ !
+ origine_info_par = "f4p2m_adj, dimension "//dim
+ num_grand_b_info_par = lamb
+ denom_grand_b_info_par = (s_mat(1,3)**2*s_mat(2,4))
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,resto,abserro)
+ !
+ if (dim == "n+2") then
+ resto = resto/plus_grand
+ else if (dim == "n+4") then
+ f4p2m_adj(1) = norma
+ f4p2m_adj(2) = 0._ki
+ resto = resto-log(plus_grand/mu2_scale_par)*norma
+ end if
+ !
+ f4p2m_adj(3) = real(resto,ki)
+ f4p2m_adj(4) = aimag(resto)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p2m_adj
+ !
+ !****f* src/integrals/four_point/function_4p2m_adj/f4p2m_adj_c
+ ! NAME
+ !
+ ! Function f4p2m_adj_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_2 = f4p2m_adj_c(dim,s24,s13,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the same thing that the function f4p2m_adj
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! two adjacent mass four point function, dim="n+4" eight dimensional
+ ! two adjacent mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p2m_adj
+ !
+ !*****
+ function f4p2m_adj_c(dim,s24,s13,s23,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(2) :: f4p2m_adj_c
+ !
+ real(ki), dimension(4) :: res4
+ !
+ res4 = f4p2m_adj(dim,s24,s13,s23,s34,par1,par2,par3,par4)
+ call to_complex(res4,f4p2m_adj_c)
+ !
+ end function f4p2m_adj_c
+ !
+ !****if* src/integrals/four_point/function_4p2m_adj/a4p2m_adj_np2
+ ! NAME
+ !
+ ! recursive function a4p2m_adj_np2
+ !
+ ! USAGE
+ !
+ ! real_dim_2 = a4p2m_adj_np2(s24,s13,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the six dimensional
+ ! two adjacent mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two reals (type ki) corresponding to the
+ ! real and imaginary part of the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p2m_adj_np2(s24,s13,s23,s34,par1,par2,par3,par4) result(res_4p2m_adj_np2)
+ !
+ real(ki), intent (in) :: s24,s13,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(2) :: res_4p2m_adj_np2
+ !
+ integer, dimension(3) :: smj,sm1
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(6) :: truc1,truc2,truc3
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(6) :: temp1,temp2,temp3,temp4
+ real(ki), dimension(2) :: temp10,temp11,temp12,temp13,temp14,temp15
+ complex(ki) :: ctemp
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ !~ sm1 = s .minus. (/1/)
+ sm1 = unpackb(ibclr(b_pro,1),3)
+ !
+ if (deja_calcule3(1,1)) then
+ !
+ truc1 = resultat3(1,1,:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,sm1)
+ resultat3(1,1,:) = truc1
+ deja_calcule3(1,1) = .true.
+ !
+ end if
+ !
+ ctemp = f2a(s24,s13,s23,s34)
+ res_4p2m_adj_np2(1) = -s13*( 2._ki*real(ctemp,ki) &
+ + s13*s24*b(1)*truc1(5) )/(2._ki*lamb)
+ res_4p2m_adj_np2(2) = -s13*( 2._ki*aimag(ctemp) &
+ + s13*s24*b(1)*truc1(6) )/(2._ki*lamb)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p2m_adj_np2(s24,s13,s23,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp0 = b(par4)*temp0
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3(j,1)) then
+ !
+ truc1 = resultat3(j,1,:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,smj)
+ resultat3(j,1,:) = truc1
+ deja_calcule3(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/2._ki
+ !
+ if (j /= par4) then
+ !
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 - b(j)*truc2/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p2m_adj_np2(1) = (temp0(1) + temp1(5) + temp2(5))/sumb
+ res_4p2m_adj_np2(2) = (temp0(2) + temp1(6) + temp2(6))/sumb
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ if (deja_calcule(par_plus(4))) then
+ !
+ temp10 = resultat(par_plus(4),:)
+ !
+ else
+ !
+ temp10 = a4p2m_adj_np2(s24,s13,s23,s34,0,0,0,par4)
+ resultat(par_plus(4),:) = temp10
+ deja_calcule(par_plus(4)) = .true.
+ !
+ end if
+ !
+ if (deja_calcule(par_plus(3))) then
+ !
+ temp11 = resultat(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a4p2m_adj_np2(s24,s13,s23,s34,0,0,0,par3)
+ resultat(par_plus(3),:) = temp11
+ deja_calcule(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp12 = resultat(1,:)
+ temp0 = b(par3)*temp10+b(par4)*temp11 - invs(par3,par4)*temp12/2._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule3(j,par_plus(3))) then
+ !
+ truc1 = resultat3(j,par_plus(3),:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj))
+ resultat3(j,par_plus(3),:) = truc1
+ deja_calcule3(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/4._ki
+ !
+ end if
+ !
+ if (j /= par4) then
+ !
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + invs(j,par3)*truc2/4._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ if (deja_calcule33(j,par_plus(3),par_plus(4))) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ !
+ else
+ !
+ truc3 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))
+ resultat33(j,par_plus(3),par_plus(4),:) = truc3
+ deja_calcule33(j,par_plus(3),par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp3 = temp3 - b(j)*truc3/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ res_4p2m_adj_np2(1) = (temp0(1) + temp1(5) + temp2(5) + temp3(5)) &
+ *2._ki/3._ki/sumb
+ res_4p2m_adj_np2(2) = (temp0(2) + temp1(6) + temp2(6) + temp3(6)) &
+ *2._ki/3._ki/sumb
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ temp10 = a4p2m_adj_np2(s24,s13,s23,s34,0,0,par2,par3)
+ temp11 = a4p2m_adj_np2(s24,s13,s23,s34,0,0,par2,par4)
+ temp12 = a4p2m_adj_np2(s24,s13,s23,s34,0,0,par3,par4)
+ !
+ temp13 = resultat(par_plus(4),:)
+ temp14 = resultat(par_plus(3),:)
+ temp15 = resultat(par_plus(2),:)
+ !
+ temp0 = b(par4)*temp10+b(par3)*temp11+b(par2)*temp12 &
+ - ( invs(par2,par3)*temp13+invs(par2,par4)*temp14&
+ +invs(par3,par4)*temp15 )/3._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ temp4 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if ( (j /= par2) .and. (j /= par3) ) then
+ !
+ truc1 = resultat33(j,par_plus(2),par_plus(3),:)
+ temp1 = temp1 + invs(j,par4)*truc1/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par4) ) then
+ !
+ truc2 = resultat33(j,par_plus(2),par_plus(4),:)
+ temp2 = temp2 + invs(j,par3)*truc2/6._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ temp3 = temp3 + invs(j,par2)*truc3/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par3) .and. (j /= par4) ) then
+ !
+ temp4 = temp4 - b(j)*f3p_sc(s_mat,smj,locateb(par2,b_pro_mj), &
+ locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p2m_adj_np2(1) = ( temp0(1) + temp1(5) + temp2(5) + temp3(5) &
+ + temp4(5) )/2._ki/sumb
+ res_4p2m_adj_np2(2) = ( temp0(2) + temp1(6) + temp2(6) + temp3(6) &
+ + temp4(6) )/2._ki/sumb
+ !
+ end if
+ !
+ end function a4p2m_adj_np2
+ !
+ !****if* src/integrals/four_point/function_4p2m_adj/a4p2m_adj_np4
+ ! NAME
+ !
+ ! recursive function a4p2m_adj_np4
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p2m_adj_np4(s24,s13,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the eight dimensional
+ ! two adjacent mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p2m_adj_np4(s24,s13,s23,s34,par1,par2,par3,par4) result(res_4p2m_adj_np4)
+ !
+ real(ki), intent (in) :: s24,s13,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: res_4p2m_adj_np4
+ !
+ integer, dimension(3) :: smj
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(4) :: truc1
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(4) :: temp1,temp2,temp3
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p2m_adj_np2(s24,s13,s23,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp1 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3_np2(j,1)) then
+ !
+ truc1 = resultat3_np2(j,1,:)
+ !
+ else
+ !
+ truc1 = f3p_np2_sc(s_mat,smj)
+ resultat3_np2(j,1,:) = truc1
+ deja_calcule3_np2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b(j)*truc1
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p2m_adj_np4(1) = (-temp1(1))/(3._ki*sumb)
+ res_4p2m_adj_np4(2) = (-temp1(2))/(3._ki*sumb)
+ res_4p2m_adj_np4(3) = (temp0(1)-temp1(3)-2._ki/3._ki*temp1(1))/(3._ki*sumb)
+ res_4p2m_adj_np4(4) = (temp0(2)-temp1(4)-2._ki/3._ki*temp1(2))/(3._ki*sumb)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ temp0 = a4p2m_adj_np2(s24,s13,s23,s34,0,0,0,par4)/3._ki
+ temp1 = b(par4)*a4p2m_adj_np4(s24,s13,s23,s34,0,0,0,0)
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ truc1 = resultat3_np2(j,1,:)
+ temp2 = temp2 + invs(j,par4)*truc1/6._ki
+ !
+ if (j /= par4) then
+ !
+ temp3 = temp3 - b(j)*f3p_np2_sc(s_mat,smj,locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p2m_adj_np4(1) = ( temp1(1)+temp2(1)+temp3(1) )/(2._ki*sumb)
+ res_4p2m_adj_np4(2) = ( temp1(2)+temp2(2)+temp3(2) )/(2._ki*sumb)
+ res_4p2m_adj_np4(3) = ( temp1(3)+temp1(1)/6._ki+temp2(3)+temp2(1)/2._ki &
+ +temp3(3)+temp3(1)/2._ki+temp0(1) )/(2._ki*sumb)
+ res_4p2m_adj_np4(4) = ( temp1(4)+temp1(2)/6._ki+temp2(4)+temp2(2)/2._ki &
+ +temp3(4)+temp3(2)/2._ki+temp0(2) )/(2._ki*sumb)
+ !
+ ! cas avec plus de un parametre de feynman au numerateur
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a4p2m_adj_np4:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of four-point integrals in n+4 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb(par),4/)
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p2m_adj_np4
+ !
+ !****f* src/integrals/four_point/function_4p2m_adj/f2a
+ ! NAME
+ !
+ ! function f2a
+ !
+ ! USAGE
+ !
+ ! complex = f2a(u,v,w,x)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the "finite part" of the scalar four dimensional two
+ ! adjacent mass four point function. The expression has been taken in
+ ! Nucl. Phys. {\bf B615} (2001) , 385
+ !
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), (p1+p2)^2
+ ! * v -- a real (type ki), (p2+p3)^2
+ ! * w -- a real (type ki), p3^2
+ ! * x -- a real (type ki), p4^2
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ ! Affected by the variable rat_or_tot_par (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f2a(u,v,w,x)
+ !
+ real(ki), intent(in) :: u,v,w,x
+ complex(ki) :: f2a
+ !
+ f2a = zdilog(1._ki-w/v,sign(un,w-v)) &
+ + zdilog(1._ki-x/v,sign(un,x-v)) &
+ + z_log(u/v,sign(un,v-u))*z_log(x/v,sign(un,v-x))/2._ki &
+ + z_log(w/v,sign(un,v-w))*z_log(u/x,sign(un,x-u))/2._ki
+ !
+ end function f2a
+ !
+ !****if* src/integrals/four_point/function_4p2m_adj/eval_numer_gi
+ ! NAME
+ !
+ ! function eval_numer_gi
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_gi(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This function contains the integrand for the numerical computation in phase
+ ! space region where det(G) ~ 0
+ !
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), between 0 and 1
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki). It is called by
+ ! the routine adapt_gauss1 in the function f4p2m_adj
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_gi(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_gi
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ z = x - eps_glob*i_*y
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ !
+ eval_numer_gi = fg(z,s24_glob,s13_glob,s23_glob,s34_glob,&
+ & par1_glob,par2_glob,par3_glob,par4_glob,&
+ & dim_glob)
+ eval_numer_gi = eval_numer_gi*jacob
+ !
+ end function eval_numer_gi
+ !
+ !****if* src/integrals/four_point/function_4p2m_adj/fg
+ ! NAME
+ !
+ ! function fg
+ !
+ ! USAGE
+ !
+ ! complex = fg(z,s24,s13,s23,s34,par1,par2,par3,par4,dim)
+ !
+ ! DESCRIPTION
+ !
+ ! This function contains the one dimensional integral representation of
+ ! the six/eight dimensional two adjacent mass four point function
+ !
+ !
+ ! INPUTS
+ !
+ ! * z -- a real (type ki), integration variable
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! two adjacent mass four point function, dim="n+4" eight dimensional
+ ! two adjacent mass four point function
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki) corresponding to the
+ ! one dimensional integral representation of the six/eight dimensional
+ ! two adjacent mass four point function
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function fg(z,s24,s13,s23,s34,par1,par2,par3,par4,dim)
+ !
+ complex(ki), intent (in) :: z
+ real(ki), intent (in) :: s24,s13,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ character (len=3) :: dim
+ complex(ki) :: fg
+ !
+ integer, dimension(4) :: par
+ integer :: nb_par
+ complex(ki) :: c_var,d_var,e_var,f_var,g_var,h_var
+ complex(ki) :: umz
+ !
+ par = (/par1,par2,par3,par4/)
+ nb_par = count(mask=par/=0)
+ umz = 1._ki - z
+ !
+ c_var = s13
+ !
+ f_var = z*s24+(1._ki-z)*(s34-s13)
+ !
+ g_var = z*(1._ki-z)*s23-z*s24-(1._ki-z)*s34
+ !
+ d_var = z*s23-s13
+ !
+ e_var = z*s24+(1._ki-z)*s34
+ !
+ h_var = z*s23
+ !
+ if (dim == "n+2") then
+ if (nb_par == 0) then
+ !
+ fg=log(e_var)/g_var/f_var*e_var-c_var/d_var/f_var*(log(1._ki-z)+z_&
+ &log(s13,1._ki))-1._ki/g_var*(log(z)+log(1._ki-z)+z_log(s23,1._ki))/&
+ &d_var*h_var
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ fg=-1._ki/2._ki*(2._ki*d_var*f_var+c_var*d_var-c_var*d_var*z+c_var*f&
+ &_var)*c_var/f_var**2/d_var**2*(log(1._ki-z)+z_log(s13,1._ki))+1._k&
+ &i/2._ki/g_var*log(e_var)/f_var**2*e_var**2-1._ki/2._ki*c_var/f_var&
+ &/d_var-1._ki/2._ki/g_var*(log(z)+log(1._ki-z)+z_log(s23,1._ki))/d_v&
+ &ar**2*h_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/2._ki*z/g_var**2*(log(z)+log(1._ki-z)+z_log(s23,1._ki))/d_va&
+ &r**2*h_var*((1._ki-z)*d_var*h_var+c_var*g_var-d_var*g_var)-1._ki/&
+ &2._ki/g_var**2*log(e_var)*z/f_var*e_var**2+1._ki/2._ki*z*c_var**2/&
+ &d_var**2/f_var*(log(1._ki-z)+z_log(s13,1._ki))-1._ki/2._ki/g_var*z/&
+ &d_var*c_var-1._ki/2._ki*z/g_var
+ !
+ case(3)
+ !
+ fg=-1._ki/2._ki*(-1._ki+z)/g_var**2*(log(z)+log(1._ki-z)+z_log(s23,1.&
+ &_ki))/d_var**2*h_var*((1._ki-z)*d_var*h_var+c_var*g_var-d_var*g_v&
+ &ar)+1._ki/2._ki/g_var**2*log(e_var)/f_var*e_var**2*(-1._ki+z)-1._ki&
+ &/2._ki*c_var**2*(-1._ki+z)/d_var**2/f_var*(log(1._ki-z)+z_log(s13,&
+ &1._ki))-1._ki/2._ki/g_var/d_var*c_var+1._ki/2._ki/g_var*z/d_var*c_va&
+ &r+1._ki/2._ki*z/g_var-1._ki/2._ki/g_var
+ !
+ case(4)
+ !
+ fg=1._ki/2._ki*(-1._ki+z)/g_var**2*(log(z)+log(1._ki-z)+z_log(s23,1._k&
+ &i))/d_var*h_var**2+1._ki/2._ki/g_var**2*log(e_var)/f_var**2*e_var&
+ &*(f_var*e_var+g_var*f_var-c_var*g_var+c_var*g_var*z)-1._ki/2._ki*&
+ &(-1._ki+z)/g_var/f_var*h_var-1._ki/2._ki*(-1._ki+z)*c_var**2/d_var/&
+ &f_var**2*(log(1._ki-z)+z_log(s13,1._ki))-1._ki/2._ki/f_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 2) then
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki*c_var/f_var**3/d_var**3*(log(umz)+z_log(s13,1._ki))*&
+ &(c_var**2*d_var**2*umz**2+3._ki*d_var*f_var**2*h_var+c_var**2*f_&
+ &var**2+c_var**2*d_var*f_var*umz+3._ki*c_var*d_var**2*f_var*umz)+&
+ &1._ki/6._ki*c_var/d_var**2/f_var**2*(-5._ki*d_var**2*umz-4._ki*c_va&
+ &r*d_var*umz+5._ki*d_var*g_var+2._ki*c_var*g_var)-1._ki/3._ki/g_var*&
+ &(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d_var**3*h_var**3+1._ki&
+ &/3._ki/g_var*log(e_var)/f_var**3*e_var**3
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*c_var**2/f_var**2/d_var**3*(log(umz)+z_log(s13,1._ki)&
+ &)*(1._ki-umz)*(3._ki*d_var*f_var+c_var*d_var*umz+2._ki*c_var*f_var&
+ &)+1._ki/6._ki*h_var**2/g_var**2/d_var**3*(log(1._ki-umz)+log(umz)+&
+ &z_log(s23,1._ki))*(1._ki-umz)*(-d_var*g_var+d_var*h_var*umz+2._ki*&
+ &c_var*g_var)+1._ki/6._ki/g_var/d_var**2/f_var*(1._ki-umz)*(d_var**&
+ &2*g_var-c_var**2*d_var*umz-2._ki*c_var*d_var**2*umz+2._ki*c_var**&
+ &2*g_var+2._ki*c_var*d_var*g_var-d_var**3*umz)+1._ki/6._ki*log(e_va&
+ &r)*e_var**3*(-1._ki+umz)/g_var**2/f_var**2
+ !
+ case(3)
+ !
+ fg=1._ki/6._ki*c_var**2/f_var**2/d_var**3*(log(umz)+z_log(s13,1._ki)&
+ &)*(3._ki*d_var*f_var+c_var*d_var*umz+2._ki*c_var*f_var)*umz+1._ki/&
+ &6._ki*h_var**2/g_var**2/d_var**3*(log(1._ki-umz)+log(umz)+z_log(s&
+ &23,1._ki))*umz*(-d_var*g_var+d_var*h_var*umz+2._ki*c_var*g_var)-1&
+ &._ki/6._ki/g_var**2*log(e_var)/f_var**2*e_var**3*umz+1._ki/6._ki/g_&
+ &var/d_var**2/f_var*(d_var**2*g_var-c_var**2*d_var*umz-2._ki*c_va&
+ &r*d_var**2*umz+2._ki*c_var**2*g_var+2._ki*c_var*d_var*g_var-d_var&
+ &**3*umz)*umz
+ !
+ case(4)
+ !
+ fg=1._ki/6._ki*c_var**2/f_var**3/d_var**2*(log(umz)+z_log(s13,1._ki)&
+ &)*umz*(3._ki*d_var*f_var+2._ki*c_var*d_var*umz+c_var*f_var)-1._ki/&
+ &6._ki/g_var**2*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d_var**2&
+ &*h_var**3*umz+1._ki/6._ki/g_var**2*log(e_var)/f_var**3*e_var**2*(&
+ &f_var*e_var+g_var*f_var-2._ki*c_var*g_var*umz)+1._ki/6._ki/d_var/g&
+ &_var/f_var**2*(-2._ki*h_var*d_var*g_var*umz+c_var**2*d_var*umz**&
+ &2+d_var**3*umz**2+2._ki*c_var*d_var**2*umz**2+d_var*g_var**2+c_v&
+ &ar**2*g_var*umz)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ fg=-1._ki/3._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d&
+ &_var**3*h_var*(-1._ki+umz)**2*(d_var**4*umz**2+2._ki*c_var*d_var*&
+ &*3*umz**2+c_var**2*d_var**2*umz**2+c_var**2*g_var*d_var*umz-c_v&
+ &ar*d_var*g_var**2-2._ki*g_var*d_var**3*umz+d_var**2*g_var**2-c_v&
+ &ar*g_var*d_var**2*umz+c_var**2*g_var**2)+1._ki/6._ki*(c_var+d_var&
+ &)/d_var**2/g_var**2*(-1._ki+umz)**2*(2._ki*c_var*g_var+2._ki*c_var&
+ &*d_var*umz+2._ki*d_var**2*umz-3._ki*d_var*g_var)-1._ki/3._ki*(-1._ki&
+ &+umz)**2*(-log(e_var)*e_var**3*d_var**3+c_var**3*g_var**3*log(u&
+ &mz)+c_var**3*g_var**3*z_log(s13,1._ki))/g_var**3/f_var/d_var**3
+ !
+ case(3)
+ !
+ fg=-1._ki/3._ki*c_var**3/d_var**3/f_var*(log(umz)+z_log(s13,1._ki))*&
+ &(1._ki-umz)*umz-1._ki/3._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log&
+ &(s23,1._ki))/d_var**3*h_var*(1._ki-umz)*umz*(d_var**4*umz**2+2._ki&
+ &*c_var*d_var**3*umz**2+c_var**2*d_var**2*umz**2+c_var**2*g_var*&
+ &d_var*umz-c_var*d_var*g_var**2-2._ki*g_var*d_var**3*umz+d_var**2&
+ &*g_var**2-c_var*g_var*d_var**2*umz+c_var**2*g_var**2)+1._ki/3._ki&
+ &/g_var**3*log(e_var)/f_var*e_var**3*(1._ki-umz)*umz+1._ki/6._ki*(c&
+ &_var+d_var)/d_var**2/g_var**2*(1._ki-umz)*(2._ki*c_var*g_var+2._ki&
+ &*c_var*d_var*umz+2._ki*d_var**2*umz-3._ki*d_var*g_var)*umz
+ !
+ case(4)
+ !
+ fg=-1._ki/6._ki*c_var**3/d_var**2/f_var**2*(log(umz)+z_log(s13,1._ki&
+ &))*(1._ki-umz)*umz+1._ki/6._ki*h_var**2/g_var**3/d_var**2*(log(1._k&
+ &i-umz)+log(umz)+z_log(s23,1._ki))*(1._ki-umz)*umz*(-2._ki*d_var*g_&
+ &var+2._ki*d_var*h_var*umz+c_var*g_var)-1._ki/6._ki/g_var**3*log(e_&
+ &var)/f_var**2*e_var**2*(1._ki-umz)*(2._ki*f_var*e_var+2._ki*g_var*&
+ &f_var-c_var*g_var*umz)-1._ki/6._ki/g_var**2/f_var/d_var*(1._ki-umz&
+ &)*(2._ki*d_var**3*umz**2+4._ki*c_var*d_var**2*umz**2+2._ki*c_var**&
+ &2*d_var*umz**2-4._ki*c_var*d_var*g_var*umz+d_var*g_var**2-3._ki*d&
+ &_var**2*g_var*umz-c_var**2*g_var*umz)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ fg=-1._ki/3._ki*c_var**3/d_var**3/f_var*(log(umz)+z_log(s13,1._ki))*&
+ &umz**2-1._ki/3._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log(s23,1._k&
+ &i))/d_var**3*h_var*umz**2*(d_var**4*umz**2+2._ki*c_var*d_var**3*&
+ &umz**2+c_var**2*d_var**2*umz**2+c_var**2*g_var*d_var*umz-c_var*&
+ &d_var*g_var**2-2._ki*g_var*d_var**3*umz+d_var**2*g_var**2-c_var*&
+ &g_var*d_var**2*umz+c_var**2*g_var**2)+1._ki/3._ki/g_var**3*log(e_&
+ &var)/f_var*e_var**3*umz**2+1._ki/6._ki*(c_var+d_var)/d_var**2/g_v&
+ &ar**2*umz**2*(2._ki*c_var*g_var+2._ki*c_var*d_var*umz+2._ki*d_var*&
+ &*2*umz-3._ki*d_var*g_var)
+ !
+ case(4)
+ !
+ fg=-1._ki/6._ki*c_var**3/d_var**2/f_var**2*(log(umz)+z_log(s13,1._ki&
+ &))*umz**2+1._ki/6._ki*h_var**2/g_var**3/d_var**2*(log(1._ki-umz)+l&
+ &og(umz)+z_log(s23,1._ki))*umz**2*(-2._ki*d_var*g_var+2._ki*d_var*h&
+ &_var*umz+c_var*g_var)-1._ki/6._ki/g_var**3*log(e_var)/f_var**2*e_&
+ &var**2*umz*(2._ki*f_var*e_var+2._ki*g_var*f_var-c_var*g_var*umz)-&
+ &1._ki/6._ki/g_var**2/f_var/d_var*(2._ki*d_var**3*umz**2+4._ki*c_var&
+ &*d_var**2*umz**2+2._ki*c_var**2*d_var*umz**2-4._ki*c_var*d_var*g_&
+ &var*umz+d_var*g_var**2-3._ki*d_var**2*g_var*umz-c_var**2*g_var*u&
+ &mz)*umz
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=-1._ki/3._ki*c_var**3/d_var/f_var**3*(log(umz)+z_log(s13,1._ki))*&
+ &umz**2-1._ki/3._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log(s23,1._k&
+ &i))/d_var*h_var**3*umz**2+1._ki/3._ki/g_var**3*log(e_var)/f_var**&
+ &3*e_var*(-c_var*g_var**2*f_var*umz+c_var**2*f_var**2*umz**2+c_v&
+ &ar**2*g_var**2*umz**2-c_var**2*g_var*f_var*umz**2+g_var**2*f_va&
+ &r**2+f_var**4+2._ki*c_var*f_var**3*umz+c_var*g_var*f_var**2*umz+&
+ &2._ki*g_var*f_var**3)+1._ki/6._ki/g_var**2/f_var**2*(g_var-c_var*u&
+ &mz-d_var*umz)*(-2._ki*c_var*d_var*umz**2-2._ki*d_var**2*umz**2+g_&
+ &var**2+d_var*g_var*umz+4._ki*c_var*g_var*umz)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 3) then
+ !
+ select case(par2)
+ !
+ case(1)
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ fg=1._ki/4._ki/f_var**4*(log(umz)+z_log(s13,1._ki))*c_var/d_var**4*(&
+ &c_var**2*d_var**2*umz**2+2._ki*c_var*d_var**2*f_var*umz+2._ki*d_v&
+ &ar*f_var**2*h_var+c_var**2*f_var**2)*(-2._ki*d_var*f_var-umz*c_v&
+ &ar*d_var-c_var*f_var)+1._ki/24._ki*c_var*(-1._ki+umz)*(-18._ki*c_va&
+ &r**2*d_var-42._ki*c_var*d_var**2-26._ki*d_var**3-18._ki*d_var*umz*&
+ &c_var**2-42._ki*umz*c_var*d_var**2-26._ki*umz*d_var**3+63._ki*c_va&
+ &r*g_var*d_var+52._ki*g_var*d_var**2+18._ki*c_var**2*g_var)/d_var*&
+ &*2/f_var**3+1._ki/4._ki/g_var*log(e_var)/f_var**4*e_var**4-7._ki/8&
+ &._ki*c_var**2/d_var**2/f_var**3*g_var**2-7._ki/4._ki*c_var**2/f_va&
+ &r**3-3._ki/4._ki*c_var**3/d_var/f_var**3+3._ki/4._ki*c_var**3/d_var&
+ &**2/f_var**3*g_var+21._ki/8._ki*c_var**2/d_var/f_var**3*g_var-13.&
+ &_ki/12._ki*c_var*d_var/f_var**3+13._ki/6._ki*c_var/f_var**3*g_var-1&
+ &3._ki/12._ki*c_var/d_var/f_var**3*g_var**2-1._ki/4._ki*c_var**3/d_v&
+ &ar**3/f_var**3*g_var**2-1._ki/4._ki/g_var*(log(1._ki-umz)+log(umz)&
+ &+z_log(s23,1._ki))/d_var**4*h_var**4
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*c_var**2/f_var**3/d_var**4*(log(umz)+z_log(s13,1._ki&
+ &))*(1._ki-umz)*(3._ki*c_var**2*f_var**2+c_var**2*d_var**2*umz**2+&
+ &6._ki*d_var**2*f_var**2+8._ki*c_var*d_var*f_var**2+2._ki*c_var**2*&
+ &d_var*f_var*umz+4._ki*c_var*d_var**2*f_var*umz)-1._ki/12._ki/g_var&
+ &**2*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d_var**4*h_var**3*&
+ &(1._ki-umz)*(-d_var*h_var*umz-3._ki*c_var*g_var+d_var*g_var)-1._ki&
+ &/4._ki/g_var/f_var**2*c_var*h_var*(1._ki-umz)*umz**2+1._ki/2._ki/f_&
+ &var**2*c_var*(1._ki-umz)*umz+1._ki/6._ki/f_var**2*d_var*(1._ki-umz)&
+ &*umz+19._ki/24._ki/f_var**2*c_var**2/d_var*(1._ki-umz)*umz+5._ki/12&
+ &._ki/f_var**2*c_var**3/d_var**2*(1._ki-umz)*umz-1._ki/12._ki/g_var/&
+ &f_var**2*d_var**2*(1._ki-umz)*umz**2-1._ki/12._ki/g_var/f_var**2*c&
+ &_var**3/d_var*(1._ki-umz)*umz**2+1._ki/24._ki*(-1._ki+umz)*(2._ki*g_&
+ &var**3*f_var*d_var**3+2._ki*log(e_var)*e_var**4*d_var**3+6._ki*c_&
+ &var**3*g_var**3*f_var+13._ki*c_var**2*g_var**3*f_var*d_var+6._ki*&
+ &c_var*g_var**3*f_var*d_var**2)/f_var**3/g_var**2/d_var**3
+ !
+ case(3)
+ !
+ fg=-1._ki/12._ki/g_var**2*log(e_var)/f_var**3*e_var**4*umz-1._ki/12.&
+ &_ki/g_var**2*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d_var**4*h&
+ &_var**3*umz*(-d_var*h_var*umz-3._ki*c_var*g_var+d_var*g_var)+1._k&
+ &i/12._ki*c_var**2/f_var**3/d_var**4*(log(umz)+z_log(s13,1._ki))*(&
+ &3._ki*c_var**2*f_var**2+c_var**2*d_var**2*umz**2+6._ki*d_var**2*f&
+ &_var**2+8._ki*c_var*d_var*f_var**2+2._ki*c_var**2*d_var*f_var*umz&
+ &+4._ki*c_var*d_var**2*f_var*umz)*umz-1._ki/4._ki/g_var/f_var**2*c_&
+ &var*h_var*umz**3+1._ki/2._ki/f_var**2*c_var*umz**2+1._ki/6._ki/f_va&
+ &r**2*d_var*umz**2+19._ki/24._ki/f_var**2*c_var**2/d_var*umz**2+5.&
+ &_ki/12._ki/f_var**2*c_var**3/d_var**2*umz**2-1._ki/4._ki*g_var/d_va&
+ &r/f_var**2*c_var*umz-1._ki/12._ki/g_var/f_var**2*c_var**3/d_var*u&
+ &mz**3-1._ki/12._ki/g_var/f_var**2*d_var**2*umz**3-13._ki/24._ki*g_v&
+ &ar/d_var**2/f_var**2*c_var**2*umz-1._ki/4._ki*g_var/d_var**3/f_va&
+ &r**2*c_var**3*umz-1._ki/12._ki*g_var*(-1._ki+umz)/f_var**2-1._ki/12&
+ &._ki*g_var/f_var**2
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki/g_var**2*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/&
+ &d_var**3*h_var**4*umz-1._ki/12._ki/g_var**2*log(e_var)/f_var**4*e&
+ &_var**3*(-f_var*e_var-g_var*f_var+3._ki*c_var*g_var*umz)+1._ki/12&
+ &._ki*c_var**2/d_var**3/f_var**4*(log(umz)+z_log(s13,1._ki))*(c_va&
+ &r**2*f_var**2+3._ki*c_var**2*d_var**2*umz**2+6._ki*d_var**2*f_var&
+ &**2+4._ki*c_var*d_var*f_var**2+2._ki*c_var**2*d_var*f_var*umz+8._k&
+ &i*c_var*d_var**2*f_var*umz)*umz+1._ki/4._ki/g_var/f_var**3*c_var*&
+ &d_var*h_var*umz**3+1._ki/4._ki*g_var/f_var**3*h_var*umz+1._ki/4._ki&
+ &*c_var**3/d_var/f_var**3*umz**2-1._ki/2._ki*c_var*d_var/f_var**3*&
+ &umz**2-1._ki/4._ki/f_var**3*d_var**2*umz**2+1._ki/24._ki*c_var**2/f&
+ &_var**3*umz**2+1._ki/12._ki/g_var/f_var**3*d_var**3*umz**3-1._ki/1&
+ &2._ki*c_var**3/d_var**2/f_var**3*g_var*umz-7._ki/24._ki*c_var**2/d&
+ &_var/f_var**3*g_var*umz+1._ki/12._ki/g_var/f_var**3*c_var**3*umz*&
+ &*3-1._ki/12._ki*g_var**2/f_var**3
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/&
+ &d_var**4*h_var**2*(-1._ki+umz)**2*(c_var**2*d_var**2*umz**2+2._ki&
+ &*c_var*d_var**3*umz**2+d_var**4*umz**2+3._ki*c_var**2*g_var**2+d&
+ &_var**2*g_var**2-2._ki*c_var*d_var*g_var**2+2._ki*c_var**2*d_var*&
+ &g_var*umz-2._ki*d_var**3*g_var*umz)+1._ki/12._ki*c_var**3/d_var**4&
+ &/f_var**2*(log(umz)+z_log(s13,1._ki))*(-1._ki+umz)**2*(-4._ki*d_va&
+ &r*f_var-umz*c_var*d_var-3._ki*c_var*f_var)+1._ki/4._ki/g_var**2/f_&
+ &var*c_var*h_var*(-1._ki+umz)**2*umz**2-1._ki/3._ki/g_var/f_var*c_v&
+ &ar*(-1._ki+umz)**2*umz-5._ki/24._ki/g_var/f_var*d_var*(-1._ki+umz)*&
+ &*2*umz+1._ki/12._ki/g_var**2/f_var*d_var**2*(-1._ki+umz)**2*umz**2&
+ &-1._ki/24._ki/g_var/f_var*c_var**2/d_var*(-1._ki+umz)**2*umz+1._ki/&
+ &12._ki/g_var**2/f_var*c_var**3/d_var*(-1._ki+umz)**2*umz**2+1._ki/&
+ &12._ki/g_var/f_var*c_var**3/d_var**2*(-1._ki+umz)**2*umz+1._ki/24.&
+ &_ki*(-1._ki+umz)**2*(3._ki*g_var**3*f_var*d_var**3+2._ki*log(e_var)&
+ &*e_var**4*d_var**3-5._ki*c_var**2*g_var**3*f_var*d_var-6._ki*c_va&
+ &r**3*g_var**3*f_var+2._ki*c_var*g_var**3*f_var*d_var**2)/f_var**&
+ &2/g_var**3/d_var**3
+ !
+ case(3)
+ !
+ fg=1._ki/12._ki/g_var**3*log(e_var)/f_var**2*e_var**4*(1._ki-umz)*um&
+ &z+1._ki/12._ki*c_var**3/d_var**4/f_var**2*(log(umz)+z_log(s13,1._k&
+ &i))*(1._ki-umz)*(-4._ki*d_var*f_var-umz*c_var*d_var-3._ki*c_var*f_&
+ &var)*umz-1._ki/12._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log(s23,&
+ &1._ki))/d_var**4*h_var**2*(1._ki-umz)*umz*(c_var**2*d_var**2*umz*&
+ &*2+2._ki*c_var*d_var**3*umz**2+d_var**4*umz**2+3._ki*c_var**2*g_v&
+ &ar**2+d_var**2*g_var**2-2._ki*c_var*d_var*g_var**2+2._ki*c_var**2&
+ &*d_var*g_var*umz-2._ki*d_var**3*g_var*umz)+1._ki/4._ki/g_var**2/f_&
+ &var*c_var*h_var*(1._ki-umz)*umz**3-1._ki/3._ki/g_var/f_var*c_var*(&
+ &1._ki-umz)*umz**2-5._ki/24._ki/g_var/f_var*d_var*(1._ki-umz)*umz**2&
+ &+1._ki/12._ki/f_var*c_var/d_var*(1._ki-umz)*umz-5._ki/24._ki/f_var*c&
+ &_var**2/d_var**2*(1._ki-umz)*umz+1._ki/12._ki/g_var**2/f_var*c_var&
+ &**3/d_var*(1._ki-umz)*umz**3-1._ki/4._ki/f_var*c_var**3/d_var**3*(&
+ &1._ki-umz)*umz-1._ki/24._ki/g_var/f_var*c_var**2/d_var*(1._ki-umz)*&
+ &umz**2+1._ki/12._ki/g_var/f_var*c_var**3/d_var**2*(1._ki-umz)*umz*&
+ &*2+1._ki/12._ki/g_var**2/f_var*d_var**2*(1._ki-umz)*umz**3-1._ki/8.&
+ &_ki*umz*(-1._ki+umz)/f_var
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/&
+ &d_var**3*h_var**3*(1._ki-umz)*umz*(-d_var*h_var*umz-c_var*g_var+&
+ &d_var*g_var)+1._ki/12._ki*c_var**3/f_var**3/d_var**3*(log(umz)+z_&
+ &log(s13,1._ki))*(1._ki-umz)*umz*(-2._ki*d_var*f_var-umz*c_var*d_va&
+ &r-c_var*f_var)+1._ki/12._ki/g_var**3*log(e_var)/f_var**3*e_var**3&
+ &*(1._ki-umz)*(-f_var*e_var-g_var*f_var+c_var*g_var*umz)-1._ki/4._k&
+ &i/g_var**2/f_var**2*c_var*d_var*h_var*(1._ki-umz)*umz**3-1._ki/4.&
+ &_ki/f_var**2*c_var*(1._ki-umz)*umz-1._ki/6._ki/f_var**2*d_var*(1._ki&
+ &-umz)*umz+3._ki/8._ki/f_var**2/g_var*c_var**2*(1._ki-umz)*umz**2+5&
+ &._ki/24._ki/g_var/f_var**2*d_var**2*(1._ki-umz)*umz**2+1._ki/12._ki/&
+ &g_var/f_var**2*c_var**3/d_var*(1._ki-umz)*umz**2-1._ki/12._ki/f_va&
+ &r**2*c_var**3/d_var**2*(1._ki-umz)*umz-1._ki/8._ki/f_var**2*c_var*&
+ &*2/d_var*(1._ki-umz)*umz-1._ki/12._ki/g_var**2/f_var**2*d_var**3*(&
+ &1._ki-umz)*umz**3+1._ki/2._ki/f_var**2/g_var*c_var*d_var*(1._ki-umz&
+ &)*umz**2-1._ki/12._ki/g_var**2/f_var**2*c_var**3*(1._ki-umz)*umz**&
+ &3-1._ki/24._ki*g_var*(-1._ki+umz)/f_var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ fg=1._ki/12._ki/g_var**3*log(e_var)/f_var**2*e_var**4*umz**2-1._ki/1&
+ &2._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d_var**4&
+ &*h_var**2*umz**2*(c_var**2*d_var**2*umz**2+2._ki*c_var*d_var**3*&
+ &umz**2+d_var**4*umz**2+3._ki*c_var**2*g_var**2+d_var**2*g_var**2&
+ &-2._ki*c_var*d_var*g_var**2+2._ki*c_var**2*d_var*g_var*umz-2._ki*d&
+ &_var**3*g_var*umz)+1._ki/12._ki*c_var**3/d_var**4/f_var**2*(log(u&
+ &mz)+z_log(s13,1._ki))*(-4._ki*d_var*f_var-umz*c_var*d_var-3._ki*c_&
+ &var*f_var)*umz**2+1._ki/4._ki/g_var**2/f_var*c_var*h_var*umz**4-1&
+ &._ki/3._ki/g_var/f_var*c_var*umz**3-5._ki/24._ki/g_var/f_var*d_var*&
+ &umz**3+1._ki/12._ki/g_var**2/f_var*d_var**2*umz**4-1._ki/4._ki/f_va&
+ &r*c_var**3/d_var**3*umz**2+1._ki/12._ki/f_var*c_var/d_var*umz**2-&
+ &5._ki/24._ki/f_var*c_var**2/d_var**2*umz**2+1._ki/12._ki/g_var**2/f&
+ &_var*c_var**3/d_var*umz**4+1._ki/12._ki/g_var/f_var*c_var**3/d_va&
+ &r**2*umz**3-1._ki/24._ki/g_var/f_var*c_var**2/d_var*umz**3+1._ki/8&
+ &._ki*(-1._ki+umz**2)/f_var+1._ki/8._ki/f_var
+ !
+ case(4)
+ !
+ fg=1._ki/12._ki*c_var**3/f_var**3/d_var**3*(log(umz)+z_log(s13,1._ki&
+ &))*umz**2*(-2._ki*d_var*f_var-umz*c_var*d_var-c_var*f_var)+1._ki/&
+ &12._ki/g_var**3*log(e_var)/f_var**3*e_var**3*(-f_var*e_var-g_var&
+ &*f_var+c_var*g_var*umz)*umz-1._ki/12._ki/g_var**3*(log(1._ki-umz)+&
+ &log(umz)+z_log(s23,1._ki))/d_var**3*h_var**3*umz**2*(-d_var*h_va&
+ &r*umz-c_var*g_var+d_var*g_var)-1._ki/4._ki/g_var**2/f_var**2*c_va&
+ &r*d_var*h_var*umz**4-1._ki/4._ki/f_var**2*c_var*umz**2-1._ki/6._ki/&
+ &f_var**2*d_var*umz**2-1._ki/12._ki/f_var**2*c_var**3/d_var**2*umz&
+ &**2-1._ki/8._ki/f_var**2*c_var**2/d_var*umz**2+1._ki/12._ki/g_var/f&
+ &_var**2*c_var**3/d_var*umz**3+1._ki/2._ki/f_var**2/g_var*c_var*d_&
+ &var*umz**3-1._ki/12._ki/g_var**2/f_var**2*c_var**3*umz**4+5._ki/24&
+ &._ki/g_var/f_var**2*d_var**2*umz**3+3._ki/8._ki/f_var**2/g_var*c_v&
+ &ar**2*umz**3-1._ki/12._ki/g_var**2/f_var**2*d_var**3*umz**4+1._ki/&
+ &24._ki*g_var*(-1._ki+umz)/f_var**2+1._ki/24._ki*g_var/f_var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/&
+ &d_var**2*h_var**4*umz**2+1._ki/12._ki/g_var**3*log(e_var)/f_var**&
+ &4*e_var**2*(f_var**4+3._ki*c_var**2*g_var**2*umz**2+c_var**2*f_v&
+ &ar**2*umz**2-2._ki*c_var**2*g_var*f_var*umz**2+2._ki*g_var*f_var*&
+ &*3+g_var**2*f_var**2+2._ki*f_var**3*c_var*umz-2._ki*c_var*g_var**&
+ &2*f_var*umz)+1._ki/12._ki*c_var**3/d_var**2/f_var**4*(log(umz)+z_&
+ &log(s13,1._ki))*umz**2*(-4._ki*d_var*f_var-3._ki*umz*c_var*d_var-c&
+ &_var*f_var)+1._ki/4._ki/g_var**2/f_var**3*c_var*d_var**2*h_var*um&
+ &z**4-1._ki/6._ki*c_var/f_var**3*g_var*umz+1._ki/24._ki*g_var/f_var*&
+ &*3*d_var*umz-1._ki/4._ki/g_var/f_var**3*c_var**3*umz**3+11._ki/24.&
+ &_ki*c_var**2/f_var**3*umz**2+1._ki/12._ki/g_var**2/f_var**3*d_var*&
+ &*4*umz**4-5._ki/24._ki/g_var/f_var**3*d_var**3*umz**3+7._ki/12._ki*&
+ &c_var*d_var/f_var**3*umz**2+1._ki/12._ki/g_var**2/f_var**3*c_var*&
+ &*3*d_var*umz**4-2._ki/3._ki/g_var/f_var**3*c_var*d_var**2*umz**3-&
+ &17._ki/24._ki/g_var/f_var**3*c_var**2*d_var*umz**3+1._ki/8._ki/f_va&
+ &r**3*d_var**2*umz**2-1._ki/12._ki*c_var**3/d_var/f_var**3*umz**2-&
+ &1._ki/24._ki*g_var**2/f_var**3
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ fg=1._ki/4._ki/g_var**4*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d_&
+ &var**4*h_var*(-1._ki+umz)**3*(-d_var*h_var*umz-c_var*g_var+d_var&
+ &*g_var)*(-2._ki*d_var**2*h_var*g_var*umz+c_var**2*d_var**2*umz**&
+ &2+2._ki*c_var*d_var**3*umz**2+d_var**4*umz**2+c_var**2*g_var**2+&
+ &d_var**2*g_var**2)+3._ki/4._ki/g_var**3*c_var*h_var*(-1._ki+umz)**&
+ &3*umz**2-1._ki/g_var**2*c_var*(-1._ki+umz)**3*umz-5._ki/8._ki/g_var&
+ &**2*d_var*(-1._ki+umz)**3*umz+1._ki/4._ki/g_var**2*c_var**3/d_var*&
+ &*2*(-1._ki+umz)**3*umz+1._ki/4._ki/g_var**3*c_var**3/d_var*(-1._ki+&
+ &umz)**3*umz**2-1._ki/8._ki/g_var**2*c_var**2/d_var*(-1._ki+umz)**3&
+ &*umz+1._ki/4._ki/g_var**3*d_var**2*(-1._ki+umz)**3*umz**2-1._ki/24.&
+ &_ki*(-1._ki+umz)**3*(6._ki*c_var**4*g_var**4*log(umz)+6._ki*c_var**&
+ &4*g_var**4*z_log(s13,1._ki)-6._ki*log(e_var)*e_var**4*d_var**4+3.&
+ &_ki*c_var**2*f_var*d_var**2*g_var**3-11._ki*f_var*d_var**4*g_var*&
+ &*3-2._ki*c_var*f_var*d_var**3*g_var**3-6._ki*c_var**3*f_var*d_var&
+ &*g_var**3)/f_var/d_var**4/g_var**4
+ !
+ case(3)
+ !
+ fg=-1._ki/4._ki/g_var**4*log(e_var)/f_var*e_var**4*(-1._ki+umz)**2*u&
+ &mz-1._ki/4._ki/g_var**4*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/&
+ &d_var**4*h_var*(-1._ki+umz)**2*umz*(-d_var*h_var*umz-c_var*g_var&
+ &+d_var*g_var)*(-2._ki*d_var**2*h_var*g_var*umz+c_var**2*d_var**2&
+ &*umz**2+2._ki*c_var*d_var**3*umz**2+d_var**4*umz**2+c_var**2*g_v&
+ &ar**2+d_var**2*g_var**2)-3._ki/4._ki/g_var**3*c_var*h_var*(-1._ki+&
+ &umz)**2*umz**3+1._ki/g_var**2*c_var*(-1._ki+umz)**2*umz**2+5._ki/8&
+ &._ki/g_var**2*d_var*(-1._ki+umz)**2*umz**2+1._ki/4._ki*c_var**4/f_v&
+ &ar/d_var**4*(log(umz)+z_log(s13,1._ki))*(-1._ki+umz)**2*umz-1._ki/&
+ &4._ki/g_var**2*c_var**3/d_var**2*(-1._ki+umz)**2*umz**2-1._ki/4._ki&
+ &/g_var**3*c_var**3/d_var*(-1._ki+umz)**2*umz**3+1._ki/8._ki/d_var*&
+ &*2/g_var*c_var**2*(-1._ki+umz)**2*umz-1._ki/4._ki/d_var**3/g_var*c&
+ &_var**3*(-1._ki+umz)**2*umz-1._ki/12._ki/d_var/g_var*c_var*(-1._ki+&
+ &umz)**2*umz+1._ki/8._ki/g_var**2*c_var**2/d_var*(-1._ki+umz)**2*um&
+ &z**2-1._ki/4._ki/g_var**3*d_var**2*(-1._ki+umz)**2*umz**3-11._ki/24&
+ &._ki*(-1._ki+umz)**2*umz/g_var
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki/g_var**4*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/&
+ &d_var**3*h_var**2*(-1._ki+umz)**2*umz*(3._ki*d_var**4*umz**2+3._ki&
+ &*c_var**2*d_var**2*umz**2+6._ki*c_var*d_var**3*umz**2-2._ki*c_var&
+ &*d_var*g_var**2+3._ki*d_var**2*g_var**2-4._ki*c_var*g_var*d_var**&
+ &2*umz+2._ki*c_var**2*d_var*g_var*umz+c_var**2*g_var**2-6._ki*d_va&
+ &r**3*g_var*umz)-1._ki/12._ki/g_var**4*log(e_var)/f_var**2*e_var**&
+ &3*(-1._ki+umz)**2*(-3._ki*f_var*e_var-3._ki*g_var*f_var+c_var*g_va&
+ &r*umz)+3._ki/4._ki/f_var/g_var**3*c_var*d_var*h_var*(-1._ki+umz)**&
+ &2*umz**3+7._ki/12._ki/g_var/f_var*c_var*(-1._ki+umz)**2*umz+11._ki/&
+ &24._ki/g_var/f_var*d_var*(-1._ki+umz)**2*umz+1._ki/12._ki*c_var**4/&
+ &d_var**3/f_var**2*(log(umz)+z_log(s13,1._ki))*(-1._ki+umz)**2*umz&
+ &+1._ki/4._ki/f_var/g_var**3*d_var**3*(-1._ki+umz)**2*umz**3-19._ki/&
+ &24._ki/f_var/g_var**2*c_var**2*(-1._ki+umz)**2*umz**2+1._ki/4._ki/f&
+ &_var/g_var**3*c_var**3*(-1._ki+umz)**2*umz**3-4._ki/3._ki/f_var/g_&
+ &var**2*c_var*d_var*(-1._ki+umz)**2*umz**2-5._ki/8._ki/g_var**2/f_v&
+ &ar*d_var**2*(-1._ki+umz)**2*umz**2-1._ki/12._ki/g_var/f_var*c_var*&
+ &*3/d_var**2*(-1._ki+umz)**2*umz+1._ki/24._ki/g_var/f_var*c_var**2/&
+ &d_var*(-1._ki+umz)**2*umz-1._ki/12._ki/g_var**2/f_var*c_var**3/d_v&
+ &ar*(-1._ki+umz)**2*umz**2-1._ki/12._ki*(-1._ki+umz)**2/f_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ fg=-1._ki/4._ki/g_var**4*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d&
+ &_var**4*h_var*(1._ki-umz)*umz**2*(-d_var*h_var*umz-c_var*g_var+d&
+ &_var*g_var)*(-2._ki*d_var**2*h_var*g_var*umz+c_var**2*d_var**2*u&
+ &mz**2+2._ki*c_var*d_var**3*umz**2+d_var**4*umz**2+c_var**2*g_var&
+ &**2+d_var**2*g_var**2)-1._ki/4._ki/g_var**4*log(e_var)/f_var*e_va&
+ &r**4*(1._ki-umz)*umz**2-3._ki/4._ki/g_var**3*c_var*h_var*(1._ki-umz&
+ &)*umz**4+1._ki/g_var**2*c_var*(1._ki-umz)*umz**3+5._ki/8._ki/g_var*&
+ &*2*d_var*(1._ki-umz)*umz**3-1._ki/4._ki/g_var**3*d_var**2*(1._ki-um&
+ &z)*umz**4+1._ki/8._ki/g_var**2*c_var**2/d_var*(1._ki-umz)*umz**3+1&
+ &._ki/4._ki*c_var**4/f_var/d_var**4*(log(umz)+z_log(s13,1._ki))*(1.&
+ &_ki-umz)*umz**2-1._ki/12._ki/d_var/g_var*c_var*(1._ki-umz)*umz**2-1&
+ &._ki/4._ki/d_var**3/g_var*c_var**3*(1._ki-umz)*umz**2+1._ki/8._ki/d_&
+ &var**2/g_var*c_var**2*(1._ki-umz)*umz**2-1._ki/4._ki/g_var**3*c_va&
+ &r**3/d_var*(1._ki-umz)*umz**4-1._ki/4._ki/g_var**2*c_var**3/d_var*&
+ &*2*(1._ki-umz)*umz**3+11._ki/24._ki*umz**2*(-1._ki+umz)/g_var
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki/g_var**4*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/&
+ &d_var**3*h_var**2*(1._ki-umz)*umz**2*(3._ki*d_var**4*umz**2+3._ki*&
+ &c_var**2*d_var**2*umz**2+6._ki*c_var*d_var**3*umz**2-2._ki*c_var*&
+ &d_var*g_var**2+3._ki*d_var**2*g_var**2-4._ki*c_var*g_var*d_var**2&
+ &*umz+2._ki*c_var**2*d_var*g_var*umz+c_var**2*g_var**2-6._ki*d_var&
+ &**3*g_var*umz)-1._ki/12._ki/g_var**4*log(e_var)/f_var**2*e_var**3&
+ &*(1._ki-umz)*(-3._ki*f_var*e_var-3._ki*g_var*f_var+c_var*g_var*umz&
+ &)*umz+3._ki/4._ki/f_var/g_var**3*c_var*d_var*h_var*(1._ki-umz)*umz&
+ &**4+7._ki/12._ki/g_var/f_var*c_var*(1._ki-umz)*umz**2+11._ki/24._ki/&
+ &g_var/f_var*d_var*(1._ki-umz)*umz**2-5._ki/8._ki/g_var**2/f_var*d_&
+ &var**2*(1._ki-umz)*umz**3+1._ki/12._ki*c_var**4/d_var**3/f_var**2*&
+ &(log(umz)+z_log(s13,1._ki))*(1._ki-umz)*umz**2-1._ki/12._ki/g_var**&
+ &2/f_var*c_var**3/d_var*(1._ki-umz)*umz**3-1._ki/12._ki/g_var/f_var&
+ &*c_var**3/d_var**2*(1._ki-umz)*umz**2+1._ki/24._ki/g_var/f_var*c_v&
+ &ar**2/d_var*(1._ki-umz)*umz**2+1._ki/4._ki/f_var/g_var**3*d_var**3&
+ &*(1._ki-umz)*umz**4-19._ki/24._ki/f_var/g_var**2*c_var**2*(1._ki-um&
+ &z)*umz**3+1._ki/4._ki/f_var/g_var**3*c_var**3*(1._ki-umz)*umz**4-4&
+ &._ki/3._ki/f_var/g_var**2*c_var*d_var*(1._ki-umz)*umz**3+1._ki/12._k&
+ &i*umz*(-1._ki+umz)/f_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki/g_var**4*log(e_var)/f_var**3*e_var**2*(1._ki-umz)*(&
+ &6._ki*f_var**3*c_var*umz+c_var**2*g_var**2*umz**2-2._ki*c_var**2*&
+ &g_var*f_var*umz**2+3._ki*c_var**2*f_var**2*umz**2+4._ki*c_var*f_v&
+ &ar**2*g_var*umz+6._ki*g_var*f_var**3+3._ki*g_var**2*f_var**2-2._ki&
+ &*c_var*g_var**2*f_var*umz+3._ki*f_var**4)-1._ki/12._ki/g_var**4*(l&
+ &og(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d_var**2*h_var**3*(1._ki-&
+ &umz)*umz**2*(-3._ki*d_var*h_var*umz-c_var*g_var+3._ki*d_var*g_var&
+ &)-3._ki/4._ki/g_var**3/f_var**2*c_var*d_var**2*h_var*(1._ki-umz)*u&
+ &mz**4+1._ki/6._ki/f_var**2*c_var*(1._ki-umz)*umz+1._ki/24._ki/f_var*&
+ &*2*d_var*(1._ki-umz)*umz-1._ki/4._ki/g_var**3/f_var**2*c_var**3*d_&
+ &var*(1._ki-umz)*umz**4-1._ki/12._ki/g_var/f_var**2*c_var**3/d_var*&
+ &(1._ki-umz)*umz**2+1._ki/12._ki*c_var**4/d_var**2/f_var**3*(log(um&
+ &z)+z_log(s13,1._ki))*(1._ki-umz)*umz**2-11._ki/24._ki/g_var/f_var**&
+ &2*d_var**2*(1._ki-umz)*umz**2+5._ki/8._ki/g_var**2/f_var**2*d_var*&
+ &*3*(1._ki-umz)*umz**3+5._ki/12._ki/g_var**2/f_var**2*c_var**3*(1._k&
+ &i-umz)*umz**3-17._ki/24._ki/f_var**2/g_var*c_var**2*(1._ki-umz)*um&
+ &z**2-1._ki/4._ki/g_var**3/f_var**2*d_var**4*(1._ki-umz)*umz**4+35.&
+ &_ki/24._ki/g_var**2/f_var**2*c_var**2*d_var*(1._ki-umz)*umz**3-13.&
+ &_ki/12._ki/f_var**2/g_var*c_var*d_var*(1._ki-umz)*umz**2+5._ki/3._ki&
+ &/g_var**2/f_var**2*c_var*d_var**2*(1._ki-umz)*umz**3-1._ki/24._ki*&
+ &g_var*(-1._ki+umz)/f_var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ fg=-1._ki/4._ki/g_var**4*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d&
+ &_var**4*h_var*umz**3*(-d_var*h_var*umz-c_var*g_var+d_var*g_var)&
+ &*(-2._ki*d_var**2*h_var*g_var*umz+c_var**2*d_var**2*umz**2+2._ki*&
+ &c_var*d_var**3*umz**2+d_var**4*umz**2+c_var**2*g_var**2+d_var**&
+ &2*g_var**2)-1._ki/4._ki/g_var**4*log(e_var)/f_var*e_var**4*umz**3&
+ &-3._ki/4._ki/g_var**3*c_var*h_var*umz**5+1._ki/g_var**2*c_var*umz*&
+ &*4+5._ki/8._ki/g_var**2*d_var*umz**4-1._ki/4._ki/g_var**3*d_var**2*&
+ &umz**5-1._ki/4._ki/g_var**2*c_var**3/d_var**2*umz**4+1._ki/4._ki*c_&
+ &var**4/f_var/d_var**4*(log(umz)+z_log(s13,1._ki))*umz**3-1._ki/4.&
+ &_ki/g_var**3*c_var**3/d_var*umz**5-1._ki/12._ki/g_var*c_var/d_var*&
+ &umz**3-1._ki/4._ki/g_var*c_var**3/d_var**3*umz**3+1._ki/8._ki/g_var&
+ &*c_var**2/d_var**2*umz**3+1._ki/8._ki/g_var**2*c_var**2/d_var*umz&
+ &**4-11._ki/24._ki*(-1._ki+umz)*(1._ki+umz+umz**2)/g_var-11._ki/24._ki&
+ &/g_var
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki/g_var**4*log(e_var)/f_var**2*e_var**3*umz**2*(-3._k&
+ &i*f_var*e_var-3._ki*g_var*f_var+c_var*g_var*umz)-1._ki/12._ki/g_va&
+ &r**4*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d_var**3*h_var**2&
+ &*umz**3*(c_var**2*g_var**2+3._ki*c_var**2*d_var**2*umz**2+6._ki*c&
+ &_var*d_var**3*umz**2+3._ki*d_var**4*umz**2-2._ki*c_var*d_var*g_va&
+ &r**2-6._ki*d_var**3*g_var*umz+3._ki*d_var**2*g_var**2+2._ki*c_var*&
+ &*2*d_var*g_var*umz-4._ki*c_var*g_var*d_var**2*umz)+3._ki/4._ki/g_v&
+ &ar**3/f_var*c_var*d_var*h_var*umz**5+7._ki/12._ki/g_var/f_var*c_v&
+ &ar*umz**3+11._ki/24._ki/g_var/f_var*d_var*umz**3-5._ki/8._ki/g_var*&
+ &*2/f_var*d_var**2*umz**4+1._ki/24._ki/g_var/f_var*c_var**2/d_var*&
+ &umz**3+1._ki/4._ki/g_var**3/f_var*c_var**3*umz**5-1._ki/12._ki/g_va&
+ &r/f_var*c_var**3/d_var**2*umz**3-1._ki/12._ki/g_var**2/f_var*c_va&
+ &r**3/d_var*umz**4+1._ki/4._ki/g_var**3/f_var*d_var**3*umz**5-4._ki&
+ &/3._ki/g_var**2/f_var*c_var*d_var*umz**4+1._ki/12._ki*c_var**4/d_v&
+ &ar**3/f_var**2*(log(umz)+z_log(s13,1._ki))*umz**3-19._ki/24._ki/g_&
+ &var**2/f_var*c_var**2*umz**4-1._ki/12._ki*(-1._ki+umz**2)/f_var-1.&
+ &_ki/12._ki/f_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=-1._ki/12._ki/g_var**4*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/&
+ &d_var**2*h_var**3*umz**3*(-3._ki*d_var*h_var*umz-c_var*g_var+3._k&
+ &i*d_var*g_var)-1._ki/12._ki/g_var**4*log(e_var)/f_var**3*e_var**2&
+ &*(6._ki*f_var**3*c_var*umz+c_var**2*g_var**2*umz**2-2._ki*c_var**&
+ &2*g_var*f_var*umz**2+3._ki*c_var**2*f_var**2*umz**2+4._ki*c_var*f&
+ &_var**2*g_var*umz+6._ki*g_var*f_var**3+3._ki*g_var**2*f_var**2-2.&
+ &_ki*c_var*g_var**2*f_var*umz+3._ki*f_var**4)*umz-3._ki/4._ki/g_var*&
+ &*3/f_var**2*c_var*d_var**2*h_var*umz**5+1._ki/6._ki/f_var**2*c_va&
+ &r*umz**2+1._ki/24._ki/f_var**2*d_var*umz**2-17._ki/24._ki/f_var**2/&
+ &g_var*c_var**2*umz**3+5._ki/8._ki/g_var**2/f_var**2*d_var**3*umz*&
+ &*4+1._ki/12._ki*c_var**4/d_var**2/f_var**3*(log(umz)+z_log(s13,1.&
+ &_ki))*umz**3+5._ki/12._ki/g_var**2/f_var**2*c_var**3*umz**4-1._ki/4&
+ &._ki/g_var**3/f_var**2*d_var**4*umz**5-13._ki/12._ki/f_var**2/g_va&
+ &r*c_var*d_var*umz**3+5._ki/3._ki/g_var**2/f_var**2*c_var*d_var**2&
+ &*umz**4+35._ki/24._ki/g_var**2/f_var**2*c_var**2*d_var*umz**4-1._k&
+ &i/4._ki/g_var**3/f_var**2*c_var**3*d_var*umz**5-1._ki/12._ki/g_var&
+ &/f_var**2*c_var**3/d_var*umz**3-11._ki/24._ki/g_var/f_var**2*d_va&
+ &r**2*umz**3+1._ki/24._ki*g_var*(-1._ki+umz)/f_var**2+1._ki/24._ki*g_&
+ &var/f_var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par3)
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ fg=-1._ki/4._ki/g_var**4*(log(1._ki-umz)+log(umz)+z_log(s23,1._ki))/d&
+ &_var*h_var**4*umz**3-1._ki/4._ki/g_var**4*log(e_var)/f_var**4*e_v&
+ &ar*(-f_var*e_var-g_var*f_var+c_var*g_var*umz)*(c_var**2*f_var**&
+ &2*umz**2+c_var**2*g_var**2*umz**2+g_var**2*f_var**2+2._ki*f_var*&
+ &*2*g_var*e_var+f_var**4+2._ki*f_var**3*c_var*umz)+3._ki/4._ki/g_va&
+ &r**3/f_var**3*c_var*d_var**3*h_var*umz**5-1._ki/6._ki*g_var/f_var&
+ &**3*c_var*umz+1._ki/8._ki*g_var/f_var**3*d_var*umz+1._ki/4._ki/g_va&
+ &r**3/f_var**3*c_var**3*d_var**2*umz**5+3._ki/4._ki/g_var/f_var**3&
+ &*c_var**3*umz**3-1._ki/2._ki/f_var**3*c_var**2*umz**2+11._ki/24._ki&
+ &/g_var/f_var**3*d_var**3*umz**3-17._ki/8._ki/g_var**2/f_var**3*c_&
+ &var**2*d_var**2*umz**4+15._ki/8._ki/g_var/f_var**3*c_var**2*d_var&
+ &*umz**3-2._ki/g_var**2/f_var**3*c_var*d_var**3*umz**4-5._ki/8._ki/&
+ &g_var**2/f_var**3*d_var**4*umz**4-1._ki/6._ki/f_var**3*c_var*d_va&
+ &r*umz**2+1._ki/4._ki/g_var**3/f_var**3*d_var**5*umz**5+1._ki/4._ki*&
+ &c_var**4/d_var/f_var**4*(log(umz)+z_log(s13,1._ki))*umz**3-3._ki/&
+ &4._ki/g_var**2/f_var**3*c_var**3*d_var*umz**4+19._ki/12._ki/g_var/&
+ &f_var**3*c_var*d_var**2*umz**3-1._ki/8._ki/f_var**3*d_var**2*umz*&
+ &*2-1._ki/12._ki*g_var**2/f_var**3
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par2 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for nb_bar = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else if (dim == "n+4") then
+ !
+ if (nb_par == 0) then
+ !
+ fg=-1._ki/6._ki/g_var**2*log(-e_var)/f_var*e_var**3+1._ki/6._ki*(-1._k&
+ &i+z)/g_var**2*(log(z)+log(1._ki-z)+z_log(-s23,-1._ki))/d_var**2*h&
+ &_var**2*((-1._ki+z)*d_var*h_var-c_var*g_var+2._ki*d_var*g_var)-1.&
+ &_ki/6._ki*(-1._ki+z)*c_var**3/d_var**2/f_var*(log(1._ki-z)+z_log(-s&
+ &13,-1._ki))+1._ki/3._ki/g_var*z*c_var+1._ki/6._ki*d_var/g_var*z-1._ki&
+ &/3._ki/g_var*c_var-1._ki/6._ki/d_var/g_var*c_var**2+1._ki/6._ki/d_va&
+ &r/g_var*z*c_var**2+4._ki/9._ki-1._ki/6._ki*d_var/g_var
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ fg=1._ki/24._ki*c_var**3/d_var**3/f_var**2*(log(umz)+z_log(-s13,-1.&
+ &_ki))*umz*(4._ki*d_var*f_var+c_var*d_var*umz+2._ki*c_var*f_var)-1.&
+ &_ki/24._ki*h_var**3/d_var**3/g_var**2*(log(1._ki-umz)+log(umz)+z_l&
+ &og(-s23,-1._ki))*umz*(-2._ki*c_var*g_var-d_var*h_var*umz+2._ki*d_v&
+ &ar*g_var)-1._ki/144._ki/d_var**2/g_var/f_var*(-25._ki*g_var*d_var*&
+ &*3*umz+18._ki*c_var*h_var*d_var**2*umz**2+6._ki*c_var**3*d_var*um&
+ &z**2+6._ki*d_var**4*umz**2+19._ki*g_var**2*d_var**2-18._ki*c_var*d&
+ &_var**2*g_var*umz-18._ki*c_var**2*d_var*g_var*umz-12._ki*c_var**3&
+ &*g_var*umz)-1._ki/24._ki/g_var**2*log(-e_var)/f_var**2*e_var**4
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*c_var**4/d_var**3/f_var*(log(umz)+z_log(-s13,-1._ki&
+ &))*(1._ki-umz)*umz-1._ki/12._ki/g_var**3*(log(1._ki-umz)+log(umz)+z&
+ &_log(-s23,-1._ki))/d_var**3*h_var**2*(1._ki-umz)*umz*(c_var**2*d_&
+ &var**2*umz**2+2._ki*c_var*d_var**3*umz**2+d_var**4*umz**2+g_var*&
+ &*2*c_var**2-2._ki*d_var*c_var*g_var**2-2._ki*c_var*d_var**2*g_var&
+ &*umz+3._ki*g_var**2*d_var**2-3._ki*g_var*d_var**3*umz+c_var**2*d_&
+ &var*g_var*umz)+1._ki/72._ki/g_var**2/d_var**2*(1._ki-umz)*(-15._ki*&
+ &g_var*d_var**3*umz+18._ki*c_var*h_var*d_var**2*umz**2+6._ki*c_var&
+ &**3*d_var*umz**2+6._ki*d_var**4*umz**2+16._ki*g_var**2*d_var**2-2&
+ &4._ki*c_var*d_var**2*g_var*umz-3._ki*c_var**2*d_var*g_var*umz+6._k&
+ &i*c_var**3*g_var*umz)-1._ki/12._ki*log(-e_var)*e_var**4*(-1._ki+um&
+ &z)/g_var**3/f_var
+ !
+ case(3)
+ !
+ fg=-1._ki/12._ki*c_var**4/d_var**3/f_var*(log(umz)+z_log(-s13,-1._ki&
+ &))*umz**2-1._ki/12._ki/g_var**3*(log(1._ki-umz)+log(umz)+z_log(-s2&
+ &3,-1._ki))/d_var**3*h_var**2*umz**2*(c_var**2*d_var**2*umz**2+2.&
+ &_ki*c_var*d_var**3*umz**2+d_var**4*umz**2+g_var**2*c_var**2-2._ki&
+ &*d_var*c_var*g_var**2-2._ki*c_var*d_var**2*g_var*umz+3._ki*g_var*&
+ &*2*d_var**2-3._ki*g_var*d_var**3*umz+c_var**2*d_var*g_var*umz)+1&
+ &._ki/12._ki/g_var**3*log(-e_var)/f_var*e_var**4*umz+1._ki/72._ki/g_&
+ &var**2/d_var**2*umz*(-15._ki*g_var*d_var**3*umz+18._ki*c_var*h_va&
+ &r*d_var**2*umz**2+6._ki*c_var**3*d_var*umz**2+6._ki*d_var**4*umz*&
+ &*2+16._ki*g_var**2*d_var**2-24._ki*c_var*d_var**2*g_var*umz-3._ki*&
+ &c_var**2*d_var*g_var*umz+6._ki*c_var**3*g_var*umz)
+ !
+ case(4)
+ !
+ fg=-1._ki/24._ki*c_var**4/d_var**2/f_var**2*(log(umz)+z_log(-s13,-1&
+ &._ki))*umz**2-1._ki/24._ki*h_var**3/d_var**2/g_var**3*(log(1._ki-um&
+ &z)+log(umz)+z_log(-s23,-1._ki))*umz**2*(3._ki*d_var*g_var-2._ki*d_&
+ &var*h_var*umz-c_var*g_var)-1._ki/24._ki/g_var**3*log(-e_var)/f_va&
+ &r**2*e_var**3*(2._ki*f_var*e_var+3._ki*f_var*g_var-c_var*g_var*um&
+ &z)-1._ki/144._ki/d_var/g_var**2/f_var*(12._ki*d_var**4*umz**3+36._k&
+ &i*c_var*h_var*d_var**2*umz**3+13._ki*d_var*g_var**3-36._ki*c_var*&
+ &*2*d_var*g_var*umz**2-g_var**2*d_var**2*umz+18._ki*d_var*c_var*g&
+ &_var**2*umz-54._ki*c_var*d_var**2*g_var*umz**2+12._ki*d_var*c_var&
+ &**3*umz**3-6._ki*c_var**3*g_var*umz**2-24._ki*g_var*d_var**3*umz*&
+ &*2)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for nb_bar = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_adj.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for dim = %c0"
+ tab_erreur_par(2)%arg_char = dim
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ end function fg
+ !
+end module function_4p2m_adj
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p2m_opp.f90 b/golem95c-1.2.1/integrals/four_point/function_4p2m_opp.f90
new file mode 100644
index 0000000..2a5c86e
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p2m_opp.f90
@@ -0,0 +1,3353 @@
+!
+!****h* src/integrals/four_point/function_4p2m_opp
+! NAME
+!
+! Module function_4p2m_opp
+!
+! USAGE
+!
+! use function_4p2m_opp
+!
+! DESCRIPTION
+!
+! This module computes the six-dimensional and eight dimensional
+! two opposite mass four point function with or without Feynman parameters
+! in the numerator.
+!
+! OUTPUT
+!
+! This module exports three functions f4p2m_opp, f4p2m_opp_c and f2b
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+!
+!*****
+module function_4p2m_opp
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ implicit none
+ !
+ private
+ !
+ real(ki) :: s24_glob,s34_glob,s12_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ integer :: flag_glob
+ character (len=3) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ !
+ public :: f4p2m_opp,f2b,f4p2m_opp_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p2m_opp/f4p2m_opp
+ ! NAME
+ !
+ ! Function f4p2m_opp
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p2m_opp(dim,s24,s13,s12,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the six dimensional/eight dimensional
+ ! two opposit mass four point function with or without Feynman parameters
+ ! in the numerator.
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! two opposit mass four point function, dim="n+4" eight dimensional
+ ! two opposit mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! If the user wants to compute:
+ ! * a six dimensional two opposit mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p2m_opp("n+2",s24,s13,s12,s34,0,0,0,0)
+ ! * a eight dimensional two opposit mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p2m_opp("n+4",s24,s13,s12,s34,0,0,0,0)
+ ! * a six dimensional two opposit mass four point function
+ ! with the Feynman parameter z1 in the numerator:
+ ! real_dim_4 = f4p2m_opp("n+2",s24,s13,s12,s34,0,0,0,1)
+ ! * a six dimensional two opposit mass four point function
+ ! with the Feynman parameters z1^2*z2 in the numerator:
+ ! real_dim_4 = f4p2m_opp("n+2",s24,s13,s12,s34,0,2,1,1)
+ !
+ !*****
+ function f4p2m_opp(dim,s24,s13,s12,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s12,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: f4p2m_opp
+ !
+ integer :: nb_par
+ real(ki) :: lamb
+ real(ki) :: plus_grand
+ real(ki) :: norma
+ complex(ki) :: rest1,abserr1
+ complex(ki) :: rest2,abserr2
+ complex(ki) :: resto,abserro
+ complex(ki) :: extra_imag1,extra_imag2
+ real(ki) :: pole1,pole2
+ complex(ki) :: residue1,residue2
+ real(ki) :: t2,t3,t4,t5
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/0._ki,s12,s13,0._ki/)
+ s_mat(2,:) = (/s12,0._ki,0._ki,s24/)
+ s_mat(3,:) = (/s13,0._ki,0._ki,s34/)
+ s_mat(4,:) = (/0._ki,s24,s34,0._ki/)
+ !
+ ! on redefinit la matrice S de telle facon a ce que ces elements
+ ! soient entre -1 et 1
+ !
+ plus_grand = maxval(array=abs(s_mat))
+ s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(3,4)-s_mat(2,4))/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ b(2) = (s_mat(3,4)-s_mat(1,3))/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ b(3) = (s_mat(1,2)-s_mat(2,4))/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ b(4) = (s_mat(1,2)-s_mat(1,3))/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(3,4)+s_mat(1,2)-s_mat(1,3)-s_mat(2,4))&
+ &/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ !
+ invs(1,1) = 0._ki
+ invs(1,2) = s_mat(3,4)/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ invs(1,3) = -s_mat(2,4)/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ invs(1,4) = 0._ki
+ invs(2,1) = s_mat(3,4)/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = -s_mat(1,3)/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ invs(3,1) = -s_mat(2,4)/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = s_mat(1,2)/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ invs(4,1) = 0._ki
+ invs(4,2) = -s_mat(1,3)/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ invs(4,3) = s_mat(1,2)/(s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(3,4)+s_mat(1,2)-s_mat(1,3)-s_mat(2,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p2m_opp = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p2m_opp) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p2m_opp (in file f4p2m_opp.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p2m_opp'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p2m_opp) then
+ !
+ !---#[ analytic computation:
+ !
+ if (dim == "n+2") then
+ !
+ f4p2m_opp(3:4)= a4p2m_opp_np2(s_mat(2,4),s_mat(1,3),&
+ &s_mat(1,2),s_mat(3,4),&
+ &par1,par2,par3,par4)/plus_grand
+ !
+ else if (dim == "n+4") then
+ !
+ f4p2m_opp = a4p2m_opp_np4(s_mat(2,4),s_mat(1,3),&
+ &s_mat(1,2),s_mat(3,4),&
+ &par1,par2,par3,par4)
+ f4p2m_opp(3) = f4p2m_opp(3)-log(plus_grand)*norma
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ & "In f4p2m_opp (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Unimplemented choice: dim = %c0"
+ tab_erreur_par(2)%arg_char = dim
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ !---#] analytic computation:
+ !
+ else
+ !
+ !---#[ numerical computation:
+ !
+ dim_glob = dim
+ par1_glob = par1
+ par2_glob = par2
+ par3_glob = par3
+ par4_glob = par4
+ !
+ s12_glob = s_mat(1,2)
+ s13_glob = s_mat(1,3)
+ s24_glob = s_mat(2,4)
+ s34_glob = s_mat(3,4)
+ !
+ t2 = (s24_glob+s13_glob-s12_glob-s34_glob)
+ t3 = (s13_glob*s24_glob-s12_glob*s34_glob)
+ t4 = s13_glob-s34_glob
+ t5 = s12_glob-s13_glob
+ !
+ resto = 0._ki
+ abserro = 0._ki
+ !
+ ! on pose z = x - i*eps*y (avec x et y > 0)
+ ! z*s24+(1-z)*s34 = s34+x*(s24-s34)-i*eps*y*(s24-s34)
+ ! on veut la partie imaginaire du meme signe que i*lambda
+ ! => eps*(s24-s34) < 0
+ !
+ ! faire attention que suivant le signe de eps_glob, on tourne dans le
+ ! sens des aiguilles d'une montre ou inversement
+ ! eps_glob = 1, on ferme le contour vers le bas --> -2 i Pi residu
+ ! eps_glob = -1, on ferme le contour vers le haut --> +2 i Pi residu
+ !
+ !
+ num_grand_b_info_par = lamb
+ denom_grand_b_info_par = (s_mat(1,2)*s_mat(3,4)-s_mat(1,3)*s_mat(2,4))
+ !
+ eps_glob = sign(1._ki,s34_glob-s24_glob)
+ flag_glob = 1
+ !
+ origine_info_par = "f4p2m_opp part 1, dimension "//dim
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,rest1,abserr1)
+ !
+ residue1 = compute_residue(t2,t3,t4,t5)
+ !
+ pole1 = (s13_glob-s34_glob)/t2
+ !
+ if ( (pole1 >= 0._ki) .and. (pole1 <= 1._ki) &
+ & .and. (eps_glob == sign(1._ki,t2)) ) then
+ !
+ extra_imag1 = -2._ki*i_*pi*residue1*eps_glob
+ !
+ else
+ !
+ extra_imag1 = 0._ki
+ !
+ end if
+ !
+ resto = resto + rest1 + extra_imag1
+ abserro = abserro + abserr1
+ !
+ eps_glob = sign(1._ki,s13_glob-s12_glob)
+ flag_glob = 2
+ !
+ origine_info_par = "f4p2m_opp part 2, dimension "//dim
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,rest2,abserr2)
+ !
+ ! le residue au pole pour la somme des deux parties est nul
+ !
+ residue2 = -residue1
+ pole2 = pole1
+ !
+ if ( (pole2 >= 0._ki) .and. (pole2 <= 1._ki) &
+ & .and. (eps_glob == sign(1._ki,t2)) ) then
+ !
+ extra_imag2 = -2._ki*i_*pi*residue2*eps_glob
+ !
+ else
+ !
+ extra_imag2 = 0._ki
+ !
+ end if
+ !
+ resto = resto + rest2 + extra_imag2
+ abserro = abserro + abserr2
+ !
+ if (dim == "n+2") then
+ !
+ resto = resto/plus_grand
+ !
+ else if (dim == "n+4") then
+ !
+ f4p2m_opp(1) = norma
+ f4p2m_opp(2) = 0._ki
+ resto = resto-log(plus_grand/mu2_scale_par)*norma
+ !
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ & "In f4p2m_opp (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Illegal value for dim = %c0"
+ tab_erreur_par(2)%arg_char = dim
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ f4p2m_opp(3) = real(resto,ki)
+ f4p2m_opp(4) = aimag(resto)
+ !
+ !---#] numerical computation:
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p2m_opp
+ !
+ !****f* src/integrals/four_point/function_4p2m_opp/f4p2m_opp_c
+ ! NAME
+ !
+ ! Function f4p2m_opp_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_2 = f4p2m_opp_c(dim,s24,s13,s12,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the same thing that the fucntion f4p2m_opp
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! two opposit mass four point function, dim="n+4" eight dimensional
+ ! two opposit mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p2m_opp
+ !
+ !*****
+ function f4p2m_opp_c(dim,s24,s13,s12,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s12,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(2) :: f4p2m_opp_c
+ !
+ real(ki), dimension(4) :: res4
+ !
+ res4 = f4p2m_opp(dim,s24,s13,s12,s34,par1,par2,par3,par4)
+ call to_complex(res4,f4p2m_opp_c)
+ !
+ end function f4p2m_opp_c
+ !
+ !****if* src/integrals/four_point/function_4p2m_opp/a4p2m_opp_np2
+ ! NAME
+ !
+ ! recursive function a4p2m_opp_np2
+ !
+ ! USAGE
+ !
+ ! real_dim_2 = a4p2m_opp_np2(s24,s13,s12,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the six dimensional
+ ! two opposit mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two reals (type ki) corresponding to the
+ ! real and imaginary part of the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p2m_opp_np2(s24,s13,s12,s34,par1,par2,par3,par4) result(res_4p2m_opp_np2)
+ !
+ real(ki), intent (in) :: s24,s13,s12,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(2) :: res_4p2m_opp_np2
+ !
+ integer, dimension(3) :: smj
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(6) :: truc1,truc2,truc3
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(6) :: temp1,temp2,temp3,temp4
+ real(ki), dimension(2) :: temp10,temp11,temp12,temp13,temp14,temp15
+ complex(ki) :: ctemp
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ ctemp = -1._ki*f2b(s24,s13,s12,s34)/(s24+s13-s12-s34)
+ res_4p2m_opp_np2(1) = real(ctemp,ki)
+ res_4p2m_opp_np2(2) = aimag(ctemp)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p2m_opp_np2(s24,s13,s12,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp0 = b(par4)*temp0
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3(j,1)) then
+ truc1 = resultat3(j,1,:)
+ else
+ truc1 = f3p_sc(s_mat,smj)
+ resultat3(j,1,:) = truc1
+ deja_calcule3(j,1) = .true.
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/2._ki
+ !
+ if (j /= par4) then
+ !
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 - b(j)*truc2/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p2m_opp_np2(1) = (temp0(1) + temp1(5) + temp2(5))/sumb
+ res_4p2m_opp_np2(2) = (temp0(2) + temp1(6) + temp2(6))/sumb
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ if (deja_calcule(par_plus(4))) then
+ !
+ temp10 = resultat(par_plus(4),:)
+ !
+ else
+ !
+ temp10 = a4p2m_opp_np2(s24,s13,s12,s34,0,0,0,par4)
+ resultat(par_plus(4),:) = temp10
+ deja_calcule(par_plus(4)) = .true.
+ !
+ end if
+ !
+ if (deja_calcule(par_plus(3))) then
+ !
+ temp11 = resultat(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a4p2m_opp_np2(s24,s13,s12,s34,0,0,0,par3)
+ resultat(par_plus(3),:) = temp11
+ deja_calcule(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp12 = resultat(1,:)
+ temp0 = b(par3)*temp10+b(par4)*temp11 - invs(par3,par4)*temp12/2._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule3(j,par_plus(3))) then
+ truc1 = resultat3(j,par_plus(3),:)
+ else
+ truc1 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj))
+ resultat3(j,par_plus(3),:) = truc1
+ deja_calcule3(j,par_plus(3)) = .true.
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/4._ki
+ !
+ end if
+ !
+ if (j /= par4) then
+ !
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + invs(j,par3)*truc2/4._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ if (deja_calcule33(j,par_plus(3),par_plus(4))) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ !
+ else
+ !
+ truc3 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))
+ resultat33(j,par_plus(3),par_plus(4),:) = truc3
+ deja_calcule33(j,par_plus(3),par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp3 = temp3 - b(j)*truc3/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p2m_opp_np2(1) = (temp0(1) + temp1(5) + temp2(5) + temp3(5)) &
+ *2._ki/3._ki/sumb
+ res_4p2m_opp_np2(2) = (temp0(2) + temp1(6) + temp2(6) + temp3(6)) &
+ *2._ki/3._ki/sumb
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ temp10 = a4p2m_opp_np2(s24,s13,s12,s34,0,0,par2,par3)
+ temp11 = a4p2m_opp_np2(s24,s13,s12,s34,0,0,par2,par4)
+ temp12 = a4p2m_opp_np2(s24,s13,s12,s34,0,0,par3,par4)
+ !
+ temp13 = resultat(par_plus(4),:)
+ temp14 = resultat(par_plus(3),:)
+ temp15 = resultat(par_plus(2),:)
+ !
+ temp0 = b(par4)*temp10+b(par3)*temp11+b(par2)*temp12 &
+ - ( invs(par2,par3)*temp13+invs(par2,par4)*temp14&
+ +invs(par3,par4)*temp15 )/3._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ temp4 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if ( (j /= par2) .and. (j /= par3) ) then
+ !
+ truc1 = resultat33(j,par_plus(2),par_plus(3),:)
+ temp1 = temp1 + invs(j,par4)*truc1/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par4) ) then
+ !
+ truc2 = resultat33(j,par_plus(2),par_plus(4),:)
+ temp2 = temp2 + invs(j,par3)*truc2/6._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ temp3 = temp3 + invs(j,par2)*truc3/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par3) .and. (j /= par4) ) then
+ !
+ temp4 = temp4 - b(j)*f3p_sc(s_mat,smj,locateb(par2,b_pro_mj), &
+ locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p2m_opp_np2(1) = ( temp0(1) + temp1(5) + temp2(5) + temp3(5) &
+ + temp4(5) )/2._ki/sumb
+ res_4p2m_opp_np2(2) = ( temp0(2) + temp1(6) + temp2(6) + temp3(6) &
+ + temp4(6) )/2._ki/sumb
+ !
+ end if
+ !
+ end function a4p2m_opp_np2
+ !
+ !****if* src/integrals/four_point/function_4p2m_opp/a4p2m_opp_np4
+ ! NAME
+ !
+ ! recursive function a4p2m_opp_np4
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p2m_opp_np4(s24,s13,s12,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the eight dimensional
+ ! two opposit mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p2m_opp_np4(s24,s13,s12,s34,par1,par2,par3,par4) result(res_4p2m_opp_np4)
+ !
+ real(ki), intent (in) :: s24,s13,s12,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: res_4p2m_opp_np4
+ !
+ integer, dimension(3) :: smj
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(4) :: truc1
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(4) :: temp1,temp2,temp3
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p2m_opp_np2(s24,s13,s12,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp1 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3_np2(j,1)) then
+ !
+ truc1 = resultat3_np2(j,1,:)
+ !
+ else
+ !
+ truc1 = f3p_np2_sc(s_mat,smj)
+ resultat3_np2(j,1,:) = truc1
+ deja_calcule3_np2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b(j)*truc1
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p2m_opp_np4(1) = (-temp1(1))/(3._ki*sumb)
+ res_4p2m_opp_np4(2) = (-temp1(2))/(3._ki*sumb)
+ res_4p2m_opp_np4(3) = (temp0(1)-temp1(3)-2._ki/3._ki*temp1(1))/(3._ki*sumb)
+ res_4p2m_opp_np4(4) = (temp0(2)-temp1(4)-2._ki/3._ki*temp1(2))/(3._ki*sumb)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ temp0 = a4p2m_opp_np2(s24,s13,s12,s34,0,0,0,par4)/3._ki
+ temp1 = b(par4)*a4p2m_opp_np4(s24,s13,s12,s34,0,0,0,0)
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ truc1 = resultat3_np2(j,1,:)
+ temp2 = temp2 + invs(j,par4)*truc1/6._ki
+ !
+ if (j /= par4) then
+ !
+ temp3 = temp3 - b(j)*f3p_np2_sc(s_mat,smj,locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p2m_opp_np4(1) = ( temp1(1)+temp2(1)+temp3(1) )/(2._ki*sumb)
+ res_4p2m_opp_np4(2) = ( temp1(2)+temp2(2)+temp3(2) )/(2._ki*sumb)
+ res_4p2m_opp_np4(3) = ( temp1(3)+temp1(1)/6._ki+temp2(3)+temp2(1)/2._ki &
+ +temp3(3)+temp3(1)/2._ki+temp0(1) )/(2._ki*sumb)
+ res_4p2m_opp_np4(4) = ( temp1(4)+temp1(2)/6._ki+temp2(4)+temp2(2)/2._ki &
+ +temp3(4)+temp3(2)/2._ki+temp0(2) )/(2._ki*sumb)
+ !
+ ! cas avec plus de un parametre de feynman au numerateur
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a4p2m_opp_np4:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of four-point integrals in n+4 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb(par),4/)
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p2m_opp_np4
+ !
+ !****f* src/integrals/four_point/function_4p2m_opp/f2b
+ ! NAME
+ !
+ ! function f2b
+ !
+ ! USAGE
+ !
+ ! complex = f2b(a,b,c,d)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the "finite part" of the scalar four dimensional two
+ ! opposit mass four point function. The expression has been taken in
+ ! Nucl. Phys. {\bf B615} (2001) , 385
+ !
+ !
+ ! INPUTS
+ !
+ ! * a -- a real (type ki), (p1+p2)^2
+ ! * b -- a real (type ki), (p2+p3)^2
+ ! * c -- a real (type ki), p2^2
+ ! * d -- a real (type ki), p4^2
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ ! Affected by the variable rat_or_tot_par (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f2b(a,b,c,d)
+ !
+ real(ki), intent(in) :: a,b,c,d
+ complex(ki) :: f2b
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2b = -( zdilog(1._ki-c*d/(a*b),sign(un,c*d*(a+b)-a*b*(c+d))) &
+ +( z_log(c*d/(a*b),sign(un,-c*d*(a+b)+a*b*(c+d))) &
+ -z_log(c/a,sign(un,a-c))-z_log(d/b,sign(un,b-d)) ) &
+ *z_log(1._ki-c*d/(a*b),sign(un,c*d*(a+b)-a*b*(c+d))) ) &
+ +zdilog(1._ki-c/a,sign(un,c-a)) &
+ +zdilog(1._ki-c/b,sign(un,c-b)) &
+ +zdilog(1._ki-d/a,sign(un,d-a)) &
+ +zdilog(1._ki-d/b,sign(un,d-b)) &
+ +z_log2(a/b,sign(un,b-a))/2._ki
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ f2b = 0._ki
+ !
+ end if
+ !
+ end function f2b
+ !
+ !****if* src/integrals/four_point/function_4p2m_opp/eval_numer_gi
+ ! NAME
+ !
+ ! function eval_numer_gi
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_gi(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This function contains the integrand for the numerical computation in phase
+ ! space region where det(G) ~ 0
+ !
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), between 0 and 1
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki). It is called by
+ ! the routine adapt_gauss1 in the function f4p2m_opp
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_gi(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_gi
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ z = x - eps_glob*i_*y
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ !
+ eval_numer_gi = fg(z,s24_glob,s13_glob,s12_glob,s34_glob,&
+ & par1_glob,par2_glob,par3_glob,par4_glob,flag_glob,&
+ & dim_glob)
+ eval_numer_gi = eval_numer_gi*jacob
+ !
+ end function eval_numer_gi
+ !
+ !****if* src/integrals/four_point/function_4p2m_opp/compute_residue
+ ! NAME
+ !
+ ! Function compute_residue
+ !
+ ! USAGE
+ !
+ ! complex = compute_residue(t2,t3,t4,t5)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the residue of the pole in the case where the pole
+ ! is inside the contour
+ !
+ ! INPUTS
+ !
+ ! * t2 -- a real (type ki)
+ ! * t3 -- a real (type ki)
+ ! * t4 -- a real (type ki)
+ ! * t5 -- a real (type ki)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global variable (for this module) dim_glob
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function compute_residue(t2,t3,t4,t5)
+ !
+ real(ki), intent (in) :: t2,t3,t4,t5
+ complex(ki) :: compute_residue
+ !
+ complex(ki) :: temp0
+ integer, dimension(4) :: par
+ integer :: nb_par
+ !
+ par = (/par1_glob,par2_glob,par3_glob,par4_glob/)
+ nb_par = count(mask=par/=0)
+ !
+ if (dim_glob == "n+2") then
+ !---#[ dim_glob == "n+2":
+ if (nb_par == 0) then
+ !---#[ nb_par == 0:
+ !
+ temp0=-z_log(1._ki/t2*t3,1._ki)/t2
+ !
+ !---#] nb_par == 0:
+ else if (nb_par == 1) then
+ !---#[ nb_par == 1:
+ select case(par4_glob)
+ !
+ case(1)
+ !
+ temp0=(-1._ki/2._ki*(t5+t2)/t2*z_log(1._ki/t2*t3,1._ki)-1._ki/2._ki*t5/&
+ &t2)/t2
+ !
+ case(2)
+ !
+ temp0=-1._ki/2._ki*t4/t2**2*z_log(1._ki/t2*t3,1._ki)
+ !
+ case(3)
+ !
+ temp0=-1._ki/2._ki*(t2-t4)*z_log(1._ki/t2*t3,1._ki)/t2**2
+ !
+ case(4)
+ !
+ temp0=(1._ki/2._ki*t5/t2*z_log(1._ki/t2*t3,1._ki)+1._ki/2._ki*t5/t2)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ !---#] nb_par == 1:
+ else if (nb_par == 2) then
+ !---#[ nb_par == 2:
+ !
+ select case(par3_glob)
+ !
+ case(1)
+ !
+ select case(par4_glob)
+ !
+ case(1)
+ !
+ temp0=(-(t2+t5)**2/t2**2*z_log(1._ki/t2*t3,1._ki)/3._ki-t5*(3._ki*t5+&
+ &4._ki*t2)/t2**2/6._ki)/t2
+ !
+ case(2)
+ !
+ temp0=(-(t3+t4*t5+t4*t2)/t2**2*z_log(1._ki/t2*t3,1._ki)/6._ki-t4*t5/&
+ &t2**2/6._ki)/t2
+ !
+ case(3)
+ !
+ temp0=(-(-t3+t5*t2+t2**2-t4*t5-t4*t2)/t2**2*z_log(1._ki/t2*t3,1._ki&
+ &)/6._ki-t5*(t2-t4)/t2**2/6._ki)/t2
+ !
+ case(4)
+ !
+ temp0=(t5*(t2+t5)/t2**2*z_log(1._ki/t2*t3,1._ki)/3._ki+t5*(3._ki*t5+2&
+ &._ki*t2)/t2**2/6._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4_glob)
+ !
+ case(2)
+ !
+ temp0=-t4**2/t2**3*z_log(1._ki/t2*t3,1._ki)/3._ki
+ !
+ case(3)
+ !
+ temp0=-t4*(t2-t4)*z_log(1._ki/t2*t3,1._ki)/t2**3/3._ki
+ !
+ case(4)
+ !
+ temp0=((t3+t4*t5)/t2**2*z_log(1._ki/t2*t3,1._ki)/6._ki+t4*t5/t2**2/6&
+ &._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4_glob)
+ !
+ case(3)
+ !
+ temp0=-(t2-t4)**2*z_log(1._ki/t2*t3,1._ki)/t2**3/3._ki
+ !
+ case(4)
+ !
+ temp0=((t5*t2-t4*t5-t3)/t2**2*z_log(1._ki/t2*t3,1._ki)/6._ki+t5*(t2-&
+ &t4)/t2**2/6._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ temp0=(-t5**2/t2**2*z_log(1._ki/t2*t3,1._ki)/3._ki-t5**2/t2**2/2._ki)&
+ &/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par3 = %d0"
+ tab_erreur_par(2)%arg_int = par3_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ !---#] nb_par == 2:
+ else if (nb_par == 3) then
+ !---#[ nb_par == 3:
+ !
+ select case(par2_glob)
+ !
+ case(1)
+ !
+ select case(par3_glob)
+ !
+ case(1)
+ !
+ select case(par4_glob)
+ !
+ case(1)
+ !
+ temp0=(-(t5+t2)**3/t2**3*z_log(1._ki/t2*t3,1._ki)/4._ki-t5*(27._ki*t5&
+ &*t2+11._ki*t5**2+18._ki*t2**2)/t2**3/24._ki)/t2
+ !
+ case(2)
+ !
+ temp0=(-(t5+t2)*(t4*t5+t4*t2+2._ki*t3)/t2**3*z_log(1._ki/t2*t3,1._ki&
+ &)/12._ki-t5*(2._ki*t3+3._ki*t4*t5+4._ki*t4*t2)/t2**3/24._ki)/t2
+ !
+ case(3)
+ !
+ temp0=((t5+t2)*(t4*t5-t5*t2+t4*t2+2._ki*t3-t2**2)/t2**3*z_log(1._ki&
+ &/t2*t3,1._ki)/12._ki+t5*(4._ki*t4*t2-4._ki*t2**2+2._ki*t3+3._ki*t4*t5&
+ &-3._ki*t5*t2)/t2**3/24._ki)/t2
+ !
+ case(4)
+ !
+ temp0=(t5*(t5+t2)**2/t2**3*z_log(1._ki/t2*t3,1._ki)/4._ki+t5*(18._ki*&
+ &t5*t2+11._ki*t5**2+6._ki*t2**2)/t2**3/24._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4_glob)
+ !
+ case(2)
+ !
+ temp0=(-t4*(t4*t5+t4*t2+2._ki*t3)/t2**3*z_log(1._ki/t2*t3,1._ki)/12.&
+ &_ki-t4**2*t5/t2**3/12._ki)/t2
+ !
+ case(3)
+ !
+ temp0=((-t2*t3+2._ki*t4*t3-t4*t5*t2-t4*t2**2+t4**2*t5+t4**2*t2)/t2&
+ &**3*z_log(1._ki/t2*t3,1._ki)/12._ki+t4*t5*(t4-t2)/t2**3/12._ki)/t2
+ !
+ case(4)
+ !
+ temp0=((2._ki*t3*t5+t2*t3+t4*t5**2+t4*t5*t2)/t2**3*z_log(1._ki/t2*t&
+ &3,1._ki)/12._ki+t5*(2._ki*t3+3._ki*t4*t5+2._ki*t4*t2)/t2**3/24._ki)/&
+ &t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4_glob)
+ !
+ case(3)
+ !
+ temp0=(-(t4-t2)*(t4*t5-t5*t2+t4*t2+2._ki*t3-t2**2)/t2**3*z_log(1._k&
+ &i/t2*t3,1._ki)/12._ki-(t4-t2)**2*t5/t2**3/12._ki)/t2
+ !
+ case(4)
+ !
+ temp0=(-(2._ki*t3*t5+t2*t3-t5**2*t2-t5*t2**2+t4*t5**2+t4*t5*t2)/t2&
+ &**3*z_log(1._ki/t2*t3,1._ki)/12._ki-t5*(2._ki*t3-3._ki*t5*t2-2._ki*t2&
+ &**2+3._ki*t4*t5+2._ki*t4*t2)/t2**3/24._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ temp0=(-t5**2*(t5+t2)/t2**3*z_log(1._ki/t2*t3,1._ki)/4._ki-t5**2*(11&
+ &._ki*t5+9._ki*t2)/t2**3/24._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par3 = %d0"
+ tab_erreur_par(2)%arg_int = par3_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3_glob)
+ !
+ case(2)
+ !
+ select case(par4_glob)
+ !
+ case(2)
+ !
+ temp0=-t4**3/t2**4*z_log(1._ki/t2*t3,1._ki)/4._ki
+ !
+ case(3)
+ !
+ temp0=t4**2*(t4-t2)*z_log(1._ki/t2*t3,1._ki)/t2**4/4._ki
+ !
+ case(4)
+ !
+ temp0=(t4*(2._ki*t3+t4*t5)/t2**3*z_log(1._ki/t2*t3,1._ki)/12._ki+t4**&
+ &2*t5/t2**3/12._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4_glob)
+ !
+ case(3)
+ !
+ temp0=-t4*(t4-t2)**2*z_log(1._ki/t2*t3,1._ki)/t2**4/4._ki
+ !
+ case(4)
+ !
+ temp0=(-(-t2*t3+2._ki*t4*t3-t4*t5*t2+t4**2*t5)/t2**3*z_log(1._ki/t2&
+ &*t3,1._ki)/12._ki-t4*t5*(t4-t2)/t2**3/12._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ temp0=(-t5*(2._ki*t3+t4*t5)/t2**3*z_log(1._ki/t2*t3,1._ki)/12._ki-t5*&
+ &(3._ki*t4*t5+2._ki*t3)/t2**3/24._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par3 = %d0"
+ tab_erreur_par(2)%arg_int = par3_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3_glob)
+ !
+ case(3)
+ !
+ select case(par4_glob)
+ !
+ case(3)
+ !
+ temp0=(t4-t2)**3*z_log(1._ki/t2*t3,1._ki)/t2**4/4._ki
+ !
+ case(4)
+ !
+ temp0=((t4-t2)*(t4*t5+2._ki*t3-t5*t2)/t2**3*z_log(1._ki/t2*t3,1._ki)&
+ &/12._ki+(t4-t2)**2*t5/t2**3/12._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ temp0=(t5*(t4*t5+2._ki*t3-t5*t2)/t2**3*z_log(1._ki/t2*t3,1._ki)/12._k&
+ &i+t5*(-3._ki*t5*t2+3._ki*t4*t5+2._ki*t3)/t2**3/24._ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par3 = %d0"
+ tab_erreur_par(2)%arg_int = par3_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par3_glob)
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ temp0=(t5**3/t2**3*z_log(1._ki/t2*t3,1._ki)/4._ki+11._ki/24._ki*t5**3/&
+ &t2**3)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par3 = %d0"
+ tab_erreur_par(2)%arg_int = par3_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par2 = %d0"
+ tab_erreur_par(2)%arg_int = par2_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ !---#] nb_par == 3:
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for nb_par = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ !---#] dim_glob == "n+2":
+ else if (dim_glob == "n+4") then
+ !---#[ dim_glob == "n+4":
+ !
+ if (nb_par == 0) then
+ !---#[ nb_par == 0:
+ temp0=-1._ki/6._ki/t2**2*t3*z_log(-1._ki/t2*t3,-1._ki)
+ !---#] nb_par == 0:
+ else if (nb_par == 1) then
+ !---#[ nb_par == 1:
+ select case(par4_glob)
+ !
+ case(1)
+ !
+ temp0=(-t3*(t5+t2)/t2**2*z_log(-1._ki/t2*t3,-1._ki)/12._ki-t3*t5/t2*&
+ &*2/24._ki)/t2
+ !
+ case(2)
+ !
+ temp0=-t4/t2**3*t3*z_log(-1._ki/t2*t3,-1._ki)/12._ki
+ !
+ case(3)
+ !
+ temp0=-t3*(t2-t4)*z_log(-1._ki/t2*t3,-1._ki)/t2**3/12._ki
+ !
+ case(4)
+ !
+ temp0=(t3*t5/t2**2*z_log(-1._ki/t2*t3,-1._ki)/12._ki+t3*t5/t2**2/24.&
+ &_ki)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for par4 = %d0"
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ !---#] nb_par == 1:
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for nb_par = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ !---#] dim_glob == "n+4":
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In compute_residue (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for dim = %c0"
+ tab_erreur_par(2)%arg_char = dim_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ compute_residue = temp0
+ !
+ end function compute_residue
+ !
+ !****if* src/integrals/four_point/function_4p2m_opp/fg
+ ! NAME
+ !
+ ! function fg
+ !
+ ! USAGE
+ !
+ ! complex = fg(z,s24,s13,s12,s34,par1,par2,par3,par4,flag,dim)
+ !
+ ! DESCRIPTION
+ !
+ ! This function contains the one dimensional integral representation of
+ ! the six/eight dimensional two opposit mass four point function
+ !
+ !
+ ! INPUTS
+ !
+ ! * z -- a real (type ki), integration variable
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ ! * flag -- TODO undocumented parameter
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! two opposit mass four point function, dim="n+4" eight dimensional
+ ! two opposit mass four point function
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki) corresponding to the
+ ! one dimensional integral representation of the six/eight dimensional
+ ! one/zero mass four point function
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function fg(z,s24,s13,s12,s34,par1,par2,par3,par4,flag,dim)
+ !
+ complex(ki), intent (in) :: z
+ real(ki), intent (in) :: s24,s13,s12,s34
+ integer, intent (in) :: par1,par2,par3,par4,flag
+ character (len=3) :: dim
+ complex(ki) :: fg
+ !
+ integer, dimension(4) :: par
+ integer :: nb_par
+ complex(ki) :: c_var,e_var,f_var
+ !
+ par = (/par1,par2,par3,par4/)
+ nb_par = count(mask=par/=0)
+ !
+ c_var = z*s12+(1._ki-z)*s13
+ !
+ f_var = z*(s24-s12)+(1._ki-z)*(s34-s13)
+ !
+ e_var = z*s24+(1._ki-z)*s34
+ !
+ if (dim == "n+2") then
+ if (nb_par == 0) then
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/2._ki*e_var*log(e_var)/f_var**2+1._ki/2._ki/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/2._ki*log(c_var)/f_var**2*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/2._ki*z*log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/2._ki*z/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/2._ki*(-1._ki+z)*log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/2._ki*(-1._ki+z)/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/2._ki*log(e_var)/f_var**2*c_var-1._ki/2._ki/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/2._ki*c_var/f_var**2*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 2) then
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki*e_var**2*log(e_var)/f_var**3-1._ki/6._ki*(c_var-3._ki*&
+ &e_var)/f_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/3._ki*log(c_var)/f_var**3*e_var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/6._ki*z*e_var*log(e_var)/f_var**2+1._ki/6._ki*z/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*z*log(c_var)/f_var**2*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/6._ki*(-1._ki+z)*e_var*log(e_var)/f_var**2-1._ki/6._ki*(-1._ki&
+ &+z)/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/6._ki*(-1._ki+z)*log(c_var)/f_var**2*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/3._ki*e_var*log(e_var)/f_var**3*c_var-1._ki/6._ki*(c_var+e_v&
+ &ar)/f_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/3._ki*log(c_var)*c_var/f_var**3*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki*z**2*log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/3._ki*z**2/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/3._ki*z*(-1._ki+z)*log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/3._ki*z*(-1._ki+z)/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/6._ki*z*log(e_var)/f_var**2*c_var-1._ki/6._ki*z/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/6._ki*z*c_var/f_var**2*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki*(-1._ki+z)**2*log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/3._ki*(-1._ki+z)**2/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/6._ki*(-1._ki+z)*log(e_var)/f_var**2*c_var+1._ki/6._ki*(-1._k&
+ &i+z)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*c_var*(-1._ki+z)/f_var**2*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki/e_var**2*log(e_var)/f_var**3*(e_var*c_var**2*f_var+&
+ &c_var**2*f_var**2+e_var**2*c_var**2+2._ki*c_var*f_var**3-f_var**&
+ &2*e_var*c_var-e_var**2*c_var*f_var-2._ki*f_var**3*e_var+f_var**4&
+ &+f_var**2*e_var**2)+1._ki/6._ki*(-e_var+3._ki*c_var)/f_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/3._ki*c_var**2/f_var**3*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 3) then
+ !
+ select case(par2)
+ !
+ case(1)
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/4._ki*e_var**3*log(e_var)/f_var**4+1._ki/24._ki*(2._ki*c_var&
+ &**2-7._ki*c_var*e_var+11._ki*e_var**2)/f_var**3
+ !
+ case(2)
+ !
+ fg=1._ki/4._ki*log(c_var)/f_var**4*e_var**3
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*z*e_var**2*log(e_var)/f_var**3-1._ki/24._ki*z*(c_var&
+ &-3._ki*e_var)/f_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*z*log(c_var)/f_var**3*e_var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*(-1._ki+z)*e_var**2*log(e_var)/f_var**3+1._ki/24._ki*(&
+ &c_var-3._ki*e_var)*(-1._ki+z)/f_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*(-1._ki+z)*log(c_var)/f_var**3*e_var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/4._ki*e_var**2*log(e_var)/f_var**4*c_var+1._ki/24._ki*(c_var&
+ &**2-5._ki*c_var*e_var-2._ki*e_var**2)/f_var**3
+ !
+ case(2)
+ !
+ fg=-1._ki/4._ki*log(c_var)*c_var/f_var**4*e_var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*z**2*e_var*log(e_var)/f_var**2+1._ki/12._ki*z**2/f_v&
+ &ar
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*z**2*log(c_var)/f_var**2*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*z*(-1._ki+z)*e_var*log(e_var)/f_var**2-1._ki/12._ki*z*&
+ &(-1._ki+z)/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*z*(-1._ki+z)*log(c_var)/f_var**2*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*z*e_var*log(e_var)/f_var**3*c_var-1._ki/24._ki*z*(c_v&
+ &ar+e_var)/f_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*z*log(c_var)*c_var/f_var**3*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*(-1._ki+z)**2*e_var*log(e_var)/f_var**2+1._ki/12._ki*&
+ &(-1._ki+z)**2/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*(-1._ki+z)**2*log(c_var)/f_var**2*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*(-1._ki+z)*e_var*log(e_var)/f_var**3*c_var+1._ki/24.&
+ &_ki*(c_var+e_var)*(-1._ki+z)/f_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*(-1._ki+z)*log(c_var)*c_var/f_var**3*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki/e_var*log(e_var)/f_var**4*(c_var**2*f_var**2+3._ki*&
+ &c_var**2*e_var**2+2._ki*c_var**2*f_var*e_var+2._ki*c_var*f_var**3&
+ &-2._ki*c_var*f_var*e_var**2+f_var**4+f_var**2*e_var**2-2._ki*f_va&
+ &r**3*e_var)+1._ki/24._ki*(-e_var**2+2._ki*c_var**2+5._ki*c_var*e_va&
+ &r)/f_var**3
+ !
+ case(2)
+ !
+ fg=1._ki/4._ki*log(c_var)*c_var**2/f_var**4*e_var
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/4._ki*z**3*log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/4._ki*z**3/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/4._ki*z**2*(-1._ki+z)*log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/4._ki*z**2*(-1._ki+z)/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*z**2*log(e_var)/f_var**2*c_var-1._ki/12._ki*z**2/f_va&
+ &r
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*z**2*c_var/f_var**2*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/4._ki*z*(-1._ki+z)**2*log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/4._ki*z*(-1._ki+z)**2/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*z*(-1._ki+z)*log(e_var)/f_var**2*c_var+1._ki/12._ki*z&
+ &*(-1._ki+z)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*z*c_var*(-1._ki+z)/f_var**2*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*z/e_var**2*log(e_var)/f_var**3*(c_var**2*e_var**2+&
+ &2._ki*c_var**2*f_var*e_var+3._ki*c_var**2*f_var**2+6._ki*c_var*f_v&
+ &ar**3-2._ki*c_var*f_var*e_var**2-4._ki*c_var*f_var**2*e_var+3._ki*&
+ &f_var**4-6._ki*f_var**3*e_var+3._ki*f_var**2*e_var**2)+1._ki/24._ki&
+ &*z*(3._ki*c_var-e_var)/f_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*z*c_var**2/f_var**3*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/4._ki*(-1._ki+z)**3*log(e_var)/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/4._ki*(-1._ki+z)**3/f_var*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*(-1._ki+z)**2*log(e_var)/f_var**2*c_var-1._ki/12._ki*(&
+ &-1._ki+z)**2/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*c_var*(-1._ki+z)**2/f_var**2*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*(-1._ki+z)/e_var**2*log(e_var)/f_var**3*(c_var**2*e_&
+ &var**2+2._ki*c_var**2*f_var*e_var+3._ki*c_var**2*f_var**2+6._ki*c_&
+ &var*f_var**3-2._ki*c_var*f_var*e_var**2-4._ki*c_var*f_var**2*e_va&
+ &r+3._ki*f_var**4-6._ki*f_var**3*e_var+3._ki*f_var**2*e_var**2)-1._k&
+ &i/24._ki*(3._ki*c_var-e_var)*(-1._ki+z)/f_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*c_var**2*(-1._ki+z)/f_var**3*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par3)
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/4._ki/e_var**2*log(e_var)/f_var**4*c_var*(-f_var**2*e_var*&
+ &*2+f_var**4+c_var**2*f_var**2+2._ki*c_var*f_var**3+c_var**2*e_va&
+ &r**2)-1._ki/24._ki*(2._ki*e_var**2+11._ki*c_var**2-7._ki*c_var*e_var&
+ &)/f_var**3
+ !
+ case(2)
+ !
+ fg=-1._ki/4._ki*c_var**3/f_var**4*log(c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par3 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par2 should be 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for nb_bar = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else if (dim == "n+4") then
+ !
+ if (nb_par == 0) then
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/6._ki*e_var*log(-e_var)/f_var+4._ki/9._ki
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*c_var/f_var*log(-c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/24._ki*e_var**2*log(-e_var)/f_var**2-1._ki/144._ki*(13._ki*c&
+ &_var-19._ki*e_var)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/24._ki*c_var*(c_var+2._ki*f_var)/f_var**2*log(-c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*z*e_var*log(-e_var)/f_var+2._ki/9._ki*z
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*z*c_var/f_var*log(-c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*(-1._ki+z)*e_var*log(-e_var)/f_var+2._ki/9._ki-2._ki/9.&
+ &_ki*z
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*c_var*(-1._ki+z)/f_var*log(-c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/24._ki*log(-e_var)/f_var**2*(-f_var*e_var+c_var*e_var)-1._k&
+ &i/144._ki*(-13._ki*e_var+19._ki*c_var)/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/24._ki*c_var**2/f_var**2*log(-c_var)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &"In function fb (function_4p2m_opp.f90)"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &"Parameter flag should be 1 or 2 but is %d0"
+ tab_erreur_par(2)%arg_int = flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "par4 should be 1, 2, 3 or 4 but is %d0"
+ tab_erreur_par(2)%arg_int = par4
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for nb_bar = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = "In fg (function_4p2m_opp.f90):"
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = "Unexpected value for dim = %c0"
+ tab_erreur_par(2)%arg_char = dim
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ end function fg
+ !
+end module function_4p2m_opp
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p3m.f90 b/golem95c-1.2.1/integrals/four_point/function_4p3m.f90
new file mode 100644
index 0000000..435dbd9
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p3m.f90
@@ -0,0 +1,7390 @@
+!
+!****h* src/integrals/four_point/function_4p3m
+! NAME
+!
+! Module function_4p3m
+!
+! USAGE
+!
+! use function_4p3m
+!
+! DESCRIPTION
+!
+! This module computes the six-dimensional and eight dimensional
+! three mass four point function with or without Feynman parameters
+! in the numerator.
+!
+! OUTPUT
+!
+! This module exports three functions f4p3m, f4p3m_c and f3
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+!
+!*****
+module function_4p3m
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ implicit none
+ !
+ private
+ !
+ real(ki) :: s23_glob,s24_glob,s34_glob,s12_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ integer :: flag_glob
+ character (len=3) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p3m,f3,f4p3m_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p3m/f4p3m
+ ! NAME
+ !
+ ! Function f4p3m
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p3m(dim,s24,s13,s12,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the six dimensional/eight dimensional
+ ! three mass four point function with or without Feynman parameters
+ ! in the numerator.
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! three mass four point function, dim="n+4" eight dimensional
+ ! three mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! If the user wants to compute:
+ ! * a six dimensional three mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p3m("n+2",s24,s13,s12,s23,s34,0,0,0,0)
+ ! * a eight dimensional three mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p3m("n+4",s24,s13,s12,s23,s34,0,0,0,0)
+ ! * a six dimensional three mass four point function
+ ! with the Feynman parameter z1 in the numerator:
+ ! real_dim_4 = f4p3m("n+2",s24,s13,s12,s23,s34,0,0,0,1)
+ ! * a six dimensional three mass four point function
+ ! with the Feynman parameters z1^2*z2 in the numerator:
+ ! real_dim_4 = f4p3m("n+2",s24,s13,s12,s23,s34,0,2,1,1)
+ !
+ !*****
+ function f4p3m(dim,s24,s13,s12,s23,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s12,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: f4p3m
+ !
+ integer :: nb_par
+ real(ki) :: lamb
+ real(ki) :: plus_grand
+ real(ki) :: norma
+ complex(ki) :: rest1,abserr1
+ complex(ki) :: rest2,abserr2
+ complex(ki) :: resto,abserro
+ complex(ki) :: extra_imag1,extra_imag2
+ real(ki) :: pole1,pole2
+ complex(ki) :: residue1,residue2
+ real(ki) :: t1,t2,t3,t4,t5,sign_arg
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/0._ki,s12,s13,0._ki/)
+ s_mat(2,:) = (/s12,0._ki,s23,s24/)
+ s_mat(3,:) = (/s13,s23,0._ki,s34/)
+ s_mat(4,:) = (/0._ki,s24,s34,0._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ plus_grand = maxval(array=abs(s_mat))
+ s_mat = s_mat/plus_grand
+ !
+ b(1)=-(-s_mat(1,2)*s_mat(3,4)**2+s_mat(3,4)*s_mat(1,3)*s_m&
+ &at(2,4)+s_mat(2,3)*s_mat(1,3)*s_mat(2,4)-2._ki*s_mat(2,4)&
+ &*s_mat(3,4)*s_mat(2,3)+s_mat(1,2)*s_mat(3,4)*s_mat(2,3)-&
+ &s_mat(2,4)**2*s_mat(1,3)+s_mat(1,2)*s_mat(3,4)*s_mat(2,4&
+ &))/(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3))**2
+ b(2)=-(s_mat(1,3)-s_mat(3,4))/(s_mat(1,2)*s_mat(3,4)-s_mat&
+ &(2,4)*s_mat(1,3))
+ b(3)=(s_mat(1,2)-s_mat(2,4))/(s_mat(1,2)*s_mat(3,4)-s_mat(&
+ &2,4)*s_mat(1,3))
+ b(4)=(2._ki*s_mat(2,3)*s_mat(1,3)*s_mat(1,2)-s_mat(2,3)*s_m&
+ &at(1,3)*s_mat(2,4)+s_mat(1,2)**2*s_mat(3,4)-s_mat(1,2)*s&
+ &_mat(3,4)*s_mat(1,3)+s_mat(2,4)*s_mat(1,3)**2-s_mat(1,2)&
+ &*s_mat(3,4)*s_mat(2,3)-s_mat(2,4)*s_mat(1,3)*s_mat(1,2))&
+ &/(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3))**2
+ !
+ sumb=2._ki*(s_mat(1,2)*s_mat(3,4)**2-s_mat(3,4)*s_mat(1,3)*&
+ &s_mat(2,4)-s_mat(2,3)*s_mat(1,3)*s_mat(2,4)+s_mat(2,4)*s&
+ &_mat(3,4)*s_mat(2,3)-s_mat(1,2)*s_mat(3,4)*s_mat(2,3)+s_&
+ &mat(2,4)**2*s_mat(1,3)-s_mat(1,2)*s_mat(3,4)*s_mat(2,4)+&
+ &s_mat(2,4)*s_mat(1,3)**2-s_mat(1,2)*s_mat(3,4)*s_mat(1,3&
+ &)+s_mat(1,2)**2*s_mat(3,4)-s_mat(2,4)*s_mat(1,3)*s_mat(1&
+ &,2)+s_mat(2,3)*s_mat(1,3)*s_mat(1,2))/(s_mat(1,2)*s_mat(&
+ &3,4)-s_mat(2,4)*s_mat(1,3))**2
+ !
+ invs(1,1)=2._ki*s_mat(2,4)*s_mat(3,4)*s_mat(2,3)/(s_mat(1,2&
+ &)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3))**2
+ invs(1,2)=s_mat(3,4)/(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_m&
+ &at(1,3))
+ invs(1,3)=-s_mat(2,4)/(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_&
+ &mat(1,3))
+ invs(1,4)=-s_mat(2,3)*(s_mat(1,2)*s_mat(3,4)+s_mat(2,4)*s_&
+ &mat(1,3))/(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3))*&
+ &*2
+ invs(2,1) = invs(1,2)
+ invs(2,2)=0._ki
+ invs(2,3)=0._ki
+ invs(2,4)=-s_mat(1,3)/(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_&
+ &mat(1,3))
+ invs(3,1) = invs(1,3)
+ invs(3,2) = invs(2,3)
+ invs(3,3)=0._ki
+ invs(3,4)=s_mat(1,2)/(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_m&
+ &at(1,3))
+ invs(4,1) = invs(1,4)
+ invs(4,2) = invs(2,4)
+ invs(4,3) = invs(3,4)
+ invs(4,4)=2._ki*s_mat(2,3)*s_mat(1,3)*s_mat(1,2)/(s_mat(1,2&
+ &)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3))**2
+ !
+ lamb = (s_mat(1,2)*s_mat(3,4)**2-s_mat(3,4)*s_mat(1,3)*&
+ &s_mat(2,4)-s_mat(2,3)*s_mat(1,3)*s_mat(2,4)+s_mat(2,4)*s&
+ &_mat(3,4)*s_mat(2,3)-s_mat(1,2)*s_mat(3,4)*s_mat(2,3)+s_&
+ &mat(2,4)**2*s_mat(1,3)-s_mat(1,2)*s_mat(3,4)*s_mat(2,4)+&
+ &s_mat(2,4)*s_mat(1,3)**2-s_mat(1,2)*s_mat(3,4)*s_mat(1,3&
+ &)+s_mat(1,2)**2*s_mat(3,4)-s_mat(2,4)*s_mat(1,3)*s_mat(1&
+ &,2)+s_mat(2,3)*s_mat(1,3)*s_mat(1,2))
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p3m = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p3m) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p3m (in file f4p3m.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p3m'
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ if (abs(sumb) > coupure_4p3m) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n+2") then
+ !
+ f4p3m(3:4)= a4p3m_np2(s_mat(2,4),s_mat(1,3),&
+ &s_mat(1,2),s_mat(2,3),s_mat(3,4),&
+ &par1,par2,par3,par4)/plus_grand
+ !
+ else if (dim == "n+4") then
+ !
+ f4p3m = a4p3m_np4(s_mat(2,4),s_mat(1,3),&
+ &s_mat(1,2),s_mat(2,3),s_mat(3,4),&
+ &par1,par2,par3,par4)
+ f4p3m(3) = f4p3m(3)-log(plus_grand)*norma
+ !
+ end if
+ !
+ else
+ !
+ ! numerical computation
+ !
+ dim_glob = dim
+ par1_glob = par1
+ par2_glob = par2
+ par3_glob = par3
+ par4_glob = par4
+ !
+ s12_glob = s_mat(1,2)
+ s13_glob = s_mat(1,3)
+ s23_glob = s_mat(2,3)
+ s24_glob = s_mat(2,4)
+ s34_glob = s_mat(3,4)
+ !
+ t1 = (s13_glob-s34_glob)*(s24_glob-s12_glob)
+ t2 = (s24_glob+s13_glob-s12_glob-s34_glob)
+ t3 = (s13_glob*s24_glob-s12_glob*s34_glob)
+ t4 = s13_glob-s34_glob
+ t5 = s12_glob-s13_glob
+ !
+ sign_arg = sign(un,(t1*s23_glob-t2*t3))
+ !
+ resto = 0._ki
+ abserro = 0._ki
+ !
+ ! on pose z = x - i*eps*y (avec x et y > 0)
+ ! z*s24+(1-z)*s34 = s34+x*(s24-s34)-i*eps*y*(s24-s34)
+ ! on veut la partie imaginaire du meme signe que i*lambda
+ ! => eps*(s24-s34) < 0
+ !
+ ! faire attention que suivant le signe de eps_glob, on tourne dans le
+ ! sens des aiguilles d'une montre ou inversement
+ ! eps_glob = 1, on ferme le contour vers le bas --> -2 i Pi residu
+ ! eps_glob = -1, on ferme le contour vers le haut --> +2 i Pi residu
+ !
+ !
+ num_grand_b_info_par = lamb
+ denom_grand_b_info_par = (s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3))**2
+ !
+ eps_glob = sign(1._ki,s34_glob-s24_glob)
+ flag_glob = 1
+ !
+ origine_info_par = "f4p3m part 1, dimension "//dim
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,rest1,abserr1)
+ !
+ residue1 = compute_residue(t1,t2,t3,t4,t5,s23_glob,sign_arg)
+ !
+ pole1 = (s13_glob-s34_glob)/t2
+ !
+ if ( (pole1 >= 0._ki) .and. (pole1 <= 1._ki) &
+ & .and. (eps_glob == sign(1._ki,t2)) ) then
+ extra_imag1 = -2._ki*i_*pi*residue1*eps_glob
+ else
+ extra_imag1 = 0._ki
+ end if
+ !
+ resto = resto + rest1 + extra_imag1
+ abserro = abserro + abserr1
+ !
+ eps_glob = sign(1._ki,s13_glob-s12_glob)
+ flag_glob = 2
+ !
+ origine_info_par = "f4p3m part 2, dimension "//dim
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,rest2,abserr2)
+ ! le residue au pole pour la somme des deux parties est nul
+ residue2 = -residue1
+ pole2 = pole1
+ !
+ if ( (pole2 >= 0._ki) .and. (pole2 <= 1._ki) &
+ & .and. (eps_glob == sign(1._ki,t2)) ) then
+ extra_imag2 = -2._ki*i_*pi*residue2*eps_glob
+ else
+ extra_imag2 = 0._ki
+ end if
+ !
+ resto = resto + rest2 + extra_imag2
+ abserro = abserro + abserr2
+ !
+ if (dim == "n+2") then
+ resto = resto/plus_grand
+ else if (dim == "n+4") then
+ f4p3m(1) = norma
+ f4p3m(2) = 0._ki
+ resto = resto-log(plus_grand/mu2_scale_par)*norma
+ end if
+ !
+ f4p3m(3) = real(resto,ki)
+ f4p3m(4) = aimag(resto)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p3m
+ !
+ !****f* src/integrals/four_point/function_4p3m/f4p3m_c
+ ! NAME
+ !
+ ! Function f4p3m_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_2 = f4p3m_c(dim,s24,s13,s12,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the same thing that the function f4p3m
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! two adjacent mass four point function, dim="n+4" eight dimensional
+ ! two adjacent mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p3m
+ !
+ !*****
+ function f4p3m_c(dim,s24,s13,s12,s23,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s12,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(2) :: f4p3m_c
+ !
+ real(ki), dimension(4) :: res4
+ !
+ res4 = f4p3m(dim,s24,s13,s12,s23,s34,par1,par2,par3,par4)
+ call to_complex(res4,f4p3m_c)
+ !
+ end function f4p3m_c
+ !
+ !****if* src/integrals/four_point/function_4p3m/a4p3m_np2
+ ! NAME
+ !
+ ! recursive function a4p3m_np2
+ !
+ ! USAGE
+ !
+ ! real_dim_2 = a4p3m_np2(s24,s13,s12,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the six dimensional
+ ! three mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two reals (type ki) corresponding to the
+ ! real and imaginary part of the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p3m_np2(s24,s13,s12,s23,s34,par1,par2,par3,par4) result(res_4p3m_np2)
+ !
+ real(ki), intent (in) :: s24,s13,s12,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(2) :: res_4p3m_np2
+ !
+ integer, dimension(3) :: smj
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(6) :: truc1,truc2,truc3
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(6) :: temp1,temp2,temp3,temp4
+ real(ki), dimension(2) :: temp10,temp11,temp12,temp13,temp14,temp15
+ complex(ki) :: ctemp
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule3(1,1)) then
+ !
+ truc1 = resultat3(1,1,:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,unpackb(ibclr(b_pro,1),3))
+ resultat3(1,1,:) = truc1
+ deja_calcule3(1,1) = .true.
+ !
+ end if
+ !
+ if (deja_calcule3(4,1)) then
+ !
+ truc2 = resultat3(4,1,:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,unpackb(ibclr(b_pro,4),3))
+ resultat3(4,1,:) = truc2
+ deja_calcule3(4,1) = .true.
+ !
+ end if
+ !
+ ctemp = f3(s24,s13,s12,s23,s34)
+ res_4p3m_np2(1) = (real(ctemp,ki) - b(1)*truc1(5) - b(4)*truc2(5))/sumb
+ res_4p3m_np2(2) = (aimag(ctemp) - b(1)*truc1(6) - b(4)*truc2(6))/sumb
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p3m_np2(s24,s13,s12,s23,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp0 = b(par4)*temp0
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3(j,1)) then
+ !
+ truc1 = resultat3(j,1,:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,smj)
+ resultat3(j,1,:) = truc1
+ deja_calcule3(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/2._ki
+ !
+ if (j /= par4) then
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 - b(j)*truc2/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p3m_np2(1) = (temp0(1) + temp1(5) + temp2(5))/sumb
+ res_4p3m_np2(2) = (temp0(2) + temp1(6) + temp2(6))/sumb
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ if (deja_calcule(par_plus(4))) then
+ !
+ temp10 = resultat(par_plus(4),:)
+ !
+ else
+ !
+ temp10 = a4p3m_np2(s24,s13,s12,s23,s34,0,0,0,par4)
+ resultat(par_plus(4),:) = temp10
+ deja_calcule(par_plus(4)) = .true.
+ !
+ end if
+ !
+ if (deja_calcule(par_plus(3))) then
+ !
+ temp11 = resultat(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a4p3m_np2(s24,s13,s12,s23,s34,0,0,0,par3)
+ resultat(par_plus(3),:) = temp11
+ deja_calcule(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp12 = resultat(1,:)
+ temp0 = b(par3)*temp10+b(par4)*temp11 - invs(par3,par4)*temp12/2._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule3(j,par_plus(3))) then
+ !
+ truc1 = resultat3(j,par_plus(3),:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj))
+ resultat3(j,par_plus(3),:) = truc1
+ deja_calcule3(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/4._ki
+ !
+ end if
+ !
+ if (j /= par4) then
+ !
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + invs(j,par3)*truc2/4._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ if (deja_calcule33(j,par_plus(3),par_plus(4))) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ !
+ else
+ !
+ truc3 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))
+ resultat33(j,par_plus(3),par_plus(4),:) = truc3
+ deja_calcule33(j,par_plus(3),par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp3 = temp3 - b(j)*truc3/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p3m_np2(1) = (temp0(1) + temp1(5) + temp2(5) + temp3(5)) &
+ *2._ki/3._ki/sumb
+ res_4p3m_np2(2) = (temp0(2) + temp1(6) + temp2(6) + temp3(6)) &
+ *2._ki/3._ki/sumb
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ temp10 = a4p3m_np2(s24,s13,s12,s23,s34,0,0,par2,par3)
+ temp11 = a4p3m_np2(s24,s13,s12,s23,s34,0,0,par2,par4)
+ temp12 = a4p3m_np2(s24,s13,s12,s23,s34,0,0,par3,par4)
+ !
+ temp13 = resultat(par_plus(4),:)
+ temp14 = resultat(par_plus(3),:)
+ temp15 = resultat(par_plus(2),:)
+ !
+ temp0 = b(par4)*temp10+b(par3)*temp11+b(par2)*temp12 &
+ - ( invs(par2,par3)*temp13+invs(par2,par4)*temp14&
+ +invs(par3,par4)*temp15 )/3._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ temp4 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if ( (j /= par2) .and. (j /= par3) ) then
+ !
+ truc1 = resultat33(j,par_plus(2),par_plus(3),:)
+ temp1 = temp1 + invs(j,par4)*truc1/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par4) ) then
+ !
+ truc2 = resultat33(j,par_plus(2),par_plus(4),:)
+ temp2 = temp2 + invs(j,par3)*truc2/6._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ temp3 = temp3 + invs(j,par2)*truc3/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par3) .and. (j /= par4) ) then
+ !
+ temp4 = temp4 - b(j)*f3p_sc(s_mat,smj,locateb(par2,b_pro_mj), &
+ locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p3m_np2(1) = ( temp0(1) + temp1(5) + temp2(5) + temp3(5) &
+ + temp4(5) )/2._ki/sumb
+ res_4p3m_np2(2) = ( temp0(2) + temp1(6) + temp2(6) + temp3(6) &
+ + temp4(6) )/2._ki/sumb
+ end if
+ !
+ end function a4p3m_np2
+ !
+ !****if* src/integrals/four_point/function_4p3m/a4p3m_np4
+ ! NAME
+ !
+ ! recursive function a4p3m_np4
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p3m_np4(s24,s13,s12,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the eight dimensional
+ ! three mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p3m_np4(s24,s13,s12,s23,s34,par1,par2,par3,par4) result(res_4p3m_np4)
+ !
+ real(ki), intent (in) :: s24,s13,s12,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: res_4p3m_np4
+ !
+ integer, dimension(3) :: smj
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(4) :: truc1
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(4) :: temp1,temp2,temp3
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p3m_np2(s24,s13,s12,s23,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp1 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3_np2(j,1)) then
+ !
+ truc1 = resultat3_np2(j,1,:)
+ !
+ else
+ !
+ truc1 = f3p_np2_sc(s_mat,smj)
+ resultat3_np2(j,1,:) = truc1
+ deja_calcule3_np2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b(j)*truc1
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p3m_np4(1) = (-temp1(1))/(3._ki*sumb)
+ res_4p3m_np4(2) = (-temp1(2))/(3._ki*sumb)
+ res_4p3m_np4(3) = (temp0(1)-temp1(3)-2._ki/3._ki*temp1(1))/(3._ki*sumb)
+ res_4p3m_np4(4) = (temp0(2)-temp1(4)-2._ki/3._ki*temp1(2))/(3._ki*sumb)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ temp0 = a4p3m_np2(s24,s13,s12,s23,s34,0,0,0,par4)/3._ki
+ temp1 = b(par4)*a4p3m_np4(s24,s13,s12,s23,s34,0,0,0,0)
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ truc1 = resultat3_np2(j,1,:)
+ temp2 = temp2 + invs(j,par4)*truc1/6._ki
+ !
+ if (j /= par4) then
+ !
+ temp3 = temp3 - b(j)*f3p_np2_sc(s_mat,smj,locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p3m_np4(1) = ( temp1(1)+temp2(1)+temp3(1) )/(2._ki*sumb)
+ res_4p3m_np4(2) = ( temp1(2)+temp2(2)+temp3(2) )/(2._ki*sumb)
+ res_4p3m_np4(3) = ( temp1(3)+temp1(1)/6._ki+temp2(3)+temp2(1)/2._ki &
+ +temp3(3)+temp3(1)/2._ki+temp0(1) )/(2._ki*sumb)
+ res_4p3m_np4(4) = ( temp1(4)+temp1(2)/6._ki+temp2(4)+temp2(2)/2._ki &
+ +temp3(4)+temp3(2)/2._ki+temp0(2) )/(2._ki*sumb)
+ !
+ ! cas avec plus de un parametre de feynman au numerateur
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a4p3m_np4:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of four-point integrals in n+4 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb(par),4/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ end function a4p3m_np4
+ !
+ !****f* src/integrals/four_point/function_4p3m/f3
+ ! NAME
+ !
+ ! function f3
+ !
+ ! USAGE
+ !
+ ! complex = f3(s,t,m2,m3,m4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the "finite part" of the scalar four dimensional three
+ ! mass four point function.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s -- a real (type ki), (p1+p2)^2
+ ! * t -- a real (type ki), (p2+p3)^2
+ ! * m2 -- a real (type ki), p2^2
+ ! * m3 -- a real (type ki), p3^2
+ ! * m4 -- a real (type ki), p4^2
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ ! Affected by the variable rat_or_tot_par (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f3(s,t,m2,m3,m4)
+ !
+ real(ki), intent(in) :: s,t,m2,m3,m4
+ complex(ki) :: f3
+ !
+ real(ki) :: lamb1
+ !
+ lamb1 = s*t-m2*m4
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f3 = ( z_log(m3/s,sign(un,s-m3))*z_log(m4/s,sign(un,s-m4)) &
+ &- z_log(t/s,sign(un,s-t))*z_log(m2/s,sign(un,s-m2)) &
+ &- z_log(t/s,sign(un,s-t))*z_log(m3/s,sign(un,s-m3)) &
+ &+ z_log(m2/s,sign(un,s-m2))*z_log(m3/s,sign(un,s-m3)) &
+ &- 2._ki*zdilog(1._ki-m2/s,sign(un,m2-s)) &
+ &- 2._ki*zdilog(1._ki-m4/t,sign(un,m4-t)) &
+ &+ 2._ki &
+ & *( zdilog(1._ki-m2*m4/(s*t),sign(un,m2*m4*(s+t)-s*t*(m2+m4))) &
+ +( z_log(m2*m4/(s*t),sign(un,-m2*m4*(s+t)+s*t*(m2+m4))) &
+ -z_log(m2/s,sign(un,s-m2))-z_log(m4/t,sign(un,t-m4)) ) &
+ *z_log(1._ki-m2*m4/(s*t),sign(un,m2*m4*(s+t)-s*t*(m2+m4))) ) &
+ & )/lamb1
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ f3 = 0._ki
+ !
+ end if
+ !
+ end function f3
+ !
+ !****if* src/integrals/four_point/function_4p3m/eval_numer_gi
+ ! NAME
+ !
+ ! function eval_numer_gi
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_gi(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This function contains the integrand for the numerical computation in phase
+ ! space region where det(G) ~ 0
+ !
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), between 0 and 1
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki). It is called by
+ ! the routine adapt_gauss1 in the function f4p3m
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_gi(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_gi
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ z = x - eps_glob*i_*y
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ !
+ eval_numer_gi = fg(z,s24_glob,s13_glob,s12_glob,s23_glob,s34_glob,&
+ & par1_glob,par2_glob,par3_glob,par4_glob,flag_glob,&
+ & dim_glob)
+ eval_numer_gi = eval_numer_gi*jacob
+ !
+ end function eval_numer_gi
+ !
+ !****if* src/integrals/four_point/function_4p3m/compute_residue
+ ! NAME
+ !
+ ! Function compute_residue
+ !
+ ! USAGE
+ !
+ ! complex = compute_residue(t1,t2,t3,t4,t5,t6,sign_arg)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the residue of the pole in the case where the pole
+ ! is inside the contour
+ !
+ ! INPUTS
+ !
+ ! * t1 -- a real (type ki)
+ ! * t2 -- a real (type ki)
+ ! * t3 -- a real (type ki)
+ ! * t4 -- a real (type ki)
+ ! * t5 -- a real (type ki)
+ ! * t6 -- a real (type ki)
+ ! * sign_arg -- a real (type ki)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the global variable (for this module) dim_glob
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function compute_residue(t1,t2,t3,t4,t5,t6,sign_arg)
+ !
+ real(ki), intent (in) :: t1,t2,t3,t4,t5,t6,sign_arg
+ complex(ki) :: compute_residue
+ !
+ complex(ki) :: temp0,stemp1,stemp2,stemp3,stemp4,&
+ &stemp5,stemp6,stemp7,stemp8,stemp9,&
+ &stemp10,stemp11
+ integer, dimension(4) :: par
+ integer :: nb_par
+ !
+ par = (/par1_glob,par2_glob,par3_glob,par4_glob/)
+ nb_par = count(mask=par/=0)
+ !
+ if (dim_glob == "n+2") then
+ if (nb_par == 0) then
+ !
+ temp0=(-z_log(t1*t6/t2**2,1._ki)+q(1,(-t1*t6+t2*t3)/t2/t3,sign_arg&
+ &))/t2
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par4_glob)
+ !
+ case(1)
+ !
+ temp0=(-1._ki/2._ki*(t2**2+t6*t2+t5*t2-2._ki*t6*t4)/t2**2*z_log(t1*t&
+ &6/t2**2,1._ki)+1._ki/2._ki/t3*(t2**2*t3+t5*t2*t3+t2*t3*t6-2._ki*t5*&
+ &t1*t6-2._ki*t2*t1*t6-2._ki*t3*t6*t4)/t2**2*q(2,(t2*t3-t1*t6)/t2/t&
+ &3,sign_arg)-1._ki/2._ki*(2._ki*t2**2+2._ki*t5*t2+t6*t2-2._ki*t6*t4)/&
+ &t2**2)/t2
+ !
+ case(2)
+ !
+ temp0=(-1._ki/2._ki*(t4*t2**3+2._ki*t2*t3*t6+2._ki*t6*t4*t5*t2-6._ki*t&
+ &3*t6*t4+2._ki*t5*t1*t6-4._ki*t4**2*t5*t6)/t2**4*z_log(t1*t6/t2**2&
+ &,1._ki)+1._ki/2._ki*t4/t2*q(2,(t2*t3-t1*t6)/t2/t3,sign_arg)-1._ki/2&
+ &._ki*(t4*t2**2*t3-4._ki*t4**2*t2*t3+2._ki*t2*t1*t3+2._ki*t2*t4*t5*t&
+ &1-6._ki*t4*t1*t3+4._ki*t4**3*t3-4._ki*t4**2*t5*t1)*t6/t1/t2**4)/t2
+ !
+ case(3)
+ !
+ temp0=(-1._ki/2._ki*(t2**4-t4*t2**3+2._ki*t6*t2**2*t5-4._ki*t2*t3*t6-&
+ &6._ki*t6*t4*t5*t2+6._ki*t3*t6*t4-2._ki*t5*t1*t6+4._ki*t4**2*t5*t6)/&
+ &t2**4*z_log(t1*t6/t2**2,1._ki)+1._ki/2._ki/t2*(t2-t4)*q(2,(t2*t3-t&
+ &1*t6)/t2/t3,sign_arg)-1._ki/2._ki*(t3*t2**3-5._ki*t4*t2**2*t3+2._ki&
+ &*t2**2*t1*t5+8._ki*t4**2*t2*t3-4._ki*t2*t1*t3-6._ki*t2*t4*t5*t1+6.&
+ &_ki*t4*t1*t3-4._ki*t4**3*t3+4._ki*t4**2*t5*t1)*t6/t1/t2**4)/t2
+ !
+ case(4)
+ !
+ temp0=(1._ki/2._ki*(t5*t2+t6*t2-2._ki*t6*t4)/t2**2*z_log(t1*t6/t2**2&
+ &,1._ki)-1._ki/2._ki/t3*(t5*t2*t3+t2*t3*t6-2._ki*t5*t1*t6-2._ki*t3*t6&
+ &*t4)/t2**2*q(2,(t2*t3-t1*t6)/t2/t3,sign_arg)+1._ki/2._ki*(t6*t2+2&
+ &._ki*t5*t2-2._ki*t6*t4)/t2**2)/t2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ & 'In function compute_residue (function_4p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par4 = %d0'
+ tab_erreur_par(2)%arg_int = par4_glob
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 2) then
+ !
+ select case(par3_glob)
+ !
+ case(1)
+ !
+ select case(par4_glob)
+ !
+ case(1)
+ !
+ stemp2=-(-2._ki*t1*t6**2+4._ki*t6**2*t4**2-4._ki*t6**2*t2*t4+t6**2*t&
+ &2**2+t2**3*t6+t6*t2**2*t5-2._ki*t6*t4*t5*t2-2._ki*t4*t6*t2**2-t6*&
+ &t3*t2+t2**4+t5**2*t2**2+2._ki*t5*t2**3)/t2**4*z_log(t1*t6/t2**2,&
+ &1._ki)/3._ki
+ !
+ stemp3=(-6._ki*t1*t6*t2**2*t3*t5+t3**2*t2**4-3._ki*t1*t6*t2*t3*t5**&
+ &2+2._ki*t2**3*t3**2*t5+t2**2*t3**2*t5**2+t2**2*t3**2*t6*t5-t6*t2&
+ &*t3**3-2._ki*t2*t3**2*t6*t4*t5+3._ki*t2**2*t1**2*t6**2-3._ki*t3*t2&
+ &**3*t1*t6+3._ki*t1**2*t6**2*t5**2+t1*t6**2*t3**2+6._ki*t1**2*t6**&
+ &2*t5*t2-3._ki*t1*t6**2*t2*t3*t5+6._ki*t1*t6**2*t3*t4*t5-3._ki*t1*t&
+ &6**2*t2**2*t3+6._ki*t1*t6**2*t2*t3*t4-2._ki*t2**2*t3**2*t6*t4+t2*&
+ &*3*t3**2*t6-4._ki*t2*t3**2*t6**2*t4+t2**2*t3**2*t6**2+4._ki*t3**2&
+ &*t6**2*t4**2)/t3**2/t2**4*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/3._k&
+ &i+(2._ki*t1*t6**2*t3-12._ki*t6**2*t3*t4**2-3._ki*t6**2*t2**2*t3+12&
+ &._ki*t6**2*t2*t3*t4+3._ki*t6*t1*t2*t5**2+3._ki*t1*t6*t2**3+6._ki*t6&
+ &*t1*t2**2*t5+3._ki*t2*t3**2*t6-5._ki*t6*t3*t2**3+10._ki*t6*t2**2*t&
+ &3*t4-5._ki*t6*t5*t2**2*t3+10._ki*t6*t2*t3*t4*t5-6._ki*t2**4*t3-6._k&
+ &i*t2**2*t3*t5**2-17._ki*t2**3*t3*t5)/t2**4/t3/6._ki
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(2)
+ !
+ stemp2=-(-36._ki*t6**2*t1*t5*t4+12._ki*t6**2*t1*t5*t2-12._ki*t1*t6**&
+ &2*t3-36._ki*t6**2*t2*t3*t4-24._ki*t6**2*t4**2*t5*t2+6._ki*t6**2*t2&
+ &**2*t4*t5+24._ki*t6**2*t5*t4**3+48._ki*t6**2*t3*t4**2+6._ki*t6**2*&
+ &t2**2*t3+2._ki*t1*t6*t2**3+2._ki*t6*t2**4*t4-4._ki*t6*t2**3*t4**2+&
+ &t4*t2**5+t4*t2**4*t5+t2**4*t3)/t2**6*z_log(t1*t6/t2**2,1._ki)/6.&
+ &_ki
+ !
+ stemp3=-(-2._ki*t6*t4*t2*t3+4._ki*t4**2*t6*t3+3._ki*t4*t2*t1*t6-t2**&
+ &2*t3*t4-t2*t3*t4*t5+3._ki*t4*t5*t1*t6-t2*t3**2+t1*t6*t3)/t2**3/t&
+ &3*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/6._ki-(-36._ki*t1**2*t6**2*t4&
+ &*t5+12._ki*t1**2*t6**2*t5*t2-12._ki*t1**2*t6**2*t3+18._ki*t6**2*t1&
+ &*t2**2*t4*t5-72._ki*t6**2*t1*t4**2*t5*t2+18._ki*t1*t6**2*t2**2*t3&
+ &+144._ki*t1*t6**2*t4**2*t3-108._ki*t1*t6**2*t2*t3*t4+72._ki*t6**2*&
+ &t1*t5*t4**3+4._ki*t6**2*t2**3*t3*t4+48._ki*t6**2*t4**3*t2*t3-24._k&
+ &i*t6**2*t2**2*t3*t4**2-32._ki*t6**2*t4**4*t3-8._ki*t6*t1*t2**3*t4&
+ &**2+4._ki*t6*t1*t4*t2**4+3._ki*t1*t4*t2**5+3._ki*t1*t4*t2**4*t5+t1&
+ &*t2**4*t3)/t2**6/t1/12._ki
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(3)
+ !
+ stemp2=(24._ki*t6**2*t1*t5*t2-36._ki*t6**2*t1*t5*t4-12._ki*t1*t6**2*&
+ &t3+18._ki*t6**2*t2**2*t3-60._ki*t6**2*t2*t3*t4-48._ki*t6**2*t4**2*&
+ &t5*t2-6._ki*t6**2*t2**3*t5+48._ki*t6**2*t3*t4**2+24._ki*t6**2*t5*t&
+ &4**3+30._ki*t6**2*t2**2*t4*t5+2._ki*t1*t6*t2**3-2._ki*t6*t2**5+6._k&
+ &i*t6*t2**4*t4-4._ki*t6*t2**3*t4**2+t2**4*t3+t4*t2**4*t5+t4*t2**5&
+ &-t5*t2**5-t2**6)/t2**6*z_log(t1*t6/t2**2,1._ki)/6._ki
+ !
+ stemp3=(2._ki*t6*t2**2*t3-6._ki*t6*t4*t2*t3+t2**2*t3*t5+3._ki*t4*t2*&
+ &t1*t6-t2**2*t3*t4+4._ki*t4**2*t6*t3-t2*t3*t4*t5+3._ki*t4*t5*t1*t6&
+ &-3._ki*t5*t2*t1*t6+t2**3*t3-t2*t3**2-3._ki*t2**2*t1*t6+t1*t6*t3)/&
+ &t2**3/t3*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/6._ki+(24._ki*t1**2*t6&
+ &**2*t5*t2-36._ki*t1**2*t6**2*t4*t5-12._ki*t1**2*t6**2*t3-180._ki*t&
+ &1*t6**2*t2*t3*t4-18._ki*t6**2*t1*t5*t2**3+72._ki*t6**2*t1*t5*t4**&
+ &3-144._ki*t6**2*t1*t4**2*t5*t2+90._ki*t6**2*t1*t2**2*t4*t5+144._ki&
+ &*t1*t6**2*t4**2*t3+54._ki*t1*t6**2*t2**2*t3-32._ki*t6**2*t4**4*t3&
+ &+80._ki*t6**2*t4**3*t2*t3-4._ki*t6**2*t2**4*t3+28._ki*t6**2*t2**3*&
+ &t3*t4-72._ki*t6**2*t2**2*t3*t4**2-8._ki*t6*t1*t2**3*t4**2+12._ki*t&
+ &6*t1*t4*t2**4-4._ki*t6*t1*t2**5+3._ki*t1*t4*t2**4*t5+t1*t2**4*t3+&
+ &3._ki*t1*t4*t2**5-3._ki*t1*t5*t2**5-3._ki*t2**6*t1)/t2**6/t1/12._ki
+ !
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp2=(-4._ki*t1*t6**2-8._ki*t6**2*t2*t4+8._ki*t6**2*t4**2+2._ki*t6*&
+ &*2*t2**2-2._ki*t4*t6*t2**2+2._ki*t6*t2**2*t5-2._ki*t6*t3*t2-4._ki*t&
+ &6*t4*t5*t2+t2**3*t6+2._ki*t5*t2**3+2._ki*t5**2*t2**2)/t2**4*z_log&
+ &(t1*t6/t2**2,1._ki)/6._ki
+ !
+ stemp3=-(2._ki*t2**3*t3**2*t5+6._ki*t1**2*t6**2*t5*t2-6._ki*t1*t6*t2&
+ &**2*t3*t5+12._ki*t1*t6**2*t3*t4*t5+2._ki*t2**2*t3**2*t6*t5-4._ki*t&
+ &2*t3**2*t6*t4*t5-6._ki*t1*t6**2*t2*t3*t5+2._ki*t2**2*t3**2*t6**2-&
+ &8._ki*t2*t3**2*t6**2*t4+8._ki*t3**2*t6**2*t4**2+2._ki*t1*t6**2*t3*&
+ &*2-2._ki*t6*t2*t3**3+2._ki*t2**2*t3**2*t5**2+6._ki*t1**2*t6**2*t5*&
+ &*2-6._ki*t1*t6*t2*t3*t5**2+t2**3*t3**2*t6-2._ki*t2**2*t3**2*t6*t4&
+ &-3._ki*t1*t6**2*t2**2*t3+6._ki*t1*t6**2*t2*t3*t4)/t3**2/t2**4*q(3&
+ &,(t2*t3-t1*t6)/t2/t3,sign_arg)/6._ki-(4._ki*t1*t6**2*t3-24._ki*t6*&
+ &*2*t3*t4**2+24._ki*t6**2*t2*t3*t4-6._ki*t6**2*t2**2*t3+6._ki*t6*t1&
+ &*t2**2*t5+6._ki*t6*t1*t2*t5**2+6._ki*t2*t3**2*t6+20._ki*t6*t2*t3*t&
+ &4*t5-10._ki*t6*t5*t2**2*t3-5._ki*t6*t3*t2**3+10._ki*t6*t2**2*t3*t4&
+ &-12._ki*t2**2*t3*t5**2-12._ki*t2**3*t3*t5)/t2**4/t3/12._ki
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4_glob)
+ !
+ case(2)
+ !
+ stemp4=2._ki*t1*t6*t2**2*t3*t5+4._ki*t6**2*t1*t2**2*t4*t5+6._ki*t1*t&
+ &6*t2*t3*t5**2-t4**2*t2**6/3._ki+t1**2*t6**2*t5*t2+16._ki*t2*t3**2&
+ &*t6**2*t4+20._ki*t6**2*t1*t5**2*t4**2-4._ki*t6**2*t4**3*t5*t2**2-&
+ &4._ki/3._ki*t6**2*t1*t4*t2**3+4._ki*t6**2*t4**4*t5*t2-48._ki*t6**2*&
+ &t4**3*t3*t5+8._ki*t6**2*t4**3*t5**2*t2-8._ki*t1*t6**2*t2*t3*t4-t2&
+ &**2*t1**2*t6**2/3._ki+4._ki*t1*t6**2*t3**2-8._ki*t1*t6**2*t2*t3*t5&
+ &+2._ki*t6**2*t2**3*t3*t4+12._ki*t6**2*t4**3*t2*t3-10._ki*t6**2*t2*&
+ &*2*t3*t4**2+4._ki/3._ki*t6*t1*t4*t2**4+6._ki*t2**2*t3**2*t6*t5-t3*&
+ &t2**3*t1*t6-2._ki*t6**2*t4**2*t5**2*t2**2+t6**2*t4**2*t5*t2**3+1&
+ &0._ki/3._ki*t6**2*t1*t4**2*t2**2+5._ki*t6*t4**2*t3*t2**3-4._ki*t6*t&
+ &4**3*t5**3*t2-8._ki*t6**2*t4**4*t5**2-2._ki*t6*t2*t3**3
+ !
+ stemp3=-2._ki*t2**2*t3**2*t6**2-4._ki/3._ki*t6**2*t4**4*t2**2-4._ki/3&
+ &._ki*t6*t4**3*t2**4+4._ki/3._ki*t6**2*t4**3*t2**3+2._ki/3._ki*t6*t4*&
+ &*2*t2**5-2._ki*t1**2*t6**2*t5**2-26._ki*t3**2*t6**2*t4**2+32._ki*t&
+ &1*t6**2*t3*t4*t5+4._ki*t6*t2**3*t3*t4*t5-10._ki*t6*t2**2*t3*t4**2&
+ &*t5+2._ki*t6*t4**2*t5**3*t2**2-2._ki*t6*t4**3*t5**2*t2**2-2._ki*t6&
+ &*t2**4*t3*t4+t6*t4**2*t5**2*t2**3-t6*t4**2*t5*t2**4+2._ki*t6*t4*&
+ &*3*t5*t2**3+2._ki*t1*t6**2*t2**2*t3-4._ki*t2**2*t3**2*t6*t4+stemp&
+ &4+4._ki*t6*t1*t4*t5**3*t2-2._ki*t6*t1*t4*t5*t2**3+2._ki*t6*t1*t4*t&
+ &5**2*t2**2-24._ki*t2*t3**2*t6*t4*t5-10._ki*t6**2*t1*t4**2*t5*t2-8&
+ &._ki*t6**2*t1*t4*t5**2*t2-30._ki*t6*t4**2*t3*t5**2*t2+12._ki*t6*t4&
+ &*t3*t5**2*t2**2-t6**2*t4**2*t2**4/3._ki+t2**3*t3**2*t6+40._ki*t6*&
+ &*2*t4**2*t3*t5*t2-8._ki*t6**2*t4*t3*t5*t2**2
+ !
+ stemp4=1._ki/t2**8*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=t4**2/t2**2*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/3._ki
+ !
+ stemp8=-3._ki*t6*t4**2*t5**2*t1**3*t2**2+12._ki*t6*t4**3*t5**2*t1**&
+ &3*t2-4._ki/3._ki*t6*t1**2*t4**2*t5*t3*t2**3-16._ki*t6*t1**2*t4**4*&
+ &t5*t3*t2+8._ki*t6*t1**2*t4**3*t5*t3*t2**2-2._ki*t6*t4**3*t3*t2**3&
+ &*t1**2+t6*t4**2*t2**4*t3*t1**2/3._ki-8._ki/3._ki*t6*t1**2*t4**5*t3&
+ &*t2-4._ki/3._ki*t4*t3**2*t2**3*t1**2*t6+t4**2*t3**2*t2**4*t1*t6/6&
+ &._ki+3._ki*t4**2*t5**2*t3*t2**3*t1**2+12._ki*t4*t3*t5**2*t1**3*t2*&
+ &*2+3._ki/2._ki*t6*t4**2*t5*t2**3*t1**3+6._ki*t4**3*t3**2*t2**2*t1*&
+ &*2-5._ki*t4**2*t3**2*t2**3*t1**2-2._ki*t4*t3*t2**4*t1**3+4._ki*t4*&
+ &*4*t3**3*t2**3+t2**3*t3**2*t1**3-4._ki/3._ki*t4**3*t2**4*t1**3-2.&
+ &_ki*t2*t3**3*t1**3-16._ki/3._ki*t4**5*t3**3*t2**2+t4**2*t3**3*t2**&
+ &5/6._ki-16._ki/3._ki*t6*t1*t4**5*t3**2*t2-15._ki*t6*t4**2*t3*t2**2*&
+ &t1**3+t6*t2**2*t3*t1**4
+ !
+ stemp7=-3._ki*t6*t3**2*t1**3*t2**2-12._ki*t6*t4**4*t5**2*t1**3+10._k&
+ &i*t6*t4**2*t5**2*t1**4+5._ki/3._ki*t6*t4**2*t2**2*t1**4-2._ki*t6*t&
+ &4**4*t2**2*t1**3-2._ki/3._ki*t6*t4*t2**3*t1**4+56._ki/3._ki*t6*t1**&
+ &2*t4**4*t3**2+8._ki/3._ki*t6*t1*t4**6*t3**2-39._ki*t6*t4**2*t1**3*&
+ &t3**2-t6*t1**3*t4**2*t2**4/2._ki+2._ki*t6*t1**3*t4**3*t2**3-12._ki&
+ &*t1*t4**3*t3**3*t2**2-2._ki*t1*t4**4*t3**2*t2**3+28._ki/3._ki*t1*t&
+ &4**4*t3**3*t2+4._ki/3._ki*t1*t4**5*t3**2*t2**2-12._ki*t1*t4**4*t3*&
+ &*2*t2**2*t5+6._ki*t1*t4**3*t3**2*t2**3*t5-12._ki*t6*t1**3*t2**2*t&
+ &3*t4*t5-24._ki*t4*t3**2*t1**3*t5*t2-30._ki*t4**2*t3**2*t5*t1**2*t&
+ &2**2-30._ki*t4**2*t3*t5**2*t1**3*t2-6._ki*t6*t4**3*t5*t2**2*t1**3&
+ &+18._ki*t6*t4**3*t3*t2*t1**3-4._ki*t6*t3*t5*t1**4*t2+60._ki*t6*t4*&
+ &*2*t3*t5*t1**3*t2+stemp8
+ !
+ stemp8=4._ki*t6*t4**4*t3**2*t2**2*t1+3._ki*t6*t4*t3*t2**3*t1**3+16.&
+ &_ki*t6*t3*t5*t1**4*t4-72._ki*t6*t4**3*t3*t5*t1**3-4._ki*t6*t2*t3*t&
+ &1**4*t4-t1*t4**2*t3**2*t2**4*t5+8._ki*t1*t4**5*t3**2*t5*t2+4._ki*&
+ &t6*t1**2*t4**4*t3*t2**2+36._ki*t4**3*t3**2*t5*t1**2*t2+10._ki*t6*&
+ &t1**2*t2**2*t3**2*t4**2+32._ki/3._ki*t6*t1**2*t4**5*t5*t3-4._ki/3.&
+ &_ki*t4**3*t3**2*t2**3*t1*t6+4._ki*t4**4*t5*t3*t2**2*t1**2+t4**2*t&
+ &5*t3*t2**4*t1**2+6._ki*t1**2*t2**3*t3**2*t4*t5-2._ki*t4**4*t3*t2*&
+ &*3*t1**2-t4**2*t3*t2**5*t1**2/2._ki-4._ki*t2**2*t3**2*t1**3*t4+t4&
+ &*t3**2*t2**4*t1**2-2._ki*t4**3*t5**2*t2**2*t1**3+2._ki*t4**2*t5**&
+ &3*t1**3*t2**2-2._ki/3._ki*t1*t4*t3**3*t2**4-t4**2*t3**2*t2**5*t1/&
+ &6._ki+2._ki*t4**3*t5*t2**3*t1**3-t4**2*t5*t2**4*t1**3
+ !
+ stemp6=-4._ki*t4**3*t5**3*t1**3*t2+5._ki*t4**2*t3**3*t1*t2**3+5._ki*&
+ &t4**2*t2**3*t1**3*t3+t4**3*t3**2*t2**4*t1+6._ki*t3**2*t5*t2**2*t&
+ &1**3-8._ki*t3**3*t2**2*t1**2*t4+13._ki*t3**3*t2*t1**2*t4**2+24._ki&
+ &*t6*t4*t3**2*t1**3*t2+6._ki*t6*t4**4*t5*t2*t1**3+stemp7+stemp8-2&
+ &4._ki*t6*t1**2*t4**3*t3**2*t2+2._ki/3._ki*t4**2*t2**5*t1**3+t1**2*&
+ &t2**3*t3**3+2._ki*t6*t3**2*t1**4-4._ki/3._ki*t4**3*t3**3*t2**4+8._k&
+ &i/3._ki*t4**6*t3**3*t2-10._ki*t4**2*t5*t3*t2**2*t1**3-4._ki*t4**3*&
+ &t5*t3*t2**3*t1**2+t4**2*t5**2*t2**3*t1**3-4._ki*t6*t4*t5**2*t1**&
+ &4*t2+2._ki*t4**3*t3*t2**4*t1**2+4._ki*t4*t5*t3*t2**3*t1**3-12._ki*&
+ &t4**3*t5**2*t3*t2**2*t1**2+12._ki*t4**4*t5**2*t3*t2*t1**2-5._ki*t&
+ &6*t4**2*t5*t2*t1**4+2._ki*t6*t4*t5*t2**2*t1**4
+ !
+ stemp7=t6/t1**3/t2**8
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(3)
+ !
+ stemp4=-72._ki*t6**2*t4**2*t3*t5*t2-t6*t1*t2**4*t5+2._ki*t6*t2**4*t&
+ &3*t5+32._ki*t6**2*t4*t3*t5*t2**2+2._ki*t1**2*t6**2*t5**2+2._ki/3._k&
+ &i*t6*t1*t2**5-2._ki/3._ki*t6**2*t1*t2**4+2._ki/3._ki*t6*t2**6*t4-t2&
+ &**7*t4/3._ki+2._ki*t6**2*t1*t5*t2**3+t6**2*t4*t2**4*t5-2._ki*t6**2&
+ &*t4*t5**2*t2**3-26._ki*t2*t3**2*t6**2*t4-t2**5*t6*t4*t5-20._ki*t6&
+ &**2*t1*t5**2*t4**2+8._ki*t6**2*t4**3*t5*t2**2+10._ki/3._ki*t6**2*t&
+ &1*t4*t2**3-4._ki*t6**2*t4**4*t5*t2+48._ki*t6**2*t4**3*t3*t5-16._ki&
+ &*t6**2*t4**3*t5**2*t2-4._ki*t6**2*t2**3*t3*t5+2._ki*t6*t4*t5**3*t&
+ &2**3+t6*t4*t5**2*t2**4-4._ki*t6**2*t1*t5**2*t2**2+6._ki*t6*t5**2*&
+ &t2**3*t3+t6*t1*t5**2*t2**3+2._ki*t6*t1*t5**3*t2**2+30._ki*t6*t4**&
+ &2*t3*t5**2*t2-30._ki*t6*t4*t3*t5**2*t2**2-4._ki*t6*t1*t4*t5**3*t2&
+ &+2._ki*t6*t1*t4*t5*t2**3-2._ki*t6*t1*t4*t5**2*t2**2-6._ki*t1*t6*t2&
+ &*t3*t5**2+2._ki*t6*t2*t3**3+6._ki*t2**2*t3**2*t6**2+5._ki/3._ki*t6*&
+ &*2*t4**2*t2**4+4._ki/3._ki*t6**2*t4**4*t2**2-t4*t2**5*t6**2/3._ki+&
+ &4._ki/3._ki*t6*t4**3*t2**4
+ !
+ stemp5=stemp4-8._ki/3._ki*t6**2*t4**3*t2**3-2._ki*t6*t4**2*t2**5-t6*&
+ &t3*t2**5+t4**2*t2**6/3._ki+24._ki*t2*t3**2*t6*t4*t5-10._ki*t6*t2**&
+ &3*t3*t4*t5+10._ki*t6*t2**2*t3*t4**2*t5+16._ki*t1*t6**2*t2*t3*t5-3&
+ &2._ki*t1*t6**2*t3*t4*t5+26._ki*t3**2*t6**2*t4**2+t2**2*t1**2*t6**&
+ &2/3._ki-2._ki*t2**3*t3**2*t6+t6**2*t2**4*t3-4._ki*t1*t6**2*t3**2+8&
+ &._ki*t6**2*t4**4*t5**2+8._ki*t1*t6**2*t2*t3*t4-2._ki*t1*t6*t2**2*t&
+ &3*t5-10._ki*t6**2*t1*t2**2*t4*t5+10._ki*t6**2*t1*t4**2*t5*t2
+ !
+ stemp3=stemp5+20._ki*t6**2*t1*t4*t5**2*t2-8._ki*t6**2*t2**3*t3*t4-1&
+ &2._ki*t6**2*t4**3*t2*t3+18._ki*t6**2*t2**2*t3*t4**2-4._ki/3._ki*t6*&
+ &t1*t4*t2**4+t3*t2**3*t1*t6+10._ki*t6**2*t4**2*t5**2*t2**2-5._ki*t&
+ &6**2*t4**2*t5*t2**3-10._ki/3._ki*t6**2*t1*t4**2*t2**2-5._ki*t6*t4*&
+ &*2*t3*t2**3+4._ki*t6*t4**3*t5**3*t2-6._ki*t6*t4**2*t5**3*t2**2+2.&
+ &_ki*t6*t4**3*t5**2*t2**2+5._ki*t6*t2**4*t3*t4-3._ki*t6*t4**2*t5**2&
+ &*t2**3+3._ki*t6*t4**2*t5*t2**4-2._ki*t6*t4**3*t5*t2**3-4._ki*t1*t6&
+ &**2*t2**2*t3+4._ki*t2**2*t3**2*t6*t4-t1**2*t6**2*t5*t2-12._ki*t2*&
+ &*2*t3**2*t6*t5
+ !
+ stemp4=1._ki/t2**8*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=-(-t2+t4)*t4/t2**2*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/3._ki
+ !
+ stemp8=12._ki*t6*t4**3*t5*t2**2*t1**3-18._ki*t6*t4**3*t3*t2*t1**3-1&
+ &5._ki/2._ki*t6*t4**2*t5*t2**3*t1**3+10._ki*t6*t4*t5**2*t1**4*t2+5.&
+ &_ki*t6*t4**2*t5*t2*t1**4-8._ki*t1*t4**5*t3**2*t5*t2+20._ki*t1*t4**&
+ &4*t3**2*t2**2*t5-18._ki*t1*t4**3*t3**2*t2**3*t5+30._ki*t4**2*t3*t&
+ &5**2*t1**3*t2+10._ki*t4**2*t5*t3*t2**2*t1**3+8._ki*t4**3*t5*t3*t2&
+ &**3*t1**2+2._ki/3._ki*t1**3*t2**6*t4-8._ki/3._ki*t4**6*t3**3*t2-t1*&
+ &*3*t2**5*t3-2._ki*t2**3*t3**2*t1**3-3._ki*t1**2*t2**3*t3**3+2._ki*&
+ &t2*t3**3*t1**3-6._ki*t6*t1**3*t2**3*t3*t5-4._ki/3._ki*t6*t1**2*t2*&
+ &*4*t3*t4*t5+t6*t1**2*t2**5*t3*t4/3._ki+24._ki*t4*t3**2*t1**3*t5*t&
+ &2-36._ki*t4**3*t3**2*t5*t1**2*t2-6._ki*t4**3*t3**2*t2**2*t1**2+9.&
+ &_ki*t4**2*t3**2*t2**3*t1**2+5._ki*t4*t3*t2**4*t1**3-5._ki*t6*t4*t5&
+ &*t2**2*t1**4+15._ki*t6*t4**2*t5**2*t1**3*t2**2-24._ki*t6*t4**3*t5&
+ &**2*t1**3*t2+7._ki*t1*t4**2*t3**2*t2**4*t5-4._ki*t4**4*t5*t3*t2**&
+ &2*t1**2-5._ki*t4**2*t5*t3*t2**4*t1**2-24._ki*t1**2*t2**3*t3**2*t4&
+ &*t5
+ !
+ stemp7=-28._ki/3._ki*t4**4*t3**3*t2**3-2._ki*t6*t3**2*t1**4-3._ki/2._k&
+ &i*t4**2*t3**3*t2**5-t6*t1**4*t2**4/3._ki+16._ki/3._ki*t4**3*t3**3*&
+ &t2**4-10._ki*t4*t5*t3*t2**3*t1**3+24._ki*t4**3*t5**2*t3*t2**2*t1*&
+ &*2-12._ki*t4**4*t5**2*t3*t2*t1**2-15._ki*t4**2*t5**2*t3*t2**3*t1*&
+ &*2-30._ki*t4*t3*t5**2*t1**3*t2**2+54._ki*t4**2*t3**2*t5*t1**2*t2*&
+ &*2+27._ki*t6*t4**2*t3*t2**2*t1**3+8._ki*t6*t3*t5*t1**4*t2-108._ki*&
+ &t6*t4**2*t3*t5*t1**3*t2-28._ki/3._ki*t6*t4**4*t3**2*t2**2*t1-12._k&
+ &i*t6*t4*t3*t2**3*t1**3-16._ki*t6*t3*t5*t1**4*t4-3._ki*t4**2*t5**2&
+ &*t2**3*t1**3+2._ki*t4**4*t3*t2**3*t1**2+5._ki/2._ki*t4**2*t3*t2**5&
+ &*t1**2+4._ki*t2**2*t3**2*t1**3*t4-4._ki*t4*t3**2*t2**4*t1**2+2._ki&
+ &*t4**3*t5**2*t2**2*t1**3-6._ki*t4**2*t5**3*t1**3*t2**2-4._ki*t4**&
+ &3*t3*t2**4*t1**2+11._ki/3._ki*t1*t4*t3**3*t2**4+7._ki/6._ki*t4**2*t&
+ &3**2*t2**5*t1-2._ki*t4**3*t5*t2**3*t1**3+3._ki*t4**2*t5*t2**4*t1*&
+ &*3+4._ki*t4**3*t5**3*t1**3*t2-13._ki*t4**2*t3**3*t1*t2**3-5._ki*t4&
+ &**2*t2**3*t1**3*t3+stemp8
+ !
+ stemp8=stemp7-3._ki*t4**3*t3**2*t2**4*t1-12._ki*t3**2*t5*t2**2*t1**&
+ &3+13._ki*t3**3*t2**2*t1**2*t4-13._ki*t3**3*t2*t1**2*t4**2+6._ki*t1&
+ &**3*t2**3*t3*t5**2+3._ki*t1**2*t2**4*t3**2*t5+t4*t5**2*t2**4*t1*&
+ &*3+2._ki*t4*t5**3*t2**3*t1**3-t1*t2**6*t3**2*t4/6._ki+56._ki/3._ki*&
+ &t1*t4**3*t3**3*t2**2+10._ki/3._ki*t1*t4**4*t3**2*t2**3-28._ki/3._ki&
+ &*t1*t4**4*t3**3*t2-4._ki/3._ki*t1*t4**5*t3**2*t2**2+2._ki*t2**4*t3&
+ &*t5*t1**3-t4*t2**5*t1**3*t5-t4*t2**6*t1**2*t3/2._ki-t6*t1**3*t4*&
+ &t2**5/2._ki+3._ki/2._ki*t6*t1**3*t2**4*t3-2._ki*t6*t2**2*t3*t1**4-2&
+ &._ki*t4**2*t2**5*t1**3-t1*t4*t3**2*t2**5*t5+t2**5*t3*t4*t1**2*t5&
+ &+3._ki*t4*t5**2*t2**4*t1**2*t3+16._ki/3._ki*t4**3*t3**2*t2**3*t1*t&
+ &6+22._ki/3._ki*t4*t3**2*t2**3*t1**2*t6-3._ki/2._ki*t4**2*t3**2*t2**&
+ &4*t1*t6+t4*t3**2*t2**5*t1*t6/6._ki+28._ki/3._ki*t6*t1**2*t4**2*t5*&
+ &t3*t2**3+80._ki/3._ki*t6*t1**2*t4**4*t5*t3*t2-24._ki*t6*t1**2*t4**&
+ &3*t5*t3*t2**2+6._ki*t6*t4**3*t3*t2**3*t1**2
+ !
+ stemp6=stemp8-7._ki/3._ki*t6*t4**2*t2**4*t3*t1**2+8._ki/3._ki*t6*t1**&
+ &2*t4**5*t3*t2-t1*t3**3*t2**5/3._ki+8._ki*t6*t1*t4**5*t3**2*t2+48.&
+ &_ki*t6*t1**3*t2**2*t3*t4*t5+t4*t3**3*t2**6/6._ki+4._ki/3._ki*t4**3*&
+ &t2**4*t1**3+t1**2*t2**5*t3**2/2._ki+8._ki*t4**5*t3**3*t2**2+9._ki*&
+ &t6*t3**2*t1**3*t2**2+12._ki*t6*t4**4*t5**2*t1**3-10._ki*t6*t4**2*&
+ &t5**2*t1**4-5._ki/3._ki*t6*t4**2*t2**2*t1**4+2._ki*t6*t4**4*t2**2*&
+ &t1**3+5._ki/3._ki*t6*t4*t2**3*t1**4-56._ki/3._ki*t6*t1**2*t4**4*t3*&
+ &*2-8._ki/3._ki*t6*t1*t4**6*t3**2+39._ki*t6*t4**2*t1**3*t3**2+5._ki/&
+ &2._ki*t6*t1**3*t4**2*t2**4+t6*t5*t2**3*t1**4-2._ki*t6*t1**4*t5**2&
+ &*t2**2-4._ki*t6*t1**3*t4**3*t2**3-2._ki/3._ki*t3**2*t2**4*t1**2*t6&
+ &+72._ki*t6*t4**3*t3*t5*t1**3+4._ki*t6*t2*t3*t1**4*t4-39._ki*t6*t4*&
+ &t3**2*t1**3*t2-6._ki*t6*t4**4*t5*t2*t1**3-20._ki/3._ki*t6*t1**2*t4&
+ &**4*t3*t2**2-26._ki*t6*t1**2*t2**2*t3**2*t4**2-32._ki/3._ki*t6*t1*&
+ &*2*t4**5*t5*t3+112._ki/3._ki*t6*t1**2*t4**3*t3**2*t2-3._ki*t6*t4*t&
+ &5**2*t2**3*t1**3+3._ki/2._ki*t6*t4*t5*t2**4*t1**3
+ !
+ stemp7=t6/t1**3/t2**8
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp1=(-6._ki*t1*t6**2*t3+6._ki*t6**2*t1*t5*t2-18._ki*t6**2*t1*t5*t&
+ &4-18._ki*t6**2*t2*t3*t4+3._ki*t6**2*t2**2*t4*t5+12._ki*t6**2*t5*t4&
+ &**3-12._ki*t6**2*t4**2*t5*t2+3._ki*t6**2*t2**2*t3+24._ki*t6**2*t3*&
+ &t4**2+2._ki*t1*t6*t2**3+2._ki*t6*t2**4*t4-4._ki*t6*t2**3*t4**2+t2*&
+ &*4*t3+t4*t2**4*t5)/t2**6*z_log(t1*t6/t2**2,1._ki)/6._ki+(3._ki*t4*&
+ &t5*t1*t6-t2*t3*t4*t5+t1*t6*t3-t2*t3**2-2._ki*t6*t4*t2*t3+4._ki*t4&
+ &**2*t6*t3)/t2**3/t3*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/6._ki+(-6.&
+ &_ki*t1**2*t6**2*t3+6._ki*t1**2*t6**2*t5*t2-18._ki*t1**2*t6**2*t4*t&
+ &5-54._ki*t1*t6**2*t2*t3*t4+36._ki*t6**2*t1*t5*t4**3+72._ki*t1*t6**&
+ &2*t4**2*t3-36._ki*t6**2*t1*t4**2*t5*t2+9._ki*t6**2*t1*t2**2*t4*t5&
+ &+9._ki*t1*t6**2*t2**2*t3-16._ki*t6**2*t4**4*t3+24._ki*t6**2*t4**3*&
+ &t2*t3-12._ki*t6**2*t2**2*t3*t4**2+2._ki*t6**2*t2**3*t3*t4+4._ki*t6&
+ &*t1*t4*t2**4-8._ki*t6*t1*t2**3*t4**2+t1*t2**4*t3+3._ki*t1*t4*t2**&
+ &4*t5)/t2**6/t1/12._ki
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4_glob)
+ !
+ case(3)
+ !
+ stemp5=-t2**8/3._ki-t2**6*t6**2/3._ki-4._ki/3._ki*t6*t4**3*t2**4-32._k&
+ &i*t6**2*t1*t4*t5**2*t2-30._ki*t6*t4**2*t3*t5**2*t2+48._ki*t6*t4*t&
+ &3*t5**2*t2**2+4._ki*t6*t1*t4*t5**3*t2+16._ki*t6*t2**3*t3*t4*t5-10&
+ &._ki*t6*t2**2*t3*t4**2*t5-t3*t2**3*t1*t6+2._ki/3._ki*t6*t2**7+3._ki&
+ &*t2**3*t3**2*t6+18._ki*t6**2*t2**3*t3*t4+12._ki*t6**2*t4**3*t2*t3&
+ &-26._ki*t6**2*t2**2*t3*t4**2+10._ki*t6*t4**2*t5**3*t2**2-2._ki*t6*&
+ &t4**3*t5**2*t2**2-8._ki*t6*t2**4*t3*t4+5._ki*t6*t4**2*t5**2*t2**3&
+ &-5._ki*t6*t4**2*t5*t2**4+2._ki*t6*t4**3*t5*t2**3
+ !
+ stemp4=stemp5+6._ki*t1*t6**2*t2**2*t3-4._ki*t2**2*t3**2*t6*t4+t1**2&
+ &*t6**2*t5*t2-6._ki*t6**2*t1*t5*t2**3-6._ki*t6**2*t4*t2**4*t5+12._k&
+ &i*t6**2*t4*t5**2*t2**3+36._ki*t2*t3**2*t6**2*t4+4._ki*t2**5*t6*t4&
+ &*t5+20._ki*t6**2*t1*t5**2*t4**2-16._ki/3._ki*t6**2*t1*t4*t2**3+4._k&
+ &i*t6**2*t4**4*t5*t2-48._ki*t6**2*t4**3*t3*t5+24._ki*t6**2*t4**3*t&
+ &5**2*t2+16._ki*t6**2*t2**3*t3*t5-8._ki*t6*t4*t5**3*t2**3-4._ki*t6*&
+ &t4*t5**2*t2**4+12._ki*t6**2*t1*t5**2*t2**2-18._ki*t6*t5**2*t2**3*&
+ &t3-2._ki*t6*t1*t5**2*t2**3-4._ki*t6*t1*t5**3*t2**2+2._ki*t6*t1*t2*&
+ &*4*t5-6._ki*t6*t2**4*t3*t5
+ !
+ stemp5=4._ki/3._ki*t6*t1*t4*t2**4+18._ki*t2**2*t3**2*t6*t5+104._ki*t6&
+ &**2*t4**2*t3*t5*t2-72._ki*t6**2*t4*t3*t5*t2**2-12._ki*t6**2*t4**3&
+ &*t5*t2**2-t4**2*t2**6/3._ki-2._ki*t6*t1*t4*t5*t2**3+2._ki*t6*t1*t4&
+ &*t5**2*t2**2+6._ki*t1*t6*t2*t3*t5**2-24._ki*t2*t3**2*t6*t4*t5-24.&
+ &_ki*t1*t6**2*t2*t3*t5+32._ki*t1*t6**2*t3*t4*t5+stemp4-26._ki*t6**2&
+ &*t4**2*t5**2*t2**2+13._ki*t6**2*t4**2*t5*t2**3+10._ki/3._ki*t6**2*&
+ &t1*t4**2*t2**2+5._ki*t6*t4**2*t3*t2**3-4._ki*t6*t4**3*t5**3*t2-8.&
+ &_ki*t1*t6**2*t2*t3*t4+2._ki*t1*t6*t2**2*t3*t5+16._ki*t6**2*t1*t2**&
+ &2*t4*t5-10._ki*t6**2*t1*t4**2*t5*t2
+ !
+ stemp3=stemp5+2._ki/3._ki*t2**7*t4-4._ki*t6**2*t2**4*t3+3._ki*t6*t3*t&
+ &2**5+t6**2*t2**5*t5+t6*t2**5*t5**2-t2**2*t1**2*t6**2/3._ki+4._ki*&
+ &t1*t6**2*t3**2-8._ki*t6**2*t4**4*t5**2-2._ki*t6*t2*t3**3-12._ki*t2&
+ &**2*t3**2*t6**2-13._ki/3._ki*t6**2*t4**2*t2**4-4._ki/3._ki*t6**2*t4&
+ &**4*t2**2+4._ki*t6**2*t4**3*t2**3+10._ki/3._ki*t6*t4**2*t2**5+2._ki&
+ &*t4*t2**5*t6**2-2._ki*t1**2*t6**2*t5**2-26._ki*t3**2*t6**2*t4**2-&
+ &4._ki/3._ki*t6*t1*t2**5+2._ki*t6**2*t1*t2**4-8._ki/3._ki*t6*t2**6*t4&
+ &-t5*t2**6*t6-2._ki*t6**2*t2**4*t5**2+2._ki*t6*t2**4*t5**3
+ !
+ stemp4=1._ki/t2**8*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=(-t2+t4)**2/t2**2*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/3._ki
+ !
+ stemp8=54._ki*t6*t4*t3**2*t1**3*t2+6._ki*t6*t4**4*t5*t2*t1**3+39._ki&
+ &/2._ki*t6*t4**2*t5*t2**3*t1**3+t3**3*t2**7/6._ki-10._ki*t4**2*t5*t&
+ &3*t2**2*t1**3-12._ki*t4**3*t5*t3*t2**3*t1**2+4._ki*t4**4*t5*t3*t2&
+ &**2*t1**2+2._ki/3._ki*t1**3*t2**7-112._ki/3._ki*t6*t1**2*t4**4*t5*t&
+ &3*t2+152._ki/3._ki*t6*t1**2*t4**3*t5*t3*t2**2-38._ki/3._ki*t6*t4**3&
+ &*t3*t2**3*t1**2-2._ki*t1**2*t2**5*t3**2+3._ki*t2**3*t3**2*t1**3+5&
+ &2._ki/3._ki*t4**4*t3**3*t2**3-6._ki*t2**5*t3*t4*t1**2*t5-18._ki*t4*&
+ &t5**2*t2**4*t1**2*t3-14._ki/3._ki*t1*t4**4*t3**2*t2**3+28._ki/3._ki&
+ &*t1*t4**4*t3**3*t2+4._ki/3._ki*t1*t4**5*t3**2*t2**2-6._ki*t2**4*t3&
+ &*t5*t1**3+4._ki*t4*t2**5*t1**3*t5+3._ki*t4*t2**6*t1**2*t3+t3**2*t&
+ &2**6*t1*t6/6._ki-6._ki*t6*t1**3*t2**4*t3-3._ki*t6*t5**2*t2**4*t1**&
+ &3-76._ki/3._ki*t1*t4**3*t3**3*t2**2+t6*t1**4*t2**4-t1**2*t2**7*t3&
+ &/2._ki+10._ki/3._ki*t4**2*t2**5*t1**3+5._ki/3._ki*t1*t3**3*t2**5-4._k&
+ &i/3._ki*t4**3*t2**4*t1**3-44._ki/3._ki*t4**3*t3**3*t2**4+6._ki*t1**&
+ &2*t2**3*t3**3-t2**6*t1**3*t5+2._ki*t5**3*t2**4*t1**3+41._ki/6._ki*&
+ &t4**2*t3**3*t2**5
+ !
+ stemp9=25._ki/3._ki*t6*t4**2*t2**4*t3*t1**2-8._ki/3._ki*t6*t1**2*t4**&
+ &5*t3*t2+28._ki/3._ki*t6*t1**2*t4**4*t3*t2**2+50._ki*t6*t1**2*t2**2&
+ &*t3**2*t4**2+3._ki*t6*t1**3*t4*t2**5+41._ki/6._ki*t4**2*t3**2*t2**&
+ &4*t1*t6-5._ki/3._ki*t4*t3**2*t2**5*t1*t6-39._ki*t6*t4**2*t3*t2**2*&
+ &t1**3-18._ki*t6*t4**3*t5*t2**2*t1**3+18._ki*t6*t4**3*t3*t2*t1**3+&
+ &48._ki*t4*t3*t5**2*t1**3*t2**2-24._ki*t4*t3**2*t1**3*t5*t2+36._ki*&
+ &t4**3*t3**2*t5*t1**2*t2-t1*t2**7*t3**2/6._ki+stemp8+13._ki*t4**2*&
+ &t5*t3*t2**4*t1**2+54._ki*t1**2*t2**3*t3**2*t4*t5+8._ki*t1*t4*t3**&
+ &2*t2**5*t5
+ !
+ stemp7=stemp9-25._ki*t1*t4**2*t3**2*t2**4*t5+8._ki*t1*t4**5*t3**2*t&
+ &5*t2-28._ki*t1*t4**4*t3**2*t2**2*t5+3._ki/2._ki*t6*t5*t2**5*t1**3+&
+ &t6*t1**2*t2**6*t3/3._ki+3._ki*t6*t2**2*t3*t1**4-18._ki*t6*t3**2*t1&
+ &**3*t2**2-12._ki*t6*t4**4*t5**2*t1**3+10._ki*t6*t4**2*t5**2*t1**4&
+ &+5._ki/3._ki*t6*t4**2*t2**2*t1**4-2._ki*t6*t4**4*t2**2*t1**3-8._ki/&
+ &3._ki*t6*t4*t2**3*t1**4+56._ki/3._ki*t6*t1**2*t4**4*t3**2+8._ki/3._k&
+ &i*t6*t1*t4**6*t3**2-39._ki*t6*t4**2*t1**3*t3**2-13._ki/2._ki*t6*t1&
+ &**3*t4**2*t2**4-3._ki*t6*t5*t2**3*t1**4+6._ki*t6*t1**4*t5**2*t2**&
+ &2+6._ki*t6*t1**3*t4**3*t2**3
+ !
+ stemp9=10._ki/3._ki*t3**2*t2**4*t1**2*t6+32._ki/3._ki*t6*t1**2*t4**5*&
+ &t5*t3-152._ki/3._ki*t6*t1**2*t4**3*t3**2*t2+18._ki*t6*t4*t5**2*t2*&
+ &*3*t1**3-9._ki*t6*t4*t5*t2**4*t1**3+24._ki*t6*t1**3*t2**3*t3*t5+3&
+ &2._ki/3._ki*t6*t1**2*t2**4*t3*t4*t5-8._ki/3._ki*t6*t1**2*t2**5*t3*t&
+ &4-44._ki/3._ki*t4**3*t3**2*t2**3*t1*t6-64._ki/3._ki*t4*t3**2*t2**3*&
+ &t1**2*t6+38._ki*t1*t4**3*t3**2*t2**3*t5-78._ki*t4**2*t3**2*t5*t1*&
+ &*2*t2**2-30._ki*t4**2*t3*t5**2*t1**3*t2+16._ki*t4*t5*t3*t2**3*t1*&
+ &*3-36._ki*t4**3*t5**2*t3*t2**2*t1**2+12._ki*t4**4*t5**2*t3*t2*t1*&
+ &*2+39._ki*t4**2*t5**2*t3*t2**3*t1**2-4._ki/3._ki*t6*t1**2*t2**5*t3&
+ &*t5
+ !
+ stemp8=stemp9-32._ki/3._ki*t6*t1*t4**5*t3**2*t2-108._ki*t6*t1**3*t2*&
+ &*2*t3*t4*t5-12._ki*t6*t3*t5*t1**4*t2+156._ki*t6*t4**2*t3*t5*t1**3&
+ &*t2+52._ki/3._ki*t6*t4**4*t3**2*t2**2*t1+27._ki*t6*t4*t3*t2**3*t1*&
+ &*3+16._ki*t6*t3*t5*t1**4*t4-72._ki*t6*t4**3*t3*t5*t1**3-4._ki*t6*t&
+ &2*t3*t1**4*t4+6._ki*t4**3*t3**2*t2**2*t1**2-13._ki*t4**2*t3**2*t2&
+ &**3*t1**2-8._ki*t4*t3*t2**4*t1**3+5._ki*t4**2*t5**2*t2**3*t1**3-2&
+ &._ki*t4**4*t3*t2**3*t1**2-13._ki/2._ki*t4**2*t3*t2**5*t1**2-4._ki*t&
+ &2**2*t3**2*t1**3*t4+9._ki*t4*t3**2*t2**4*t1**2-2._ki*t4**3*t5**2*&
+ &t2**2*t1**3
+ !
+ stemp6=stemp8+10._ki*t4**2*t5**3*t1**3*t2**2+6._ki*t4**3*t3*t2**4*t&
+ &1**2-32._ki/3._ki*t1*t4*t3**3*t2**4-25._ki/6._ki*t4**2*t3**2*t2**5*&
+ &t1+2._ki*t4**3*t5*t2**3*t1**3-5._ki*t4**2*t5*t2**4*t1**3-4._ki*t4*&
+ &*3*t5**3*t1**3*t2+25._ki*t4**2*t3**3*t1*t2**3+5._ki*t4**2*t2**3*t&
+ &1**3*t3+19._ki/3._ki*t4**3*t3**2*t2**4*t1+18._ki*t3**2*t5*t2**2*t1&
+ &**3-18._ki*t3**3*t2**2*t1**2*t4+13._ki*t3**3*t2*t1**2*t4**2+t2**6&
+ &*t3*t1**2*t5+3._ki*t2**5*t3*t5**2*t1**2-18._ki*t1**3*t2**3*t3*t5*&
+ &*2-12._ki*t1**2*t2**4*t3**2*t5-4._ki*t4*t5**2*t2**4*t1**3-8._ki*t4&
+ &*t5**3*t2**3*t1**3-t1*t2**6*t3**2*t5+4._ki/3._ki*t1*t2**6*t3**2*t&
+ &4-32._ki/3._ki*t4**5*t3**3*t2**2-t6*t1**3*t2**6/2._ki+8._ki/3._ki*t4&
+ &**6*t3**3*t2-2._ki*t2*t3**3*t1**3-5._ki/3._ki*t4*t3**3*t2**6+2._ki*&
+ &t6*t3**2*t1**4+3._ki*t1**3*t2**5*t3-8._ki/3._ki*t1**3*t2**6*t4+t5*&
+ &*2*t2**5*t1**3-16._ki*t6*t4*t5**2*t1**4*t2-5._ki*t6*t4**2*t5*t2*t&
+ &1**4+8._ki*t6*t4*t5*t2**2*t1**4-39._ki*t6*t4**2*t5**2*t1**3*t2**2&
+ &+36._ki*t6*t4**3*t5**2*t1**3*t2-100._ki/3._ki*t6*t1**2*t4**2*t5*t3&
+ &*t2**3+stemp7
+ !
+ stemp7=t6/t1**3/t2**8
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp2=-(12._ki*t6**2*t1*t5*t2-18._ki*t6**2*t1*t5*t4-6._ki*t1*t6**2*&
+ &t3-30._ki*t6**2*t2*t3*t4+12._ki*t6**2*t5*t4**3+15._ki*t6**2*t2**2*&
+ &t4*t5-24._ki*t6**2*t4**2*t5*t2+24._ki*t6**2*t3*t4**2+9._ki*t6**2*t&
+ &2**2*t3-3._ki*t6**2*t2**3*t5+2._ki*t1*t6*t2**3-2._ki*t6*t2**5+6._ki&
+ &*t6*t2**4*t4-4._ki*t6*t2**3*t4**2+t4*t2**4*t5-t5*t2**5+t2**4*t3)&
+ &/t2**6*z_log(t1*t6/t2**2,1._ki)/6._ki
+ !
+ stemp3=-(-3._ki*t5*t2*t1*t6+2._ki*t6*t2**2*t3+t2**2*t3*t5-6._ki*t6*t&
+ &4*t2*t3+4._ki*t4**2*t6*t3-t2*t3*t4*t5+3._ki*t4*t5*t1*t6+t1*t6*t3-&
+ &t2*t3**2)/t2**3/t3*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/6._ki-(12._k&
+ &i*t1**2*t6**2*t5*t2-18._ki*t1**2*t6**2*t4*t5-6._ki*t1**2*t6**2*t3&
+ &-9._ki*t6**2*t1*t5*t2**3+72._ki*t1*t6**2*t4**2*t3-90._ki*t1*t6**2*&
+ &t2*t3*t4+27._ki*t1*t6**2*t2**2*t3-72._ki*t6**2*t1*t4**2*t5*t2+45.&
+ &_ki*t6**2*t1*t2**2*t4*t5+36._ki*t6**2*t1*t5*t4**3-36._ki*t6**2*t2*&
+ &*2*t3*t4**2+40._ki*t6**2*t4**3*t2*t3+14._ki*t6**2*t2**3*t3*t4-2._k&
+ &i*t6**2*t2**4*t3-16._ki*t6**2*t4**4*t3-8._ki*t6*t1*t2**3*t4**2+12&
+ &._ki*t6*t1*t4*t2**4-4._ki*t6*t1*t2**5+3._ki*t1*t4*t2**4*t5+t1*t2**&
+ &4*t3-3._ki*t1*t5*t2**5)/t2**6/t1/12._ki
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ temp0=(-(-2._ki*t1*t6**2+4._ki*t6**2*t4**2-4._ki*t6**2*t2*t4+t6**2*t&
+ &2**2-2._ki*t6*t4*t5*t2-t6*t3*t2+t6*t2**2*t5+t5**2*t2**2)/t2**4*z&
+ &_log(t1*t6/t2**2,1._ki)/3._ki+(6._ki*t1*t6**2*t3*t4*t5-3._ki*t1*t6*&
+ &t2*t3*t5**2+t1*t6**2*t3**2-3._ki*t1*t6**2*t2*t3*t5+3._ki*t1**2*t6&
+ &**2*t5**2+t2**2*t3**2*t6**2+t2**2*t3**2*t5**2-t6*t2*t3**3-4._ki*&
+ &t2*t3**2*t6**2*t4+t2**2*t3**2*t6*t5+4._ki*t3**2*t6**2*t4**2-2._ki&
+ &*t2*t3**2*t6*t4*t5)/t3**2/t2**4*q(3,(t2*t3-t1*t6)/t2/t3,sign_ar&
+ &g)/3._ki+(2._ki*t1*t6**2*t3-12._ki*t6**2*t3*t4**2+12._ki*t6**2*t2*t&
+ &3*t4-3._ki*t6**2*t2**2*t3+3._ki*t6*t1*t2*t5**2-5._ki*t6*t5*t2**2*t&
+ &3+10._ki*t6*t2*t3*t4*t5+3._ki*t2*t3**2*t6-6._ki*t2**2*t3*t5**2)/t2&
+ &**4/t3/6)/t2
+ !
+ end select
+ !
+ end select
+ !
+ else if (nb_par == 3) then
+ !
+ select case(par2_glob)
+ !
+ case(1)
+ !
+ select case(par3_glob)
+ !
+ case(1)
+ !
+ select case(par4_glob)
+ !
+ case(1)
+ !
+ stemp2=-(4._ki*t6**2*t2*t3*t4-2._ki*t6*t4*t5**2*t2**2-4._ki*t6*t2**3&
+ &*t4*t5-2._ki*t6*t2**2*t3*t5-2._ki*t6**2*t1*t5*t2-2._ki*t6*t3*t2**3&
+ &+t6**2*t5*t2**3-2._ki*t6**2*t2**2*t3+3._ki*t5*t2**5+t2**5*t6+t6**&
+ &3*t2**3-8._ki*t6**3*t4**3-4._ki*t6**2*t5*t2**2*t4+4._ki*t6**2*t5*t&
+ &2*t4**2+12._ki*t6**3*t4**2*t2+t6*t2**3*t5**2-2._ki*t6*t2**4*t4+t5&
+ &**3*t2**3+t2**6+3._ki*t5**2*t2**4+t6**2*t2**4+2._ki*t6*t2**4*t5+1&
+ &2._ki*t6**3*t1*t4-6._ki*t6**3*t2**2*t4-4._ki*t6**2*t2**3*t4+4._ki*t&
+ &6**2*t2**2*t4**2-6._ki*t6**3*t1*t2-2._ki*t6**2*t1*t2**2)/t2**6*z_&
+ &log(t1*t6/t2**2,1._ki)/4._ki
+ !
+ stemp4=-(2._ki*t1**2*t6**2*t2**2-2._ki*t1*t6**2*t2**2*t3+t3**2*t6**&
+ &2*t2**2+4._ki*t1**2*t6**2*t5*t2+4._ki*t1*t6**2*t2*t3*t4-2._ki*t3*t&
+ &1*t6**2*t5*t2-4._ki*t3**2*t6**2*t4*t2+2._ki*t6**2*t1**2*t5**2+4._k&
+ &i*t3*t6**2*t4*t1*t5+2._ki*t3**2*t1*t6**2+4._ki*t3**2*t6**2*t4**2-&
+ &2._ki*t6*t1*t3*t2**3-4._ki*t1*t6*t2**2*t3*t5-2._ki*t6*t1*t3*t5**2*&
+ &t2-2._ki*t2*t3**3*t6+t3**2*t2**4+2._ki*t2**3*t3**2*t5+t3**2*t5**2&
+ &*t2**2)*(2._ki*t6*t3*t4+2._ki*t1*t6*t5-t3*t6*t2+2._ki*t1*t6*t2-t3*&
+ &t2*t5-t2**2*t3)/t3**3/t2**6*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/4&
+ &._ki
+ !
+ stemp7=2._ki*t6*t1*t3*t2**3*t5**2-11._ki/12._ki*t3**2*t2**3*t5**3+2.&
+ &_ki*t6*t1*t5*t2**4*t3+2._ki/3._ki*t6*t1*t3*t2**2*t5**3+7._ki/6._ki*t&
+ &6*t3**2*t2**3*t4*t5-11._ki/24._ki*t6**3*t2**3*t3**2-17._ki/6._ki*t6&
+ &**2*t2*t3**2*t4**2*t5+17._ki/6._ki*t6**2*t3**2*t4*t5*t2**2+11._ki/&
+ &3._ki*t6**3*t3**2*t4**3+t3**3*t2**3*t6/12._ki+5._ki/3._ki*t6*t3**2*&
+ &t2**2*t4*t5**2-11._ki/12._ki*t3**2*t2**6+t6**2*t1*t2**4*t3/2._ki+1&
+ &7._ki/6._ki*t6**2*t2**3*t3**2*t4-11._ki/6._ki*t6**2*t2*t3**3*t4-17.&
+ &_ki/24._ki*t6**2*t2**3*t3**2*t5-17._ki/6._ki*t6**2*t3**2*t4**2*t2**&
+ &2+2._ki/3._ki*t6*t1*t3*t2**5+5._ki/4._ki*t6**3*t1*t3**2*t2-5._ki/2._k&
+ &i*t6**3*t3**2*t1*t4-11._ki/2._ki*t6**3*t3**2*t2*t4**2
+ !
+ stemp6=stemp7+11._ki/4._ki*t6**3*t2**2*t3**2*t4-t6**2*t1**2*t5**2*t&
+ &2**2-t3**2*t2**2*t1*t6**2/12._ki+7._ki/6._ki*t6*t3**3*t2**2*t5-5._k&
+ &i/6._ki*t6*t3**2*t2**3*t5**2+5._ki/3._ki*t6*t2**4*t3**2*t4-7._ki/12&
+ &._ki*t6*t2**4*t3**2*t5-t6**2*t1**2*t5*t2**3-t6**2*t1**2*t2*t5**3&
+ &/3._ki-67._ki/12._ki*t3**2*t2**4*t5**2-17._ki/24._ki*t6**2*t3**2*t2*&
+ &*4-5._ki/6._ki*t6*t2**5*t3**2+11._ki/12._ki*t6**2*t2**2*t3**3+t6**2&
+ &*t1*t2**3*t3*t5-59._ki/12._ki*t2**5*t3**2*t5-t1**2*t2**4*t6**2/3.&
+ &_ki-t6**2*t1*t2*t3*t4*t5**2-t6**2*t1*t2*t5*t3**2/12._ki-2._ki*t6**&
+ &2*t1*t3*t4*t5*t2**2-t6**2*t1*t2**3*t3*t4+t6**2*t1*t5**2*t3*t2**&
+ &2/2._ki
+ !
+ stemp7=1._ki/t3**2/t2**6
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(2)
+ !
+ stemp2=-(2._ki*t3*t5*t2**5+t4*t2**7-36._ki*t6**3*t1**2*t5+2._ki*t6*t&
+ &1*t2**5-216._ki*t1*t6**3*t4*t5*t2-6._ki*t3*t4*t6*t2**4-96._ki*t6**&
+ &3*t4**4*t5-12._ki*t6**2*t2**4*t4**2-240._ki*t6**3*t3*t4**3+12._ki*&
+ &t6**3*t3*t2**3+2._ki*t6*t2**5*t3+12._ki*t6**2*t2**3*t4**3-18._ki*t&
+ &6**2*t1*t2**3*t4+288._ki*t6**3*t1*t5*t4**2+36._ki*t1*t6**3*t2**2*&
+ &t5+12._ki*t6**3*t2**3*t5*t4-72._ki*t6**3*t2**2*t5*t4**2+2._ki*t6*t&
+ &2**5*t4*t5-4._ki*t6*t2**4*t4**2*t5+180._ki*t6**3*t4*t1*t3+288._ki*&
+ &t6**3*t3*t2*t4**2-108._ki*t6**3*t3*t2**2*t4+2._ki*t6*t1*t2**4*t5-&
+ &72._ki*t6**3*t3*t2*t1+144._ki*t6**3*t4**3*t5*t2+2._ki*t6*t2**6*t4-&
+ &4._ki*t6*t2**5*t4**2+3._ki*t6**2*t2**5*t4+2._ki*t2**6*t4*t5+2._ki*t&
+ &3*t2**6+t4*t5**2*t2**5+6._ki*t6**2*t1*t2**4)/t2**8*z_log(t1*t6/t&
+ &2**2,1._ki)/12._ki
+ !
+ stemp4=(-4._ki*t3*t4*t5**2*t2*t1*t6+2._ki*t3**2*t2**3*t4*t5+4._ki*t1&
+ &**2*t6**2*t3*t2-6._ki*t1*t6*t3**2*t2**2-6._ki*t2*t6*t3**3*t4-2._ki&
+ &*t2*t1*t6**2*t3**2+6._ki*t4*t2**2*t1**2*t6**2+3._ki*t2**2*t4*t3**&
+ &2*t6**2+2._ki*t2**3*t4*t6*t3**2-4._ki*t2**2*t4**2*t6*t3**2+t3**2*&
+ &t4*t5**2*t2**2+12._ki*t4**3*t3**2*t6**2+2._ki*t4*t5*t3**2*t6*t2**&
+ &2-8._ki*t2**2*t4*t1*t6**2*t3+16._ki*t2*t4**2*t1*t6**2*t3+2._ki*t2*&
+ &*3*t3**3+t4*t3**2*t2**4+2._ki*t2**2*t5*t3**3+2._ki*t6*t3**3*t2**2&
+ &+4._ki*t5*t1**2*t6**2*t3+6._ki*t1*t6**2*t3**2*t4-12._ki*t2*t4**2*t&
+ &3**2*t6**2+6._ki*t4*t5**2*t6**2*t1**2+12._ki*t4*t5*t2*t6**2*t1**2&
+ &-4._ki*t4*t3*t2**3*t1*t6-6._ki*t2*t5*t1*t6*t3**2-8._ki*t3*t4*t5*t2&
+ &*t6**2*t1+16._ki*t3*t4**2*t5*t6**2*t1-4._ki*t3**2*t4**2*t5*t2*t6-&
+ &8._ki*t4*t3*t5*t2**2*t1*t6)/t2**5/t3**2*q(4,(t2*t3-t1*t6)/t2/t3,&
+ &sign_arg)/12._ki
+ !
+ stemp7=-5._ki/36._ki*t1*t2**6*t3*t4*t5-7._ki/36._ki*t1*t2**5*t3*t4*t5&
+ &**2-7._ki/18._ki*t6*t1*t2**6*t4*t3+t6*t1**2*t2**4*t4*t5**2/6._ki+2&
+ &._ki/3._ki*t6*t1*t4*t3**2*t2**4-2._ki/9._ki*t6*t1*t2**5*t3**2+t6*t1&
+ &**2*t2**5*t3/9._ki+t6**3*t3*t5*t1**3-25._ki/2._ki*t6**3*t1**2*t4*t&
+ &3**2+5._ki*t6**3*t1**2*t2*t3**2+110._ki/3._ki*t6**3*t1*t4**3*t3**2&
+ &+t1*t3**2*t2**6/36._ki+7._ki/9._ki*t6*t1*t2**5*t4**2*t3+15._ki*t6**&
+ &3*t1**2*t3*t4*t5*t2+3._ki/2._ki*t6**2*t1*t3*t2**4*t4**2-3._ki/2._ki&
+ &*t6**2*t1*t3*t2**3*t4**3-11._ki/6._ki*t6**3*t1*t3*t2**3*t5*t4+3._k&
+ &i/4._ki*t6**2*t1**2*t3*t2**3*t4-3._ki/8._ki*t6**2*t1*t3*t2**5*t4+t&
+ &6*t1**2*t2**6*t4/6._ki
+ !
+ stemp6=stemp7-t6**3*t4*t3**2*t2**4/4._ki-11._ki/6._ki*t6**3*t1*t3**2&
+ &*t2**3-6._ki*t6**3*t3**2*t2**2*t4**3-t6**2*t1**2*t3*t2**4/4._ki-4&
+ &4._ki*t6**3*t1*t2*t4**2*t3**2+11._ki*t6**3*t1*t3*t2**2*t5*t4**2+2&
+ &._ki*t6**3*t3**2*t2**3*t4**2+8._ki*t6**3*t3**2*t4**4*t2-2._ki/9._ki&
+ &*t1*t2**5*t3**2*t5-7._ki/36._ki*t1*t2**7*t3*t4+t6*t1**2*t2**5*t4*&
+ &t5/3._ki+44._ki/3._ki*t6**3*t1*t3*t4**4*t5+33._ki/2._ki*t6**3*t1*t2*&
+ &*2*t4*t3**2-20._ki*t6**3*t1**2*t3*t5*t4**2-5._ki/2._ki*t6**3*t1**2&
+ &*t3*t2**2*t5+t6*t1**2*t2**4*t5*t3/9._ki-22._ki*t6**3*t1*t3*t4**3*&
+ &t5*t2+7._ki/9._ki*t6*t1*t2**4*t3*t4**2*t5-7._ki/18._ki*t6*t1*t2**5*&
+ &t3*t4*t5-4._ki*t6**3*t3**2*t4**5
+ !
+ stemp7=1._ki/t1/t2**8/t3
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(3)
+ !
+ stemp2=-(-2._ki*t2**6*t4*t5+360._ki*t1*t6**3*t4*t5*t2+6._ki*t3*t4*t6&
+ &*t2**4+18._ki*t6**2*t1*t2**3*t4-6._ki*t6*t2**5*t4*t5+4._ki*t6*t2**&
+ &4*t4**2*t5+96._ki*t6**3*t4**4*t5+24._ki*t6**2*t2**4*t4**2-12._ki*t&
+ &6**2*t2**3*t4**3-6._ki*t6*t2**6*t4+4._ki*t6*t2**5*t4**2-t4*t2**7-&
+ &15._ki*t6**2*t2**5*t4+240._ki*t6**3*t3*t4**3-48._ki*t6**3*t3*t2**3&
+ &-2._ki*t3*t5*t2**5+2._ki*t5*t2**7-2._ki*t3*t2**6+t5**2*t2**6+2._ki*&
+ &t6*t2**7-288._ki*t6**3*t1*t5*t4**2-108._ki*t1*t6**3*t2**2*t5-84._k&
+ &i*t6**3*t2**3*t5*t4+216._ki*t6**3*t2**2*t5*t4**2-240._ki*t6**3*t4&
+ &**3*t5*t2+108._ki*t6**3*t3*t2*t1-180._ki*t6**3*t4*t1*t3-432._ki*t6&
+ &**3*t3*t2*t4**2+252._ki*t6**3*t3*t2**2*t4-2._ki*t6*t1*t2**4*t5-t4&
+ &*t5**2*t2**5-12._ki*t6**2*t1*t2**4-4._ki*t6*t2**5*t3+36._ki*t6**3*&
+ &t1**2*t5+12._ki*t6**3*t5*t2**4+2._ki*t6*t2**6*t5-2._ki*t6*t1*t2**5&
+ &+t2**8+3._ki*t6**2*t2**6)/t2**8*z_log(t1*t6/t2**2,1._ki)/12._ki
+ !
+ stemp6=t3**2*t5**2*t2**3/12._ki+t2**2*t1**2*t6**2*t5-t1**2*t6**2*t&
+ &3*t2/3._ki+t1*t6*t3**2*t2**2/2._ki+t5*t3**2*t6*t2**3/6._ki-t1*t6**&
+ &2*t3**2*t4/2._ki+t2*t6*t3**3*t4/2._ki+t2*t1*t6**2*t3**2/3._ki-t4*t&
+ &2**2*t1**2*t6**2/2._ki-t5*t1**2*t6**2*t3/3._ki-t4*t5**2*t6**2*t1*&
+ &*2/2._ki+2._ki*t2*t4**2*t3**2*t6**2-5._ki/4._ki*t2**2*t4*t3**2*t6**&
+ &2-t2**3*t4*t6*t3**2/2._ki+t2**2*t4**2*t6*t3**2/3._ki-t3**2*t2**3*&
+ &t4*t5/6._ki+t3**2*t2**3*t6**2/4._ki-4._ki/3._ki*t3*t4**2*t5*t6**2*t&
+ &1-t3*t2**2*t5**2*t1*t6/3._ki-2._ki/3._ki*t3*t5*t2**3*t1*t6-2._ki/3.&
+ &_ki*t3*t2**2*t6**2*t5*t1+t3**2*t2**5/12._ki
+ !
+ stemp5=stemp6-t2**3*t3**3/6._ki-2._ki/3._ki*t3*t2**3*t6**2*t1-t3*t2*&
+ &*4*t1*t6/3._ki+t2*t5**2*t1**2*t6**2/2._ki+t3**2*t4**2*t5*t2*t6/3.&
+ &_ki+t3*t4*t5**2*t2*t1*t6/3._ki+2._ki*t2**2*t4*t1*t6**2*t3+t3**2*t2&
+ &**4*t6/6._ki-t6*t3**3*t2**2/3._ki-t4**3*t3**2*t6**2-t4*t3**2*t2**&
+ &4/12._ki-t2**2*t5*t3**3/6._ki+t2**3*t1**2*t6**2/2._ki+t3**2*t2**4*&
+ &t5/6._ki-4._ki/3._ki*t2*t4**2*t1*t6**2*t3+2._ki/3._ki*t4*t3*t5*t2**2&
+ &*t1*t6-t4*t5*t2*t6**2*t1**2+t4*t3*t2**3*t1*t6/3._ki+t2*t5*t1*t6*&
+ &t3**2/2._ki+2._ki*t3*t4*t5*t2*t6**2*t1-t4*t5*t3**2*t6*t2**2/2._ki-&
+ &t3**2*t4*t5**2*t2**2/12._ki
+ !
+ stemp6=1._ki/t3**2/t2**5*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)
+ !
+ stemp4=stemp5*stemp6
+ !
+ stemp7=-t6**3*t3**2*t2**5/4._ki+3._ki/2._ki*t6**2*t1*t3*t2**3*t4**3-&
+ &3._ki*t6**2*t1*t3*t2**4*t4**2-t6*t1**2*t2**4*t5*t3/9._ki-44._ki/3.&
+ &_ki*t6**3*t1*t3*t4**4*t5-77._ki/2._ki*t6**3*t1*t2**2*t4*t3**2+20._k&
+ &i*t6**3*t1**2*t3*t5*t4**2+15._ki/2._ki*t6**3*t1**2*t3*t2**2*t5-3.&
+ &_ki/4._ki*t6**2*t1**2*t3*t2**3*t4+15._ki/8._ki*t6**2*t1*t3*t2**5*t4&
+ &-t6*t1**2*t2**5*t4*t5/3._ki-t6*t1**2*t2**4*t4*t5**2/6._ki+77._ki/6&
+ &._ki*t6**3*t1*t3*t2**3*t5*t4+110._ki/3._ki*t6**3*t1*t3*t4**3*t5*t2&
+ &+66._ki*t6**3*t1*t2*t4**2*t3**2-7._ki/18._ki*t6*t1*t2**6*t3*t5-33.&
+ &_ki*t6**3*t1*t3*t2**2*t5*t4**2-t1*t3**2*t2**6/36._ki+t6*t1**2*t2*&
+ &*7/6._ki-25._ki*t6**3*t1**2*t3*t4*t5*t2-11._ki/6._ki*t6**3*t1*t3*t5&
+ &*t2**4+7._ki/6._ki*t6*t1*t2**6*t4*t3-2._ki/3._ki*t6*t1*t4*t3**2*t2*&
+ &*4-7._ki/9._ki*t6*t1*t2**5*t4**2*t3+4._ki*t6**3*t3**2*t4**5
+ !
+ stemp6=stemp7-7._ki/36._ki*t1*t2**8*t3-7._ki/9._ki*t6*t1*t2**4*t3*t4*&
+ &*2*t5+7._ki/6._ki*t6*t1*t2**5*t3*t4*t5+5._ki/36._ki*t1*t2**6*t3*t4*&
+ &t5+7._ki/36._ki*t1*t2**5*t3*t4*t5**2-t6*t1**2*t2**5*t3/9._ki-3._ki/&
+ &8._ki*t6**2*t2**6*t1*t3+t6*t1**2*t5*t2**6/3._ki+t6*t1**2*t2**5*t5&
+ &**2/6._ki-7._ki/18._ki*t6*t1*t3*t2**7-t6**3*t3*t5*t1**3+25._ki/2._ki&
+ &*t6**3*t1**2*t4*t3**2-15._ki/2._ki*t6**3*t1**2*t2*t3**2-110._ki/3.&
+ &_ki*t6**3*t1*t4**3*t3**2+9._ki/4._ki*t6**3*t4*t3**2*t2**4+22._ki/3.&
+ &_ki*t6**3*t1*t3**2*t2**3+14._ki*t6**3*t3**2*t2**2*t4**3+t6**2*t1*&
+ &*2*t3*t2**4/2._ki-8._ki*t6**3*t3**2*t2**3*t4**2-12._ki*t6**3*t3**2&
+ &*t4**4*t2-t6*t1**2*t2**6*t4/6._ki+2._ki/9._ki*t1*t2**5*t3**2*t5+7.&
+ &_ki/36._ki*t1*t2**7*t3*t4+4._ki/9._ki*t6*t1*t2**5*t3**2-7._ki/36._ki*&
+ &t1*t2**6*t3*t5**2-5._ki/36._ki*t1*t3*t2**7*t5
+ !
+ stemp7=1._ki/t1/t2**8/t3
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp2=(-18._ki*t6**3*t1*t2+36._ki*t6**3*t1*t4-18._ki*t6**3*t2**2*t4&
+ &+3._ki*t5**3*t2**3+6._ki*t5**2*t2**4+3._ki*t5*t2**5+2._ki*t6**2*t2*&
+ &*4+t2**5*t6+3._ki*t6**3*t2**3-24._ki*t6**3*t4**3+36._ki*t6**3*t4**&
+ &2*t2-4._ki*t6**2*t1*t2**2-6._ki*t6**2*t2**2*t3+8._ki*t6**2*t2**2*t&
+ &4**2-8._ki*t6**2*t2**3*t4+3._ki*t6**2*t5*t2**3+3._ki*t6*t2**3*t5**&
+ &2+4._ki*t6*t2**4*t5-2._ki*t6*t2**4*t4-4._ki*t6*t3*t2**3-6._ki*t6**2&
+ &*t1*t5*t2-12._ki*t6**2*t5*t2**2*t4+12._ki*t6**2*t5*t2*t4**2+12._ki&
+ &*t6**2*t2*t3*t4-6._ki*t6*t4*t5**2*t2**2-8._ki*t6*t2**3*t4*t5-6._ki&
+ &*t6*t2**2*t3*t5)/t2**6*z_log(t1*t6/t2**2,1._ki)/12._ki
+ !
+ stemp6=t1**3*t6**3*t5**3+2._ki*t3**3*t6**3*t4**3-t3**3*t6*t2**5/12&
+ &._ki-3._ki/2._ki*t6**2*t5*t2*t1*t3**3-3._ki/2._ki*t2*t3*t1**2*t6**3*&
+ &t5**2+t2**2*t3**2*t1*t6**2*t5**2+4._ki*t3**2*t1*t6**3*t5*t4**2+t&
+ &2**2*t3**2*t1*t6*t5**3-3._ki/2._ki*t2*t3*t1**2*t6**2*t5**3+3._ki*t&
+ &3*t1**2*t6**3*t4*t5**2+t2**2*t3**2*t1*t6**3*t5-4._ki*t2*t3**2*t1&
+ &*t6**3*t5*t4-2._ki*t2*t3**2*t1*t6**2*t4*t5**2+t2**2*t3**3*t6**2*&
+ &t5*t4-t2*t3**3*t6**2*t5*t4**2+t2**2*t3**3*t6*t4*t5**2/2._ki+4._ki&
+ &*t6**3*t1**2*t3*t4*t5*t2+2._ki/3._ki*t3**3*t2**3*t6*t4*t5+t3*t2**&
+ &2*t6**3*t4*t1**2-2._ki/3._ki*t3**2*t2**3*t1*t6**2*t4-3._ki/2._ki*t3&
+ &*t2**3*t1**2*t6**2*t5+t3**2*t2**4*t1*t6*t5+2._ki*t5**2*t2*t1**3*&
+ &t6**3+2._ki/3._ki*t3**3*t2**3*t6**2*t4-t3**3*t2**4*t6*t5/3._ki-2._k&
+ &i/3._ki*t3**3*t2**2*t6**2*t4**2-t3*t2**3*t6**3*t1**2/2._ki+t3**2*&
+ &t2**4*t1*t6**2/3._ki
+ !
+ stemp5=stemp6+t3**3*t2**4*t6*t4/6._ki+t6*t5*t2**2*t3**4/2._ki-3._ki*&
+ &t2*t3**3*t6**3*t4**2+3._ki/2._ki*t2**2*t3**3*t6**3*t4+t3**3*t6**3&
+ &*t1*t4+t2**2*t1**3*t6**3*t5+t6**3*t5*t1**2*t3**2-t2**3*t3**3*t6&
+ &*t5**2/4._ki-t2**3*t3**3*t6**2*t5/4._ki+2._ki/3._ki*t6**3*t1**2*t2*&
+ &t3**2+2._ki/3._ki*t6**3*t1*t3**2*t2**3-t3**3*t2*t6**3*t1/2._ki-t3*&
+ &*4*t2*t6**2*t4-t6**2*t2**2*t1*t3**3-t3**3*t5**2*t2**4/2._ki-8._ki&
+ &/3._ki*t6**3*t1*t2**2*t4*t3**2-2._ki*t6**3*t1**2*t3*t2**2*t5+8._ki&
+ &/3._ki*t6**3*t1*t2*t4**2*t3**2-t3**3*t2**5*t5/4._ki-t2**3*t3**3*t&
+ &5**3/4._ki-t3**3*t2**4*t6**2/6._ki+4._ki/3._ki*t3**2*t2**3*t6**2*t5&
+ &*t1-8._ki/3._ki*t3**2*t2**2*t6**2*t4*t5*t1-3._ki*t3*t5**2*t2**2*t1&
+ &**2*t6**2+2._ki*t3**2*t5**2*t2**3*t1*t6+t6*t2**3*t3**4/3._ki+t3**&
+ &4*t2**2*t6**2/2._ki-t2**3*t3**3*t6**3/4._ki
+ !
+ stemp6=1._ki/t2**6/t3**3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)
+ !
+ stemp4=stemp5*stemp6
+ !
+ stemp7=11._ki/24._ki*t6**3*t2**3*t3**2-11._ki/3._ki*t6**3*t3**2*t4**3&
+ &-11._ki/12._ki*t6**2*t2**2*t3**3+17._ki/36._ki*t6**2*t3**2*t2**4+5.&
+ &_ki/18._ki*t6*t2**5*t3**2+t6**2*t1*t2*t5*t3**2/12._ki+4._ki/3._ki*t6&
+ &**2*t1*t3*t4*t5*t2**2+t6**2*t1*t2**3*t3*t4/3._ki-t6**2*t1*t5**2*&
+ &t3*t2**2/2._ki+t6**2*t1**2*t5*t2**3/3._ki+t6**2*t1**2*t2*t5**3/3.&
+ &_ki-t6**2*t1*t2**4*t3/6._ki-17._ki/9._ki*t6**2*t2**3*t3**2*t4+11._ki&
+ &/6._ki*t6**2*t2*t3**3*t4+17._ki/24._ki*t6**2*t2**3*t3**2*t5+17._ki/&
+ &9._ki*t6**2*t3**2*t4**2*t2**2-5._ki/4._ki*t6**3*t1*t3**2*t2+5._ki/2&
+ &._ki*t6**3*t3**2*t1*t4+11._ki/2._ki*t6**3*t3**2*t2*t4**2
+ !
+ stemp6=stemp7-11._ki/4._ki*t6**3*t2**2*t3**2*t4+2._ki/3._ki*t6**2*t1*&
+ &*2*t5**2*t2**2+t3**2*t2**2*t1*t6**2/18._ki-7._ki/6._ki*t6*t3**3*t2&
+ &**2*t5+5._ki/6._ki*t6*t3**2*t2**3*t5**2-5._ki/9._ki*t6*t2**4*t3**2*&
+ &t4+10._ki/9._ki*t6*t2**4*t3**2*t5+17._ki/8._ki*t3**2*t2**4*t5**2+17&
+ &._ki/6._ki*t6**2*t2*t3**2*t4**2*t5-17._ki/6._ki*t6**2*t3**2*t4*t5*t&
+ &2**2-4._ki/3._ki*t6*t1*t3*t2**3*t5**2-2._ki/3._ki*t6*t1*t5*t2**4*t3&
+ &-2._ki/3._ki*t6*t1*t3*t2**2*t5**3-20._ki/9._ki*t6*t3**2*t2**3*t4*t5&
+ &-5._ki/3._ki*t6*t3**2*t2**2*t4*t5**2-2._ki/3._ki*t6**2*t1*t2**3*t3*&
+ &t5+t6**2*t1*t2*t3*t4*t5**2+11._ki/12._ki*t2**5*t3**2*t5-7._ki/9._ki&
+ &*t3**3*t2**3*t6+11._ki/12._ki*t3**2*t2**3*t5**3
+ !
+ stemp7=1._ki/t3**2/t2**6
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4_glob)
+ !
+ case(2)
+ !
+ stemp5=95._ki*t6**3*t3**2*t4**3+7._ki/12._ki*t6**2*t4**2*t2**6+6._ki*&
+ &t6**2*t4*t5*t3*t2**4-30._ki*t6**2*t4**2*t5*t3*t2**3+36._ki*t6**2*&
+ &t4**3*t5*t3*t2**2+15._ki*t6**2*t4*t5**2*t3*t2**3+10._ki*t6**2*t1*&
+ &t4*t5**3*t2**2+6._ki*t6**2*t1*t4*t5**2*t2**3-25._ki*t6**2*t1*t4**&
+ &2*t5**3*t2-t6*t4**2*t2**7/4._ki-t4**2*t5*t2**7/12._ki-5._ki*t6**2*&
+ &t2**2*t3**3+20._ki*t6**3*t4**5*t5**2-t4*t3*t2**7/6._ki-t6**3*t4**&
+ &2*t2**5/4._ki+3._ki/2._ki*t6**3*t4**3*t2**4-3._ki/4._ki*t6**3*t1**2*&
+ &t2**3+2._ki*t6**3*t4**5*t2**2+7._ki/3._ki*t6**2*t4**4*t2**4-60._ki*&
+ &t6**2*t3**2*t4*t5*t2**2+3._ki/2._ki*t6**2*t3**2*t2**4-30._ki*t6**3&
+ &*t1*t4**2*t5*t2**2+6._ki*t6**3*t1*t4*t5*t2**3+75._ki*t6**3*t4**2*&
+ &t3*t5*t2**2+10._ki*t6**2*t1*t2**3*t3*t4+15._ki*t6**2*t1*t5**2*t3*&
+ &t2**2
+ !
+ stemp4=195._ki/2._ki*t6**2*t2*t3**2*t4**2*t5+90._ki*t6**2*t4**3*t5**&
+ &2*t3*t2-15._ki*t6**2*t1*t4**2*t5**2*t2**2-75._ki*t6**2*t4**2*t5**&
+ &2*t3*t2**2+6._ki*t6**2*t1*t2**3*t3*t5-15._ki*t6**2*t1*t2*t5*t3**2&
+ &-24._ki*t6**2*t1*t3*t4*t5*t2**2-t6*t4*t2**6*t1/2._ki+30._ki*t6**3*&
+ &t2**2*t3**2*t4+3._ki/2._ki*t6**2*t1**2*t5**2*t2**2-3._ki*t3**2*t2*&
+ &*2*t1*t6**2+15._ki/2._ki*t6**3*t1*t4**2*t2**3-60._ki*t6**2*t1*t2*t&
+ &3*t4*t5**2-10._ki*t6**3*t4*t3*t5*t2**3-15._ki*t6**3*t1*t3*t5*t2**&
+ &2-12._ki*t6**3*t1**2*t5*t2*t4+25._ki/2._ki*t6**2*t1*t4**2*t5*t2**3&
+ &+stemp5+15._ki*t6**2*t2*t3**3*t4+15._ki/2._ki*t6**2*t2**3*t3**2*t5&
+ &+39._ki/2._ki*t6**2*t3**2*t4**2*t2**2+15._ki*t6**3*t1*t3**2*t2-45.&
+ &_ki*t6**3*t3**2*t1*t4-5._ki/4._ki*t6**2*t4**2*t5*t2**5+5._ki*t6**2*&
+ &t4**3*t5*t2**4-5._ki*t6**2*t4**4*t5*t2**3-15._ki*t6**2*t4**3*t3*t&
+ &2**3
+ !
+ stemp5=stemp4-5._ki/2._ki*t6**2*t4*t3*t2**5-6._ki*t6**2*t4**3*t5**2*&
+ &t2**3+6._ki*t6**2*t4**4*t5**2*t2**2+3._ki/2._ki*t6**2*t4**2*t5**2*&
+ &t2**4-10._ki*t6**2*t4**3*t5**3*t2**2+10._ki*t6**2*t4**4*t5**3*t2+&
+ &5._ki/2._ki*t6**2*t4**2*t5**3*t2**3-35._ki/6._ki*t6**2*t1*t4**2*t2*&
+ &*4+7._ki/3._ki*t6**2*t1*t4*t2**5-5._ki/4._ki*t6**2*t1**2*t5*t2**3+5&
+ &._ki/2._ki*t6**2*t1**2*t2*t5**3-5._ki/2._ki*t6**2*t1*t2**4*t3-12._ki&
+ &*t6**2*t2**3*t3**2*t4-195._ki/2._ki*t6**3*t3**2*t2*t4**2-5._ki*t6*&
+ &*2*t1*t4*t5*t2**4-180._ki*t6**3*t4**3*t3*t5*t2+120._ki*t6**3*t1*t&
+ &3*t5*t2*t4-15._ki*t6**3*t1*t4*t5**2*t2**2+36._ki*t6**3*t1*t4**3*t&
+ &5*t2+39._ki*t6**3*t1*t2*t3*t4**2-195._ki*t6**3*t1*t4**2*t3*t5+75.&
+ &_ki*t6**3*t1*t4**2*t5**2*t2-24._ki*t6**3*t1*t2**2*t3*t4-t4**2*t2*&
+ &*8/12._ki-3._ki/2._ki*t6**3*t1*t4*t2**4
+ !
+ stemp3=stemp5-90._ki*t6**3*t1*t4**3*t5**2+3._ki*t6**3*t1*t2**3*t3+1&
+ &5._ki*t6**3*t1**2*t3*t5+3._ki*t6**3*t1**2*t2**2*t4-28._ki*t6**3*t4&
+ &**4*t3*t2-15._ki*t6**3*t4**2*t3*t2**3-30._ki*t6**3*t4**4*t5**2*t2&
+ &+36._ki*t6**3*t4**3*t3*t2**2+2._ki*t6**3*t4*t3*t2**4+15._ki*t6**3*&
+ &t4**3*t5**2*t2**2-9._ki*t6**3*t1*t4**3*t2**2-8._ki*t6**3*t4**5*t5&
+ &*t2-5._ki/2._ki*t6**3*t4**2*t5**2*t2**3-6._ki*t6**3*t4**3*t5*t2**3&
+ &+12._ki*t6**3*t4**4*t5*t2**2+t6**3*t4**2*t5*t2**4+140._ki*t6**3*t&
+ &4**4*t3*t5+30._ki*t6**3*t1**2*t5**2*t4-15._ki/2._ki*t6**3*t1**2*t5&
+ &**2*t2-3._ki*t6**3*t1**2*t2*t3+3._ki*t6**3*t1**2*t5*t2**2+25._ki/2&
+ &._ki*t6**2*t4**2*t3*t2**4-3._ki*t6**3*t4**4*t2**3+7._ki/12._ki*t1**&
+ &2*t2**4*t6**2-7._ki/3._ki*t6**2*t4**3*t2**5+t6*t4**3*t2**6/2._ki-5&
+ &._ki/2._ki*t6**3*t2**3*t3**2
+ !
+ stemp4=1._ki/t2**10*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=-(-t2**2*t3*t4+4._ki*t4*t2*t1*t6-3._ki*t6*t4*t2*t3+6._ki*t4**&
+ &2*t3*t6-2._ki*t3**2*t2+2._ki*t3*t1*t6+4._ki*t4*t1*t6*t5-t3*t5*t2*t&
+ &4)*t4/t2**4/t3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/12._ki
+ !
+ stemp9=-25._ki/2._ki*t6**3*t1**4*t4*t5**2*t2**2+22._ki*t6**3*t1**3*t&
+ &4**4*t5*t2**2-t1**3*t4**2*t2**8/9._ki+t6**2*t1**2*t4*t3**2*t2**5&
+ &-14._ki*t6**2*t1**2*t4**4*t3**2*t2**2-55._ki/3._ki*t6**3*t1**3*t4*&
+ &t3*t5*t2**3-45._ki*t6**3*t1**2*t4**3*t3**2*t2**2-8._ki*t6**3*t1**&
+ &2*t4**5*t3*t2**2-45._ki*t6**2*t1**3*t4**2*t5*t3*t2**3+54._ki*t6**&
+ &2*t1**3*t4**3*t5*t3*t2**2+15._ki*t6**2*t1**3*t4**4*t5**3*t2-5._ki&
+ &/4._ki*t6**3*t1**2*t4**2*t5*t2**4*t3-5._ki/12._ki*t6**2*t1*t2**5*t&
+ &3**3*t4-5._ki/8._ki*t6**2*t1*t4**2*t3**2*t2**5*t5-25._ki/2._ki*t6**&
+ &3*t1**4*t3*t5*t2**2+70._ki/3._ki*t6**2*t1*t4**4*t3**3*t2**2+25._ki&
+ &/6._ki*t6**2*t1*t2**4*t3**3*t4**2-15._ki/2._ki*t6**2*t1**4*t4**2*t&
+ &5**2*t2**2-5._ki/2._ki*t6**2*t1**4*t4*t5*t2**4-25._ki/2._ki*t6**2*t&
+ &1**4*t4**2*t5**3*t2
+ !
+ stemp8=stemp9+25._ki/4._ki*t6**2*t1**4*t4**2*t5*t2**3+5._ki*t6**2*t1&
+ &**4*t4*t5**3*t2**2+3._ki*t6**2*t1**4*t2**3*t3*t5-2._ki*t6**2*t1*t&
+ &4**6*t3**2*t2**2+4._ki*t6**2*t1*t4**5*t3**2*t2**3+t6**2*t1*t3**2&
+ &*t4**3*t2**5-10._ki*t6**3*t1*t4**5*t3**2*t2**2-4._ki*t6**3*t1**5*&
+ &t5*t2*t4+10._ki*t6**3*t1*t4**6*t3**2*t2+5._ki*t6**3*t1*t4**4*t3**&
+ &2*t2**3-t6**3*t1**5*t2**3/4._ki+15._ki/4._ki*t6**2*t1**3*t4**2*t5*&
+ &*3*t2**3+45._ki/2._ki*t6**2*t1**3*t4*t5**2*t3*t2**3-325._ki/2._ki*t&
+ &6**3*t1**4*t4**2*t3*t5+100._ki*t6**3*t1**4*t3*t5*t2*t4+15._ki/2._k&
+ &i*t6**2*t1**3*t4**3*t5*t2**4-15._ki/2._ki*t6**2*t1**3*t4**4*t5*t2&
+ &**3+5._ki*t6**2*t1*t4**3*t3**2*t5*t2**4-3._ki*t6**2*t1*t4**4*t3**&
+ &2*t2**4-95._ki/3._ki*t6**2*t1**2*t3**3*t4**3*t2+65._ki/2._ki*t6**2*&
+ &t1**2*t3**3*t4**2*t2**2
+ !
+ stemp9=20._ki*t6**2*t1*t4**5*t3**2*t5*t2**2-15._ki/8._ki*t6**2*t1**3&
+ &*t4**2*t5*t2**5-t6**2*t1*t4**2*t3**2*t2**6/8._ki+117._ki/4._ki*t6*&
+ &*2*t1**3*t3**2*t2**2*t4**2-18._ki*t6**2*t1**3*t3**2*t2**3*t4-15.&
+ &_ki*t6**2*t1**3*t4**3*t5**3*t2**2+125._ki/2._ki*t6**3*t1**4*t4**2*&
+ &t5**2*t2-6._ki*t6**2*t1**2*t4**3*t5*t3*t2**4-5._ki/4._ki*t6**3*t1*&
+ &t4**3*t3**2*t2**4-20._ki*t6**2*t1**2*t4**5*t3*t5**2*t2-70._ki*t6*&
+ &*2*t1**2*t3**2*t4**4*t5*t2+5._ki*t6**2*t1**4*t2**3*t3*t4-12._ki*t&
+ &6**2*t1**4*t2**2*t3*t4*t5-30._ki*t6**2*t1**4*t5**2*t3*t2*t4+55._k&
+ &i*t6**3*t1**3*t4*t3**2*t2**2+11._ki/3._ki*t6**3*t1**3*t4*t3*t2**4&
+ &+770._ki/3._ki*t6**3*t1**3*t4**4*t3*t5+11._ki/6._ki*t6**3*t1**3*t4*&
+ &*2*t5*t2**4-330._ki*t6**3*t1**3*t4**3*t3*t5*t2-715._ki/4._ki*t6**3&
+ &*t1**3*t3**2*t4**2*t2+9._ki*t6**2*t1**3*t4*t5*t3*t2**4
+ !
+ stemp7=stemp9+9._ki/4._ki*t6**2*t1**3*t4**2*t5**2*t2**4-44._ki/3._ki*&
+ &t6**3*t1**3*t4**5*t5*t2-15._ki*t6**2*t1**2*t4**3*t3*t5**2*t2**3+&
+ &10._ki/3._ki*t6**2*t1**2*t4**5*t3*t2**3-15._ki/2._ki*t6**2*t1**2*t4&
+ &**2*t3**2*t2**4+12._ki*t6**2*t1**2*t4**4*t5*t3*t2**3+90._ki*t6**2&
+ &*t1**2*t3**2*t4**3*t5*t2**2+3._ki*t6**2*t1**4*t4*t5**2*t2**3-15.&
+ &_ki/2._ki*t6**2*t1**4*t3**2*t5*t2+15._ki/2._ki*t6**2*t1**4*t5**2*t3&
+ &*t2**2+5._ki*t6**3*t1**5*t3*t5+10._ki*t6**3*t1**5*t5**2*t4-5._ki/2&
+ &._ki*t6**3*t1**5*t5**2*t2+t6**3*t1**5*t5*t2**2-t6**3*t1**5*t2*t3&
+ &-15._ki/2._ki*t6**3*t1**4*t4**3*t2**2+25._ki/4._ki*t6**3*t1**4*t4**&
+ &2*t2**3-5._ki/4._ki*t6**3*t1**4*t4*t2**4-75._ki/2._ki*t6**3*t1**4*t&
+ &3**2*t4-75._ki*t6**3*t1**4*t4**3*t5**2+stemp8
+ !
+ stemp9=stemp7+5._ki/2._ki*t6**3*t1**4*t2**3*t3+25._ki/2._ki*t6**3*t1*&
+ &*4*t3**2*t2+11._ki/4._ki*t6**3*t1**3*t4**3*t2**4+11._ki/3._ki*t6**3&
+ &*t1**3*t4**5*t2**2-55._ki/12._ki*t6**3*t1**3*t3**2*t2**3+110._ki/3&
+ &._ki*t6**3*t1**3*t4**5*t5**2+1045._ki/6._ki*t6**3*t1**3*t3**2*t4**&
+ &3-11._ki/24._ki*t6**3*t1**3*t4**2*t2**5-11._ki/2._ki*t6**3*t1**3*t4&
+ &**4*t2**3-15._ki/2._ki*t6**2*t1**3*t3**3*t2**2-35._ki/12._ki*t6**2*&
+ &t1**4*t4**2*t2**4-5._ki/4._ki*t6**2*t1**4*t2**4*t3-3._ki/2._ki*t6**&
+ &2*t1**4*t3**2*t2**2+5._ki/6._ki*t6**2*t1**2*t3**3*t2**4+10._ki/3._k&
+ &i*t6**2*t4**4*t3**3*t2**4-20._ki/3._ki*t6**2*t4**5*t3**3*t2**3+20&
+ &._ki/3._ki*t6**2*t4**6*t3**3*t2**2-8._ki/3._ki*t6**2*t4**7*t3**3*t2&
+ &+7._ki/6._ki*t6**2*t1**4*t4*t2**5+7._ki/8._ki*t6**2*t1**3*t4**2*t2*&
+ &*6
+ !
+ stemp8=stemp9+7._ki/2._ki*t6**2*t1**3*t4**4*t2**4-7._ki/2._ki*t6**2*t&
+ &1**3*t4**3*t2**5+9._ki/4._ki*t6**2*t1**3*t3**2*t2**4+t6*t1**3*t4*&
+ &*3*t2**6/2._ki-t6*t1**3*t4**2*t2**7/4._ki+t6**2*t2**6*t3**3*t4**2&
+ &/12._ki+t6**3*t1**5*t2**2*t4-10._ki*t6**2*t1*t4**6*t3**2*t5*t2-15&
+ &._ki*t6**2*t1*t4**4*t3**2*t5*t2**3-15._ki*t6**2*t1*t2**3*t3**3*t4&
+ &**3+5._ki/2._ki*t6**2*t1**2*t4**2*t3*t5**2*t2**4-8._ki*t6**2*t1**2&
+ &*t4**5*t5*t3*t2**2+5._ki*t6**2*t1**2*t4*t3**2*t5*t2**4-10._ki*t6*&
+ &*2*t1**2*t4*t3**3*t2**3-5._ki/12._ki*t6**2*t1**2*t4**2*t3*t2**6-5&
+ &._ki*t6**2*t1**2*t4**4*t3*t2**4+18._ki*t6**2*t1**2*t4**3*t3**2*t2&
+ &**3+5._ki/2._ki*t6**2*t1**2*t4**3*t3*t2**5-55._ki*t6**3*t1**3*t4**&
+ &4*t5**2*t2+55._ki/2._ki*t6**3*t1**3*t4**3*t5**2*t2**2+275._ki/2._ki&
+ &*t6**3*t1**3*t4**2*t3*t5*t2**2
+ !
+ stemp9=stemp8+40._ki*t6**3*t1**2*t4**5*t3*t5*t2+t6**3*t1**2*t4**2*&
+ &t3*t2**5/4._ki-5._ki/4._ki*t6**3*t1**2*t4*t3**2*t2**4-225._ki/2._ki*&
+ &t6**2*t1**3*t4**2*t5**2*t3*t2**2+135._ki*t6**2*t1**3*t4**3*t5**2&
+ &*t3*t2+5._ki*t6**3*t1**4*t4*t5*t2**3+45._ki/4._ki*t6**2*t1**3*t2**&
+ &3*t3**2*t5+75._ki/4._ki*t6**2*t1**3*t4**2*t3*t2**4-55._ki/12._ki*t6&
+ &**3*t1**3*t4**2*t5**2*t2**3-55._ki/2._ki*t6**3*t1**3*t4**2*t3*t2*&
+ &*3+66._ki*t6**3*t1**3*t4**3*t3*t2**2-154._ki/3._ki*t6**3*t1**3*t4*&
+ &*4*t3*t2+t6**3*t1*t4**2*t3**2*t2**5/8._ki+30._ki*t6**3*t1**4*t4**&
+ &3*t5*t2+65._ki/2._ki*t6**3*t1**4*t2*t3*t4**2-11._ki*t6**3*t1**3*t4&
+ &**3*t5*t2**3-5._ki/6._ki*t6**2*t2**5*t3**3*t4**3-t1**3*t4**2*t5*t&
+ &2**7/9._ki+585._ki/4._ki*t6**2*t1**3*t3**2*t5*t2*t4**2-90._ki*t6**2&
+ &*t1**3*t3**2*t5*t2**2*t4
+ !
+ stemp6=stemp9-45._ki/2._ki*t6**2*t1**3*t4**3*t3*t2**3-15._ki/4._ki*t6&
+ &**2*t1**3*t4*t3*t2**5+45._ki/2._ki*t6**2*t1**3*t3**3*t2*t4-9._ki*t&
+ &6**2*t1**3*t4**3*t5**2*t2**3-75._ki/2._ki*t6**2*t1**2*t3**2*t4**2&
+ &*t5*t2**3+30._ki*t6**2*t1**2*t4**4*t3*t5**2*t2**2-40._ki/3._ki*t6*&
+ &*2*t1*t4**5*t3**3*t2-2._ki*t6**3*t1**2*t4**3*t3*t2**4+25._ki/2._ki&
+ &*t6**3*t1**2*t4**2*t3**2*t2**3-20._ki*t6**3*t1**2*t4**6*t3*t5+4.&
+ &_ki*t6**3*t1**2*t4**6*t3*t2+6._ki*t6**3*t1**2*t4**4*t3*t2**3+t6**&
+ &2*t1**2*t4**2*t5*t3*t2**5-30._ki*t6**3*t1**2*t4**4*t3*t5*t2**2+1&
+ &0._ki*t6**3*t1**2*t4**3*t3*t5*t2**3-20._ki*t6**3*t1**4*t2**2*t3*t&
+ &4-25._ki*t6**3*t1**4*t4**2*t5*t2**2-t1**3*t4*t3*t2**7/18._ki-40._k&
+ &i*t6**3*t1**2*t4**5*t3**2-4._ki*t6**3*t1*t4**7*t3**2+9._ki*t6**2*&
+ &t1**3*t4**4*t5**2*t2**2+70._ki*t6**3*t1**2*t4**4*t3**2*t2
+ !
+ stemp7=1._ki/t1**3/t2**10
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(3)
+ !
+ stemp5=54._ki*t6**3*t1*t4**2*t5*t2**2-24._ki*t6**3*t1*t4*t5*t2**3-t&
+ &6*t1*t2**7/4._ki+7._ki/12._ki*t6**2*t4*t2**7+3._ki/4._ki*t6*t4**2*t2&
+ &**7+t6**3*t2**5*t3-3._ki/4._ki*t6**3*t1*t2**5-t6**3*t4*t2**6/4._ki&
+ &+t4**2*t2**8/12._ki+10._ki*t6**2*t4*t3*t2**5+12._ki*t6**2*t4**3*t5&
+ &**2*t2**3+3._ki*t6**3*t1*t5*t2**4-15._ki/2._ki*t6**3*t1*t5**2*t2**&
+ &3-5._ki/4._ki*t6**2*t2**6*t4*t5+3._ki/2._ki*t6**2*t4*t5**2*t2**5+5.&
+ &_ki/2._ki*t6**2*t4*t5**3*t2**4+10._ki*t6**3*t2**3*t3**2+3._ki/2._ki*&
+ &t6**3*t1**2*t2**3-9._ki/2._ki*t6**3*t4**3*t2**4-7._ki/3._ki*t6**2*t&
+ &4**4*t2**4-2._ki*t6**3*t4**5*t2**2+45._ki*t6**3*t3**2*t1*t4-135._k&
+ &i/2._ki*t6**3*t2**2*t3**2*t4+3._ki*t3**2*t2**2*t1*t6**2-3._ki/2._ki&
+ &*t6**2*t1**2*t5**2*t2**2-30._ki*t6**2*t1*t5**2*t3*t2**2+280._ki*t&
+ &6**3*t4**3*t3*t5*t2-195._ki*t6**3*t4**2*t3*t5*t2**2-195._ki/2._ki*&
+ &t6**2*t2*t3**2*t4**2*t5-195._ki*t6**3*t1*t3*t5*t2*t4+195._ki/2._ki&
+ &*t6**2*t3**2*t4*t5*t2**2+60._ki*t6**3*t1*t4*t5**2*t2**2
+ !
+ stemp4=-25._ki/2._ki*t6**2*t1*t4**2*t5*t2**3-20._ki*t6**3*t4**5*t5**&
+ &2-95._ki*t6**3*t3**2*t4**3+stemp5-36._ki*t6**3*t1*t4**3*t5*t2-39.&
+ &_ki*t6**3*t1*t2*t3*t4**2-15._ki*t6**2*t1*t4*t5**2*t2**3-25._ki*t6*&
+ &*2*t1*t4*t5**3*t2**2-t4*t2**9/12._ki+15._ki*t6**2*t1*t4**2*t5**2*&
+ &t2**2-24._ki*t6**2*t4*t5*t3*t2**4-15._ki/2._ki*t6**2*t4**2*t5**2*t&
+ &2**4+20._ki*t6**2*t4**3*t5**3*t2**2-10._ki*t6**2*t4**4*t5**3*t2-2&
+ &5._ki/2._ki*t6**2*t4**2*t5**3*t2**3+t6**3*t4*t5*t2**5+35._ki/6._ki*&
+ &t6**2*t1*t4**2*t2**4+t6*t4*t2**6*t1/2._ki+3._ki*t6**2*t3*t5*t2**5&
+ &+6._ki*t6**3*t1*t4*t2**4+90._ki*t6**3*t1*t4**3*t5**2-9._ki*t6**3*t&
+ &1*t2**3*t3-15._ki*t6**3*t1**2*t3*t5-3._ki*t6**3*t1**2*t2**2*t4-27&
+ &._ki/2._ki*t6**3*t1*t4**2*t2**3+135._ki*t6**2*t4**2*t5**2*t3*t2**2&
+ &+25._ki/2._ki*t6**2*t1*t4*t5*t2**4+12._ki*t6**3*t1**2*t5*t2*t4-90.&
+ &_ki*t6**2*t4**3*t5**2*t3*t2-140._ki*t6**3*t4**4*t3*t5-30._ki*t6**3&
+ &*t1**2*t5**2*t4+15._ki*t6**3*t1**2*t5**2*t2+3._ki*t6**3*t1**2*t2*&
+ &t3
+ !
+ stemp5=stemp4-5._ki*t6**3*t3*t2**4*t5-5._ki/2._ki*t6**3*t4*t5**2*t2*&
+ &*4+25._ki*t6**2*t1*t4**2*t5**3*t2-6._ki*t6**3*t1**2*t5*t2**2+25._k&
+ &i/4._ki*t6**2*t4**2*t5*t2**5-10._ki*t6**2*t4**3*t5*t2**4+5._ki*t6*&
+ &*2*t4**4*t5*t2**3+15._ki*t6**2*t4**3*t3*t2**3-45._ki/2._ki*t6**2*t&
+ &4**2*t3*t2**4+3._ki*t6**2*t1*t5**2*t2**4-5._ki/2._ki*t6**2*t1*t5*t&
+ &2**5+5._ki*t6**2*t1*t5**3*t2**3+15._ki/2._ki*t6**2*t3*t5**2*t2**4-&
+ &6._ki*t6**2*t4**4*t5**2*t2**2+39._ki/2._ki*t6**2*t2**3*t3**2*t4+28&
+ &5._ki/2._ki*t6**3*t3**2*t2*t4**2-15._ki*t6**2*t2*t3**3*t4-45._ki/2.&
+ &_ki*t6**2*t2**3*t3**2*t5-39._ki/2._ki*t6**2*t3**2*t4**2*t2**2-45._k&
+ &i/2._ki*t6**3*t1*t3**2*t2+54._ki*t6**2*t4**2*t5*t3*t2**3+60._ki*t6&
+ &**2*t1*t2*t3*t4*t5**2-36._ki*t6**2*t4**3*t5*t3*t2**2+28._ki*t6**3&
+ &*t4**4*t3*t2+50._ki*t6**3*t4**4*t5**2*t2-56._ki*t6**3*t4**3*t3*t2&
+ &**2-11._ki*t6**3*t4*t3*t2**4-45._ki*t6**3*t4**3*t5**2*t2**2+39._ki&
+ &*t6**3*t4**2*t3*t2**3-60._ki*t6**2*t4*t5**2*t3*t2**3+t4**2*t5*t2&
+ &**7/12._ki
+ !
+ stemp3=stemp5+15._ki*t6**2*t1*t2*t5*t3**2+55._ki*t6**3*t4*t3*t5*t2*&
+ &*3+15._ki/2._ki*t6**2*t2**2*t3**3+t4*t3*t2**7/6._ki+45._ki*t6**3*t1&
+ &*t3*t5*t2**2-5._ki/4._ki*t6**2*t3*t2**6+7._ki/6._ki*t6**2*t1*t2**6+&
+ &9._ki*t6**3*t1*t4**3*t2**2+8._ki*t6**3*t4**5*t5*t2+35._ki/2._ki*t6*&
+ &*3*t4**2*t5**2*t2**3+18._ki*t6**3*t4**3*t5*t2**3-20._ki*t6**3*t4*&
+ &*4*t5*t2**2-7._ki*t6**3*t4**2*t5*t2**4+195._ki*t6**3*t1*t4**2*t3*&
+ &t5+24._ki*t6**2*t1*t3*t4*t5*t2**2-t6*t4**3*t2**6/2._ki-10._ki*t6**&
+ &2*t1*t2**3*t3*t4-35._ki/6._ki*t6**2*t1*t4*t2**5-135._ki*t6**3*t1*t&
+ &4**2*t5**2*t2+39._ki*t6**3*t1*t2**2*t3*t4-t4*t2**8*t5/12._ki-9._ki&
+ &/2._ki*t6**2*t3**2*t2**4+5._ki/4._ki*t6**2*t1**2*t5*t2**3-5._ki/2._k&
+ &i*t6**2*t1**2*t2*t5**3+5._ki*t6**2*t1*t2**4*t3-35._ki/12._ki*t6**2&
+ &*t4**2*t2**6+5._ki*t6**3*t4**4*t2**3-t3*t2**8/12._ki+7._ki/4._ki*t6&
+ &**3*t4**2*t2**5+14._ki/3._ki*t6**2*t4**3*t2**5-12._ki*t6**2*t1*t2*&
+ &*3*t3*t5-7._ki/12._ki*t1**2*t2**4*t6**2-t6*t4*t2**8/4._ki
+ !
+ stemp4=1._ki/t2**10*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=-(t4**2*t3*t2**2-4._ki*t4**2*t2*t1*t6+9._ki*t4**2*t3*t6*t2+t&
+ &3*t4**2*t2*t5+4._ki*t4*t2**2*t1*t6+2._ki*t4*t3**2*t2-t4*t3*t2**3-&
+ &t3**2*t2**2+4._ki*t4*t2*t1*t6*t5-4._ki*t4**2*t5*t1*t6-2._ki*t4*t3*&
+ &t1*t6-6._ki*t3*t4**3*t6+t3*t2*t1*t6-t4*t3*t5*t2**2-3._ki*t4*t3*t6&
+ &*t2**2)/t2**4/t3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/12._ki
+ !
+ stemp9=143._ki/2._ki*t6**3*t1**3*t4**2*t3*t2**3+385._ki/12._ki*t6**3*&
+ &t1**3*t4**2*t5**2*t2**3-308._ki/3._ki*t6**3*t1**3*t4**3*t3*t2**2-&
+ &5._ki/4._ki*t6**2*t1**4*t5*t2**5-45._ki/4._ki*t6**3*t1**4*t4**2*t2*&
+ &*3+5._ki*t6**3*t1**4*t4*t2**4+75._ki/2._ki*t6**3*t1**4*t3**2*t4+75&
+ &._ki*t6**3*t1**4*t4**3*t5**2-15._ki/2._ki*t6**3*t1**4*t2**3*t3-585&
+ &._ki/4._ki*t6**2*t1**3*t3**2*t5*t2*t4**2+45._ki/2._ki*t6**2*t1**3*t&
+ &4**3*t3*t2**3+39._ki/2._ki*t6**2*t1**2*t4**2*t3**2*t2**4-20._ki*t6&
+ &**2*t1**2*t4**4*t5*t3*t2**3+15._ki/2._ki*t6**2*t1**4*t3**2*t5*t2+&
+ &45._ki/4._ki*t6**2*t1**3*t3*t5**2*t2**4+585._ki/4._ki*t6**2*t1**3*t&
+ &3**2*t5*t2**2*t4-15._ki*t6**2*t1**3*t4**4*t5**3*t2+15._ki*t6**2*t&
+ &1**3*t4*t3*t2**5-45._ki/2._ki*t6**2*t1**3*t3**3*t2*t4-5._ki/12._ki*&
+ &t6**2*t1**2*t4*t3*t2**7+154._ki/3._ki*t6**3*t1**3*t4**4*t3*t2-15.&
+ &_ki*t6**2*t1**4*t5**2*t3*t2**2+18._ki*t6**2*t1**3*t4**3*t5**2*t2*&
+ &*3-55._ki/12._ki*t6**3*t1**3*t4*t5**2*t2**4+5._ki/2._ki*t6**2*t1**2&
+ &*t2**5*t3**2*t5
+ !
+ stemp8=-135._ki/4._ki*t6**2*t1**3*t4**2*t3*t2**4-135._ki/4._ki*t6**2*&
+ &t1**3*t2**3*t3**2*t5-60._ki*t6**3*t1**2*t4**5*t3*t5*t2+75._ki/8._k&
+ &i*t6**2*t1**3*t4**2*t5*t2**5-140._ki*t6**2*t1**2*t3**2*t4**3*t5*&
+ &t2**2-15._ki*t6**2*t1**3*t4**3*t5*t2**4+15._ki/2._ki*t6**2*t1**3*t&
+ &4**4*t5*t2**3-9._ki*t6**2*t1**3*t4**4*t5**2*t2**2+195._ki/2._ki*t6&
+ &**2*t1**2*t3**2*t4**2*t5*t2**3+70._ki*t6**3*t1**2*t4**4*t3*t5*t2&
+ &**2+9._ki/2._ki*t6**2*t1**3*t3*t5*t2**5+20._ki*t6**3*t1*t4**5*t3**&
+ &2*t2**2-14._ki*t6**3*t1**2*t4**4*t3*t2**3-100._ki*t6**3*t1**2*t4*&
+ &*4*t3**2*t2-5._ki/4._ki*t6**3*t1**2*t4*t5*t2**5*t3+t6**3*t1**2*t4&
+ &*t3*t2**6/4._ki-40._ki*t6**3*t1**2*t4**3*t3*t5*t2**3-11._ki/2._ki*t&
+ &6**2*t1**2*t4*t3**2*t2**5-6._ki*t6**2*t1**4*t2**3*t3*t5-325._ki/2&
+ &._ki*t6**3*t1**4*t3*t5*t2*t4-85._ki/6._ki*t6**2*t1*t2**4*t3**3*t4*&
+ &*2-20._ki*t6**2*t1*t4**3*t3**2*t5*t2**4-5._ki*t6**2*t1**4*t2**3*t&
+ &3*t4+35._ki/12._ki*t6**2*t1*t2**5*t3**3*t4-75._ki/4._ki*t6**2*t1**3&
+ &*t4**2*t5**3*t2**3+stemp9
+ !
+ stemp9=-50._ki*t6**2*t1**2*t4**4*t3*t5**2*t2**2+14._ki*t6**2*t1**2*&
+ &t4**4*t3**2*t2**2-90._ki*t6**2*t1**3*t4*t5**2*t3*t2**3+40._ki/3._k&
+ &i*t6**2*t1*t4**5*t3**3*t2+12._ki*t6**2*t1**4*t2**2*t3*t4*t5+9._ki&
+ &/4._ki*t6**2*t1**3*t4*t5**2*t2**5+7._ki*t6**2*t1**3*t4**3*t2**5-2&
+ &7._ki/4._ki*t6**2*t1**3*t3**2*t2**4-t6*t1**3*t4**3*t2**6/2._ki+3._k&
+ &i/4._ki*t6*t1**3*t4**2*t2**7-25._ki/4._ki*t6**3*t1**4*t5**2*t2**3-&
+ &15._ki/8._ki*t6**2*t1**3*t3*t2**6+3._ki/2._ki*t6**2*t1**4*t5**2*t2*&
+ &*4+5._ki/2._ki*t6**2*t1**4*t5**3*t2**3+45._ki*t6**2*t1**2*t4**3*t3&
+ &*t5**2*t2**3-75._ki/4._ki*t6**3*t1**4*t3**2*t2-t6**3*t1**5*t2**2*&
+ &t4-10._ki*t6**3*t1**5*t5**2*t4+5._ki*t6**3*t1**5*t5**2*t2-2._ki*t6&
+ &**3*t1**5*t5*t2**2+t6**3*t1**5*t2*t3+15._ki/2._ki*t6**3*t1**4*t4*&
+ &*3*t2**2+40._ki*t6**3*t1**2*t4**5*t3**2+30._ki*t6**2*t1**4*t5**2*&
+ &t3*t2*t4-11._ki/12._ki*t6**2*t2**6*t3**3*t4**2
+ !
+ stemp7=stemp9-5._ki/24._ki*t6**2*t1*t2**6*t3**3+25._ki/6._ki*t6**2*t2&
+ &**5*t3**3*t4**3+11._ki/6._ki*t6**3*t1**3*t2**5*t3+95._ki/3._ki*t6**&
+ &2*t1**2*t3**3*t4**3*t2+7._ki*t6**2*t1*t4**4*t3**2*t2**4+45._ki/4.&
+ &_ki*t6**3*t1**2*t4**2*t5*t2**4*t3+t1**3*t4*t3*t2**7/18._ki-t1**3*&
+ &t4*t2**8*t5/9._ki+5._ki/2._ki*t6**3*t1**4*t5*t2**4-10._ki/3._ki*t6**&
+ &2*t1**2*t3**3*t2**4-5._ki/8._ki*t6**2*t1*t4*t3**2*t2**6*t5+2._ki*t&
+ &6**2*t1*t4**6*t3**2*t2**2+4._ki*t6**3*t1**5*t5*t2*t4-35._ki/2._ki*&
+ &t6**2*t1**2*t4**2*t3*t5**2*t2**4-5._ki/8._ki*t6**3*t1**4*t2**5+8.&
+ &_ki*t6**2*t1**2*t4**5*t5*t3*t2**2-11._ki/8._ki*t6**3*t1*t4**2*t3**&
+ &2*t2**5-6._ki*t6**2*t1*t4**5*t3**2*t2**3-55._ki/6._ki*t6**3*t1**3*&
+ &t3*t2**4*t5-15._ki/2._ki*t6**2*t1**2*t4**3*t3*t2**5-95._ki/2._ki*t6&
+ &**2*t1**2*t3**3*t4**2*t2**2-t6**2*t1*t4*t3**2*t2**7/8._ki-14._ki*&
+ &t6**3*t1*t4**6*t3**2*t2+18._ki*t6**2*t1**2*t4**3*t5*t3*t2**4-7._k&
+ &i*t6**2*t1**2*t4**2*t5*t3*t2**5+stemp8
+ !
+ stemp9=stemp7+4._ki*t6**3*t1*t4**7*t3**2-5._ki*t6**3*t1**5*t3*t5+7.&
+ &_ki/8._ki*t6**2*t1**3*t4*t2**7-t6*t1**3*t4*t2**8/4._ki-20._ki*t6**3&
+ &*t1**4*t4*t5*t2**3-30._ki*t6**2*t1*t4**5*t3**2*t5*t2**2-30._ki*t6&
+ &**3*t1**4*t4**3*t5*t2+605._ki/6._ki*t6**3*t1**3*t4*t3*t5*t2**3+45&
+ &._ki/8._ki*t6**2*t1*t4**2*t3**2*t2**5*t5+9._ki/8._ki*t6**2*t1*t4**2&
+ &*t3**2*t2**6+33._ki*t6**3*t1**3*t4**3*t5*t2**3-65._ki/2._ki*t6**3*&
+ &t1**4*t2*t3*t4**2+t6**3*t1*t4*t3**2*t2**6/8._ki+50._ki*t6**3*t1**&
+ &4*t4*t5**2*t2**2+25._ki/4._ki*t6**3*t1*t4**3*t3**2*t2**4+95._ki*t6&
+ &**3*t1**2*t4**3*t3**2*t2**2+10._ki*t6**2*t1*t4**6*t3**2*t5*t2+20&
+ &._ki*t6**2*t1**2*t4**5*t3*t5**2*t2-15._ki*t6**3*t1*t4**4*t3**2*t2&
+ &**3-t1**3*t4*t2**9/9._ki-10._ki*t6**2*t4**4*t3**3*t2**4+40._ki/3._k&
+ &i*t6**2*t4**5*t3**3*t2**3-28._ki/3._ki*t6**2*t4**6*t3**3*t2**2+8.&
+ &_ki/3._ki*t6**2*t4**7*t3**3*t2
+ !
+ stemp8=stemp9-35._ki/12._ki*t6**2*t1**4*t4*t2**5-35._ki/8._ki*t6**2*t&
+ &1**3*t4**2*t2**6-7._ki/2._ki*t6**2*t1**3*t4**4*t2**4-55._ki/2._ki*t&
+ &6**2*t1**2*t4*t3**2*t5*t2**4-4._ki*t6**2*t1*t3**2*t4**3*t2**5+27&
+ &5._ki/3._ki*t6**3*t1**3*t4**4*t5**2*t2-100._ki/3._ki*t6**2*t1*t4**4&
+ &*t3**3*t2**2+44._ki/3._ki*t6**3*t1**3*t4**5*t5*t2-110._ki/3._ki*t6*&
+ &*3*t1**3*t4**4*t5*t2**2-495._ki/4._ki*t6**3*t1**3*t4*t3**2*t2**2+&
+ &35._ki*t6**2*t1*t4**4*t3**2*t5*t2**3+15._ki/2._ki*t6**2*t1**4*t4**&
+ &2*t5**2*t2**2-36._ki*t6**2*t1**3*t4*t5*t3*t2**4+95._ki/3._ki*t6**2&
+ &*t1*t2**3*t3**3*t4**3+75._ki/2._ki*t6**3*t1**4*t3*t5*t2**2+25._ki/&
+ &4._ki*t6**2*t1**4*t4*t5*t2**4-165._ki/2._ki*t6**3*t1**3*t4**3*t5**&
+ &2*t2**2+35._ki/12._ki*t6**2*t1**2*t4**2*t3*t2**6+45._ki/2._ki*t6**2&
+ &*t1**2*t4*t3**3*t2**3+405._ki/2._ki*t6**2*t1**3*t4**2*t5**2*t3*t2&
+ &**2-121._ki/6._ki*t6**3*t1**3*t4*t3*t2**4-135._ki*t6**2*t1**3*t4**&
+ &3*t5**2*t3*t2-770._ki/3._ki*t6**3*t1**3*t4**4*t3*t5+25._ki/2._ki*t6&
+ &**2*t1**4*t4**2*t5**3*t2-9._ki/4._ki*t6**3*t1**2*t4**2*t3*t2**5+1&
+ &2._ki*t6**3*t1**2*t4**5*t3*t2**2
+ !
+ stemp9=stemp8+25._ki/3._ki*t6**2*t1**2*t4**4*t3*t2**4-225._ki/2._ki*t&
+ &6**3*t1**4*t4**2*t5**2*t2+65._ki/2._ki*t6**3*t1**4*t2**2*t3*t4+55&
+ &._ki/6._ki*t6**3*t1**3*t4**4*t2**3+35._ki/12._ki*t6**2*t1**4*t4**2*&
+ &t2**4+5._ki/2._ki*t6**2*t1**4*t2**4*t3+3._ki/2._ki*t6**2*t1**4*t3**&
+ &2*t2**2-5._ki/8._ki*t6**3*t1**2*t3**2*t2**5+t6**2*t1**2*t3**2*t2*&
+ &*6/2._ki+t6**2*t2**7*t3**3*t4/12._ki+t1**3*t4**2*t5*t2**7/9._ki+45&
+ &._ki/4._ki*t6**2*t1**3*t3**3*t2**2-25._ki/4._ki*t6**2*t1**4*t4**2*t&
+ &5*t2**3+7._ki/12._ki*t6**2*t1**4*t2**6+20._ki*t6**3*t1**2*t4**6*t3&
+ &*t5-45._ki/4._ki*t6**2*t1**3*t4**2*t5**2*t2**4-t1**3*t3*t2**8/36.&
+ &_ki-117._ki/4._ki*t6**2*t1**3*t3**2*t2**2*t4**2-28._ki*t6**2*t1**2*&
+ &t4**3*t3**2*t2**3+35._ki/4._ki*t6**3*t1**2*t4*t3**2*t2**4-25._ki/2&
+ &._ki*t6**2*t1**4*t4*t5**3*t2**2+45._ki*t6**3*t1**4*t4**2*t5*t2**2&
+ &-77._ki/6._ki*t6**3*t1**3*t4**2*t5*t2**4+1540._ki/3._ki*t6**3*t1**3&
+ &*t4**3*t3*t5*t2+t6**3*t1**5*t2**3/2._ki
+ !
+ stemp6=stemp9+117._ki/4._ki*t6**2*t1**3*t3**2*t2**3*t4+30._ki*t6**2*&
+ &t1**3*t4**3*t5**3*t2**2+t1**3*t4**2*t2**8/9._ki+8._ki*t6**3*t1**2&
+ &*t4**3*t3*t2**4-85._ki/2._ki*t6**3*t1**2*t4**2*t3**2*t2**3+70._ki*&
+ &t6**2*t1**2*t3**2*t4**4*t5*t2-10._ki/3._ki*t6**2*t1**2*t4**5*t3*t&
+ &2**3-715._ki/2._ki*t6**3*t1**3*t4**2*t3*t5*t2**2-15._ki/2._ki*t6**2&
+ &*t1**4*t4*t5**2*t2**3+11._ki/6._ki*t6**3*t1**3*t4*t5*t2**5+t6**2*&
+ &t1**2*t2**6*t3*t4*t5+325._ki/2._ki*t6**3*t1**4*t4**2*t3*t5+81._ki*&
+ &t6**2*t1**3*t4**2*t5*t3*t2**3-4._ki*t6**3*t1**2*t4**6*t3*t2-54._k&
+ &i*t6**2*t1**3*t4**3*t5*t3*t2**2-15._ki/8._ki*t6**2*t1**3*t2**6*t4&
+ &*t5+1045._ki/4._ki*t6**3*t1**3*t3**2*t4**2*t2-11._ki/24._ki*t6**3*t&
+ &1**3*t4*t2**6-33._ki/4._ki*t6**3*t1**3*t4**3*t2**4-11._ki/3._ki*t6*&
+ &*3*t1**3*t4**5*t2**2+55._ki/3._ki*t6**3*t1**3*t3**2*t2**3-110._ki/&
+ &3._ki*t6**3*t1**3*t4**5*t5**2-1045._ki/6._ki*t6**3*t1**3*t3**2*t4*&
+ &*3+77._ki/24._ki*t6**3*t1**3*t4**2*t2**5+5._ki/2._ki*t6**2*t1**2*t3&
+ &*t5**2*t2**5*t4+15._ki/4._ki*t6**2*t1**3*t4*t5**3*t2**4
+ !
+ stemp7=1._ki/t1**3/t2**10
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp2=(-12._ki*t6**2*t2**4*t4**2+12._ki*t6**2*t2**3*t4**3+t6*t2**6&
+ &*t4+3._ki*t6**2*t2**5*t4-120._ki*t6**3*t3*t4**3+6._ki*t6**3*t3*t2*&
+ &*3+2._ki*t6*t2**5*t3+2._ki*t3*t5*t2**5-18._ki*t6**2*t1*t2**3*t4+2.&
+ &_ki*t6*t2**5*t4*t5-4._ki*t6*t2**4*t4**2*t5-6._ki*t3*t4*t6*t2**4+14&
+ &4._ki*t6**3*t1*t5*t4**2+18._ki*t1*t6**3*t2**2*t5+6._ki*t6**3*t2**3&
+ &*t5*t4-36._ki*t6**3*t2**2*t5*t4**2+72._ki*t6**3*t4**3*t5*t2-36._ki&
+ &*t6**3*t3*t2*t1+90._ki*t6**3*t4*t1*t3-54._ki*t6**3*t3*t2**2*t4+2.&
+ &_ki*t6*t1*t2**4*t5+144._ki*t6**3*t3*t2*t4**2-108._ki*t1*t6**3*t4*t&
+ &5*t2+t3*t2**6+t2**6*t4*t5-2._ki*t6*t2**5*t4**2+t4*t5**2*t2**5+6.&
+ &_ki*t6**2*t1*t2**4-18._ki*t6**3*t1**2*t5+t6*t1*t2**5-48._ki*t6**3*&
+ &t4**4*t5)/t2**8*z_log(t1*t6/t2**2,1._ki)/12._ki
+ !
+ stemp4=(-t3**2*t4*t5**2*t2**2-2._ki*t6*t3**3*t2**2-2._ki*t2**2*t5*t&
+ &3**3-t3**2*t2**3*t4*t5-2._ki*t1**2*t6**2*t3*t2+3._ki*t1*t6*t3**2*&
+ &t2**2-6._ki*t1*t6**2*t3**2*t4+6._ki*t2*t6*t3**3*t4+2._ki*t2*t1*t6*&
+ &*2*t3**2-4._ki*t5*t1**2*t6**2*t3-6._ki*t4*t5**2*t6**2*t1**2+12._ki&
+ &*t2*t4**2*t3**2*t6**2-3._ki*t2**2*t4*t3**2*t6**2-t2**3*t4*t6*t3*&
+ &*2+2._ki*t2**2*t4**2*t6*t3**2+4._ki*t4*t3*t5*t2**2*t1*t6-6._ki*t4*&
+ &t5*t2*t6**2*t1**2+6._ki*t2*t5*t1*t6*t3**2+8._ki*t3*t4*t5*t2*t6**2&
+ &*t1-12._ki*t4**3*t3**2*t6**2-16._ki*t3*t4**2*t5*t6**2*t1+4._ki*t3*&
+ &*2*t4**2*t5*t2*t6+4._ki*t3*t4*t5**2*t2*t1*t6+4._ki*t2**2*t4*t1*t6&
+ &**2*t3-8._ki*t2*t4**2*t1*t6**2*t3-2._ki*t4*t5*t3**2*t6*t2**2-t2**&
+ &3*t3**3)/t3**2/t2**5*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/12._ki
+ !
+ stemp7=3._ki/2._ki*t6**2*t1*t3*t2**3*t4**3-3._ki/2._ki*t6**2*t1*t3*t2&
+ &**4*t4**2-3._ki/4._ki*t6**2*t1**2*t3*t2**3*t4+t1*t3**2*t2**6/9._ki&
+ &+2._ki*t6**3*t3**2*t4**5+7._ki/36._ki*t6*t1*t2**6*t4*t3+7._ki/36._ki&
+ &*t1*t2**6*t3*t4*t5+7._ki/36._ki*t1*t2**5*t3*t4*t5**2-2._ki/3._ki*t6&
+ &*t1*t4*t3**2*t2**4-7._ki/18._ki*t6*t1*t2**5*t4**2*t3-15._ki/2._ki*t&
+ &6**3*t1**2*t3*t4*t5*t2+11._ki/12._ki*t6**3*t1*t3*t2**3*t5*t4-22._k&
+ &i/3._ki*t6**3*t1*t3*t4**4*t5-33._ki/4._ki*t6**3*t1*t2**2*t4*t3**2-&
+ &t6*t1**2*t2**5*t4*t5/6._ki-t6*t1**2*t2**4*t4*t5**2/6._ki-t6*t1**2&
+ &*t2**4*t5*t3/9._ki-7._ki/9._ki*t6*t1*t2**4*t3*t4**2*t5+7._ki/18._ki*&
+ &t6*t1*t2**5*t3*t4*t5
+ !
+ stemp6=stemp7+t6**2*t1**2*t3*t2**4/4._ki-t6**3*t3**2*t2**3*t4**2-4&
+ &._ki*t6**3*t3**2*t4**4*t2+2._ki/9._ki*t1*t2**5*t3**2*t5+2._ki/9._ki*&
+ &t6*t1*t2**5*t3**2-t6*t1**2*t2**5*t3/18._ki-t6**3*t3*t5*t1**3/2._k&
+ &i+25._ki/4._ki*t6**3*t1**2*t4*t3**2-5._ki/2._ki*t6**3*t1**2*t2*t3**&
+ &2-55._ki/3._ki*t6**3*t1*t4**3*t3**2+t6**3*t4*t3**2*t2**4/8._ki+11.&
+ &_ki/12._ki*t6**3*t1*t3**2*t2**3+3._ki*t6**3*t3**2*t2**2*t4**3+10._k&
+ &i*t6**3*t1**2*t3*t5*t4**2+5._ki/4._ki*t6**3*t1**2*t3*t2**2*t5+11.&
+ &_ki*t6**3*t1*t3*t4**3*t5*t2+22._ki*t6**3*t1*t2*t4**2*t3**2-11._ki/&
+ &2._ki*t6**3*t1*t3*t2**2*t5*t4**2+3._ki/8._ki*t6**2*t1*t3*t2**5*t4
+ !
+ stemp7=1._ki/t1/t2**8/t3
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4_glob)
+ !
+ case(3)
+ !
+ stemp5=195._ki/2._ki*t6**2*t2*t3**2*t4**2*t5-135._ki*t6**2*t3**2*t4*&
+ &t5*t2**2+39._ki/2._ki*t6**3*t1*t4**2*t2**3-27._ki/2._ki*t6**3*t1*t4&
+ &*t2**4-45._ki/2._ki*t6**2*t4*t3*t2**5-18._ki*t6**2*t4**3*t5**2*t2*&
+ &*3-12._ki*t6**3*t1*t5*t2**4+30._ki*t6**3*t1*t5**2*t2**3-15._ki*t6*&
+ &*2*t4*t5**3*t2**4-9._ki*t6**2*t1*t5**2*t2**4+15._ki/2._ki*t6**2*t1&
+ &*t5*t2**5-15._ki*t6**2*t1*t5**3*t2**3-30._ki*t6**2*t3*t5**2*t2**4&
+ &+6._ki*t6**2*t4**4*t5**2*t2**2+90._ki*t6**2*t4**3*t5**2*t3*t2-195&
+ &._ki*t6**2*t4**2*t5**2*t3*t2**2-160._ki*t6**3*t4*t3*t5*t2**3-t2**&
+ &9*t5/12._ki+t4*t2**9/6._ki-90._ki*t6**3*t1*t3*t5*t2**2-195._ki*t6**&
+ &3*t1*t4**2*t3*t5+7._ki/12._ki*t6**2*t2**8-5._ki/4._ki*t6**2*t5*t2**&
+ &7+95._ki*t6**3*t3**2*t4**3-t4**2*t5*t2**7/12._ki+t4*t2**8*t5/6._ki&
+ &-10._ki*t6**2*t2**2*t3**3+3._ki/2._ki*t6**2*t5**2*t2**6-45._ki*t6**&
+ &3*t3**2*t1*t4-375._ki/2._ki*t6**3*t3**2*t2*t4**2+120._ki*t6**3*t2*&
+ &*2*t3**2*t4+3._ki/2._ki*t6**2*t1**2*t5**2*t2**2+30._ki*t6**3*t1*t3&
+ &**2*t2-3._ki*t3**2*t2**2*t1*t6**2
+ !
+ stemp4=-12._ki*t6**2*t3*t5*t2**5-25._ki/4._ki*t6**3*t4**2*t2**5-25._k&
+ &i*t6**3*t2**3*t3**2+7._ki/3._ki*t6**2*t4**4*t2**4+195._ki*t6**3*t1&
+ &*t4**2*t5**2*t2-7._ki*t6**3*t4**4*t2**3+54._ki*t6**2*t4*t5*t3*t2*&
+ &*4-9._ki/4._ki*t6**3*t1**2*t2**3-5._ki*t6**3*t2**5*t3+2._ki*t6**3*t&
+ &4**5*t2**2+19._ki/2._ki*t6**3*t4**3*t2**4+t6*t4*t2**8+20._ki*t6**3&
+ &*t4**5*t5**2+39._ki/2._ki*t6**2*t4**2*t5**2*t2**4-30._ki*t6**2*t4*&
+ &*3*t5**3*t2**2+10._ki*t6**2*t4**4*t5**3*t2+65._ki/2._ki*t6**2*t4**&
+ &2*t5**3*t2**3-8._ki*t6**3*t4*t5*t2**5-35._ki/6._ki*t6**2*t1*t4**2*&
+ &t2**4+9._ki*t6**2*t3**2*t2**4-15._ki*t6**2*t1*t4**2*t5**2*t2**2+2&
+ &5._ki*t6**3*t4**2*t5*t2**4+140._ki*t6**3*t4**4*t3*t5+32._ki*t6**3*&
+ &t4*t3*t2**4+95._ki*t6**3*t4**3*t5**2*t2**2+76._ki*t6**3*t4**3*t3*&
+ &t2**2-90._ki*t6**3*t1*t4**3*t5**2+18._ki*t6**3*t1*t2**3*t3-7._ki*t&
+ &6**2*t4**3*t2**5+7._ki/12._ki*t1**2*t2**4*t6**2-54._ki*t6**3*t1*t2&
+ &**2*t3*t4+stemp5+t3*t2**8/6._ki+91._ki/12._ki*t6**2*t4**2*t2**6-20&
+ &._ki*t6**2*t1*t4*t5*t2**4-5._ki/4._ki*t6*t4**2*t2**7
+ !
+ stemp5=54._ki*t6**3*t1*t4*t5*t2**3+t6*t1*t2**7/2._ki-78._ki*t6**3*t1&
+ &*t4**2*t5*t2**2-65._ki/4._ki*t6**2*t4**2*t5*t2**5-5._ki*t6**2*t4**&
+ &4*t5*t2**3-15._ki*t6**2*t4**3*t3*t2**3+30._ki*t6**3*t1**2*t5**2*t&
+ &4-45._ki/2._ki*t6**3*t1**2*t5**2*t2-3._ki*t6**3*t1**2*t2*t3+25._ki*&
+ &t6**3*t3*t2**4*t5+15._ki*t6**2*t4**3*t5*t2**4-7._ki/2._ki*t6**2*t4&
+ &*t2**7-7._ki/2._ki*t6**2*t1*t2**6+t6*t4**3*t2**6/2._ki+5._ki*t6**2*&
+ &t3*t2**6+3._ki*t6**3*t1*t2**5-t6**3*t2**7/4._ki-5._ki/2._ki*t6**3*t&
+ &5**2*t2**5+40._ki*t6**2*t1*t4*t5**3*t2**2+t6**3*t5*t2**6+2._ki*t6&
+ &**3*t4*t2**6+5._ki/2._ki*t6**2*t5**3*t2**5-5._ki/4._ki*t6**2*t1**2*&
+ &t5*t2**3+24._ki*t6**2*t1*t4*t5**2*t2**3-t4*t3*t2**7/6._ki+375._ki*&
+ &t6**3*t4**2*t3*t5*t2**2+15._ki*t6**3*t1**2*t3*t5-28._ki*t6**3*t4*&
+ &*4*t3*t2-75._ki*t6**3*t4**2*t3*t2**3-70._ki*t6**3*t4**4*t5**2*t2+&
+ &15._ki/2._ki*t6**2*t2**6*t4*t5-9._ki*t6**2*t4*t5**2*t2**5+3._ki*t6*&
+ &*3*t1**2*t2**2*t4-60._ki*t6**2*t1*t2*t3*t4*t5**2-380._ki*t6**3*t4&
+ &**3*t3*t5*t2
+ !
+ stemp3=stemp5-t6*t2**9/4._ki+stemp4+5._ki/2._ki*t6**2*t1**2*t2*t5**3&
+ &-15._ki/2._ki*t6**2*t1*t2**4*t3-27._ki*t6**2*t2**3*t3**2*t4+15._ki*&
+ &t6**2*t2*t3**3*t4+45._ki*t6**2*t2**3*t3**2*t5+39._ki/2._ki*t6**2*t&
+ &3**2*t4**2*t2**2-15._ki*t6**2*t1*t2*t5*t3**2-25._ki*t6**2*t1*t4**&
+ &2*t5**3*t2-78._ki*t6**2*t4**2*t5*t3*t2**3+270._ki*t6**3*t1*t3*t5*&
+ &t2*t4-135._ki*t6**3*t1*t4*t5**2*t2**2+36._ki*t6**2*t4**3*t5*t3*t2&
+ &**2+135._ki*t6**2*t4*t5**2*t3*t2**3-12._ki*t6**3*t1**2*t5*t2*t4+3&
+ &6._ki*t6**3*t1*t4**3*t5*t2+39._ki*t6**3*t1*t2*t3*t4**2-24._ki*t6**&
+ &2*t1*t3*t4*t5*t2**2+25._ki/2._ki*t6**2*t1*t4**2*t5*t2**3+10._ki*t6&
+ &**2*t1*t2**3*t3*t4+45._ki*t6**2*t1*t5**2*t3*t2**2-t4**2*t2**8/12&
+ &._ki+28._ki/3._ki*t6**2*t1*t4*t2**5-t6*t4*t2**6*t1/2._ki+18._ki*t6**&
+ &2*t1*t2**3*t3*t5-t2**10/12._ki+20._ki*t6**3*t4*t5**2*t2**4+65._ki/&
+ &2._ki*t6**2*t4**2*t3*t2**4-9._ki*t6**3*t1*t4**3*t2**2-8._ki*t6**3*&
+ &t4**5*t5*t2-125._ki/2._ki*t6**3*t4**2*t5**2*t2**3-38._ki*t6**3*t4*&
+ &*3*t5*t2**3+28._ki*t6**3*t4**4*t5*t2**2+9._ki*t6**3*t1**2*t5*t2**&
+ &2
+ !
+ stemp4=1._ki/t2**10*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=-(-t3*t2**3+4._ki*t2**2*t1*t6+t2**2*t3*t4-3._ki*t3*t6*t2**2-&
+ &t3*t5*t2**2+9._ki*t6*t4*t2*t3+2._ki*t3**2*t2+4._ki*t5*t2*t1*t6+t3*&
+ &t5*t2*t4-4._ki*t4*t2*t1*t6-6._ki*t4**2*t3*t6-4._ki*t4*t1*t6*t5-2._k&
+ &i*t3*t1*t6)*(-t4+t2)/t2**4/t3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)&
+ &/12._ki
+ !
+ stemp9=-5._ki/4._ki*t6**3*t1**2*t2**6*t3*t5-41._ki/8._ki*t6**2*t1*t4*&
+ &*2*t3**2*t2**6+30._ki*t6**3*t1**4*t4**3*t5*t2+65._ki/2._ki*t6**3*t&
+ &1**4*t2*t3*t4**2-81._ki/2._ki*t6**2*t1**3*t3**2*t2**3*t4-t6**2*t1&
+ &*t2**8*t3**2/8._ki-55._ki/6._ki*t6**3*t1**3*t2**5*t3+11._ki/3._ki*t6&
+ &**3*t1**3*t4*t2**6+t6**3*t1**2*t2**7*t3/4._ki+9._ki/4._ki*t6**2*t1&
+ &**3*t5**2*t2**6-55._ki/12._ki*t6**3*t1**3*t5**2*t2**5+11._ki/6._ki*&
+ &t6**3*t1**3*t5*t2**6-45._ki*t6**2*t1**3*t4**3*t5**3*t2**2+16._ki*&
+ &t6**2*t1**2*t4*t3**2*t2**5-40._ki*t6**2*t1**2*t4*t3**3*t2**3-7._k&
+ &i/4._ki*t6**2*t1**4*t2**6+15._ki*t6**2*t1**3*t4**4*t5**3*t2-165._k&
+ &i*t6**3*t1**2*t4**3*t3**2*t2**2+55._ki*t6**2*t1*t4**3*t3**2*t5*t&
+ &2**4-45._ki*t6**2*t1**3*t3*t5**2*t2**4-45._ki/2._ki*t6**2*t1**3*t4&
+ &*t5**3*t2**4+195._ki/4._ki*t6**2*t1**3*t4**2*t5**3*t2**3+405._ki/2&
+ &._ki*t6**2*t1**3*t4*t5**2*t3*t2**3+45._ki/2._ki*t6**2*t1**3*t4**3*&
+ &t5*t2**4+54._ki*t6**2*t1**3*t4**3*t5*t3*t2**2-15._ki/2._ki*t6**2*t&
+ &1**3*t4**4*t5*t2**3+91._ki/8._ki*t6**2*t1**3*t4**2*t2**6
+ !
+ stemp8=7._ki/2._ki*t6**2*t1**3*t4**4*t2**4-21._ki/2._ki*t6**2*t1**3*t&
+ &4**3*t2**5+27._ki/2._ki*t6**2*t1**3*t3**2*t2**4+t6*t1**3*t4**3*t2&
+ &**6/2._ki-5._ki/4._ki*t6*t1**3*t4**2*t2**7+9._ki*t6**2*t1**4*t2**3*&
+ &t3*t5-18._ki*t6**2*t1**3*t3*t5*t2**5-125._ki/12._ki*t6**2*t1*t2**5&
+ &*t3**3*t4+117._ki/4._ki*t6**2*t1**3*t3**2*t2**2*t4**2-40._ki/3._ki*&
+ &t6**2*t1*t4**5*t3**3*t2-13._ki*t6**2*t1*t4**4*t3**2*t2**4+117._ki&
+ &/4._ki*t6**2*t1**3*t4**2*t5**2*t2**4-205._ki/8._ki*t6**2*t1*t4**2*&
+ &t3**2*t2**5*t5+80._ki*t6**2*t1**2*t4*t3**2*t5*t2**4-95._ki/3._ki*t&
+ &6**2*t1**2*t3**3*t4**3*t2+275._ki/6._ki*t6**3*t1**3*t4**2*t5*t2**&
+ &4+110._ki/3._ki*t6**3*t1**3*t4*t5**2*t2**4+125._ki/2._ki*t6**2*t1**&
+ &2*t3**3*t4**2*t2**2-1375._ki/4._ki*t6**3*t1**3*t3**2*t4**2*t2+41.&
+ &_ki/4._ki*t6**3*t1**2*t4**2*t3*t2**5+5._ki*t6**2*t1**4*t2**3*t3*t4&
+ &+45._ki/4._ki*t6**2*t1**3*t2**6*t4*t5-125._ki/4._ki*t6**3*t1**2*t4*&
+ &t3**2*t2**4-125._ki/12._ki*t6**2*t1**2*t4**2*t3*t2**6-35._ki/3._ki*&
+ &t6**2*t1**2*t4**4*t3*t2**4-t1**3*t4*t3*t2**7/18._ki-117._ki*t6**2&
+ &*t1**3*t4**2*t5*t3*t2**3+5._ki/2._ki*t6**3*t1**4*t2**5+stemp9
+ !
+ stemp9=-t1**3*t2**9*t5/9._ki-t1**3*t4**2*t2**8/9._ki+325._ki/2._ki*t6&
+ &**3*t1**4*t4**2*t5**2*t2-75._ki*t6**3*t1**4*t3*t5*t2**2+t1**3*t3&
+ &*t2**8/18._ki-8._ki*t6**2*t1**2*t2**6*t3*t4*t5+38._ki*t6**2*t1**2*&
+ &t4**3*t3**2*t2**3+40._ki*t6**2*t1*t4**5*t3**2*t5*t2**2-45._ki*t6*&
+ &*3*t1**4*t2**2*t3*t4-22._ki*t6**3*t1**2*t4**3*t3*t2**4-16._ki*t6*&
+ &*3*t1**2*t4**5*t3*t2**2+95._ki/6._ki*t6**2*t1**2*t4**3*t3*t2**5+2&
+ &5._ki*t6**2*t1**2*t4**2*t5*t3*t2**5+2._ki/9._ki*t1**3*t4*t2**9-2._k&
+ &i*t6**2*t1*t4**6*t3**2*t2**2+8._ki*t6**2*t1*t4**5*t3**2*t2**3-20&
+ &._ki*t6**2*t1**2*t3*t5**2*t2**5*t4+25._ki/2._ki*t6**3*t1**2*t4*t5*&
+ &t2**5*t3-205._ki/4._ki*t6**3*t1**2*t4**2*t5*t2**4*t3-27._ki/2._ki*t&
+ &6**2*t1**3*t4*t5**2*t2**5-12._ki*t6**2*t1**4*t2**2*t3*t4*t5-30._k&
+ &i*t6**2*t1**4*t5**2*t3*t2*t4-1375._ki/12._ki*t6**3*t1**3*t4**2*t5&
+ &**2*t2**3-38._ki*t6**2*t1**2*t4**3*t5*t3*t2**4-20._ki*t6**2*t1**2&
+ &*t4**5*t3*t5**2*t2+t6**2*t2**8*t3**3/12._ki-65._ki*t6**3*t1**4*t4&
+ &**2*t5*t2**2+stemp8
+ !
+ stemp7=205._ki/2._ki*t6**3*t1**2*t4**2*t3**2*t2**3-20._ki*t6**3*t1**&
+ &2*t4**6*t3*t5-10._ki*t6**2*t1*t4**6*t3**2*t5*t2-15._ki/2._ki*t6**2&
+ &*t1**4*t5**3*t2**3+15._ki/4._ki*t6**2*t1**4*t5*t2**5-21._ki/4._ki*t&
+ &6**2*t1**3*t4*t2**7+t6*t1**3*t4*t2**8+61._ki/12._ki*t6**2*t2**6*t&
+ &3**3*t4**2+5._ki/4._ki*t6**2*t1*t2**6*t3**3-85._ki/6._ki*t6**2*t2**&
+ &5*t3**3*t4**3+15._ki/4._ki*t6**2*t1**3*t5**3*t2**5-15._ki/8._ki*t6*&
+ &*2*t1**3*t5*t2**7-325._ki/2._ki*t6**3*t1**4*t4**2*t3*t5+7._ki/8._ki&
+ &*t6**2*t1**3*t2**8+11._ki*t6**2*t1*t3**2*t4**3*t2**5-275._ki/2._ki&
+ &*t6**3*t1**3*t4**2*t3*t2**3-5._ki/2._ki*t6**3*t1**2*t4*t3*t2**6+1&
+ &30._ki/3._ki*t6**2*t1*t4**4*t3**3*t2**2-44._ki/3._ki*t6**3*t1**3*t4&
+ &*t5*t2**5-3._ki/2._ki*t6**3*t1*t4*t3**2*t2**6+stemp9-3._ki/4._ki*t6&
+ &**3*t1**5*t2**3+4._ki*t6**3*t1**2*t4**6*t3*t2-t6**2*t2**7*t3**3*&
+ &t4-10._ki*t6**3*t1**4*t5*t2**4+25._ki/3._ki*t6**2*t1**2*t3**3*t2**&
+ &4-t1**3*t4**2*t5*t2**7/9._ki+225._ki*t6**3*t1**4*t3*t5*t2*t4-65._k&
+ &i*t6**2*t1*t4**4*t3**2*t5*t2**3
+ !
+ stemp9=stemp7-585._ki/2._ki*t6**2*t1**3*t4**2*t5**2*t3*t2**2-55._ki*&
+ &t6**2*t1*t2**3*t3**3*t4**3-11._ki/24._ki*t6**3*t1**3*t2**7-85._ki/&
+ &4._ki*t6**3*t1*t4**3*t3**2*t2**4+12._ki*t6**2*t1**4*t4*t5**2*t2**&
+ &3-15._ki/2._ki*t6**2*t1**4*t3**2*t5*t2+45._ki/2._ki*t6**2*t1**4*t5*&
+ &*2*t3*t2**2+81._ki*t6**2*t1**3*t4*t5*t3*t2**4-44._ki/3._ki*t6**3*t&
+ &1**3*t4**5*t5*t2-t6*t1**3*t2**9/4._ki+11._ki/3._ki*t6**3*t1**3*t4*&
+ &*5*t2**2+209._ki/12._ki*t6**3*t1**3*t4**3*t2**4-275._ki/6._ki*t6**3&
+ &*t1**3*t3**2*t2**3+110._ki/3._ki*t6**3*t1**3*t4**5*t5**2+1045._ki/&
+ &6._ki*t6**3*t1**3*t3**2*t4**3-275._ki/24._ki*t6**3*t1**3*t4**2*t2*&
+ &*5-77._ki/6._ki*t6**3*t1**3*t4**4*t2**3-75._ki/2._ki*t6**2*t1**2*t4&
+ &**2*t3**2*t2**4-385._ki/3._ki*t6**3*t1**3*t4**4*t5**2*t2+1045._ki/&
+ &6._ki*t6**3*t1**3*t4**3*t5**2*t2**2+t6**3*t1*t3**2*t2**7/8._ki+t6&
+ &**2*t1**2*t5*t2**7*t3+28._ki*t6**2*t1**2*t4**4*t5*t3*t2**3+26._ki&
+ &*t6**3*t1**2*t4**4*t3*t2**3+205._ki/6._ki*t6**2*t1*t2**4*t3**3*t4&
+ &**2+190._ki*t6**2*t1**2*t3**2*t4**3*t5*t2**2
+ !
+ stemp8=stemp9+5._ki/2._ki*t6**2*t1**2*t3*t5**2*t2**6-t1**3*t2**10/9&
+ &._ki+5._ki/4._ki*t6**2*t1*t4*t3**2*t2**7-15._ki*t6**2*t1**3*t3**3*t&
+ &2**2-35._ki/12._ki*t6**2*t1**4*t4**2*t2**4-15._ki/4._ki*t6**2*t1**4&
+ &*t2**4*t3-3._ki/2._ki*t6**2*t1**4*t3**2*t2**2+15._ki/4._ki*t6**3*t1&
+ &**2*t3**2*t2**5-5._ki/2._ki*t6**2*t1**2*t3**2*t2**6-405._ki/2._ki*t&
+ &6**2*t1**3*t3**2*t5*t2**2*t4+135._ki*t6**2*t1**3*t4**3*t5**2*t3*&
+ &t2+585._ki/4._ki*t6**2*t1**3*t3**2*t5*t2*t4**2-34._ki*t6**3*t1*t4*&
+ &*5*t3**2*t2**2+25._ki/4._ki*t6**2*t1*t4*t3**2*t2**6*t5-40._ki*t6**&
+ &3*t1**2*t4**5*t3**2-4._ki*t6**3*t1*t4**7*t3**2+5._ki*t6**3*t1**5*&
+ &t3*t5+t6**3*t1**5*t2**2*t4+10._ki*t6**3*t1**5*t5**2*t4-15._ki/2._k&
+ &i*t6**3*t1**5*t5**2*t2+3._ki*t6**3*t1**5*t5*t2**2-t6**3*t1**5*t2&
+ &*t3-45._ki/2._ki*t6**2*t1**3*t4**3*t3*t2**3+61._ki/8._ki*t6**3*t1*t&
+ &4**2*t3**2*t2**5+1375._ki/2._ki*t6**3*t1**3*t4**2*t3*t5*t2**2+80.&
+ &_ki*t6**3*t1**2*t4**5*t3*t5*t2-4._ki*t6**3*t1**5*t5*t2*t4+18._ki*t&
+ &6**3*t1*t4**6*t3**2*t2
+ !
+ stemp9=stemp8-135._ki/4._ki*t6**2*t1**3*t4*t3*t2**5+275._ki/6._ki*t6*&
+ &*3*t1**3*t3*t2**4*t5+35._ki*t6**3*t1*t4**4*t3**2*t2**3+10._ki/3._k&
+ &i*t6**2*t1**2*t4*t3*t2**7-14._ki*t6**2*t1**2*t4**4*t3**2*t2**2-5&
+ &._ki/8._ki*t6**2*t1*t2**7*t3**2*t5-130._ki*t6**3*t1**2*t4**4*t3*t5&
+ &*t2**2-225._ki/2._ki*t6**3*t1**4*t4*t5**2*t2**2+154._ki/3._ki*t6**3&
+ &*t1**3*t4**4*t5*t2**2-209._ki/3._ki*t6**3*t1**3*t4**3*t5*t2**3-70&
+ &._ki*t6**2*t1**2*t3**2*t4**4*t5*t2-15._ki/2._ki*t6**2*t1**4*t4**2*&
+ &t5**2*t2**2+25._ki*t6**3*t1**4*t5**2*t2**3-5._ki/12._ki*t6**2*t1**&
+ &2*t3*t2**8+15._ki/2._ki*t6**2*t1**3*t3*t2**6-9._ki/2._ki*t6**2*t1**&
+ &4*t5**2*t2**4-25._ki/2._ki*t6**2*t1**2*t2**5*t3**2*t5+418._ki/3._ki&
+ &*t6**3*t1**3*t4**3*t3*t2**2+110._ki*t6**3*t1**2*t4**3*t3*t5*t2**&
+ &3-375._ki/2._ki*t6**2*t1**2*t3**2*t4**2*t5*t2**3+45._ki/2._ki*t6**2&
+ &*t1**3*t3**3*t2*t4+770._ki/3._ki*t6**3*t1**3*t4**4*t3*t5-10._ki*t6&
+ &**2*t1**4*t4*t5*t2**4-25._ki/2._ki*t6**2*t1**4*t4**2*t5**3*t2+10.&
+ &_ki/3._ki*t6**2*t1**2*t4**5*t3*t2**3+220._ki*t6**3*t1**3*t4*t3**2*&
+ &t2**2-154._ki/3._ki*t6**3*t1**3*t4**4*t3*t2
+ !
+ stemp6=stemp9+130._ki*t6**3*t1**2*t4**4*t3**2*t2+70._ki*t6**2*t1**2&
+ &*t4**4*t3*t5**2*t2**2-15._ki/2._ki*t6**3*t1**4*t4**3*t2**2+65._ki/&
+ &4._ki*t6**3*t1**4*t4**2*t2**3-45._ki/4._ki*t6**3*t1**4*t4*t2**4-75&
+ &._ki/2._ki*t6**3*t1**4*t3**2*t4-75._ki*t6**3*t1**4*t4**3*t5**2+15.&
+ &_ki*t6**3*t1**4*t2**3*t3+25._ki*t6**3*t1**4*t3**2*t2+176._ki/3._ki*&
+ &t6**3*t1**3*t4*t3*t2**4-27._ki*t6**2*t1**3*t4**3*t5**2*t2**3+25.&
+ &_ki/4._ki*t6**2*t1**4*t4**2*t5*t2**3+135._ki/2._ki*t6**2*t1**3*t2**&
+ &3*t3**2*t5+195._ki/4._ki*t6**2*t1**3*t4**2*t3*t2**4-195._ki/8._ki*t&
+ &6**2*t1**3*t4**2*t5*t2**5+2._ki/9._ki*t1**3*t4*t2**8*t5+70._ki/3._k&
+ &i*t6**2*t4**4*t3**3*t2**4-68._ki/3._ki*t6**2*t4**5*t3**3*t2**3+12&
+ &._ki*t6**2*t4**6*t3**3*t2**2-8._ki/3._ki*t6**2*t4**7*t3**3*t2+14._k&
+ &i/3._ki*t6**2*t1**4*t4*t2**5-880._ki/3._ki*t6**3*t1**3*t4*t3*t5*t2&
+ &**3-95._ki*t6**2*t1**2*t4**3*t3*t5**2*t2**3-2090._ki/3._ki*t6**3*t&
+ &1**3*t4**3*t3*t5*t2+9._ki*t6**2*t1**3*t4**4*t5**2*t2**2+20._ki*t6&
+ &**2*t1**4*t4*t5**3*t2**2-8._ki*t6**2*t1**2*t4**5*t5*t3*t2**2+45.&
+ &_ki*t6**3*t1**4*t4*t5*t2**3+125._ki/2._ki*t6**2*t1**2*t4**2*t3*t5*&
+ &*2*t2**4
+ !
+ stemp7=1._ki/t1**3/t2**10
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp2=(-6._ki*t6*t2**5*t4*t5+4._ki*t6*t2**4*t4**2*t5+6._ki*t3*t4*t6&
+ &*t2**4+18._ki*t6**2*t1*t2**3*t4-144._ki*t6**3*t1*t5*t4**2-t3*t2**&
+ &6+t5**2*t2**6+3._ki*t6**2*t2**6+t6*t2**7+t5*t2**7-t2**6*t4*t5-t4&
+ &*t5**2*t2**5-12._ki*t6**2*t1*t2**4+18._ki*t6**3*t1**2*t5+6._ki*t6*&
+ &*3*t5*t2**4+2._ki*t6*t2**6*t5-t6*t1*t2**5+48._ki*t6**3*t4**4*t5+2&
+ &4._ki*t6**2*t2**4*t4**2-12._ki*t6**2*t2**3*t4**3-3._ki*t6*t2**6*t4&
+ &+2._ki*t6*t2**5*t4**2-15._ki*t6**2*t2**5*t4+120._ki*t6**3*t3*t4**3&
+ &-90._ki*t6**3*t4*t1*t3-216._ki*t6**3*t3*t2*t4**2+126._ki*t6**3*t3*&
+ &t2**2*t4-2._ki*t6*t1*t2**4*t5-54._ki*t1*t6**3*t2**2*t5-42._ki*t6**&
+ &3*t2**3*t5*t4+108._ki*t6**3*t2**2*t5*t4**2-120._ki*t6**3*t4**3*t5&
+ &*t2+54._ki*t6**3*t3*t2*t1-24._ki*t6**3*t3*t2**3-4._ki*t6*t2**5*t3-&
+ &2._ki*t3*t5*t2**5+180._ki*t1*t6**3*t4*t5*t2)/t2**8*z_log(t1*t6/t2&
+ &**2,1._ki)/12._ki
+ !
+ stemp6=t4*t5*t2*t6**2*t1**2/2._ki+t3**2*t4*t5**2*t2**2/12._ki+t3*t2&
+ &**2*t5**2*t1*t6/3._ki+t3*t5*t2**3*t1*t6/3._ki+t6*t3**3*t2**2/3._ki&
+ &+2._ki/3._ki*t3*t2**2*t6**2*t5*t1+t2**3*t3**3/12._ki-t3**2*t2**3*t&
+ &6**2/4._ki-t2**2*t4*t1*t6**2*t3+2._ki/3._ki*t2*t4**2*t1*t6**2*t3+t&
+ &4*t5*t3**2*t6*t2**2/2._ki+t3**2*t2**3*t4*t5/12._ki+t3*t2**3*t6**2&
+ &*t1/3._ki-t2*t5**2*t1**2*t6**2/2._ki-t2**2*t1**2*t6**2*t5/2._ki-t3&
+ &**2*t5**2*t2**3/12._ki-t3**2*t2**4*t6/12._ki+t4**3*t3**2*t6**2+t2&
+ &**2*t5*t3**3/6._ki
+ !
+ stemp5=stemp6-t3**2*t2**4*t5/12._ki+t1**2*t6**2*t3*t2/6._ki-t1*t6*t&
+ &3**2*t2**2/4._ki-t5*t3**2*t6*t2**3/6._ki+t1*t6**2*t3**2*t4/2._ki-t&
+ &2*t6*t3**3*t4/2._ki-t2*t1*t6**2*t3**2/3._ki+t5*t1**2*t6**2*t3/3._k&
+ &i+t4*t5**2*t6**2*t1**2/2._ki-2._ki*t2*t4**2*t3**2*t6**2+5._ki/4._ki&
+ &*t2**2*t4*t3**2*t6**2+t2**3*t4*t6*t3**2/4._ki-t2**2*t4**2*t6*t3*&
+ &*2/6._ki-t4*t3*t5*t2**2*t1*t6/3._ki-t2*t5*t1*t6*t3**2/2._ki-2._ki*t&
+ &3*t4*t5*t2*t6**2*t1+4._ki/3._ki*t3*t4**2*t5*t6**2*t1-t3**2*t4**2*&
+ &t5*t2*t6/3._ki-t3*t4*t5**2*t2*t1*t6/3._ki
+ !
+ stemp6=1._ki/t3**2/t2**5*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)
+ !
+ stemp4=stemp5*stemp6
+ !
+ stemp7=7._ki/36._ki*t6*t1*t3*t2**7-25._ki/4._ki*t6**3*t1**2*t4*t3**2+&
+ &15._ki/4._ki*t6**3*t1**2*t2*t3**2+55._ki/3._ki*t6**3*t1*t4**3*t3**2&
+ &-9._ki/8._ki*t6**3*t4*t3**2*t2**4-11._ki/3._ki*t6**3*t1*t3**2*t2**3&
+ &-7._ki*t6**3*t3**2*t2**2*t4**3-t6**2*t1**2*t3*t2**4/2._ki+4._ki*t6&
+ &**3*t3**2*t2**3*t4**2+6._ki*t6**3*t3**2*t4**4*t2+t6**3*t3*t5*t1*&
+ &*3/2._ki-4._ki/9._ki*t6*t1*t2**5*t3**2+t6*t1**2*t2**5*t3/18._ki+3._k&
+ &i/8._ki*t6**2*t2**6*t1*t3-t6*t1**2*t5*t2**6/6._ki-2._ki/9._ki*t1*t2&
+ &**5*t3**2*t5+7._ki/36._ki*t1*t2**6*t3*t5**2+7._ki/36._ki*t1*t3*t2**&
+ &7*t5-t6*t1**2*t2**5*t5**2/6._ki+22._ki/3._ki*t6**3*t1*t3*t4**4*t5+&
+ &77._ki/4._ki*t6**3*t1*t2**2*t4*t3**2-10._ki*t6**3*t1**2*t3*t5*t4**&
+ &2-15._ki/4._ki*t6**3*t1**2*t3*t2**2*t5
+ !
+ stemp6=-55._ki/3._ki*t6**3*t1*t3*t4**3*t5*t2+stemp7+t6*t1**2*t2**4*&
+ &t4*t5**2/6._ki+t6*t1**2*t2**4*t5*t3/9._ki+11._ki/12._ki*t6**3*t1*t3&
+ &*t5*t2**4-7._ki/12._ki*t6*t1*t2**6*t4*t3+2._ki/3._ki*t6*t1*t4*t3**2&
+ &*t2**4+7._ki/18._ki*t6*t1*t2**5*t4**2*t3+t6**3*t3**2*t2**5/8._ki-2&
+ &._ki*t6**3*t3**2*t4**5-t1*t3**2*t2**6/9._ki-33._ki*t6**3*t1*t2*t4*&
+ &*2*t3**2+33._ki/2._ki*t6**3*t1*t3*t2**2*t5*t4**2+7._ki/18._ki*t6*t1&
+ &*t2**6*t3*t5-7._ki/6._ki*t6*t1*t2**5*t3*t4*t5+7._ki/9._ki*t6*t1*t2*&
+ &*4*t3*t4**2*t5+3._ki*t6**2*t1*t3*t2**4*t4**2+3._ki/4._ki*t6**2*t1*&
+ &*2*t3*t2**3*t4-15._ki/8._ki*t6**2*t1*t3*t2**5*t4+t6*t1**2*t2**5*t&
+ &4*t5/6._ki-7._ki/36._ki*t1*t2**6*t3*t4*t5-7._ki/36._ki*t1*t2**5*t3*t&
+ &4*t5**2-3._ki/2._ki*t6**2*t1*t3*t2**3*t4**3+25._ki/2._ki*t6**3*t1**&
+ &2*t3*t4*t5*t2-77._ki/12._ki*t6**3*t1*t3*t2**3*t5*t4
+ !
+ stemp7=1._ki/t1/t2**8/t3
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ stemp2=-(-18._ki*t6**3*t1*t2+36._ki*t6**3*t1*t4-24._ki*t6**3*t4**3+3&
+ &._ki*t6**3*t2**3-18._ki*t6**3*t2**2*t4+36._ki*t6**3*t4**2*t2-2._ki*&
+ &t6**2*t1*t2**2-6._ki*t6**2*t1*t5*t2+t6**2*t2**4+3._ki*t6**2*t5*t2&
+ &**3-6._ki*t6**2*t2**2*t3-4._ki*t6**2*t2**3*t4+12._ki*t6**2*t5*t2*t&
+ &4**2+4._ki*t6**2*t2**2*t4**2-12._ki*t6**2*t5*t2**2*t4+12._ki*t6**2&
+ &*t2*t3*t4-6._ki*t6*t4*t5**2*t2**2+3._ki*t6*t2**3*t5**2+2._ki*t6*t2&
+ &**4*t5-4._ki*t6*t2**3*t4*t5-2._ki*t6*t3*t2**3-6._ki*t6*t2**2*t3*t5&
+ &+3._ki*t5**3*t2**3+3._ki*t5**2*t2**4)/t2**6*z_log(t1*t6/t2**2,1._k&
+ &i)/12._ki
+ !
+ stemp6=-2._ki/3._ki*t3**2*t2**3*t6**2*t5*t1-t3**2*t5**2*t2**3*t1*t6&
+ &+3._ki/2._ki*t3*t5**2*t2**2*t1**2*t6**2-2._ki*t6**3*t1**2*t3*t4*t5&
+ &*t2+3._ki/2._ki*t2*t3*t1**2*t6**3*t5**2+3._ki/2._ki*t6**2*t5*t2*t1*&
+ &t3**3-t3**3*t2**3*t6*t4*t5/3._ki-t2**2*t3**2*t1*t6**2*t5**2-4._ki&
+ &*t3**2*t1*t6**3*t5*t4**2-t2**2*t3**3*t6*t4*t5**2/2._ki+t2*t3**3*&
+ &t6**2*t5*t4**2-t2**2*t3**3*t6**2*t5*t4-t2**2*t3**2*t1*t6**3*t5-&
+ &3._ki*t3*t1**2*t6**3*t4*t5**2+3._ki/2._ki*t2*t3*t1**2*t6**2*t5**3-&
+ &t2**2*t3**2*t1*t6*t5**3-2._ki*t3**3*t6**3*t4**3-t1**3*t6**3*t5**&
+ &3+t2**3*t3**3*t6**3/4._ki-t3**4*t2**2*t6**2/2._ki-t6*t2**3*t3**4/&
+ &6._ki+t3**3*t2**4*t6**2/12._ki+t2**3*t3**3*t5**3/4._ki
+ !
+ stemp5=stemp6+t3**3*t5**2*t2**4/4._ki+4._ki/3._ki*t3**2*t2**2*t6**2*&
+ &t4*t5*t1-t6**3*t1*t3**2*t2**3/3._ki-t6**3*t1**2*t2*t3**2/3._ki-3.&
+ &_ki/2._ki*t2**2*t3**3*t6**3*t4+3._ki*t2*t3**3*t6**3*t4**2-t6*t5*t2&
+ &**2*t3**4/2._ki+t3**3*t2**2*t6**2*t4**2/3._ki+t3**3*t2**4*t6*t5/6&
+ &._ki-t3**3*t2**3*t6**2*t4/3._ki-t5**2*t2*t1**3*t6**3+t6**2*t2**2*&
+ &t1*t3**3/2._ki+t3**4*t2*t6**2*t4+t3**3*t2*t6**3*t1/2._ki+t2**3*t3&
+ &**3*t6**2*t5/4._ki+t2**3*t3**3*t6*t5**2/4._ki-t6**3*t5*t1**2*t3**&
+ &2-t3**3*t6**3*t1*t4+4._ki*t2*t3**2*t1*t6**3*t5*t4+2._ki*t2*t3**2*&
+ &t1*t6**2*t4*t5**2+4._ki/3._ki*t6**3*t1*t2**2*t4*t3**2+t6**3*t1**2&
+ &*t3*t2**2*t5-4._ki/3._ki*t6**3*t1*t2*t4**2*t3**2
+ !
+ stemp6=1._ki/t2**6/t3**3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)
+ !
+ stemp4=stemp5*stemp6
+ !
+ stemp5=-(66._ki*t3**2*t2**3*t5**3+48._ki*t6**2*t1*t3*t4*t5*t2**2+72&
+ &._ki*t6**2*t1*t2*t3*t4*t5**2-28._ki*t3**3*t2**3*t6+33._ki*t6**3*t2&
+ &**3*t3**2+66._ki*t3**2*t2**4*t5**2-264._ki*t6**3*t3**2*t4**3-66._k&
+ &i*t6**2*t2**2*t3**3+17._ki*t6**2*t3**2*t2**4-120._ki*t6*t3**2*t2*&
+ &*2*t4*t5**2-68._ki*t6**2*t2**3*t3**2*t4+24._ki*t6**2*t1**2*t2*t5*&
+ &*3+180._ki*t6**3*t3**2*t1*t4-90._ki*t6**3*t1*t3**2*t2+68._ki*t6**2&
+ &*t3**2*t4**2*t2**2+51._ki*t6**2*t2**3*t3**2*t5+132._ki*t6**2*t2*t&
+ &3**3*t4+24._ki*t6**2*t1**2*t5**2*t2**2-198._ki*t6**3*t2**2*t3**2*&
+ &t4+396._ki*t6**3*t3**2*t2*t4**2+40._ki*t6*t2**4*t3**2*t5+60._ki*t6&
+ &*t3**2*t2**3*t5**2-84._ki*t6*t3**3*t2**2*t5+2._ki*t3**2*t2**2*t1*&
+ &t6**2-24._ki*t6**2*t1*t2**3*t3*t5+6._ki*t6**2*t1*t2*t5*t3**2-36._k&
+ &i*t6**2*t1*t5**2*t3*t2**2+204._ki*t6**2*t2*t3**2*t4**2*t5-204._ki&
+ &*t6**2*t3**2*t4*t5*t2**2-48._ki*t6*t1*t3*t2**3*t5**2-48._ki*t6*t1&
+ &*t3*t2**2*t5**3-80._ki*t6*t3**2*t2**3*t4*t5)/t3**2/t2**6/72._ki
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3_glob)
+ !
+ case(2)
+ !
+ select case(par4_glob)
+ !
+ case(2)
+ !
+ stemp6=30._ki*t3*t5**2*t2**2*t1**2*t6**2-60._ki*t3**2*t5**2*t2**3*t&
+ &1*t6+60._ki*t3**2*t2**3*t6**2*t5*t1+480._ki*t6**2*t4**4*t3*t5**2*&
+ &t2**2-80._ki*t6**2*t4**4*t5*t2**3*t3+90._ki*t6**2*t4**2*t3*t5**2*&
+ &t2**4+9._ki*t6**2*t1*t3*t2**4*t4**2-75._ki*t6*t1*t4*t5**4*t2**2*t&
+ &3-3._ki*t6**2*t1*t3*t2**5*t4-30._ki*t6**2*t1*t4*t5*t2**4*t3-540._k&
+ &i*t6**2*t1*t4**2*t3*t5**2*t2**2-720._ki*t6**2*t1*t4**2*t5**3*t2*&
+ &t3+240._ki*t6**2*t1*t4*t5**3*t3*t2**2+180._ki*t6**2*t4*t3**2*t5**&
+ &2*t2**3-120._ki*t6*t1*t4*t5**3*t3*t2**3-120._ki*t6*t4**2*t3*t5**3&
+ &*t2**4-75._ki*t6*t4**2*t5**4*t3*t2**3-36._ki*t6*t4*t5*t2**5*t3**2&
+ &+108._ki*t6*t4**2*t3**2*t5*t2**4-36._ki*t6*t4**2*t5**2*t2**5*t3+9&
+ &._ki*t6**3*t1*t4**2*t5*t2**4-45._ki*t6**3*t4**2*t3*t5**2*t2**3
+ !
+ stemp5=stemp6-20._ki*t3**4*t2**2*t6**2-5._ki*t2**3*t3**3*t6**3-5._ki&
+ &*t1**3*t6**3*t5**3-4._ki*t3**3*t6*t2**5+40._ki*t6**3*t4**6*t5**3-&
+ &t6**2*t4**4*t2**6-50._ki*t2**2*t3**2*t1*t6*t5**3+40._ki*t2*t3*t1*&
+ &*2*t6**2*t5**3+225._ki*t3*t1**2*t6**3*t4*t5**2-45._ki*t2**2*t3**2&
+ &*t1*t6**3*t5+450._ki*t2*t3**2*t1*t6**3*t5*t4-600._ki*t2*t3**2*t1*&
+ &t6**2*t4*t5**2+640._ki*t6**2*t4**4*t3*t5**3*t2-15._ki*t6**2*t4**2&
+ &*t5*t2**5*t3+70._ki*t6**2*t4**3*t5*t2**4*t3-36._ki*t6*t1*t4*t3*t2&
+ &**4*t5**2-150._ki*t6*t4*t5**3*t3**2*t2**3-300._ki*t3**2*t2**2*t6*&
+ &*2*t4*t5*t1+200._ki*t3**3*t2**3*t6*t4*t5-15._ki*t3*t2**2*t6**3*t4&
+ &*t1**2+25._ki*t3**2*t2**3*t1*t6**2*t4-5._ki*t3*t2**3*t1**2*t6**2*&
+ &t5+6._ki*t6*t1*t2**5*t3*t4*t5
+ !
+ stemp6=-3._ki*t6*t1*t2**6*t4*t3-80._ki*t6**2*t5*t2*t1*t3**3-1125._ki&
+ &*t6**3*t4**3*t3**2*t5*t2+405._ki*t6**3*t4**2*t3**2*t5*t2**2-400.&
+ &_ki*t2**2*t3**3*t6**2*t5*t4+60._ki*t6**2*t1*t4**2*t5**4*t2**2+7._k&
+ &i*t6**2*t1*t4**3*t5*t2**4-140._ki*t6**2*t1*t4**3*t5**4*t2-3._ki*t&
+ &6**2*t1*t4**2*t5*t2**5-15._ki*t6**2*t1*t4**2*t5**2*t2**4+60._ki*t&
+ &6**2*t1*t4**2*t5**3*t2**3-140._ki*t6**2*t1*t4**3*t5**3*t2**2-3._k&
+ &i/2._ki*t6**2*t1**2*t4*t5*t2**4-t4**3*t2**9/4._ki+stemp5+30._ki*t6&
+ &**2*t1**2*t4*t5**4*t2-15._ki/2._ki*t6**2*t1**2*t4*t5**2*t2**3+30.&
+ &_ki*t6**2*t1**2*t4*t5**3*t2**2+35._ki*t6**2*t1*t4**3*t5**2*t2**3-&
+ &12._ki*t3**2*t2**4*t1*t6*t5-45._ki*t2*t3*t1**2*t6**3*t5**2+120._ki&
+ &*t2**2*t3**2*t1*t6**2*t5**2-855._ki*t3**2*t1*t6**3*t5*t4**2
+ !
+ stemp4=stemp6-14._ki*t6*t4**3*t5*t3*t2**5+6._ki*t6*t4**2*t5*t3*t2**&
+ &6-180._ki*t6*t4*t3**2*t5**2*t2**4+450._ki*t6*t4**2*t5**3*t3**2*t2&
+ &**2-12._ki*t6*t1*t4**2*t5**3*t2**4+t6**2*t4**3*t2**7/4._ki+315._ki&
+ &*t3**3*t6**3*t4**3+t6**2*t4**5*t2**5+10._ki*t6*t2**3*t3**4+90._ki&
+ &*t6**2*t1*t4**2*t5*t2**3*t3+180._ki*t6**2*t1*t4*t3*t5**2*t2**3+1&
+ &500._ki*t6**2*t4**3*t3**2*t5**2*t2+90._ki*t6**2*t4*t3**2*t5*t2**4&
+ &-540._ki*t6**2*t4**2*t3**2*t5*t2**3-560._ki*t6**2*t4**3*t3*t5**3*&
+ &t2**2+10._ki*t3**3*t2**4*t6**2-1080._ki*t6**2*t4**2*t3**2*t5**2*t&
+ &2**2+750._ki*t6**2*t4**3*t3**2*t5*t2**2+760._ki*t2*t3**3*t6**2*t5&
+ &*t4**2+250._ki*t2**2*t3**3*t6*t4*t5**2+9._ki*t6**3*t1**2*t4*t5*t2&
+ &**3-27._ki*t6**3*t1**2*t4**2*t5*t2**2-45._ki*t6**3*t1**2*t4*t5**3&
+ &*t2+75._ki*t6**3*t1*t2**2*t3*t4**3
+ !
+ stemp6=stemp4-45._ki*t6**3*t3**2*t2**3*t4*t5-135._ki*t6**3*t1*t4*t3&
+ &*t5**2*t2**2+810._ki*t6**3*t1*t4**2*t3*t5**2*t2+315._ki*t6**3*t4*&
+ &*3*t3*t5**2*t2**2-720._ki*t6**3*t4**4*t3*t5**2*t2+t6*t1*t2**5*t3&
+ &**2-100._ki*t3**3*t2**3*t6**2*t4-40._ki*t3**3*t2**4*t6*t5+190._ki*&
+ &t3**3*t2**2*t6**2*t4**2+3._ki*t3*t2**3*t6**3*t1**2-5._ki*t3**2*t2&
+ &**4*t1*t6**2+20._ki*t3**3*t2**4*t6*t4+25._ki*t6*t5*t2**2*t3**4-28&
+ &5._ki*t2*t3**3*t6**3*t4**2+75._ki*t2**2*t3**3*t6**3*t4-105._ki*t3*&
+ &*3*t6**3*t1*t4+84._ki*t6*t4**3*t5**2*t2**4*t3+540._ki*t6*t4**2*t3&
+ &**2*t5**2*t2**3+175._ki*t6*t4**3*t3*t5**4*t2**2+280._ki*t6*t4**3*&
+ &t3*t5**3*t2**3+48._ki*t6**3*t1*t4**4*t5*t2**2-1125._ki*t6**3*t1*t&
+ &4**3*t3*t5**2
+ !
+ stemp5=stemp6+9._ki*t6**3*t1*t2**4*t3*t4-45._ki*t6**3*t1*t4**2*t5**&
+ &3*t2**2-54._ki*t6**3*t1*t2**3*t3*t4**2+210._ki*t6**3*t1*t4**3*t5*&
+ &*3*t2-42._ki*t6**3*t1*t4**3*t5*t2**3-3._ki*t6*t1*t4**2*t2**6*t5+3&
+ &._ki*t6*t1*t4**2*t5**2*t2**5-15._ki*t6*t1*t4**2*t5**5*t2**2-30._ki&
+ &*t6*t1*t4**2*t5**4*t2**3+2._ki*t6**2*t4**4*t5*t2**5-2._ki*t6**2*t&
+ &4**5*t5*t2**4-10._ki*t6**2*t4**5*t5**2*t2**3+10._ki*t6**2*t4**4*t&
+ &5**2*t2**4-5._ki/2._ki*t6**2*t4**3*t5**2*t2**5-36._ki*t6**3*t4**5*&
+ &t3*t2**2-10._ki*t6*t4**3*t5**4*t2**4+20._ki*t6*t4**4*t5**4*t2**3-&
+ &t6*t4**3*t5*t2**7+2._ki*t6*t4**4*t5*t2**6-5._ki*t6*t4**3*t5**5*t2&
+ &**3+10._ki*t6*t4**4*t5**5*t2**2+8._ki*t6*t4**4*t5**3*t2**4-3._ki*t&
+ &6*t4**2*t3*t2**7
+ !
+ stemp6=stemp5-4._ki*t6*t4**3*t5**3*t2**5+7._ki*t6*t4**3*t3*t2**6+3.&
+ &_ki*t6*t4*t3**2*t2**6-9._ki*t6*t4**2*t3**2*t2**5+t6*t4**3*t5**2*t&
+ &2**6-2._ki*t6*t4**4*t5**2*t2**5+120._ki*t6**2*t4**2*t5**3*t3*t2**&
+ &3-420._ki*t6**2*t4**3*t3*t5**2*t2**3+t2**2*t1**3*t6**3*t5+45._ki*&
+ &t6**3*t5*t1**2*t3**2-50._ki*t2**3*t3**3*t6*t5**2+40._ki*t2**3*t3*&
+ &*3*t6**2*t5-t6**2*t1**2*t3*t2**4/2._ki+30._ki*t3**3*t2*t6**3*t1+7&
+ &0._ki*t3**4*t2*t6**2*t4-20._ki*t6**2*t2**2*t1*t3**3+990._ki*t6**3*&
+ &t4**4*t3**2*t5+t6**3*t4**3*t5*t2**5-8._ki*t6**3*t4**6*t5*t2**2-5&
+ &._ki*t6**3*t4**3*t5**3*t2**3+3._ki*t6**3*t4**2*t3*t2**5-60._ki*t6*&
+ &*3*t4**5*t5**3*t2
+ !
+ stemp3=stemp6+30._ki*t6**3*t4**4*t5**3*t2**2-6._ki*t6**3*t4**4*t5*t&
+ &2**4+48._ki*t6**3*t4**4*t3*t2**3-21._ki*t6**3*t4**3*t3*t2**4+540.&
+ &_ki*t6**3*t4**5*t3*t5**2+12._ki*t6**3*t4**5*t5*t2**3+135._ki*t6**3&
+ &*t1**2*t4**2*t5**3-240._ki*t6**3*t1*t4**4*t5**3+3._ki/4._ki*t6**2*&
+ &t1**2*t4*t2**5+3._ki/2._ki*t6**2*t1*t4**2*t2**6-7._ki/2._ki*t6**2*t&
+ &1*t4**3*t2**5-15._ki/2._ki*t6**2*t4*t3**2*t2**5+45._ki*t6**2*t4**2&
+ &*t3**2*t2**4-3._ki/2._ki*t6**2*t4**2*t3*t2**6+7._ki*t6**2*t4**3*t3&
+ &*t2**5+10._ki*t6**2*t4**3*t5**4*t2**3-40._ki*t6**2*t4**4*t5**4*t2&
+ &**2+40._ki*t6**2*t4**5*t5**4*t2-125._ki/2._ki*t6**2*t4**3*t3**2*t2&
+ &**3-8._ki*t6**2*t4**4*t3*t2**4+10._ki*t6**2*t4**3*t5**3*t2**4-40.&
+ &_ki*t6**2*t4**4*t5**3*t2**3+40._ki*t6**2*t4**5*t5**3*t2**2-t6**2*&
+ &t4**3*t5*t2**6/2._ki
+ !
+ stemp4=1._ki/t2**12*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=t4**3/t2**3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/4._ki
+ !
+ stemp10=20._ki*t6*t1**3*t4**4*t3**2*t5*t2**5+80._ki*t6*t1**3*t4**6*&
+ &t3**2*t5*t2**3-420._ki*t6*t1**4*t4**3*t3**2*t5**2*t2**3-600._ki*t&
+ &6*t1**5*t3**3*t5*t2**2*t4+105._ki*t6*t1**5*t4**3*t5*t2**4*t3+180&
+ &._ki*t6*t1**5*t4**2*t5**3*t3*t2**3+960._ki*t6*t1**5*t4**4*t3*t5**&
+ &3*t2-300._ki*t6*t1**6*t4*t3**2*t5**2*t2+135._ki*t6*t1**5*t4*t3**2&
+ &*t5*t2**4+270._ki*t6*t1**5*t4*t3**2*t5**2*t2**3-810._ki*t6*t1**5*&
+ &t4**2*t3**2*t5*t2**3+32._ki*t2**3*t3**5*t4**8-96._ki*t1**4*t4**4*&
+ &t5*t2**4*t3**2+80._ki/3._ki*t1**2*t4**4*t3**3*t5*t2**6+175._ki/3._k&
+ &i*t1**2*t4**3*t3**4*t5*t2**5+400._ki/3._ki*t1**2*t4**6*t3**3*t5**&
+ &2*t2**3+450._ki*t1**4*t4**2*t3**3*t2**3*t5**2-100._ki*t1**2*t4**5&
+ &*t3**3*t5**2*t2**4+100._ki/3._ki*t1**2*t4**4*t3**3*t5**2*t2**5+16&
+ &0._ki/3._ki*t6*t1**2*t2**4*t4**4*t3**4+84._ki*t1**4*t4**3*t5*t2**5&
+ &*t3**2+320._ki*t1**3*t4**4*t3**3*t2**4*t5-240._ki*t1**3*t4**5*t3*&
+ &*3*t2**3*t5+10._ki*t1**3*t4**3*t3**2*t5**2*t2**6-60._ki*t1**3*t4*&
+ &*4*t3**2*t5**2*t2**5-32._ki/3._ki*t6*t1**2*t4**8*t3**3*t2**2
+ !
+ stemp9=40._ki/3._ki*t6*t1**2*t4**5*t3**3*t2**5-176._ki/3._ki*t6*t1**2&
+ &*t4**7*t3**4*t2-1620._ki*t6*t1**5*t4**2*t3**2*t5**2*t2**2+8._ki/3&
+ &._ki*t1**2*t4**4*t3**3*t2**7+135._ki/2._ki*t6*t1**5*t4**2*t3**2*t2&
+ &**4-15._ki/4._ki*t6*t1**5*t4**3*t5**2*t2**5-150._ki*t6*t1**6*t4*t5&
+ &*t3**2*t2**2+40._ki/3._ki*t6*t1**4*t4**3*t5**3*t3*t2**4-80._ki*t6*&
+ &t1**4*t4**4*t5**3*t3*t2**3+60._ki*t6*t1**4*t4**2*t3**2*t5**2*t2*&
+ &*4+40._ki/3._ki*t6*t1**4*t4**6*t3*t2**3*t5+160._ki*t6*t1**4*t4**5*&
+ &t5**3*t3*t2**2-720._ki*t6*t1**4*t4**5*t3**2*t5**2*t2-200._ki/3._ki&
+ &*t1**2*t4**7*t3**3*t5**2*t2**2-80._ki*t1**2*t4**5*t3**3*t5*t2**5&
+ &+2250._ki*t6*t1**5*t4**3*t3**2*t5**2*t2-630._ki*t6*t1**5*t4**3*t3&
+ &*t5**2*t2**3+720._ki*t6*t1**5*t4**4*t3*t5**2*t2**2+15._ki*t6*t1**&
+ &5*t4**3*t5**3*t2**4+t6*t1**2*t4**3*t3**3*t2**7/3._ki-10._ki/3._ki*&
+ &t6*t1**2*t4**4*t3**3*t2**6+80._ki/3._ki*t6*t1**2*t4**7*t3**3*t2**&
+ &3+400._ki/3._ki*t6*t1**2*t4**6*t3**4*t2**2+32._ki*t6*t1*t2**2*t3**&
+ &4*t4**8+4._ki/3._ki*t6*t1**2*t4**3*t5*t2**6*t3**3-40._ki*t6*t1**4*&
+ &t4**4*t3**2*t2**4-90._ki*t6*t1**4*t2**4*t3**3*t4**2+stemp10
+ !
+ stemp10=stemp9-50._ki*t6*t1**4*t3**4*t2**3*t4+120._ki*t6*t1**6*t4*t&
+ &5**3*t3*t2**2+90._ki*t6*t1**6*t4*t3*t5**2*t2**3+5._ki/4._ki*t1*t4*&
+ &*3*t5*t2**7*t3**4-25._ki/2._ki*t1*t4**4*t5*t2**6*t3**4+40._ki*t1*t&
+ &4**7*t3**4*t2**4-44._ki/3._ki*t6**2*t1**5*t4**6*t5*t2**2-11._ki*t6&
+ &**2*t1**5*t4**4*t5*t2**4-110._ki*t6**2*t1**5*t4**5*t5**3*t2+75._k&
+ &i*t6**2*t1**7*t4*t3*t5**2-15._ki*t6**2*t1**7*t3*t5**2*t2+400._ki*&
+ &t1**3*t4**4*t3**3*t5**2*t2**3+25._ki/3._ki*t1**3*t4**3*t3**2*t5**&
+ &3*t2**5-475._ki/2._ki*t1**4*t4**2*t3**4*t5*t2**2-90._ki*t1**4*t4**&
+ &2*t3**2*t5**2*t2**5-20._ki*t1**4*t4**3*t5**3*t3*t2**5+80._ki*t1**&
+ &4*t4**4*t5**3*t3*t2**4+22._ki*t6**2*t1**5*t4**5*t5*t2**3-66._ki*t&
+ &6**2*t1**5*t4**5*t3*t2**2-300._ki*t6**2*t1**4*t4**6*t3**2*t5+t6*&
+ &*2*t1**4*t4**3*t3*t2**6/4._ki-375._ki/2._ki*t6**2*t1**4*t4**3*t3**&
+ &3*t2**2+320._ki/3._ki*t6*t1**2*t4**7*t3**3*t5*t2**2-140._ki*t1**3*&
+ &t4**3*t3**3*t2**5*t5+20._ki*t1**3*t4**2*t3**3*t2**6*t5+120._ki*t1&
+ &**3*t4**5*t3**2*t5**2*t2**4
+ !
+ stemp8=2._ki*t1**3*t3**2*t4**3*t5*t2**7-16._ki*t1**3*t3**2*t4**6*t5&
+ &*t2**4-80._ki*t1**3*t4**6*t3**2*t5**2*t2**3+160._ki/3._ki*t6*t1**2&
+ &*t4**5*t3**3*t5*t2**4-225._ki/2._ki*t1**3*t4**2*t3**4*t2**4*t5-16&
+ &5._ki/2._ki*t6**2*t1**5*t4**2*t3*t5**2*t2**3+3._ki*t6**2*t1**7*t4*&
+ &t5*t2**3-15._ki*t6**2*t1**7*t4*t5**3*t2+675._ki*t6**2*t1**6*t4**2&
+ &*t3*t5**2*t2+55._ki*t6**2*t1**5*t4**4*t5**3*t2**2+990._ki*t6**2*t&
+ &1**5*t4**5*t3*t5**2-40._ki*t2**4*t3**5*t4**7+5._ki/6._ki*t1**3*t3*&
+ &*5*t2**5+2._ki*t4**4*t3**5*t2**7-5._ki*t1**4*t3**4*t2**5+80._ki/3.&
+ &_ki*t2**5*t3**5*t4**6-t4**3*t3**5*t2**8/6._ki-10._ki*t4**5*t3**5*t&
+ &2**6-4._ki*t1**5*t3**3*t2**5+350._ki*t1**4*t4**3*t3**2*t5**3*t2**&
+ &3-80._ki*t1**4*t4**5*t5**3*t3*t2**3-50._ki*t1**4*t4**5*t5**4*t3*t&
+ &2**2-25._ki/2._ki*t1**4*t4**3*t5**4*t3*t2**4-880._ki*t6*t1**4*t4**&
+ &4*t3**3*t5*t2+420._ki*t1**4*t4**3*t3**2*t5**2*t2**4+24._ki*t1**4*&
+ &t4**4*t3*t2**5*t5**2-270._ki*t6*t1**6*t4**2*t3*t5**2*t2**2-15._ki&
+ &*t6*t1**6*t4*t5*t2**4*t3+stemp10
+ !
+ stemp10=stemp8-1425._ki/2._ki*t6**2*t1**6*t4**2*t3**2*t5-45._ki*t6**&
+ &2*t1**6*t2**3*t3*t4**2+70._ki/3._ki*t6*t1**3*t4**3*t3**3*t2**5+t6&
+ &*t1**4*t4**4*t3*t2**6-210._ki*t6*t1**4*t4**3*t3**4*t2-20._ki/3._ki&
+ &*t6*t1**3*t4**6*t3**2*t2**4-1045._ki/2._ki*t6**2*t1**5*t3**3*t4**&
+ &2*t2-5._ki/2._ki*t6*t1**3*t4**2*t3**3*t2**6+30._ki*t6*t1**3*t4**2*&
+ &t3**4*t2**4+5._ki*t6*t1**3*t4**5*t3**2*t2**5-5._ki/3._ki*t6*t1**3*&
+ &t4**4*t3**2*t2**6+5._ki/24._ki*t6*t1**3*t4**3*t3**2*t2**7+21._ki/2&
+ &._ki*t6*t1**5*t4**3*t3*t2**5+15._ki*t6*t1**5*t4**3*t5**4*t2**3+60&
+ &._ki*t6*t1**5*t4**5*t5**4*t2+5._ki*t1**4*t3**5*t2**3+10._ki*t1**5*&
+ &t2**3*t3**4-5._ki*t1*t4**4*t3**4*t2**7+20._ki*t1*t4**5*t3**4*t2**&
+ &6+t1*t4**3*t3**4*t2**8/2._ki+100._ki*t1*t2**3*t3**5*t4**6+2._ki*t1&
+ &**4*t4**4*t3*t2**7-t1**4*t4**3*t3*t2**8/2._ki-35._ki/2._ki*t1**4*t&
+ &3**5*t2**2*t4-2._ki*t1**4*t4**5*t3*t2**6-7._ki*t1**4*t4**3*t3**2*&
+ &t2**6
+ !
+ stemp9=t1**3*t4**4*t3**2*t2**7+5._ki*t1**3*t4*t3**4*t2**6-25._ki/2.&
+ &_ki*t1**3*t3**5*t2**4*t4-40._ki*t1*t4**6*t3**4*t2**5-44._ki*t1*t2*&
+ &*2*t3**5*t4**7+3._ki/4._ki*t1*t2**7*t3**5*t4**2-16._ki*t1*t4**8*t3&
+ &**4*t2**3+7._ki*t1**5*t4**3*t3*t2**6+20._ki*t1**5*t3**3*t2**4*t4-&
+ &4._ki*t1**5*t4**3*t5**3*t2**5+50._ki*t1**4*t4*t3**4*t2**4-25._ki/2&
+ &._ki*t1**4*t3**4*t5*t2**4-9._ki*t1**5*t4**2*t3**2*t2**5+36._ki*t1*&
+ &*4*t4**2*t3**3*t2**5-50._ki*t1**4*t3**3*t4**3*t2**4-2._ki*t1**5*t&
+ &4**4*t5**2*t2**5+95._ki/2._ki*t1**3*t3**5*t2**3*t4**2+125._ki*t1**&
+ &3*t4**3*t3**4*t2**4+4._ki/3._ki*t1**3*t4**6*t3**2*t2**5-110._ki*t1&
+ &**3*t4**4*t3**4*t2**3+2._ki*t1**3*t4**2*t3**3*t2**7-105._ki/2._ki*&
+ &t1**3*t3**5*t2**2*t4**3-t1**3*t4**3*t3**2*t2**8/6._ki-2._ki*t1**3&
+ &*t4**5*t3**2*t2**6-45._ki*t1**3*t4**2*t3**4*t2**5-14._ki*t1**3*t4&
+ &**3*t3**3*t2**6+32._ki*t1**3*t4**4*t3**3*t2**5+stemp10
+ !
+ stemp10=stemp9-24._ki*t1**3*t4**5*t3**3*t2**4+3._ki/4._ki*t6*t1**6*t&
+ &4**2*t2**6+10._ki/3._ki*t6*t1**4*t3**4*t2**4-5._ki/2._ki*t6*t1**6*t&
+ &3**2*t2**4+t6**2*t1**7*t3*t2**3+45._ki*t6**2*t1**7*t4**2*t5**3-1&
+ &75._ki/2._ki*t6**2*t1**6*t3**3*t4+1155._ki/2._ki*t6**2*t1**5*t4**3*&
+ &t3**3+25._ki*t6**2*t1**6*t3**3*t2+15._ki*t6*t1**5*t4**4*t5**2*t2*&
+ &*4-15._ki*t6*t1**5*t4**5*t5**2*t2**3-120._ki*t6*t1**5*t4**4*t5*t2&
+ &**3*t3+135._ki*t6*t1**5*t4**2*t3*t5**2*t2**4+1125._ki*t6*t1**5*t4&
+ &**3*t3**2*t5*t2**2-165._ki/2._ki*t6**2*t1**5*t3**2*t2**3*t4*t5-77&
+ &._ki/2._ki*t6**2*t1**5*t4**3*t3*t2**4+1815._ki*t6**2*t1**5*t4**4*t&
+ &3**2*t5+11._ki/2._ki*t6**2*t1**5*t4**2*t3*t2**5+25._ki*t1**3*t4**2&
+ &*t3**3*t5**2*t2**5-500._ki*t1**4*t4**3*t3**3*t5*t2**3+625._ki/2._k&
+ &i*t1**3*t4**3*t3**4*t2**3*t5-625._ki*t1**4*t4**3*t3**3*t5**2*t2*&
+ &*2+50._ki*t1**4*t4**4*t5**4*t3*t2**3-400._ki*t1**4*t4**4*t3**2*t5&
+ &**3*t2**2-18._ki*t1**4*t4**2*t5*t2**6*t3**2-480._ki*t1**4*t4**4*t&
+ &3**2*t5**2*t2**3
+ !
+ stemp7=-500._ki/3._ki*t1**2*t4**6*t3**4*t5*t2**2-160._ki/3._ki*t1**2*&
+ &t4**7*t3**3*t5*t2**3+8._ki*t1**4*t4**4*t3**2*t2**5-40._ki*t1*t4**&
+ &8*t3**4*t5*t2**2+100._ki*t1*t4**7*t3**4*t5*t2**3+275._ki/2._ki*t6*&
+ &*2*t1**5*t3**3*t2**2*t4+88._ki*t6**2*t1**5*t4**4*t3*t2**3+11._ki/&
+ &6._ki*t6**2*t1**5*t4**3*t5*t2**5-55._ki/6._ki*t6**2*t1**5*t4**3*t5&
+ &**3*t2**3-320._ki/3._ki*t6*t1**4*t4**6*t5**3*t3*t2-6._ki*t1**4*t4*&
+ &*3*t3*t2**6*t5**2-24._ki*t1**4*t4**5*t3*t2**4*t5**2-60._ki*t1**4*&
+ &t4*t3**3*t5*t2**5-120._ki*t6*t1**2*t4**5*t3**4*t2**3+t6*t1**2*t4&
+ &**2*t3**4*t2**6+375._ki*t6**2*t1**6*t3**2*t5*t2*t4-45._ki/4._ki*t6&
+ &**2*t1**4*t4**2*t3**2*t5*t2**4+60._ki*t6*t1**5*t4**5*t5**3*t2**2&
+ &-60._ki*t6*t1**5*t4**4*t5**3*t2**3-3._ki*t6*t1**5*t4**5*t5*t2**4-&
+ &12._ki*t6*t1**5*t4**4*t3*t2**4-9._ki/4._ki*t6*t1**5*t4**2*t3*t2**6&
+ &+60._ki*t6*t1**5*t3**3*t5*t2**3-375._ki/4._ki*t6*t1**5*t4**3*t3**2&
+ &*t2**3-40._ki*t6*t1**3*t4**7*t3**2*t5*t2**2-45._ki/2._ki*t6*t1**5*&
+ &t4**2*t5*t2**5*t3-840._ki*t6*t1**5*t4**3*t3*t5**3*t2**2+3._ki*t6*&
+ &t1**5*t4**4*t5*t2**5+stemp10
+ !
+ stemp10=stemp7-3._ki/4._ki*t6*t1**5*t4**3*t5*t2**6-128._ki/3._ki*t6*t&
+ &1**2*t4**8*t3**3*t5*t2-40._ki/3._ki*t6*t1**2*t4**4*t5*t2**5*t3**3&
+ &+2._ki*t6*t1*t4**4*t3**4*t2**6+80._ki/3._ki*t6*t1*t2**4*t3**4*t4**&
+ &6+1155._ki/2._ki*t6**2*t1**5*t4**3*t3*t5**2*t2**2-1320._ki*t6**2*t&
+ &1**5*t4**4*t3*t5**2*t2+1485._ki/2._ki*t6**2*t1**5*t4**2*t3**2*t5*&
+ &t2**2-t6*t1*t4**3*t3**4*t2**7/6._ki-120._ki*t6*t1**3*t4**5*t3**2*&
+ &t5**2*t2**3+160._ki*t6*t1**3*t4**6*t3**2*t5**2*t2**2-80._ki*t6*t1&
+ &**3*t4**7*t3**2*t5**2*t2+480._ki*t6*t1**3*t4**5*t3**3*t5*t2**2-8&
+ &00._ki/3._ki*t6*t1**3*t4**6*t3**3*t5*t2+280._ki/3._ki*t6*t1**3*t4**&
+ &3*t3**3*t5*t2**4+220._ki*t6*t1**3*t4**4*t3**4*t2**2-200._ki/3._ki*&
+ &t6*t1**3*t4**6*t3**3*t2**2-125._ki*t6*t1**3*t4**3*t3**4*t2**3-14&
+ &0._ki*t6*t1**3*t4**5*t3**4*t2-5._ki/2._ki*t6*t1**3*t3**4*t4*t2**5+&
+ &10._ki/3._ki*t6*t1**3*t4**7*t3**2*t2**3+120._ki*t6*t1**3*t4**5*t3*&
+ &*3*t2**3-80._ki*t6*t1**3*t4**4*t3**3*t2**4-275._ki*t1**3*t4**4*t3&
+ &**4*t2**2*t5-300._ki*t1**3*t4**5*t3**3*t5**2*t2**2+108._ki*t1**5*&
+ &t4**2*t3**2*t5*t2**4
+ !
+ stemp9=10._ki*t6*t1**4*t4**3*t3*t5**2*t2**5-360._ki*t6*t1**4*t4**2*&
+ &t3**3*t2**3*t5-320._ki/3._ki*t6*t1**2*t4**6*t3**3*t5*t2**3-10._ki*&
+ &t6*t1*t4**5*t3**4*t2**5+1140._ki*t6*t1**5*t4**2*t3**3*t5*t2-100.&
+ &_ki*t1*t4**6*t3**4*t5*t2**4-75._ki*t1**4*t4**2*t3**2*t5**3*t2**4+&
+ &stemp10+175._ki*t1**5*t4**3*t3*t5**4*t2**2-320._ki*t6*t1**3*t4**4&
+ &*t3**3*t5*t2**3-35._ki/3._ki*t6*t1**2*t3**4*t4**3*t2**5-t6*t1**4*&
+ &t4**3*t3*t2**7/6._ki-220._ki*t6*t1**4*t4**4*t3**3*t2**2+540._ki*t1&
+ &**5*t4**2*t3**2*t5**2*t2**3-36._ki*t1**5*t4**2*t5**2*t2**5*t3-36&
+ &._ki*t1**5*t4*t5*t2**5*t3**2-75._ki*t1**5*t4**2*t5**4*t3*t2**3-5.&
+ &_ki/3._ki*t6*t1**4*t4**3*t3*t2**6*t5+1000._ki*t6*t1**4*t4**3*t3**3&
+ &*t2**2*t5-60._ki*t6*t1**4*t4**4*t3*t5**2*t2**4+30._ki*t6*t1**4*t4&
+ &**2*t3**2*t5*t2**5+120._ki*t6*t1**4*t4**5*t3*t5**2*t2**3-360._ki*&
+ &t6*t1**6*t4**2*t5**3*t2*t3+45._ki*t6*t1**6*t4**2*t5*t2**3*t3+60.&
+ &_ki*t6*t1**6*t3**2*t5**2*t2**2-10._ki/3._ki*t1**2*t4**3*t5*t3**3*t&
+ &2**7-25._ki/4._ki*t1**2*t4**2*t3**4*t5*t2**6+45._ki*t6**2*t1**4*t4&
+ &**2*t3**3*t2**3
+ !
+ stemp10=stemp9+6._ki*t6**2*t1**4*t4**5*t3*t2**4+4._ki*t6**2*t1**4*t&
+ &4**7*t3*t2**2-60._ki*t6*t1**5*t4**4*t5**4*t2**2+960._ki*t6*t1**4*&
+ &t4**4*t3**2*t5**2*t2**2-35._ki*t6**2*t1**6*t4**3*t5*t2**3-20._ki*&
+ &t6*t1**4*t4**5*t3*t2**4*t5+10._ki*t6*t1**4*t4**4*t3*t2**5*t5-2._k&
+ &i*t6*t1**4*t4**5*t3*t2**5-150._ki*t6*t1**5*t4*t3**3*t2**3+190._ki&
+ &*t6*t1**4*t3**4*t2**2*t4**2+30._ki*t6*t1**4*t4**5*t3**2*t2**3+35&
+ &._ki/2._ki*t6*t1**4*t4**3*t3**2*t2**5-5._ki/2._ki*t6*t1**4*t4**2*t3&
+ &**2*t2**6+10._ki*t6*t1**4*t2**5*t3**3*t4-1875._ki/2._ki*t6**2*t1**&
+ &6*t4**3*t3*t5**2-75._ki/2._ki*t6**2*t1**6*t3**2*t5*t2**2+15._ki/2.&
+ &_ki*t6**2*t1**6*t4**2*t5*t2**4+15._ki/2._ki*t6**2*t1**6*t2**4*t3*t&
+ &4+40._ki*t6**2*t1**6*t4**4*t5*t2**2-225._ki/2._ki*t6**2*t1**6*t4*t&
+ &3*t5**2*t2**2-5._ki/2._ki*t6*t1**3*t4**3*t5*t3**2*t2**6-5._ki*t6*t&
+ &1**3*t4**3*t5**2*t2**5*t3**2-4125._ki/2._ki*t6**2*t1**5*t4**3*t3*&
+ &*2*t5*t2-32._ki/3._ki*t2**2*t3**5*t4**9-75._ki/2._ki*t6**2*t1**6*t4&
+ &**2*t5**3*t2**2+175._ki*t6**2*t1**6*t4**3*t5**3*t2
+ !
+ stemp8=stemp10+125._ki/2._ki*t6**2*t1**6*t2**2*t3*t4**3+4._ki/3._ki*t&
+ &6*t1**4*t4**6*t3*t2**4+30._ki*t6*t1**6*t4**2*t5**4*t2**2+7._ki/2.&
+ &_ki*t6*t1**6*t4**3*t5*t2**4-40._ki*t6*t1**6*t3**3*t5*t2-3._ki/2._ki&
+ &*t6*t1**6*t4**2*t5*t2**5-55._ki/6._ki*t6**2*t1**5*t2**3*t3**3+220&
+ &._ki/3._ki*t6**2*t1**5*t4**6*t5**3-210._ki*t6**2*t1**4*t4**5*t3**3&
+ &-44._ki*t6**2*t1**3*t4**7*t3**3-16._ki/3._ki*t6**2*t1**2*t4**9*t3*&
+ &*3-10._ki*t6*t1**6*t3**3*t2**2+3._ki/2._ki*t6*t1**5*t4**5*t2**5-3.&
+ &_ki/2._ki*t6*t1**5*t4**4*t2**6+3._ki/8._ki*t6*t1**5*t4**3*t2**7-30.&
+ &_ki*t6*t1**5*t3**4*t2**2+15._ki*t6*t1**5*t3**3*t2**4-7._ki/4._ki*t6&
+ &*t1**6*t4**3*t2**5+15._ki*t6**2*t1**7*t3**2*t5-200._ki*t6**2*t1**&
+ &6*t4**4*t5**3-95._ki*t1**4*t4**2*t3**4*t2**3-15._ki/4._ki*t6**2*t1&
+ &**4*t3**3*t2**4*t4-8._ki*t6**2*t1**4*t4**6*t3*t2**3+40._ki*t6*t1*&
+ &*4*t4*t3**3*t5*t2**4-80._ki*t6*t1**4*t4**6*t3*t5**2*t2**2+250._ki&
+ &*t6*t1**4*t2**3*t3**3*t4**3+250._ki*t1**5*t4*t3**3*t5**2*t2**2+4&
+ &50._ki*t1**5*t4**2*t5**3*t3**2*t2**2
+ !
+ stemp10=stemp8+200._ki*t1**5*t4*t5*t3**3*t2**3-150._ki*t1**5*t4*t5*&
+ &*3*t3**2*t2**3-40._ki*t6*t1*t2**3*t3**4*t4**7-32._ki/3._ki*t6*t1*t&
+ &2*t3**4*t4**9-2._ki*t6**2*t1**4*t4**4*t3*t2**5-60._ki*t6**2*t1**4&
+ &*t4**7*t3*t5**2+330._ki*t6**2*t1**4*t4**4*t3**3*t2+40._ki*t6**2*t&
+ &1**3*t4**4*t3**3*t2**3+3._ki/4._ki*t6**2*t1**3*t4**2*t3**3*t2**5+&
+ &100._ki*t6**2*t1**3*t4**6*t3**3*t2-14._ki*t1**5*t4**3*t5*t3*t2**5&
+ &+6._ki*t1**5*t4**2*t5*t3*t2**6-120._ki*t1**5*t4**2*t3*t5**3*t2**4&
+ &+50._ki*t1*t4**5*t3**4*t5*t2**5+280._ki*t1**5*t4**3*t3*t5**3*t2**&
+ &3+100._ki*t1**3*t4**5*t3**2*t5**3*t2**3-80._ki/3._ki*t6*t1**2*t4**&
+ &6*t3**3*t2**4-200._ki/3._ki*t1**3*t4**6*t3**2*t5**3*t2**2-50._ki*t&
+ &1**3*t4**4*t3**2*t5**3*t2**4+30._ki*t6*t1**6*t4**2*t5**3*t2**3-7&
+ &0._ki*t6*t1**6*t4**3*t5**4*t2+35._ki/2._ki*t6*t1**6*t4**3*t5**2*t2&
+ &**3-70._ki*t6*t1**6*t4**3*t5**3*t2**2+285._ki*t6*t1**5*t3**3*t2**&
+ &2*t4**2+105._ki*t6*t1**5*t3**4*t2*t4-45._ki/4._ki*t6*t1**5*t4*t3**&
+ &2*t2**5
+ !
+ stemp9=stemp10-5._ki/2._ki*t1**2*t4**2*t3**4*t2**7+70._ki/3._ki*t1**2&
+ &*t4**3*t3**4*t2**6-200._ki/3._ki*t1**2*t4**6*t3**4*t2**3-t1**2*t4&
+ &**3*t3**3*t2**8/3._ki-16._ki/3._ki*t1**2*t4**7*t3**3*t2**4+32._ki/3&
+ &._ki*t1**2*t4**6*t3**3*t2**5-8._ki*t1**2*t4**5*t3**3*t2**6-80._ki*&
+ &t1**2*t4**4*t3**4*t2**5+120._ki*t1**2*t4**5*t3**4*t2**4-70._ki*t1&
+ &**2*t2**2*t3**5*t4**5+15._ki*t1**2*t2**5*t3**5*t4**2+110._ki*t1**&
+ &2*t2**3*t3**5*t4**4-5._ki/4._ki*t1**2*t4*t3**5*t2**6-125._ki/2._ki*&
+ &t1**2*t2**4*t3**5*t4**3-35._ki/4._ki*t1*t2**6*t3**5*t4**3-50._ki*t&
+ &1**5*t3**3*t5**2*t2**3-3._ki*t1**5*t4**2*t3*t2**7+3._ki*t1**5*t4*&
+ &t3**2*t2**6-10._ki*t1**5*t4**3*t5**4*t2**4+t1**5*t4**3*t5**2*t2*&
+ &*6-40._ki*t1**5*t3**3*t5*t2**4+20._ki*t1**5*t4**4*t5**4*t2**3+2._k&
+ &i*t1**5*t4**4*t5*t2**6+25._ki*t1**5*t3**4*t5*t2**2-5._ki*t1**5*t4&
+ &**3*t5**5*t2**3+10._ki*t1**5*t4**4*t5**5*t2**2+3._ki/2._ki*t1**4*t&
+ &4**2*t3**2*t2**7
+ !
+ stemp10=stemp9-6._ki*t1**4*t4*t3**3*t2**6-t1**5*t4**3*t5*t2**7-90.&
+ &_ki*t1*t2**4*t3**5*t4**5+40._ki*t1*t2**5*t3**5*t4**4+540._ki*t6**2&
+ &*t1**4*t4**5*t3**2*t5*t2-360._ki*t6**2*t1**4*t4**4*t3**2*t5*t2**&
+ &2+8._ki*t1**5*t4**4*t5**3*t2**4-10._ki*t6*t1**3*t4**2*t3**3*t5*t2&
+ &**5+40._ki*t6*t1**3*t4**4*t3**2*t5**2*t2**4-60._ki*t6*t1**3*t4**5&
+ &*t3**2*t5*t2**4+120._ki*t6**2*t1**4*t4**6*t3*t5**2*t2-15._ki/2._ki&
+ &*t6**2*t1**3*t4**4*t5*t2**4*t3**2-60._ki*t6**2*t1**3*t4**6*t3**2&
+ &*t5*t2**2+3._ki/4._ki*t6**2*t1**3*t4**3*t5*t2**5*t3**2-24._ki*t6**&
+ &2*t1**3*t4**8*t3**2*t5-180._ki*t1**5*t4*t3**2*t5**2*t2**4+360._ki&
+ &*t1**4*t4**2*t3**3*t5*t2**4+30._ki*t6**2*t1**3*t4**5*t3**2*t5*t2&
+ &**3+60._ki*t6**2*t1**3*t4**7*t3**2*t5*t2-5._ki*t6**2*t1**7*t2**2*&
+ &t3*t4-9._ki*t6**2*t1**7*t4**2*t5*t2**2-35._ki/4._ki*t6**2*t1**3*t3&
+ &**3*t4**3*t2**4+105._ki*t6**2*t1**4*t4**3*t5*t3**2*t2**3-15._ki/4&
+ &._ki*t6**2*t1**4*t4**3*t5**2*t2**4*t3+30._ki*t6**2*t1**4*t4**4*t5&
+ &**2*t2**3*t3-90._ki*t6**2*t1**4*t4**5*t3*t5**2*t2**2+84._ki*t1**5&
+ &*t4**3*t5**2*t2**4*t3
+ !
+ stemp6=stemp10-4._ki*t1**4*t4**4*t3*t2**6*t5+125._ki*t1**4*t3**4*t5&
+ &*t2**3*t4-75._ki*t1**4*t4*t3**3*t2**4*t5**2+t1**4*t4**3*t3*t2**7&
+ &*t5+4._ki*t1**4*t4**5*t3*t2**5*t5+30._ki*t6*t1**6*t2**3*t3**2*t5+&
+ &25._ki/2._ki*t6*t1**6*t2**3*t4*t3**2+9._ki/2._ki*t6*t1**6*t4**2*t3*&
+ &t2**4-15._ki/2._ki*t6*t1**6*t4**2*t5**2*t2**4-3._ki/2._ki*t6*t1**6*&
+ &t4*t3*t2**5-210._ki*t6*t1**4*t4**3*t3**2*t5*t2**4+480._ki*t6*t1**&
+ &4*t4**4*t3**2*t5*t2**3-360._ki*t6*t1**4*t4**5*t3**2*t5*t2**2+25.&
+ &_ki/2._ki*t1**3*t4*t3**4*t2**5*t5-12._ki*t1**3*t3**2*t4**4*t5*t2**&
+ &6+24._ki*t1**3*t3**2*t4**5*t5*t2**5-175._ki*t1**3*t4**3*t3**3*t5*&
+ &*2*t2**4-200._ki*t1**2*t4**4*t3**4*t5*t2**4-25._ki/6._ki*t1**2*t4*&
+ &*3*t5**2*t2**6*t3**3+320._ki/3._ki*t1**2*t4**6*t3**3*t5*t2**4+300&
+ &._ki*t1**2*t4**5*t3**4*t5*t2**3+t6**2*t1**2*t4**4*t3**3*t2**5+40&
+ &._ki/3._ki*t6**2*t1**2*t4**6*t3**3*t2**3+16._ki*t6**2*t1**2*t4**8*&
+ &t3**3*t2-5._ki*t6**2*t1**2*t4**5*t3**3*t2**4-90._ki*t6**2*t1**3*t&
+ &4**5*t3**3*t2**2-20._ki*t6**2*t1**2*t4**7*t3**3*t2**2-t6**2*t1**&
+ &2*t4**3*t3**3*t2**6/12._ki
+ !
+ stemp7=t6/t2**12/t1**5
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(3)
+ !
+ stemp6=-30._ki*t6**3*t1*t4*t5**3*t2**3-250._ki*t2**2*t3**3*t6*t4*t5&
+ &**2-5._ki/4._ki*t6**2*t4**3*t2**7-45._ki*t6**3*t1*t3*t5**2*t2**3-t&
+ &6*t1*t2**5*t3**2-190._ki*t3**3*t2**2*t6**2*t4**2-6._ki*t3*t2**3*t&
+ &6**3*t1**2+10._ki*t3**2*t2**4*t1*t6**2-20._ki*t3**3*t2**4*t6*t4-2&
+ &5._ki*t6*t5*t2**2*t3**4+410._ki*t2*t3**3*t6**3*t4**2-165._ki*t2**2&
+ &*t3**3*t6**3*t4+70._ki*t6**2*t1*t4*t5*t2**4*t3-30._ki*t6**3*t4*t3&
+ &*t5**2*t2**4+2._ki*t6*t1*t4*t5**2*t2**6-9._ki*t6**2*t1*t3*t2**4*t&
+ &4**2+7._ki*t6**2*t1*t3*t2**5*t4-1395._ki*t6**3*t1*t4**2*t3*t5**2*&
+ &t2-24._ki*t6*t4*t5**2*t2**6*t3-25._ki*t6*t1*t5**4*t3*t2**3+6._ki*t&
+ &6**3*t1*t4*t5*t2**5+80._ki*t6**2*t1*t3*t5**3*t2**3+60._ki*t6**2*t&
+ &4*t3*t5**2*t2**5-10._ki*t6**2*t1*t4*t5**2*t2**5-40._ki*t6*t1*t5**&
+ &3*t3*t2**4-30._ki*t3*t5**2*t2**2*t1**2*t6**2+60._ki*t3**2*t5**2*t&
+ &2**3*t1*t6-10._ki*t6**2*t1*t3*t5*t2**5+2._ki*t6*t1*t2**6*t3*t5+80&
+ &._ki*t3**3*t2**4*t6*t5
+ !
+ stemp5=80._ki*t6**2*t4**4*t5**3*t2**3-40._ki*t6**2*t4**5*t5**3*t2**&
+ &2+5._ki/2._ki*t6**2*t4**3*t5*t2**6-4._ki*t6**2*t4**4*t5*t2**5+2._ki&
+ &*t6**2*t4**5*t5*t2**4+10._ki*t6**2*t4**5*t5**2*t2**3-20._ki*t6**2&
+ &*t4**4*t5**2*t2**4+5._ki*t1**3*t6**3*t5**3-8._ki*t6*t1*t4*t5**3*t&
+ &2**5-20._ki*t6*t1*t4*t5**4*t2**4+40._ki*t6**2*t1*t4*t5**4*t2**3-2&
+ &1._ki*t6**3*t1**2*t4*t5*t2**3-4._ki*t6*t4**2*t5**3*t2**6+20._ki*t6&
+ &**2*t2**2*t1*t3**3-90._ki*t6**3*t4**4*t5**3*t2**2+18._ki*t6**3*t4&
+ &**4*t5*t2**4-76._ki*t6**3*t4**4*t3*t2**3+57._ki*t6**3*t4**3*t3*t2&
+ &**4-10._ki*t6*t1*t4*t5**5*t2**3-40._ki*t6**3*t4**6*t5**3+27._ki*t6&
+ &**3*t1**2*t4**2*t5*t2**2+105._ki*t6**3*t1**2*t4*t5**3*t2-t6**2*t&
+ &4**5*t2**5+540._ki*t6**2*t1*t4**2*t3*t5**2*t2**2+720._ki*t6**2*t1&
+ &*t4**2*t5**3*t2*t3+105._ki*t3**3*t6**3*t1*t4-t2**2*t1**3*t6**3*t&
+ &5-45._ki*t6**3*t5*t1**2*t3**2-8._ki*t6*t4**4*t5**3*t2**4+8._ki*t6*&
+ &t4**2*t3*t2**7+12._ki*t6*t4**3*t5**3*t2**5+stemp6
+ !
+ stemp6=-t6*t1*t3*t2**7+90._ki*t2*t3*t1**2*t6**3*t5**2-560._ki*t6**2&
+ &*t1*t4*t5**3*t3*t2**2-660._ki*t6**2*t4*t3**2*t5**2*t2**3-48._ki*t&
+ &6**3*t1*t4**4*t5*t2**2-75._ki*t6**3*t1*t2**2*t3*t4**3+36._ki*t6*t&
+ &1*t4*t3*t2**4*t5**2+1125._ki*t6**3*t1*t4**3*t3*t5**2+320._ki*t6*t&
+ &4**2*t3*t5**3*t2**4+350._ki*t6*t4*t5**3*t3**2*t2**3-240._ki*t2**2&
+ &*t3**2*t1*t6**2*t5**2-t4**2*t2**10/4._ki+50._ki*t2**2*t3**2*t1*t6&
+ &*t5**3-120._ki*t2**3*t3**3*t6**2*t5-t6*t4**2*t2**8*t5-60._ki*t6*t&
+ &3**2*t2**5*t5**2+t6*t4**2*t5**2*t2**7-33._ki*t6**3*t1*t2**4*t3*t&
+ &4+200._ki*t6*t4**2*t5**4*t3*t2**3+84._ki*t6*t4*t5*t2**5*t3**2+855&
+ &._ki*t3**2*t1*t6**3*t5*t4**2+8._ki*t3**3*t6*t2**5-315._ki*t3**3*t6&
+ &**3*t4**3-540._ki*t6**3*t4**5*t3*t5**2-20._ki*t6**3*t4**5*t5*t2**&
+ &3-135._ki*t6**3*t1**2*t4**2*t5**3+240._ki*t6**3*t1*t4**4*t5**3-3.&
+ &_ki/4._ki*t6**2*t1**2*t4*t2**5-4._ki*t6**2*t1*t4**2*t2**6+7._ki/2._k&
+ &i*t6**2*t1*t4**3*t2**5-108._ki*t6*t4**2*t3**2*t5*t2**4
+ !
+ stemp4=-5._ki/2._ki*t6**2*t3**2*t2**6-10._ki*t6*t2**3*t3**4+t6**2*t1&
+ &**2*t2**6/4._ki+96._ki*t6*t4**2*t5**2*t2**5*t3-10._ki*t6**2*t4*t5*&
+ &t2**6*t3-520._ki*t6**2*t4**2*t5**3*t3*t2**3-7._ki*t6*t4**3*t3*t2*&
+ &*6-7._ki*t6*t4*t3**2*t2**6+9._ki*t6*t4**2*t3**2*t2**5-3._ki*t6*t4*&
+ &*3*t5**2*t2**6-84._ki*t6*t4**3*t5**2*t2**4*t3-540._ki*t6*t4**2*t3&
+ &**2*t5**2*t2**3-5._ki*t6*t4**2*t5**5*t2**4-990._ki*t6**3*t4**4*t3&
+ &**2*t5-7._ki*t6**3*t4**3*t5*t2**5+8._ki*t6**3*t4**6*t5*t2**2+35._k&
+ &i*t6**3*t4**3*t5**3*t2**3-5._ki/2._ki*t6**2*t4**2*t5**2*t2**6-175&
+ &._ki*t6*t4**3*t3*t5**4*t2**2+195._ki*t6**3*t1*t4**2*t5**3*t2**2+9&
+ &3._ki*t6**3*t1*t2**3*t3*t4**2-450._ki*t6*t4**2*t5**3*t3**2*t2**2-&
+ &750._ki*t6**2*t4**3*t3**2*t5*t2**2-390._ki*t6**3*t1*t4**3*t5**3*t&
+ &2+78._ki*t6**3*t1*t4**3*t5*t2**3-3._ki*t6*t1*t4**2*t5**2*t2**5+12&
+ &._ki*t6*t1*t4**2*t5**3*t2**4-50._ki*t6*t3**2*t5**3*t2**4-2._ki*t6*&
+ &t4*t3*t2**8-10._ki*t6*t4**2*t5**4*t2**5+stemp6+stemp5
+ !
+ stemp6=10._ki*t6**2*t4**2*t5**3*t2**5-t6**2*t4**2*t5*t2**7/2._ki-t6&
+ &**2*t4*t3*t2**7+25._ki/2._ki*t6**2*t4**3*t5**2*t2**5+30._ki*t6*t4*&
+ &*3*t5**4*t2**4-20._ki*t6*t4**4*t5**4*t2**3+3._ki*t6*t4**3*t5*t2**&
+ &7-2._ki*t6*t4**4*t5*t2**6+15._ki*t6*t4**3*t5**5*t2**3-10._ki*t6*t4&
+ &**4*t5**5*t2**2+100._ki*t2**3*t3**3*t6*t5**2+20._ki*t2**3*t3**3*t&
+ &6**3-640._ki*t6**2*t4**4*t3*t5**3*t2+55._ki/2._ki*t6**2*t4*t3**2*t&
+ &2**5-155._ki/2._ki*t6**2*t4**2*t3**2*t2**4+13._ki/2._ki*t6**2*t4**2&
+ &*t3*t2**6+2._ki*t6**3*t4*t3*t2**6+60._ki*t6**2*t3**2*t2**4*t5**2+&
+ &10._ki*t6**2*t4**2*t5**4*t2**4-t6**2*t1**2*t5*t2**5/2._ki+30._ki*t&
+ &6**2*t2**5*t3**2*t5+t6**2*t1*t4*t2**7-15._ki*t6**3*t3**2*t2**4*t&
+ &5-15._ki*t6**3*t1**2*t5**3*t2**2+15._ki*t6*t1*t4**2*t5**5*t2**2+3&
+ &0._ki*t6*t1*t4**2*t5**4*t2**3-30._ki*t3**3*t2**4*t6**2+30._ki*t3**&
+ &4*t2**2*t6**2+65._ki*t6**2*t4**2*t5*t2**5*t3-39._ki*t6**3*t1*t4**&
+ &2*t5*t2**4
+ !
+ stemp5=-280._ki*t6*t4**3*t3*t5**3*t2**3+270._ki*t6**3*t4**2*t3*t5**&
+ &2*t2**3-855._ki*t6**3*t4**3*t3*t5**2*t2**2+1140._ki*t6**3*t4**4*t&
+ &3*t5**2*t2+1695._ki*t6**3*t4**3*t3**2*t5*t2-70._ki*t3**4*t2*t6**2&
+ &*t4-45._ki*t3**3*t2*t6**3*t1+3._ki*t6**3*t1*t3*t2**5+3._ki*t6**3*t&
+ &1**2*t5*t2**4+t6**2*t1**2*t3*t2**4/2._ki-12._ki*t6*t5*t3**2*t2**6&
+ &+2._ki*t6**2*t4**4*t2**6-130._ki*t6**2*t4**3*t5*t2**4*t3+stemp6-2&
+ &._ki*t6*t1*t4*t5*t2**7-990._ki*t6**3*t4**2*t3**2*t5*t2**2-1500._ki&
+ &*t6**2*t4**3*t3**2*t5**2*t2+120._ki*t6*t1*t4*t5**3*t3*t2**3+14._k&
+ &i*t6*t4**3*t5*t3*t2**5+780._ki*t6**2*t4**3*t3*t5**2*t2**3+t6*t3*&
+ &*2*t2**7+930._ki*t6**2*t4**2*t3**2*t5*t2**3-330._ki*t6**2*t4*t3**&
+ &2*t5*t2**4-16._ki*t6*t4**2*t5*t3*t2**6+420._ki*t6*t4*t3**2*t5**2*&
+ &t2**4+t4**3*t2**9/4._ki-40._ki*t2*t3*t1**2*t6**2*t5**3-30._ki*t6**&
+ &2*t1**2*t4*t5**4*t2+5._ki*t3*t2**3*t1**2*t6**2*t5-480._ki*t6**2*t&
+ &4**4*t3*t5**2*t2**2-30._ki*t6**2*t1**2*t4*t5**3*t2**2+15._ki/2._ki&
+ &*t6**2*t1**2*t4*t5**2*t2**3
+ !
+ stemp6=-35._ki*t6**2*t1*t4**3*t5**2*t2**3-6._ki*t6*t1*t2**5*t3*t4*t&
+ &5-225._ki*t3*t1**2*t6**3*t4*t5**2-160._ki*t6**2*t1*t4**2*t5**4*t2&
+ &**2-7._ki*t6**2*t1*t4**3*t5*t2**4+3._ki*t6*t1*t4**2*t2**6*t5+140.&
+ &_ki*t6**2*t1*t4**3*t5**4*t2+80._ki*t6**2*t4*t5**3*t2**4*t3+stemp4&
+ &+40._ki*t6**2*t1*t4*t5**3*t2**4+3._ki*t6*t1*t2**6*t4*t3+12._ki*t3*&
+ &*2*t2**4*t1*t6*t5+135._ki*t2**2*t3**2*t1*t6**3*t5+80._ki*t6**2*t4&
+ &**4*t5*t2**3*t3+80._ki*t6**2*t5*t2*t1*t3**3+8._ki*t6**2*t1*t4**2*&
+ &t5*t2**5+40._ki*t6**2*t1*t4**2*t5**2*t2**4-390._ki*t6**2*t4**2*t3&
+ &*t5**2*t2**4-13._ki*t6**2*t4**3*t3*t2**5-50._ki*t6**2*t4**3*t5**4&
+ &*t2**3+80._ki*t6**2*t4**4*t5**4*t2**2-40._ki*t6**2*t4**5*t5**4*t2&
+ &+125._ki/2._ki*t6**2*t4**3*t3**2*t2**3+8._ki*t6**2*t4**4*t3*t2**4-&
+ &50._ki*t6**2*t4**3*t5**3*t2**4-120._ki*t3**2*t2**3*t6**2*t5*t1+75&
+ &._ki*t6*t1*t4*t5**4*t2**2*t3+stemp5-2._ki*t6**2*t1*t2**6*t4*t5-16&
+ &0._ki*t6**2*t1*t4**2*t5**3*t2**3+140._ki*t6**2*t1*t4**3*t5**3*t2*&
+ &*2
+ !
+ stemp3=stemp6+1040._ki*t6**2*t4**3*t3*t5**3*t2**2+3._ki/2._ki*t6**2*&
+ &t1**2*t4*t5*t2**4+300._ki*t3**2*t2**2*t6**2*t4*t5*t1-200._ki*t3**&
+ &3*t2**3*t6*t4*t5-18._ki*t6**3*t4**2*t3*t2**5+36._ki*t6**3*t4**5*t&
+ &3*t2**2+100._ki*t6**3*t4**5*t5**3*t2+60._ki*t6**2*t1*t3*t5**2*t2*&
+ &*4-90._ki*t6**2*t1*t4**2*t5*t2**3*t3-420._ki*t6**2*t1*t4*t3*t5**2&
+ &*t2**3-720._ki*t2*t3**2*t1*t6**3*t5*t4+1860._ki*t6**2*t4**2*t3**2&
+ &*t5**2*t2**2+600._ki*t2*t3**2*t1*t6**2*t4*t5**2-50._ki*t6*t4*t5**&
+ &4*t2**4*t3-5._ki/2._ki*t6**2*t1**2*t5**2*t2**4+10._ki*t6**2*t1**2*&
+ &t5**3*t2**3+10._ki*t6**2*t1**2*t5**4*t2**2-5._ki*t6**3*t4**2*t5**&
+ &3*t2**4+t6**3*t4**2*t5*t2**6+160._ki*t3**3*t2**3*t6**2*t4-760._ki&
+ &*t2*t3**3*t6**2*t5*t4**2+640._ki*t2**2*t3**3*t6**2*t5*t4+225._ki*&
+ &t6**3*t3**2*t2**3*t4*t5-t6**2*t2**6*t1*t3+2._ki*t6*t4**4*t5**2*t&
+ &2**5+4._ki*t6*t4*t3*t2**7*t5-80._ki*t6*t4*t5**3*t2**5*t3-25._ki*t3&
+ &**2*t2**3*t1*t6**2*t4+15._ki*t3*t2**2*t6**3*t4*t1**2+495._ki*t6**&
+ &3*t1*t4*t3*t5**2*t2**2-12._ki*t6*t1*t3*t5**2*t2**5+t6**2*t4**2*t&
+ &2**8/4._ki
+ !
+ stemp4=1._ki/t2**12*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=(-t4+t2)*t4**2/t2**3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/4._k&
+ &i
+ !
+ stemp11=-5._ki/3._ki*t6*t4*t2**7*t3**2*t1**4-2._ki*t6*t1**6*t4**2*t2&
+ &**6-40._ki/3._ki*t6*t1**4*t3**4*t2**4+5._ki*t6*t1**6*t3**2*t2**4+1&
+ &75._ki/2._ki*t6**2*t1**6*t3**3*t4-1155._ki/2._ki*t6**2*t1**5*t4**3*&
+ &t3**3-77._ki/6._ki*t6**2*t1**5*t4**3*t5*t2**5-418._ki/3._ki*t6**2*t&
+ &1**5*t4**4*t3*t2**3-520._ki/3._ki*t1**2*t4**5*t3**4*t2**4+70._ki*t&
+ &1**2*t2**2*t3**5*t4**5-95._ki/2._ki*t1**2*t2**5*t3**5*t4**2-460._k&
+ &i/3._ki*t1**2*t2**3*t3**5*t4**4+95._ki/12._ki*t1**2*t4*t3**5*t2**6&
+ &+755._ki/6._ki*t1**2*t2**4*t3**5*t4**3+155._ki/4._ki*t1*t2**6*t3**5&
+ &*t4**3-1300._ki/3._ki*t1**2*t4**5*t3**4*t5*t2**3
+ !
+ stemp10=stemp11-320._ki/3._ki*t1**2*t4**4*t3**3*t5*t2**6+825._ki/2._k&
+ &i*t6**2*t1**6*t4*t3*t5**2*t2**2+200._ki/3._ki*t1**3*t4**6*t3**2*t&
+ &5**3*t2**2+150._ki*t1**3*t4**4*t3**2*t5**3*t2**4-200._ki*t6*t1**4&
+ &*t4*t3**3*t5*t2**4-250._ki*t1**5*t4*t3**3*t5**2*t2**2-625._ki/3._k&
+ &i*t1**2*t4**3*t3**4*t5*t2**5-375._ki*t6**2*t1**4*t4**3*t5*t3**2*&
+ &t2**3-200._ki*t1**2*t4**6*t3**3*t5**2*t2**3+120._ki*t6**2*t1**3*t&
+ &4**6*t3**2*t5*t2**2+16._ki/3._ki*t6**2*t1**2*t4**9*t3**3-3._ki/2._k&
+ &i*t6*t1**5*t4**5*t2**5+3._ki*t6*t1**5*t4**4*t2**6-15._ki/8._ki*t6*&
+ &t1**5*t4**3*t2**7+80._ki*t1*t4**6*t3**4*t2**5+44._ki*t1*t2**2*t3*&
+ &*5*t4**7-7._ki*t1*t2**7*t3**5*t4**2
+ !
+ stemp11=16._ki*t1*t4**8*t3**4*t2**3-2325._ki/2._ki*t6**2*t1**6*t4**2&
+ &*t3*t5**2*t2+220._ki*t6*t1**4*t4**4*t3**3*t2**2+13._ki/6._ki*t6*t1&
+ &*t4**3*t3**4*t2**7+280._ki*t6*t1**3*t4**5*t3**2*t5**2*t2**3+40._k&
+ &i/3._ki*t6*t4**2*t5**3*t2**5*t1**4*t3+95._ki/4._ki*t6**2*t1**4*t3*&
+ &*3*t2**4*t4-465._ki/4._ki*t6*t1**5*t4**2*t3**2*t2**4+75._ki/4._ki*t&
+ &6*t1**5*t4**3*t5**2*t2**5-156._ki*t1**4*t4**3*t5*t2**5*t3**2+96.&
+ &_ki*t1**4*t4**4*t5*t2**4*t3**2+120._ki*t6*t1**5*t4**4*t5**4*t2**2&
+ &+240._ki*t6*t1**5*t4*t3**3*t2**3+100._ki*t1**4*t4**3*t5**3*t3*t2*&
+ &*5-450._ki*t1**5*t4**2*t5**3*t3**2*t2**2-160._ki*t6*t1**2*t4**5*t&
+ &3**3*t5*t2**4-448._ki/3._ki*t6*t1**2*t4**7*t3**3*t5*t2**2
+ !
+ stemp9=stemp11-820._ki/3._ki*t6*t1**4*t3**4*t2**2*t4**2-160._ki*t1**&
+ &4*t4**4*t5**3*t3*t2**4+35._ki*t6*t1**6*t4*t5*t2**4*t3+2790._ki*t6&
+ &*t1**5*t4**2*t3**2*t5**2*t2**2-30._ki*t6*t1**4*t4**5*t3**2*t2**3&
+ &-95._ki/2._ki*t6*t1**4*t4**3*t3**2*t2**5+t4**2*t3**4*t2**9*t1/2._k&
+ &i+t6*t1**6*t4*t2**7/2._ki-t6*t1**6*t3*t2**6/2._ki+100._ki*t1**5*t3&
+ &**3*t5**2*t2**3+8._ki*t1**5*t4**2*t3*t2**7-7._ki*t1**5*t4*t3**2*t&
+ &2**6+30._ki*t1**5*t4**3*t5**4*t2**4-3._ki*t1**5*t4**3*t5**2*t2**6&
+ &-70._ki*t1**3*t4**3*t3**2*t5**2*t2**6+570._ki*t6*t1**4*t4**3*t3**&
+ &2*t5*t2**4+stemp10
+ !
+ stemp11=180._ki*t6*t1**4*t4**4*t3*t5**2*t2**4+270._ki*t6*t1**6*t4**&
+ &2*t3*t5**2*t2**2+6215._ki/2._ki*t6**2*t1**5*t4**3*t3**2*t5*t2+30.&
+ &_ki*t1**4*t4**3*t3*t2**6*t5**2-4._ki/3._ki*t6*t1**4*t4**6*t3*t2**4&
+ &-75._ki/2._ki*t6**2*t1**6*t3*t5**2*t2**3-t6*t4**2*t3**4*t2**8*t1/&
+ &6._ki+78._ki*t1**4*t4**2*t5*t2**6*t3**2-2250._ki*t6*t1**5*t4**3*t3&
+ &**2*t5**2*t2-50._ki*t1**5*t4*t5**4*t2**4*t3+24._ki*t1**4*t4**5*t3&
+ &*t2**4*t5**2+220._ki*t1**4*t4*t3**3*t5*t2**5-25._ki*t6**2*t1**6*t&
+ &4*t5**3*t2**3+11._ki/6._ki*t6**2*t4**2*t2**6*t1**5*t5+t1**4*t4**2&
+ &*t3*t2**8*t5+40._ki*t6*t1**6*t3*t5**3*t2**3+140._ki*t6*t1**3*t4**&
+ &5*t3**4*t2
+ !
+ stemp10=stemp11-15._ki/4._ki*t6*t1**5*t3**2*t2**6-5._ki/6._ki*t6*t3**&
+ &4*t2**6*t1**3+10._ki/3._ki*t6*t3**3*t2**6*t1**4+5._ki/2._ki*t6**2*t&
+ &1**6*t3*t2**5-565._ki/3._ki*t1**3*t4**3*t3**4*t2**4-4._ki/3._ki*t1*&
+ &*3*t4**6*t3**2*t2**5+110._ki*t1**3*t4**4*t3**4*t2**3-12._ki*t1**3&
+ &*t4**2*t3**3*t2**7+105._ki/2._ki*t1**3*t3**5*t2**2*t4**3+7._ki/6._k&
+ &i*t1**3*t4**3*t3**2*t2**8-8._ki*t1**4*t4**4*t3**2*t2**5-13._ki/2.&
+ &_ki*t1**4*t4**2*t3**2*t2**7+22._ki*t1**4*t4*t3**3*t2**6+3._ki*t1**&
+ &5*t4**3*t5*t2**7+170._ki*t1*t2**4*t3**5*t4**5-110._ki*t1*t2**5*t3&
+ &**5*t4**4-56._ki*t1*t4**7*t3**4*t2**4
+ !
+ stemp11=25._ki*t1*t4**4*t3**4*t2**7+4._ki*t1**5*t4*t3*t2**7*t5-33._k&
+ &i/4._ki*t6**2*t1**3*t4**3*t5*t2**5*t3**2-120._ki*t1**3*t4**2*t3**&
+ &3*t2**6*t5-180._ki*t6*t1**5*t3**3*t5*t2**3+240._ki*t6*t1**4*t4**4&
+ &*t5**3*t3*t2**3-60._ki*t1*t4**5*t3**4*t2**6-11._ki/2._ki*t1*t4**3*&
+ &t3**4*t2**8-136._ki*t1*t2**3*t3**5*t4**6-4._ki*t1**4*t4**4*t3*t2*&
+ &*7+5._ki/2._ki*t1**4*t4**3*t3*t2**8+35._ki/2._ki*t1**4*t3**5*t2**2*&
+ &t4+2._ki*t1**4*t4**5*t3*t2**6+13._ki*t1**4*t4**3*t3**2*t2**6-3._ki&
+ &*t1**3*t4**4*t3**2*t2**7-24._ki*t1**5*t4*t5**2*t2**6*t3-60._ki*t1&
+ &**4*t4*t3**2*t5**2*t2**6
+ !
+ stemp8=stemp11+500._ki*t1**4*t4**3*t3**3*t5*t2**3-2825._ki/6._ki*t1*&
+ &*3*t4**3*t3**4*t2**3*t5+50._ki/3._ki*t6*t1**2*t4**4*t3**3*t2**6-5&
+ &._ki*t6*t1**6*t3*t5*t2**5+95._ki/6._ki*t6*t1**3*t3**4*t4*t2**5+24.&
+ &_ki*t6**2*t1**3*t4**8*t3**2*t5-80._ki*t1**5*t4*t5**3*t2**5*t3-200&
+ &._ki*t1**5*t4*t5*t3**3*t2**3-108._ki*t1**5*t4**2*t3**2*t5*t2**4+1&
+ &00._ki/3._ki*t6*t1**4*t4**5*t3*t2**4*t5-30._ki*t6*t1**4*t4**4*t3*t&
+ &2**5*t5+375._ki/4._ki*t6*t1**5*t4**3*t3**2*t2**3+180._ki*t1**3*t4*&
+ &*4*t3**2*t5**2*t2**5-200._ki*t1**3*t4**5*t3**2*t5**2*t2**4+t1**5&
+ &*t3**2*t2**7+72._ki*t6*t1*t2**3*t3**4*t4**7+stemp10+stemp9
+ !
+ stemp11=128._ki/3._ki*t6*t1**2*t4**8*t3**3*t5*t2+170._ki*t6**2*t1**3&
+ &*t4**5*t3**3*t2**2+5._ki*t6**2*t1**6*t4*t5*t2**5-55._ki/2._ki*t6**&
+ &2*t5*t2**4*t3**2*t1**5-35._ki/3._ki*t6*t1**3*t4**5*t3**2*t2**5-10&
+ &._ki/3._ki*t6*t1**3*t4**7*t3**2*t2**3+35._ki/3._ki*t6*t1**4*t4**3*t&
+ &3*t2**6*t5-2080._ki/3._ki*t6*t1**3*t4**5*t3**3*t5*t2**2+640._ki/3.&
+ &_ki*t6*t1**2*t4**6*t3**3*t5*t2**3+350._ki*t1**5*t4*t5**3*t3**2*t2&
+ &**3-200._ki/3._ki*t2**5*t3**5*t4**6+5._ki/3._ki*t3**4*t2**7*t1**3+t&
+ &6**2*t4*t3**3*t2**6*t1**3/2._ki-360._ki*t6*t1**4*t4**2*t3**2*t5**&
+ &2*t2**4-40._ki/3._ki*t6*t1**4*t4**6*t3*t2**3*t5+40._ki/3._ki*t4*t3*&
+ &*3*t2**7*t1**3*t5
+ !
+ stemp10=stemp11-60._ki*t6*t1**6*t2**3*t3**2*t5-5._ki/2._ki*t6*t4**2*&
+ &t5*t3**2*t2**7*t1**3+80._ki*t6*t1**4*t4**6*t3*t5**2*t2**2+275._ki&
+ &*t1**3*t4**4*t3**4*t2**2*t5-14._ki*t1**3*t3**2*t4**3*t5*t2**7-78&
+ &0._ki*t6**2*t1**4*t4**5*t3**2*t5*t2-112._ki/3._ki*t6*t1**2*t4**7*t&
+ &3**3*t2**3+200._ki/3._ki*t6*t1**2*t4**4*t5*t2**5*t3**3+110._ki/3._k&
+ &i*t6*t1*t4**5*t3**4*t2**5-8._ki*t1**5*t4**4*t5**3*t2**4+4._ki/3._k&
+ &i*t4*t2**8*t3**3*t1**3+95._ki*t1**4*t4**2*t3**4*t2**3-50._ki*t1**&
+ &5*t3**2*t5**3*t2**4-2._ki*t1**5*t4*t3*t2**8-10._ki*t1**5*t4**2*t5&
+ &**4*t2**5-210._ki*t6*t1**6*t4*t3*t5**2*t2**3+15._ki*t6*t1**4*t4**&
+ &2*t3**2*t2**6
+ !
+ stemp11=1170._ki*t6*t1**5*t4**3*t3*t5**2*t2**3-1900._ki/3._ki*t1**3*&
+ &t4**4*t3**3*t5**2*t2**3+300._ki*t1**3*t4**5*t3**3*t5**2*t2**2-15&
+ &._ki/2._ki*t1**4*t3**5*t2**3+20._ki/3._ki*t6*t1**3*t4**4*t3**2*t2**&
+ &6-15._ki/8._ki*t6*t1**3*t4**3*t3**2*t2**7+36._ki*t6**2*t1**2*t4**7&
+ &*t3**3*t2**2-5._ki*t6*t4**2*t5**2*t2**6*t1**3*t3**2+13._ki/12._ki*&
+ &t6**2*t1**2*t4**3*t3**3*t2**6-6._ki*t6**2*t1**2*t4**4*t3**3*t2**&
+ &5-544._ki/3._ki*t6*t1**2*t4**6*t3**4*t2**2-25._ki/2._ki*t6*t1**6*t2&
+ &**3*t4*t3**2+385._ki/6._ki*t6**2*t1**5*t4**3*t5**3*t2**3+84._ki*t1&
+ &**5*t4*t5*t2**5*t3**2+1140._ki*t6*t1**4*t4**3*t3**2*t5**2*t2**3+&
+ &16._ki*t1**3*t3**2*t4**6*t5*t2**4-25._ki/6._ki*t4*t5*t2**7*t3**4*t&
+ &1**2
+ !
+ stemp9=stemp11+80._ki*t1**3*t4**6*t3**2*t5**2*t2**3-720._ki*t6*t1**&
+ &5*t4**4*t3*t5**2*t2**2+780._ki*t6**2*t1**4*t4**4*t3**2*t5*t2**2-&
+ &39._ki/2._ki*t6*t1**5*t4**3*t3*t2**5-75._ki*t6*t1**5*t4**3*t5**3*t&
+ &2**4-35._ki/2._ki*t6*t1**6*t4**3*t5**2*t2**3+70._ki*t6*t1**6*t4**3&
+ &*t5**3*t2**2+200._ki*t1*t4**6*t3**4*t5*t2**4+80._ki*t1**5*t3**3*t&
+ &5*t2**4-2._ki*t1**5*t4**4*t5*t2**6-25._ki*t1**5*t3**4*t5*t2**2+15&
+ &._ki*t1**5*t4**3*t5**5*t2**3-10._ki*t1**5*t4**4*t5**5*t2**2-75._ki&
+ &/2._ki*t6**2*t1**6*t3**3*t2-45._ki*t6**2*t1**7*t4**2*t5**3-2._ki*t&
+ &6**2*t1**7*t3*t2**3-20._ki*t1**5*t4**4*t5**4*t2**3+stemp10
+ !
+ stemp11=325._ki/2._ki*t6**2*t1**6*t4**2*t5**3*t2**2+800._ki/3._ki*t6*&
+ &t1**3*t4**6*t3**3*t5*t2-75._ki*t6*t1**5*t4**3*t5**4*t2**3+40._ki/&
+ &3._ki*t6*t5*t2**5*t3**3*t1**4-10._ki/3._ki*t1**3*t3**5*t2**5+90._ki&
+ &*t6*t1**5*t3**2*t2**4*t5**2+15._ki*t6*t1**5*t4**2*t5**4*t2**4-12&
+ &5._ki/2._ki*t1**3*t4*t3**4*t2**5*t5+10._ki/3._ki*t6*t1**4*t4**5*t3*&
+ &t2**5+40._ki*t6*t1**3*t4**7*t3**2*t5*t2**2+200._ki/3._ki*t1**2*t4*&
+ &*7*t3**3*t5**2*t2**2-620._ki*t1**4*t4**2*t3**3*t5*t2**4+560._ki/3&
+ &._ki*t1**2*t4**5*t3**3*t5*t2**5-32._ki/3._ki*t1**2*t4**4*t3**3*t2*&
+ &*7-80._ki*t6*t1**6*t4**2*t5**4*t2**2-285._ki*t6*t1**5*t3**3*t2**2&
+ &*t4**2+320._ki*t1**5*t4**2*t3*t5**3*t2**4
+ !
+ stemp10=stemp11-5._ki/3._ki*t6*t4*t3**3*t2**7*t1**3-75._ki*t6**2*t1*&
+ &*7*t4*t3*t5**2+20._ki*t6*t1**6*t4*t5**3*t2**4+40._ki*t6*t4*t3**2*&
+ &t2**5*t1**4*t5**2+825._ki/2._ki*t6**2*t1**5*t3**2*t2**3*t4*t5-30.&
+ &_ki*t6*t1**5*t4**4*t5**2*t2**4+14._ki*t1**5*t4**3*t5*t3*t2**5+110&
+ &._ki*t6*t1**4*t3**4*t2**3*t4-105._ki*t6*t1**5*t3**4*t2*t4-128._ki/&
+ &3._ki*t6*t1*t2**2*t3**4*t4**8-44._ki/3._ki*t6*t1**2*t4**3*t5*t2**6&
+ &*t3**3-12._ki*t4**4*t3**5*t2**7-t6*t1**6*t2**6*t4*t5+30._ki*t6*t1&
+ &**6*t3*t5**2*t2**4-40._ki*t6*t1**2*t4**5*t3**3*t2**5-25._ki/6._ki*&
+ &t4**2*t5**2*t2**7*t1**2*t3**3+480._ki*t1**4*t4**4*t3**2*t5**2*t2&
+ &**3
+ !
+ stemp7=-16._ki*t1**5*t4**2*t5*t3*t2**6+stemp8-250._ki/3._ki*t6*t1**3&
+ &*t4**3*t3**3*t2**5-325._ki*t6**2*t1**6*t4**3*t5**3*t2-125._ki/2._k&
+ &i*t6**2*t1**6*t2**2*t3*t4**3-5._ki*t6*t1**6*t4*t5**2*t2**5-540._k&
+ &i*t1**5*t4**2*t3**2*t5**2*t2**3+495._ki*t6**2*t1**5*t4**2*t3*t5*&
+ &*2*t2**3+700._ki/3._ki*t1**2*t4**5*t3**3*t5**2*t2**4-400._ki/3._ki*&
+ &t1**2*t4**4*t3**3*t5**2*t2**5+stemp10-180._ki*t6*t1**4*t4**2*t3*&
+ &*2*t5*t2**5-200._ki*t6*t1**4*t4**5*t3*t5**2*t2**3+33._ki*t6**2*t1&
+ &**5*t4**4*t5*t2**4+110._ki/3._ki*t4**5*t3**5*t2**6-2._ki*t1**4*t3*&
+ &*3*t2**7+15._ki*t6*t1**5*t4**5*t5**2*t2**3-1000._ki/3._ki*t6*t1**3&
+ &*t4**3*t3**3*t5*t2**4+176._ki/3._ki*t6*t1**2*t4**7*t3**4*t2-7._ki*&
+ &t6**2*t1**3*t4**2*t3**3*t2**5+90._ki*t6*t1**5*t4*t3*t5**2*t2**5+&
+ &96._ki*t1**5*t4**2*t5**2*t2**5*t3-150._ki*t1**3*t4**2*t3**3*t5**2&
+ &*t2**5+20._ki*t6*t1**6*t4*t5**4*t2**3+36._ki*t1**3*t3**2*t4**4*t5&
+ &*t2**6-128._ki/3._ki*t2**3*t3**5*t4**8+72._ki*t2**4*t3**5*t4**7+15&
+ &._ki*t1**4*t3**4*t2**5-t4**2*t3**5*t2**9/6._ki+8._ki*t1**5*t3**3*t&
+ &2**5-175._ki/3._ki*t1**3*t4**3*t3**2*t5**3*t2**5-136._ki*t6**2*t1*&
+ &*3*t4**6*t3**3*t2+165._ki/4._ki*t6*t1**5*t4*t3**2*t2**5-55._ki/6._k&
+ &i*t6**2*t4**2*t5**3*t2**4*t1**5+stemp9
+ !
+ stemp10=-100._ki/3._ki*t6**2*t1**2*t4**6*t3**3*t2**3-64._ki/3._ki*t6*&
+ &*2*t1**2*t4**8*t3**3*t2-5._ki/3._ki*t6*t4**2*t2**7*t1**4*t3*t5-11&
+ &40._ki*t6*t1**5*t4**2*t3**3*t5*t2-12._ki*t1**4*t3**2*t5*t4*t2**7-&
+ &50._ki*t1**4*t4*t5**3*t2**5*t3**2-20._ki*t1**4*t4**2*t3*t5**3*t2*&
+ &*6+220._ki*t6*t1**4*t2**4*t3**3*t4**2-800._ki/3._ki*t6*t1**4*t4**5&
+ &*t5**3*t3*t2**2-50._ki*t6*t1**4*t2**5*t3**3*t4+190._ki/3._ki*t6*t1&
+ &**4*t4**4*t3**2*t2**4+10._ki*t6*t4**2*t3*t2**6*t1**4*t5**2-5._ki*&
+ &t6**2*t1**7*t5**3*t2**2+t4*t3**5*t2**8*t1/2._ki+25._ki/6._ki*t5*t2&
+ &**6*t3**4*t1**3-5._ki*t1**5*t4**2*t5**5*t2**4-t1**5*t4**2*t2**8*&
+ &t5-60._ki*t1**5*t3**2*t2**5*t5**2+t1**5*t4**2*t5**2*t2**7-10._ki*&
+ &t1**5*t2**3*t3**4-7._ki*t1**5*t4**3*t3*t2**6-20._ki*t1**5*t3**3*t&
+ &2**4*t4+10._ki*t6*t1**6*t3**3*t2**2-5._ki/3._ki*t4*t3**4*t2**8*t1*&
+ &*2+12._ki*t1**5*t4**3*t5**3*t2**5-80._ki*t1**4*t4*t3**4*t2**4+75.&
+ &_ki/2._ki*t1**4*t3**4*t5*t2**4+9._ki*t1**5*t4**2*t3**2*t2**5-62._ki&
+ &*t1**4*t4**2*t3**3*t2**5+360._ki*t6*t1**6*t4**2*t5**3*t2*t3-3._ki&
+ &/4._ki*t6*t1**5*t4**2*t5*t2**7-6._ki*t1**4*t4**2*t5**2*t2**7*t3+1&
+ &50._ki*t6*t1**6*t4*t5*t3**2*t2**2
+ !
+ stemp11=stemp10-25._ki/2._ki*t1**4*t4**2*t3*t5**4*t2**5+155._ki/4._ki&
+ &*t6**2*t1**3*t3**3*t4**3*t2**4-285._ki/2._ki*t6**2*t1**4*t4**2*t3&
+ &**3*t2**3+120._ki*t6*t1**5*t4**4*t5*t2**3*t3-14._ki*t6**2*t1**4*t&
+ &4**5*t3*t2**4+30._ki*t6**2*t1**7*t3*t5**2*t2-7._ki*t6**2*t1**7*t4&
+ &*t5*t2**3-40._ki*t1**3*t3**2*t4**5*t5*t2**5+475._ki*t1**3*t4**3*t&
+ &3**3*t5**2*t2**4+380._ki*t1**3*t4**3*t3**3*t2**5*t5+135._ki/4._ki*&
+ &t6**2*t1**4*t4**3*t5**2*t2**4*t3+55._ki/3._ki*t6**2*t1**2*t4**5*t&
+ &3**3*t2**4-80._ki*t6*t1**3*t4**4*t3**2*t5*t2**5-120._ki*t6*t1**3*&
+ &t4**6*t3**2*t5*t2**3-25._ki*t1**3*t4*t3**4*t2**6+55._ki/2._ki*t1**&
+ &3*t3**5*t2**4*t4
+ !
+ stemp9=stemp11+110._ki/3._ki*t6**2*t1**5*t2**3*t3**3-220._ki/3._ki*t6&
+ &**2*t1**5*t4**6*t5**3+210._ki*t6**2*t1**4*t4**5*t3**3+44._ki*t6**&
+ &2*t1**3*t4**7*t3**3-4._ki*t6**2*t1**4*t4**7*t3*t2**2+10._ki/3._ki*&
+ &t1**3*t4**5*t3**2*t2**6+110._ki*t1**3*t4**2*t3**4*t2**5+38._ki*t1&
+ &**3*t4**3*t3**3*t2**6-152._ki/3._ki*t1**3*t4**4*t3**3*t2**5+24._ki&
+ &*t1**3*t4**5*t3**3*t2**4+3._ki/8._ki*t6*t1**5*t4**2*t2**8+35._ki*t&
+ &6**2*t1**7*t4*t5**3*t2-165._ki*t6**2*t1**5*t4**4*t5**3*t2**2+25.&
+ &_ki/3._ki*t4**2*t5**3*t2**6*t1**3*t3**2+230._ki/3._ki*t6*t1**3*t4**&
+ &2*t3**3*t5*t2**5-160._ki*t6*t1**3*t4**4*t3**2*t5**2*t2**4+200._ki&
+ &*t1**5*t4**2*t5**4*t3*t2**3
+ !
+ stemp11=550._ki/3._ki*t6**2*t1**5*t4**5*t5**3*t2+680._ki/3._ki*t6*t1*&
+ &*2*t4**5*t3**4*t2**3-15._ki*t6*t1**5*t4*t5*t2**6*t3-28._ki/3._ki*t&
+ &6*t1**2*t4**2*t3**4*t2**6+880._ki*t6*t1**4*t4**4*t3**3*t5*t2-650&
+ &._ki*t1**4*t4**3*t3**2*t5**3*t2**3+300._ki*t6*t1**6*t4*t3**2*t5**&
+ &2*t2-90._ki*t6**2*t1**3*t4**5*t3**2*t5*t2**3-1125._ki*t6*t1**5*t4&
+ &**3*t3**2*t5*t2**2-495._ki*t6*t1**5*t4*t3**2*t5*t2**4-150._ki*t1*&
+ &t4**5*t3**4*t5*t2**5+40._ki*t1*t4**8*t3**4*t5*t2**2+80._ki*t1**4*&
+ &t4**5*t5**3*t3*t2**3-240._ki*t6*t1**3*t4**6*t3**2*t5**2*t2**2-84&
+ &._ki*t6**2*t1**3*t4**7*t3**2*t5*t2+44._ki/3._ki*t6**2*t1**5*t4**6*&
+ &t5*t2**2-110._ki/3._ki*t6**2*t1**5*t4**5*t5*t2**3
+ !
+ stemp10=stemp11+195._ki/2._ki*t6*t1**5*t4**2*t5*t2**5*t3-3135._ki/2.&
+ &_ki*t6**2*t1**5*t4**3*t3*t5**2*t2**2-5._ki/12._ki*t3**5*t2**7*t1**&
+ &2-3._ki*t6*t1**4*t4**4*t3*t2**6-440._ki/3._ki*t6*t1**2*t2**4*t4**4&
+ &*t3**4-200._ki/3._ki*t6*t1*t2**4*t3**4*t4**6-280._ki*t6*t1**6*t4*t&
+ &5**3*t3*t2**2+13._ki/6._ki*t4**3*t3**5*t2**8+66._ki*t6**2*t1**5*t4&
+ &**5*t3*t2**2+1560._ki*t6*t1**5*t4**3*t3*t5**3*t2**2+50._ki*t1**4*&
+ &t3**3*t4**3*t2**4+2._ki*t1**5*t4**4*t5**2*t2**5-205._ki/3._ki*t1**&
+ &3*t3**5*t2**3*t4**2+45._ki*t6*t1**5*t3**4*t2**2-45._ki*t6*t1**5*t&
+ &3**3*t2**4+7._ki/4._ki*t6*t1**6*t4**3*t2**5-15._ki*t6**2*t1**7*t3*&
+ &*2*t5
+ !
+ stemp11=stemp10+200._ki*t6**2*t1**6*t4**4*t5**3-3._ki/2._ki*t6*t1**5&
+ &*t4*t3*t2**7-280._ki*t1**5*t4**3*t3*t5**3*t2**3+420._ki*t1**5*t4*&
+ &t3**2*t5**2*t2**4+210._ki*t6*t1**4*t4**3*t3**4*t2+20._ki*t6*t4*t3&
+ &**2*t2**6*t1**4*t5-175._ki*t1**5*t4**3*t3*t5**4*t2**2-990._ki*t6*&
+ &t1**5*t4*t3**2*t5**2*t2**3+300._ki*t6**2*t1**4*t4**6*t3**2*t5+50&
+ &0._ki/3._ki*t1**2*t4**6*t3**4*t5*t2**2-6._ki*t6*t1**5*t4**4*t5*t2*&
+ &*5+15._ki/4._ki*t6*t1**5*t4**3*t5*t2**6-9._ki/4._ki*t6**2*t1**4*t4*&
+ &*3*t3*t2**6+15._ki*t6*t1**5*t4**2*t5**3*t2**5+50._ki*t1**4*t4**5*&
+ &t5**4*t3*t2**2+125._ki/2._ki*t1**4*t4**3*t5**4*t3*t2**4
+ !
+ stemp8=stemp11-11._ki/3._ki*t6*t1**2*t4**3*t3**3*t2**7+140._ki*t6*t1&
+ &**3*t4**5*t3**2*t5*t2**4-60._ki*t6*t1**5*t4**5*t5**3*t2**2+225._k&
+ &i/2._ki*t6**2*t1**6*t3**2*t5*t2**2+120._ki*t6*t1**5*t4**4*t5**3*t&
+ &2**3-70._ki*t6*t1**4*t4**3*t3*t5**2*t2**5-140._ki*t1*t4**7*t3**4*&
+ &t5*t2**3+45._ki*t6*t1**5*t2**5*t3**2*t5+5._ki*t6**2*t1**7*t2**2*t&
+ &3*t4+9._ki*t6**2*t1**7*t4**2*t5*t2**2+12._ki*t6**2*t1**4*t4**6*t3&
+ &*t2**3-1130._ki/3._ki*t6*t1**4*t2**3*t3**3*t4**3-60._ki*t6*t1**5*t&
+ &4**5*t5**4*t2+50._ki/3._ki*t4*t3**3*t2**6*t1**3*t5**2-t6**2*t4**2&
+ &*t3**3*t2**7*t1**2/12._ki+65._ki*t6**2*t1**6*t4**3*t5*t2**3+10._ki&
+ &*t4**2*t3**2*t2**7*t1**3*t5**2+stemp9
+ !
+ stemp11=stemp8+209._ki/2._ki*t6**2*t1**5*t4**3*t3*t2**4+2090._ki*t6*&
+ &*2*t1**5*t4**4*t3*t5**2*t2-120._ki*t6**2*t1**4*t4**4*t5**2*t2**3&
+ &*t3+2._ki*t4**2*t3**2*t2**8*t1**3*t5+320._ki/3._ki*t6*t1**4*t4**6*&
+ &t5**3*t3*t2+210._ki*t6**2*t1**4*t4**5*t3*t5**2*t2**2+160._ki/3._ki&
+ &*t1**2*t4**7*t3**3*t5*t2**3+880._ki*t6*t1**4*t4**2*t3**3*t2**3*t&
+ &5-33._ki*t6**2*t1**5*t4**2*t3*t2**5-780._ki*t1**4*t4**3*t3**2*t5*&
+ &*2*t2**4-1815._ki*t6**2*t1**5*t4**4*t3**2*t5+115._ki/6._ki*t6*t1**&
+ &3*t4**2*t3**3*t2**6-95._ki*t6*t1**3*t4**2*t3**4*t2**4-180._ki*t6*&
+ &*2*t1**4*t4**6*t3*t5**2*t2+8._ki*t6**2*t1**4*t4**4*t3*t2**5
+ !
+ stemp10=stemp11+8._ki*t1**4*t4**4*t3*t2**6*t5-48._ki*t1**4*t4**4*t3&
+ &*t2**5*t5**2-t6*t1**4*t4**2*t3*t2**8/6._ki-280._ki/3._ki*t6*t1**4*&
+ &t4**3*t5**3*t3*t2**4+60._ki*t6**2*t1**4*t4**7*t3*t5**2-55._ki*t6*&
+ &*2*t4*t3*t2**4*t1**5*t5**2-9._ki/2._ki*t6*t1**6*t4**2*t3*t2**4-7.&
+ &_ki/2._ki*t6*t1**6*t4**3*t5*t2**4+1395._ki*t6*t1**5*t4**2*t3**2*t5&
+ &*t2**3+30._ki*t1**2*t4**3*t5*t3**3*t2**7+625._ki*t1**4*t4**3*t3**&
+ &3*t5**2*t2**2-20._ki/3._ki*t6*t4*t5*t2**6*t3**3*t1**3+4._ki/3._ki*t&
+ &6*t4**2*t5*t2**7*t1**2*t3**3-1815._ki*t6**2*t1**5*t4**2*t3**2*t5&
+ &*t2**2+345._ki/4._ki*t6**2*t1**4*t4**2*t3**2*t5*t2**4+t6**2*t4**2&
+ &*t3*t2**7*t1**4/4._ki-585._ki*t6*t1**5*t4**2*t3*t5**2*t2**4
+ !
+ stemp11=stemp10+960._ki*t6*t1**5*t3**3*t5*t2**2*t4+32._ki/3._ki*t2**&
+ &2*t3**5*t4**9+2255._ki/3._ki*t6**2*t1**5*t3**3*t4**2*t2-460._ki*t6&
+ &**2*t1**4*t4**4*t3**3*t2-12._ki*t6*t1*t4**4*t3**4*t2**6-10._ki/3.&
+ &_ki*t4**2*t5*t3**3*t2**8*t1**2-775._ki*t1**4*t4**2*t3**3*t2**3*t5&
+ &**2-1520._ki*t6*t1**4*t4**4*t3**2*t5**2*t2**2+575._ki/12._ki*t1**2&
+ &*t4**2*t3**4*t5*t2**6-200._ki*t1**4*t3**4*t5*t2**3*t4+1425._ki/2.&
+ &_ki*t6**2*t1**6*t4**2*t3**2*t5+155._ki/2._ki*t6**2*t1**6*t2**3*t3*&
+ &t4**2+720._ki*t6*t1**4*t4**5*t3**2*t5**2*t2-500._ki/3._ki*t1**3*t4&
+ &**5*t3**2*t5**3*t2**3-15._ki/4._ki*t6*t1**5*t4**2*t5**2*t2**6+2._k&
+ &i/3._ki*t6*t4*t3**4*t2**7*t1**2
+ !
+ stemp9=stemp11+120._ki*t6*t1**5*t4*t5**3*t2**4*t3-600._ki*t6**2*t1*&
+ &*6*t3**2*t5*t2*t4+11._ki/3._ki*t6**2*t4*t2**6*t3*t1**5-15._ki/4._ki&
+ &*t6**2*t4**2*t5**2*t2**5*t1**4*t3-55._ki/4._ki*t1*t4**3*t5*t2**7*&
+ &t3**4+1300._ki/3._ki*t1**2*t4**4*t3**4*t5*t2**4+10._ki*t6*t1**3*t4&
+ &**6*t3**2*t2**4+stemp7+5._ki/24._ki*t6*t4**2*t3**2*t2**8*t1**3+3.&
+ &_ki/4._ki*t6**2*t4**2*t5*t2**6*t1**3*t3**2+75._ki/2._ki*t1**2*t4**3&
+ &*t5**2*t2**6*t3**3-15._ki/2._ki*t6**2*t4*t5*t2**5*t3**2*t1**4-195&
+ &._ki*t6*t1**5*t4**3*t5*t2**4*t3-920._ki/3._ki*t6*t1**3*t4**4*t3**4&
+ &*t2**2-5._ki/4._ki*t6**2*t3**3*t2**5*t1**4+3._ki*t6*t1**5*t4**5*t5&
+ &*t2**4-760._ki*t6*t1**4*t4**4*t3**2*t5*t2**3+1875._ki/2._ki*t6**2*&
+ &t1**6*t4**3*t3*t5**2
+ !
+ stemp11=stemp9-100._ki*t1**4*t4**4*t5**4*t3*t2**3+400._ki*t1**4*t4*&
+ &*4*t3**2*t5**3*t2**2+275._ki*t1**4*t4*t3**3*t2**4*t5**2+40._ki*t6&
+ &*t1**6*t3**3*t5*t2+4._ki*t6*t1**6*t4**2*t5*t2**5+32._ki/3._ki*t6*t&
+ &1*t2*t3**4*t4**9-4520._ki/3._ki*t6*t1**4*t4**3*t3**3*t2**2*t5+5._k&
+ &i/4._ki*t4**2*t5*t2**8*t1*t3**4+125._ki/2._ki*t1*t4**4*t5*t2**6*t3&
+ &**4+160._ki/3._ki*t6*t1**2*t4**6*t3**3*t2**4+32._ki/3._ki*t6*t1**2*&
+ &t4**8*t3**3*t2**2-65._ki/2._ki*t6**2*t1**6*t4**2*t5*t2**4+45._ki/2&
+ &._ki*t6*t1**3*t4**3*t5*t3**2*t2**6+360._ki*t6*t1**4*t4**5*t3**2*t&
+ &5*t2**2+20._ki*t6*t1**6*t4**2*t5**2*t2**4+7._ki/2._ki*t6*t1**6*t4*&
+ &t3*t2**5
+ !
+ stemp10=stemp11+80._ki*t6*t1**3*t4**7*t3**2*t5**2*t2-12._ki*t1**5*t&
+ &5*t3**2*t2**6-4._ki*t1**5*t4**2*t5**3*t2**6-25._ki*t1**4*t3**3*t5&
+ &**2*t2**5+t6**2*t1**7*t5*t2**4-t4**2*t3**3*t2**9*t1**2/3._ki-20.&
+ &_ki*t1**4*t3**3*t5*t2**6+t1**4*t4*t3**2*t2**8-t1**4*t4**2*t3*t2*&
+ &*9/2._ki-t1**3*t4**2*t3**2*t2**9/6._ki-55._ki/2._ki*t6**2*t1**6*t2*&
+ &*4*t3*t4-40._ki*t6**2*t1**6*t4**4*t5*t2**2-80._ki*t6*t1**6*t4**2*&
+ &t5**3*t2**3-780._ki*t6*t1**5*t4**2*t5**3*t3*t2**3+755._ki/3._ki*t6&
+ &*t1**3*t4**3*t3**4*t2**3-110._ki*t6**2*t1**3*t4**4*t3**3*t2**3-1&
+ &20._ki*t6*t1**6*t3**2*t5**2*t2**2
+ !
+ stemp11=stemp10+200._ki/3._ki*t6*t1**3*t4**6*t3**3*t2**2+520._ki/3._k&
+ &i*t6*t1**3*t4**4*t3**3*t2**4-520._ki/3._ki*t6*t1**3*t4**5*t3**3*t&
+ &2**3-960._ki*t6*t1**5*t4**4*t3*t5**3*t2+t6*t4**2*t3**3*t2**8*t1*&
+ &*2/3._ki+325._ki*t1**4*t4**2*t3**2*t5**3*t2**4-84._ki*t1**5*t4**3*&
+ &t5**2*t2**4*t3+45._ki*t6*t1**3*t4**3*t5**2*t2**5*t3**2+115._ki/6.&
+ &_ki*t1**2*t4**2*t3**4*t2**7-250._ki/3._ki*t1**2*t4**3*t3**4*t2**6+&
+ &200._ki/3._ki*t1**2*t4**6*t3**4*t2**3+3._ki*t1**2*t4**3*t3**3*t2**&
+ &8+16._ki/3._ki*t1**2*t4**7*t3**3*t2**4-45._ki*t6*t1**6*t4**2*t5*t2&
+ &**3*t3+390._ki*t1**4*t4**2*t3**2*t5**2*t2**5-605._ki/2._ki*t6**2*t&
+ &1**5*t3**3*t2**2*t4+39._ki/4._ki*t6*t1**5*t4**2*t3*t2**6
+ !
+ stemp6=stemp11-160._ki*t1**2*t4**6*t3**3*t5*t2**4+7._ki/6._ki*t6*t1*&
+ &*4*t4**3*t3*t2**7-16._ki*t1**2*t4**6*t3**3*t2**5+56._ki/3._ki*t1**&
+ &2*t4**5*t3**3*t2**6+520._ki/3._ki*t1**2*t4**4*t3**4*t2**5-5._ki*t1&
+ &**4*t4**3*t3*t2**7*t5-4._ki*t1**4*t4**5*t3*t2**5*t5+275._ki*t1**3&
+ &*t4**2*t3**4*t2**4*t5-1520._ki/3._ki*t1**3*t4**4*t3**3*t2**4*t5+7&
+ &55._ki/2._ki*t6**2*t1**4*t4**3*t3**3*t2**2+2080._ki/3._ki*t6*t1**3*&
+ &t4**4*t3**3*t5*t2**3+75._ki/2._ki*t6**2*t1**3*t4**4*t5*t2**4*t3**&
+ &2+70._ki*t6*t1**6*t4**3*t5**4*t2+240._ki*t1**3*t4**5*t3**3*t2**3*&
+ &t5+475._ki/2._ki*t1**4*t4**2*t3**4*t5*t2**2+155._ki/3._ki*t6*t1**2*&
+ &t3**4*t4**3*t2**5-990._ki*t6**2*t1**5*t4**5*t3*t5**2+12._ki*t6*t1&
+ &**5*t4**4*t3*t2**4
+ !
+ stemp7=t6/t1**5/t2**12
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp5=20._ki*t6**2*t1*t2*t3*t4*t5**2+5._ki*t6**2*t1*t2*t5*t3**2+5.&
+ &_ki*t6**3*t1*t3*t5*t2**2+65._ki*t6**3*t1*t4**2*t3*t5-25._ki*t6**3*&
+ &t1*t4**2*t5**2*t2-14._ki/3._ki*t6**2*t1*t2**3*t3*t4+16._ki*t6**3*t&
+ &1*t2**2*t3*t4+7._ki/6._ki*t6**2*t4*t3*t2**5+10._ki/3._ki*t6**2*t4**&
+ &3*t5**3*t2**2-10._ki/3._ki*t6**2*t4**4*t5**3*t2-5._ki/6._ki*t6**2*t&
+ &4**2*t5**3*t2**3+5._ki*t6**2*t1*t4**2*t2**4-2._ki*t6**2*t1*t4*t2*&
+ &*5+t6*t4*t2**6*t1/2._ki+20._ki*t6**3*t1*t4**2*t5*t2**2+56._ki/3._ki&
+ &*t6**3*t4**4*t3*t2+10._ki*t6**3*t4**2*t3*t2**3+10._ki*t6**3*t4**4&
+ &*t5**2*t2-24._ki*t6**3*t4**3*t3*t2**2-4._ki/3._ki*t6**3*t4*t3*t2**&
+ &4-5._ki*t6**3*t4**3*t5**2*t2**2+9._ki*t6**3*t1*t4**3*t2**2
+ !
+ stemp4=stemp5+16._ki/3._ki*t6**3*t4**5*t5*t2+5._ki/6._ki*t6**3*t4**2*&
+ &t5**2*t2**3+4._ki*t6**3*t4**3*t5*t2**3-8._ki*t6**3*t4**4*t5*t2**2&
+ &-2._ki/3._ki*t6**3*t4**2*t5*t2**4-4._ki*t6**3*t1*t4*t5*t2**3-25._ki&
+ &*t6**3*t4**2*t3*t5*t2**2-2._ki*t6**2*t4**4*t2**4-35._ki/6._ki*t6**&
+ &2*t4**2*t3*t2**4+7._ki/12._ki*t6**2*t4**2*t5*t2**5-7._ki/3._ki*t6**&
+ &2*t4**3*t5*t2**4+7._ki/3._ki*t6**2*t4**4*t5*t2**3+7._ki*t6**2*t4**&
+ &3*t3*t2**3-140._ki/3._ki*t6**3*t4**4*t3*t5-10._ki*t6**3*t1**2*t5**&
+ &2*t4+5._ki/2._ki*t6**3*t1**2*t5**2*t2+2._ki*t6**3*t1**2*t2*t3-2._ki&
+ &*t6**3*t1**2*t5*t2**2+60._ki*t6**3*t4**3*t3*t5*t2-40._ki*t6**3*t1&
+ &*t3*t5*t2*t4+5._ki*t6**3*t1*t4*t5**2*t2**2-24._ki*t6**3*t1*t4**3*&
+ &t5*t2
+ !
+ stemp5=-26._ki*t6**3*t1*t2*t3*t4**2-5._ki*t6**2*t1*t5**2*t3*t2**2-6&
+ &5._ki/2._ki*t6**2*t2*t3**2*t4**2*t5+20._ki*t6**2*t3**2*t4*t5*t2**2&
+ &+8._ki*t6**3*t1**2*t5*t2*t4-35._ki/6._ki*t6**2*t1*t4**2*t5*t2**3+5&
+ &._ki/3._ki*t6**2*t2**2*t3**3-t1**2*t2**4*t6**2/2._ki-20._ki/3._ki*t6&
+ &**3*t4**5*t5**2+t6**3*t4**2*t2**5/4._ki-3._ki/2._ki*t6**3*t4**3*t2&
+ &**4+3._ki/4._ki*t6**3*t1**2*t2**3-2._ki*t6**3*t4**5*t2**2+t4**2*t5&
+ &*t2**7/12._ki+t4*t3*t2**7/6._ki+2._ki*t6**2*t4**3*t2**5+5._ki/6._ki*&
+ &t6**3*t2**3*t3**2-95._ki/3._ki*t6**3*t3**2*t4**3+7._ki/3._ki*t6**2*&
+ &t1*t4*t5*t2**4+t6*t4**2*t2**7/4._ki+3._ki*t6**3*t4**4*t2**3-t6**2&
+ &*t4**2*t2**6/2._ki
+ !
+ stemp3=stemp5-t6*t4**3*t2**6/2._ki+25._ki*t6**2*t4**2*t5**2*t3*t2**&
+ &2+stemp4-30._ki*t6**2*t4**3*t5**2*t3*t2-5._ki*t6**2*t4*t5**2*t3*t&
+ &2**3-10._ki/3._ki*t6**2*t1*t4*t5**3*t2**2+25._ki/3._ki*t6**2*t1*t4*&
+ &*2*t5**3*t2+10._ki/3._ki*t6**3*t4*t3*t5*t2**3+7._ki/12._ki*t6**2*t1&
+ &**2*t5*t2**3-5._ki/6._ki*t6**2*t1**2*t2*t5**3+7._ki/6._ki*t6**2*t1*&
+ &t2**4*t3-5._ki*t6**2*t2*t3**3*t4-5._ki/2._ki*t6**2*t2**3*t3**2*t5-&
+ &5._ki*t6**3*t1*t3**2*t2+15._ki*t6**3*t3**2*t1*t4+65._ki/2._ki*t6**3&
+ &*t3**2*t2*t4**2-10._ki*t6**3*t2**2*t3**2*t4-15._ki/2._ki*t6**3*t1*&
+ &t4**2*t2**3+3._ki/2._ki*t6**3*t1*t4*t2**4+30._ki*t6**3*t1*t4**3*t5&
+ &**2-2._ki*t6**3*t1*t2**3*t3-5._ki*t6**3*t1**2*t3*t5-3._ki*t6**3*t1&
+ &**2*t2**2*t4
+ !
+ stemp4=1._ki/t2**10*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=-(-2._ki*t3*t1*t6+2._ki*t3**2*t2+3._ki*t6*t4*t2*t3-6._ki*t4**2&
+ &*t3*t6+t3*t5*t2*t4-4._ki*t4*t1*t6*t5)*t4/t2**4/t3*q(4,(t2*t3-t1*&
+ &t6)/t2/t3,sign_arg)/12._ki
+ !
+ stemp9=22._ki/3._ki*t6**3*t1**3*t4**3*t5*t2**3+25._ki/6._ki*t6**3*t1*&
+ &*4*t4*t5**2*t2**2+7._ki/3._ki*t6**2*t1**2*t4**4*t3*t2**4-7._ki/6._k&
+ &i*t6**2*t1**2*t4**3*t3*t2**5+2._ki/3._ki*t6**3*t1**5*t2*t3+15._ki/&
+ &2._ki*t6**3*t1**4*t4**3*t2**2-25._ki/4._ki*t6**3*t1**4*t4**2*t2**3&
+ &+t1**3*t4*t3*t2**7/18._ki+5._ki/4._ki*t6**3*t1**4*t4*t2**4+25._ki*t&
+ &6**3*t1**4*t4**3*t5**2-5._ki/3._ki*t6**3*t1**4*t2**3*t3-11._ki/4._k&
+ &i*t6**3*t1**3*t4**3*t2**4-11._ki/3._ki*t6**3*t1**3*t4**5*t2**2+55&
+ &._ki/36._ki*t6**3*t1**3*t3**2*t2**3-110._ki/9._ki*t6**3*t1**3*t4**5&
+ &*t5**2-1045._ki/18._ki*t6**3*t1**3*t3**2*t4**3+11._ki/24._ki*t6**3*&
+ &t1**3*t4**2*t2**5
+ !
+ stemp8=stemp9+11._ki/2._ki*t6**3*t1**3*t4**4*t2**3+5._ki/2._ki*t6**2*&
+ &t1**3*t3**3*t2**2+5._ki/2._ki*t6**2*t1**4*t4**2*t2**4+7._ki/12._ki*&
+ &t6**2*t1**4*t2**4*t3+5._ki/12._ki*t6**3*t1*t4**3*t3**2*t2**4-70._k&
+ &i/9._ki*t6**2*t1*t4**4*t3**3*t2**2-25._ki/18._ki*t6**2*t1*t2**4*t3&
+ &**3*t4**2+20._ki/3._ki*t6**2*t1**2*t4**5*t3*t5**2*t2+70._ki/3._ki*t&
+ &6**2*t1**2*t3**2*t4**4*t5*t2-14._ki/9._ki*t6**2*t1**2*t4**5*t3*t2&
+ &**3-30._ki*t6**2*t1**2*t3**2*t4**3*t5*t2**2-5._ki/18._ki*t6**2*t1*&
+ &*2*t3**3*t2**4-10._ki/9._ki*t6**2*t4**4*t3**3*t2**4+20._ki/9._ki*t6&
+ &**2*t4**5*t3**3*t2**3-20._ki/9._ki*t6**2*t4**6*t3**3*t2**2+25._ki/&
+ &2._ki*t6**3*t1**4*t3**2*t4-25._ki/6._ki*t6**3*t1**4*t3**2*t2
+ !
+ stemp9=8._ki/9._ki*t6**2*t4**7*t3**3*t2-t6**2*t1**4*t4*t2**5-3._ki/4&
+ &._ki*t6**2*t1**3*t4**2*t2**6-3._ki*t6**2*t1**3*t4**4*t2**4+3._ki*t&
+ &6**2*t1**3*t4**3*t2**5-t6*t1**3*t4**3*t2**6/2._ki+t6*t1**3*t4**2&
+ &*t2**7/4._ki-t6**2*t2**6*t3**3*t4**2/36._ki+5._ki/18._ki*t6**2*t2**&
+ &5*t3**3*t4**3+t1**3*t4**2*t5*t2**7/9._ki-70._ki/3._ki*t6**3*t1**2*&
+ &t4**4*t3**2*t2+55._ki/9._ki*t6**3*t1**3*t4*t3*t5*t2**3+15._ki*t6**&
+ &3*t1**2*t4**3*t3**2*t2**2+16._ki/3._ki*t6**3*t1**2*t4**5*t3*t2**2&
+ &-44._ki/3._ki*t6**3*t1**3*t4**4*t5*t2**2-55._ki/3._ki*t6**3*t1**3*t&
+ &4*t3**2*t2**2-22._ki/9._ki*t6**3*t1**3*t4*t3*t2**4
+ !
+ stemp7=stemp9+stemp8-40._ki/3._ki*t6**3*t1**2*t4**5*t3*t5*t2+10._ki*&
+ &t6**3*t1**2*t4**4*t3*t5*t2**2-25._ki/6._ki*t6**3*t1**2*t4**2*t3**&
+ &2*t2**3+4._ki/3._ki*t6**3*t1**2*t4**3*t3*t2**4-770._ki/9._ki*t6**3*&
+ &t1**3*t4**4*t3*t5+55._ki/3._ki*t6**3*t1**3*t4**4*t5**2*t2-55._ki/6&
+ &._ki*t6**3*t1**3*t4**3*t5**2*t2**2+25._ki/2._ki*t6**2*t1**2*t3**2*&
+ &t4**2*t5*t2**3-10._ki*t6**2*t1**2*t4**4*t3*t5**2*t2**2-11._ki/9._k&
+ &i*t6**3*t1**3*t4**2*t5*t2**4+7._ki/6._ki*t6**2*t1**4*t4*t5*t2**4+&
+ &25._ki/6._ki*t6**2*t1**4*t4**2*t5**3*t2+10._ki/3._ki*t6**3*t1*t4**5&
+ &*t3**2*t2**2+8._ki/3._ki*t6**3*t1**5*t5*t2*t4+20._ki/3._ki*t6**3*t1&
+ &**2*t4**6*t3*t5-8._ki/3._ki*t6**3*t1**2*t4**6*t3*t2-4._ki*t6**3*t1&
+ &**2*t4**4*t3*t2**3
+ !
+ stemp9=stemp7-35._ki/12._ki*t6**2*t1**4*t4**2*t5*t2**3+110._ki*t6**3&
+ &*t1**3*t4**3*t3*t5*t2+715._ki/12._ki*t6**3*t1**3*t3**2*t4**2*t2+5&
+ &5._ki/36._ki*t6**3*t1**3*t4**2*t5**2*t2**3+40._ki/9._ki*t6**2*t1*t4&
+ &**5*t3**3*t2+88._ki/9._ki*t6**3*t1**3*t4**5*t5*t2-10._ki/3._ki*t6**&
+ &3*t1**2*t4**3*t3*t5*t2**3-5._ki/3._ki*t6**2*t1**4*t4*t5**3*t2**2-&
+ &7._ki/3._ki*t6**2*t1**4*t2**3*t3*t4+55._ki/3._ki*t6**3*t1**3*t4**2*&
+ &t3*t2**3+40._ki/3._ki*t6**3*t1**2*t4**5*t3**2+4._ki/3._ki*t6**3*t1*&
+ &t4**7*t3**2-5._ki/3._ki*t6**3*t1**5*t3*t5-t6**3*t1**5*t2**2*t4-10&
+ &._ki/3._ki*t6**3*t1**5*t5**2*t4+5._ki/6._ki*t6**3*t1**5*t5**2*t2
+ !
+ stemp8=stemp9-2._ki/3._ki*t6**3*t1**5*t5*t2**2-44._ki*t6**3*t1**3*t4&
+ &**3*t3*t2**2-10._ki/3._ki*t6**3*t1*t4**6*t3**2*t2+5._ki*t6**2*t1*t&
+ &4**4*t3**2*t5*t2**3+5._ki*t6**2*t1*t2**3*t3**3*t4**3+75._ki/2._ki*&
+ &t6**2*t1**3*t4**2*t5**2*t3*t2**2+308._ki/9._ki*t6**3*t1**3*t4**4*&
+ &t3*t2-15._ki/4._ki*t6**2*t1**3*t2**3*t3**2*t5-45._ki*t6**2*t1**3*t&
+ &4**3*t5**2*t3*t2+10._ki*t6**2*t1**4*t5**2*t3*t2*t4+5._ki/2._ki*t6*&
+ &*2*t1**4*t3**2*t5*t2-195._ki/4._ki*t6**2*t1**3*t3**2*t5*t2*t4**2-&
+ &35._ki/4._ki*t6**2*t1**3*t4**2*t3*t2**4-275._ki/6._ki*t6**3*t1**3*t&
+ &4**2*t3*t5*t2**2+7._ki/4._ki*t6**2*t1**3*t4*t3*t2**5-5._ki/3._ki*t6&
+ &**3*t1*t4**4*t3**2*t2**3+25._ki/6._ki*t6**3*t1**4*t3*t5*t2**2-5._k&
+ &i/2._ki*t6**2*t1**4*t5**2*t3*t2**2
+ !
+ stemp9=stemp8-t6**3*t1**2*t4**2*t3*t2**5/6._ki+30._ki*t6**2*t1**3*t&
+ &3**2*t5*t2**2*t4+21._ki/2._ki*t6**2*t1**3*t4**3*t3*t2**3-125._ki/6&
+ &._ki*t6**3*t1**4*t4**2*t5**2*t2+7._ki/8._ki*t6**2*t1**3*t4**2*t5*t&
+ &2**5+95._ki/9._ki*t6**2*t1**2*t3**3*t4**3*t2-65._ki/6._ki*t6**2*t1*&
+ &*2*t3**3*t4**2*t2**2-20._ki/3._ki*t6**2*t1*t4**5*t3**2*t5*t2**2+1&
+ &0._ki/3._ki*t6**2*t1*t4**6*t3**2*t5*t2-15._ki/2._ki*t6**2*t1**3*t3*&
+ &*3*t2*t4-7._ki/2._ki*t6**2*t1**3*t4**3*t5*t2**4+7._ki/2._ki*t6**2*t&
+ &1**3*t4**4*t5*t2**3+40._ki/3._ki*t6**3*t1**4*t2**2*t3*t4+50._ki/3.&
+ &_ki*t6**3*t1**4*t4**2*t5*t2**2+325._ki/6._ki*t6**3*t1**4*t4**2*t3*&
+ &t5-100._ki/3._ki*t6**3*t1**4*t3*t5*t2*t4-t6**3*t1*t4**2*t3**2*t2*&
+ &*5/24._ki
+ !
+ stemp6=stemp9+5._ki/12._ki*t6**3*t1**2*t4*t3**2*t2**4+5._ki/12._ki*t6&
+ &**3*t1**2*t4**2*t5*t2**4*t3+5._ki/36._ki*t6**2*t1*t2**5*t3**3*t4+&
+ &5._ki*t6**2*t1**2*t4**3*t3*t5**2*t2**3+10._ki/3._ki*t6**2*t1**2*t4&
+ &*t3**3*t2**3+t6**3*t1**5*t2**3/4._ki-5._ki/3._ki*t6**2*t1*t4**3*t3&
+ &**2*t5*t2**4+5._ki*t6**2*t1**3*t4**3*t5**3*t2**2-5._ki*t6**2*t1**&
+ &3*t4**4*t5**3*t2-10._ki/3._ki*t6**3*t1**4*t4*t5*t2**3-20._ki*t6**3&
+ &*t1**4*t4**3*t5*t2+5._ki/24._ki*t6**2*t1*t4**2*t3**2*t2**5*t5-5._k&
+ &i/6._ki*t6**2*t1**2*t4**2*t3*t5**2*t2**4-5._ki/3._ki*t6**2*t1**2*t&
+ &4*t3**2*t5*t2**4+7._ki/36._ki*t6**2*t1**2*t4**2*t3*t2**6-65._ki/3.&
+ &_ki*t6**3*t1**4*t2*t3*t4**2-5._ki/4._ki*t6**2*t1**3*t4**2*t5**3*t2&
+ &**3-15._ki/2._ki*t6**2*t1**3*t4*t5**2*t3*t2**3
+ !
+ stemp7=1._ki/t1**3/t2**10
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4_glob)
+ !
+ case(3)
+ !
+ stemp7=-660._ki*t6*t4*t3**2*t5**2*t2**4+450._ki*t6*t4**2*t5**3*t3**&
+ &2*t2**2-12._ki*t6*t1*t4**2*t5**3*t2**4+3._ki*t6*t1*t4**2*t5**2*t2&
+ &**5-15._ki*t6*t1*t4**2*t5**5*t2**2-30._ki*t6*t1*t4**2*t5**4*t2**3&
+ &-3._ki*t6*t1*t4**2*t2**6*t5-140._ki*t6**2*t1*t4*t5**3*t2**4-400._k&
+ &i*t6**2*t4*t5**3*t2**4*t3+30._ki*t6**2*t1**2*t4*t5**4*t2-15._ki/2&
+ &._ki*t6**2*t1**2*t4*t5**2*t2**3+30._ki*t6**2*t1**2*t4*t5**3*t2**2&
+ &+35._ki*t6**2*t1*t4**3*t5**2*t2**3+260._ki*t6**2*t1*t4**2*t5**4*t&
+ &2**2+7._ki*t6**2*t1*t4**3*t5*t2**4-140._ki*t6**2*t1*t4**3*t5**4*t&
+ &2-13._ki*t6**2*t1*t4**2*t5*t2**5
+ !
+ stemp6=stemp7-65._ki*t6**2*t1*t4**2*t5**2*t2**4+260._ki*t6**2*t1*t4&
+ &**2*t5**3*t2**3-140._ki*t6**2*t1*t4**3*t5**3*t2**2-3._ki/2._ki*t6*&
+ &*2*t1**2*t4*t5*t2**4+90._ki*t6**2*t1*t4**2*t5*t2**3*t3+660._ki*t6&
+ &**2*t1*t4*t3*t5**2*t2**3-110._ki*t6**2*t1*t4*t5*t2**4*t3-540._ki*&
+ &t6**2*t1*t4**2*t3*t5**2*t2**2-720._ki*t6**2*t1*t4**2*t5**3*t2*t3&
+ &+880._ki*t6**2*t1*t4*t5**3*t3*t2**2-120._ki*t6**2*t4**4*t5**4*t2*&
+ &*2+40._ki*t6**2*t4**5*t5**4*t2-125._ki/2._ki*t6**2*t4**3*t3**2*t2*&
+ &*3-8._ki*t6**2*t4**4*t3*t2**4+130._ki*t6**2*t4**3*t5**3*t2**4-120&
+ &._ki*t6**2*t4**4*t5**3*t2**3-13._ki/2._ki*t6**2*t4**3*t5*t2**6+6._k&
+ &i*t6**2*t4**4*t5*t2**5
+ !
+ stemp5=-2._ki*t6**2*t4**5*t5*t2**4-10._ki*t6**2*t4**5*t5**2*t2**3+3&
+ &0._ki*t6**2*t4**4*t5**2*t2**4-65._ki/2._ki*t6**2*t4**3*t5**2*t2**5&
+ &-50._ki*t6*t4**3*t5**4*t2**4+20._ki*t6*t4**4*t5**4*t2**3-5._ki*t6*&
+ &t4**3*t5*t2**7+2._ki*t6*t4**4*t5*t2**6-25._ki*t6*t4**3*t5**5*t2**&
+ &3+10._ki*t6*t4**4*t5**5*t2**2+8._ki*t6*t4**4*t5**3*t2**4-13._ki*t6&
+ &*t4**2*t3*t2**7-20._ki*t6*t4**3*t5**3*t2**5+7._ki*t6*t4**3*t3*t2*&
+ &*6+11._ki*t6*t4*t3**2*t2**6-9._ki*t6*t4**2*t3**2*t2**5+5._ki*t6*t4&
+ &**3*t5**2*t2**6-2._ki*t6*t4**4*t5**2*t2**5-13._ki*t6**3*t4*t3*t2*&
+ &*6-240._ki*t6**2*t3**2*t2**4*t5**2-60._ki*t6**2*t4**2*t5**4*t2**4&
+ &+t6**2*t1**2*t5*t2**5+5._ki*t6**2*t1**2*t5**2*t2**4-20._ki*t6**2*&
+ &t1**2*t5**3*t2**3-20._ki*t6**2*t1**2*t5**4*t2**2+40._ki*t6**3*t4*&
+ &*2*t5**3*t2**4-8._ki*t6**3*t4**2*t5*t2**6+t6*t1*t2**5*t3**2-220.&
+ &_ki*t3**3*t2**3*t6**2*t4-120._ki*t3**3*t2**4*t6*t5+190._ki*t3**3*t&
+ &2**2*t6**2*t4**2+9._ki*t3*t2**3*t6**3*t1**2-15._ki*t3**2*t2**4*t1&
+ &*t6**2+20._ki*t3**3*t2**4*t6*t4+25._ki*t6*t5*t2**2*t3**4+stemp6
+ !
+ stemp6=-535._ki*t2*t3**3*t6**3*t4**2+290._ki*t2**2*t3**3*t6**3*t4-1&
+ &05._ki*t3**3*t6**3*t1*t4+3._ki*t6**2*t2**6*t1*t3+2._ki*t6*t1*t3*t2&
+ &**7+t2**2*t1**3*t6**3*t5+45._ki*t6**3*t5*t1**2*t3**2-150._ki*t2**&
+ &3*t3**3*t6*t5**2+240._ki*t2**3*t3**3*t6**2*t5+4._ki*t6*t4**2*t2**&
+ &8*t5+180._ki*t3**2*t2**3*t6**2*t5*t1-300._ki*t3**2*t2**2*t6**2*t4&
+ &*t5*t1+200._ki*t3**3*t2**3*t6*t4*t5-15._ki*t3*t2**2*t6**3*t4*t1**&
+ &2+25._ki*t3**2*t2**3*t1*t6**2*t4-5._ki*t3*t2**3*t1**2*t6**2*t5+6.&
+ &_ki*t6*t1*t2**5*t3*t4*t5-3._ki*t6*t1*t2**6*t4*t3-12._ki*t3**2*t2**&
+ &4*t1*t6*t5-80._ki*t6**2*t5*t2*t1*t3**3-135._ki*t2*t3*t1**2*t6**3*&
+ &t5**2+360._ki*t2**2*t3**2*t1*t6**2*t5**2-855._ki*t3**2*t1*t6**3*t&
+ &5*t4**2+t4**2*t2**10/2._ki-t4**3*t2**9/4._ki+t6**2*t4*t2**9/4._ki-&
+ &3._ki/2._ki*t6**2*t4**2*t2**8+60._ki*t3**3*t2**4*t6**2-5._ki*t1**3*&
+ &t6**3*t5**3+10._ki*t6*t2**3*t3**4-40._ki*t3**4*t2**2*t6**2+40._ki*&
+ &t6**3*t4**6*t5**3-3._ki*t6*t3**2*t2**7+stemp5-630._ki*t6**3*t3**2&
+ &*t2**3*t4*t5
+ !
+ stemp7=stemp6-1080._ki*t6**3*t1*t4*t3*t5**2*t2**2+1980._ki*t6**3*t1&
+ &*t4**2*t3*t5**2*t2+33._ki*t6**3*t1**2*t4*t5*t2**3-27._ki*t6**3*t1&
+ &**2*t4**2*t5*t2**2-165._ki*t6**3*t1**2*t4*t5**3*t2+75._ki*t6**3*t&
+ &1*t2**2*t3*t4**3+48._ki*t6**3*t1*t4**4*t5*t2**2-1125._ki*t6**3*t1&
+ &*t4**3*t3*t5**2+72._ki*t6**3*t1*t2**4*t3*t4-465._ki*t6**3*t1*t4**&
+ &2*t5**3*t2**2-132._ki*t6**3*t1*t2**3*t3*t4**2+570._ki*t6**3*t1*t4&
+ &**3*t5**3*t2-114._ki*t6**3*t1*t4**3*t5*t2**3+93._ki*t6**3*t1*t4**&
+ &2*t5*t2**4-855._ki*t6**3*t4**2*t3*t5**2*t2**3+1695._ki*t6**3*t4**&
+ &3*t3*t5**2*t2**2-1560._ki*t6**3*t4**4*t3*t5**2*t2
+ !
+ stemp4=stemp7-2265._ki*t6**3*t4**3*t3**2*t5*t2+1845._ki*t6**3*t4**2&
+ &*t3**2*t5*t2**2+40._ki*t6**2*t4**5*t5**3*t2**2+40._ki*t2*t3*t1**2&
+ &*t6**2*t5**3+225._ki*t3*t1**2*t6**3*t4*t5**2-270._ki*t2**2*t3**2*&
+ &t1*t6**3*t5+990._ki*t2*t3**2*t1*t6**3*t5*t4-600._ki*t2*t3**2*t1*t&
+ &6**2*t4*t5**2-880._ki*t2**2*t3**3*t6**2*t5*t4+760._ki*t2*t3**3*t6&
+ &**2*t5*t4**2+175._ki*t6*t4*t5**4*t2**4*t3-14._ki*t6*t4*t3*t2**7*t&
+ &5+280._ki*t6*t4*t5**3*t2**5*t3+250._ki*t2**2*t3**3*t6*t4*t5**2+15&
+ &0._ki*t6**3*t1*t4*t5**3*t2**3+180._ki*t6**3*t1*t3*t5**2*t2**3+84.&
+ &_ki*t6*t4*t5**2*t2**6*t3+50._ki*t6*t1*t5**4*t3*t2**3+80._ki*t6*t1*&
+ &t5**3*t3*t2**4
+ !
+ stemp6=stemp4-300._ki*t6**2*t4*t3*t5**2*t2**5+35._ki*t6**2*t1*t4*t5&
+ &**2*t2**5-140._ki*t6**2*t1*t4*t5**4*t2**3+1440._ki*t6**2*t4*t3**2&
+ &*t5**2*t2**3+1500._ki*t6**2*t4**3*t3**2*t5**2*t2+720._ki*t6**2*t4&
+ &*t3**2*t5*t2**4-1320._ki*t6**2*t4**2*t3**2*t5*t2**3-1520._ki*t6**&
+ &2*t4**3*t3*t5**3*t2**2-2640._ki*t6**2*t4**2*t3**2*t5**2*t2**2+75&
+ &0._ki*t6**2*t4**3*t3**2*t5*t2**2+640._ki*t6**2*t4**4*t3*t5**3*t2-&
+ &155._ki*t6**2*t4**2*t5*t2**5*t3+190._ki*t6**2*t4**3*t5*t2**4*t3+4&
+ &._ki*t6*t1*t4*t5*t2**7+24._ki*t6*t1*t3*t5**2*t2**5-4._ki*t6*t1*t4*&
+ &t5**2*t2**6+195._ki*t6**3*t4*t3*t5**2*t2**4+180._ki*t6*t3**2*t2**&
+ &5*t5**2-4._ki*t6*t4**2*t5**2*t2**7+150._ki*t6*t3**2*t5**3*t2**4+7&
+ &._ki*t6*t4*t3*t2**8+40._ki*t6*t4**2*t5**4*t2**5-60._ki*t6**2*t4**2&
+ &*t5**3*t2**5+3._ki*t6**2*t4**2*t5*t2**7+5._ki*t6**2*t4*t3*t2**7-1&
+ &20._ki*t6**2*t2**5*t3**2*t5-7._ki/2._ki*t6**2*t1*t4*t2**7+75._ki*t6&
+ &**3*t3**2*t2**4*t5+45._ki*t6**3*t1**2*t5**3*t2**2-9._ki*t6**3*t1*&
+ &*2*t5*t2**4-12._ki*t6**3*t1*t3*t2**5-t6**2*t1**2*t3*t2**4/2._ki+6&
+ &0._ki*t3**3*t2*t6**3*t1+70._ki*t3**4*t2*t6**2*t4
+ !
+ stemp5=stemp6-20._ki*t6**2*t2**2*t1*t3**3+36._ki*t6*t5*t3**2*t2**6+&
+ &16._ki*t6*t4**2*t5**3*t2**6+15._ki*t6**2*t4**2*t5**2*t2**6+20._ki*&
+ &t6*t4**2*t5**5*t2**4+t6**3*t4*t5*t2**7-5._ki*t6**3*t4*t5**3*t2**&
+ &5-15._ki*t6**3*t3*t5**2*t2**5-15._ki*t6**3*t1*t5**3*t2**4+3._ki*t6&
+ &**3*t1*t5*t2**6+10._ki*t6**2*t4*t5**3*t2**6-5._ki/2._ki*t6**2*t4*t&
+ &5**2*t2**7-5._ki*t6**2*t5*t2**7*t3+10._ki*t6**2*t4*t5**4*t2**5+30&
+ &._ki*t6**2*t3*t5**2*t2**6+40._ki*t6**2*t5**3*t2**5*t3-t6*t1*t5*t2&
+ &**8-40._ki*t6*t3*t5**3*t2**6-25._ki*t6*t5**4*t2**5*t3+2._ki*t6*t5*&
+ &t3*t2**8-t6**2*t4*t2**8*t5/2._ki-5._ki*t6**2*t1*t5**2*t2**6-t6**2&
+ &*t1*t5*t2**7+20._ki*t6**2*t1*t5**4*t2**4+20._ki*t6**2*t1*t5**3*t2&
+ &**5-10._ki*t6*t4*t5**4*t2**6-t6*t4*t2**9*t5-4._ki*t6*t4*t5**3*t2*&
+ &*7+t6*t2**8*t4*t5**2-5._ki*t6*t4*t5**5*t2**5-12._ki*t6*t3*t5**2*t&
+ &2**7-10._ki*t6*t1*t5**4*t2**5-5._ki*t6*t1*t5**5*t2**4-4._ki*t6*t1*&
+ &t5**3*t2**6+t6*t1*t5**2*t2**7
+ !
+ stemp6=stemp5+990._ki*t6**3*t4**4*t3**2*t5+25._ki*t6**3*t4**3*t5*t2&
+ &**5-8._ki*t6**3*t4**6*t5*t2**2-125._ki*t6**3*t4**3*t5**3*t2**3+57&
+ &._ki*t6**3*t4**2*t3*t2**5-36._ki*t6**3*t4**5*t3*t2**2-140._ki*t6**&
+ &3*t4**5*t5**3*t2+190._ki*t6**3*t4**4*t5**3*t2**2-38._ki*t6**3*t4*&
+ &*4*t5*t2**4+104._ki*t6**3*t4**4*t3*t2**3-113._ki*t6**3*t4**3*t3*t&
+ &2**4+540._ki*t6**3*t4**5*t3*t5**2+28._ki*t6**3*t4**5*t5*t2**3+135&
+ &._ki*t6**3*t1**2*t4**2*t5**3-240._ki*t6**3*t1*t4**4*t5**3+3._ki/4.&
+ &_ki*t6**2*t1**2*t4*t2**5+13._ki/2._ki*t6**2*t1*t4**2*t2**6-7._ki/2.&
+ &_ki*t6**2*t1*t4**3*t2**5-60._ki*t6**2*t4*t3**2*t2**5+110._ki*t6**2&
+ &*t4**2*t3**2*t2**4-31._ki/2._ki*t6**2*t4**2*t3*t2**6+19._ki*t6**2*&
+ &t4**3*t3*t2**5+130._ki*t6**2*t4**3*t5**4*t2**3+50._ki*t6**2*t4*t5&
+ &*t2**6*t3+1240._ki*t6**2*t4**2*t5**3*t3*t2**3-1140._ki*t6**2*t4**&
+ &3*t3*t5**2*t2**3+480._ki*t6**2*t4**4*t3*t5**2*t2**2-80._ki*t6**2*&
+ &t4**4*t5*t2**3*t3+930._ki*t6**2*t4**2*t3*t5**2*t2**4-75._ki*t6*t1&
+ &*t4*t5**4*t2**2*t3+7._ki*t6**2*t1*t2**6*t4*t5-180._ki*t6**2*t1*t3&
+ &*t5**2*t2**4+9._ki*t6**2*t1*t3*t2**4*t4**2-11._ki*t6**2*t1*t3*t2*&
+ &*5*t4-50._ki*t2**3*t3**3*t6**3
+ !
+ stemp7=stemp6+315._ki*t3**3*t6**3*t4**3+10._ki*t6**2*t3**2*t2**6-t6&
+ &**2*t1**2*t2**6/2._ki-12._ki*t3**3*t6*t2**5+t6**3*t3*t2**7-t6**2*&
+ &t3*t2**8/2._ki+t6**2*t1*t2**8/2._ki-t6*t3*t2**9+13._ki/4._ki*t6**2*&
+ &t4**3*t2**7-3._ki*t6**2*t4**4*t2**6+t6**2*t4**5*t2**5+30._ki*t3*t&
+ &5**2*t2**2*t1**2*t6**2-60._ki*t3**2*t5**2*t2**3*t1*t6-t4*t2**11/&
+ &4._ki-50._ki*t2**2*t3**2*t1*t6*t5**3-30._ki*t6**3*t1*t4*t5*t2**5-2&
+ &40._ki*t6**2*t1*t3*t5**3*t2**3
+ !
+ stemp3=stemp7+30._ki*t6**2*t1*t3*t5*t2**5-4._ki*t6*t1*t2**6*t3*t5+1&
+ &6._ki*t6*t1*t4*t5**3*t2**5+40._ki*t6*t1*t4*t5**4*t2**4+20._ki*t6*t&
+ &1*t4*t5**5*t2**3-36._ki*t6*t1*t4*t3*t2**4*t5**2-550._ki*t6*t4*t5*&
+ &*3*t3**2*t2**3-520._ki*t6*t4**2*t3*t5**3*t2**4-325._ki*t6*t4**2*t&
+ &5**4*t3*t2**3-132._ki*t6*t4*t5*t2**5*t3**2+108._ki*t6*t4**2*t3**2&
+ &*t5*t2**4-156._ki*t6*t4**2*t5**2*t2**5*t3+84._ki*t6*t4**3*t5**2*t&
+ &2**4*t3+540._ki*t6*t4**2*t3**2*t5**2*t2**3+175._ki*t6*t4**3*t3*t5&
+ &**4*t2**2+280._ki*t6*t4**3*t3*t5**3*t2**3-120._ki*t6*t1*t4*t5**3*&
+ &t3*t2**3-14._ki*t6*t4**3*t5*t3*t2**5+26._ki*t6*t4**2*t5*t3*t2**6
+ !
+ stemp4=1._ki/t2**12*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=(-t4+t2)**2*t4/t2**3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/4._k&
+ &i
+ !
+ stemp11=20._ki*t6*t3**2*t5**2*t2**6*t1**4-5._ki/2._ki*t6*t4*t5*t3**2&
+ &*t2**8*t1**3-5._ki*t6*t3**2*t4*t2**7*t1**3*t5**2+4._ki/3._ki*t6*t3&
+ &**3*t4*t2**8*t1**2*t5+15._ki*t6*t1**5*t4*t5**4*t2**5+45._ki*t6*t1&
+ &**5*t3*t5**2*t2**6+60._ki*t6*t1**5*t5**3*t2**5*t3+10._ki*t6*t5*t3&
+ &**2*t2**7*t1**4-10._ki/3._ki*t6*t2**7*t3**3*t1**3*t5+4._ki/3._ki*t6&
+ &*t1**4*t4**2*t3*t2**8-19._ki/3._ki*t6*t4*t3**4*t2**7*t1**2-600._ki&
+ &*t6*t1**5*t4*t5**3*t2**4*t3-25._ki/12._ki*t6*t4**2*t3**2*t2**8*t1&
+ &**3-450._ki*t6*t1**5*t4*t3*t5**2*t2**5+9._ki/2._ki*t6*t1**5*t4**2*&
+ &t5*t2**7+15._ki/2._ki*t6*t1**5*t4*t3*t2**7-180._ki*t6*t1**5*t2**5*&
+ &t3**2*t5+45._ki/2._ki*t6*t1**5*t4**2*t5**2*t2**6+240._ki*t6**2*t1*&
+ &*4*t4**6*t3*t5**2*t2
+ !
+ stemp10=stemp11-255._ki/2._ki*t6**2*t1**3*t4**4*t5*t2**4*t3**2-204.&
+ &_ki*t6**2*t1**3*t4**6*t3**2*t5*t2**2+183._ki/4._ki*t6**2*t1**3*t4*&
+ &*3*t5*t2**5*t3**2-24._ki*t6**2*t1**3*t4**8*t3**2*t5-278._ki*t6**2&
+ &*t1**3*t4**5*t3**3*t2**2-172._ki/3._ki*t6**2*t1**2*t4**7*t3**3*t2&
+ &**2-85._ki/12._ki*t6**2*t1**2*t4**3*t3**3*t2**6+73._ki/3._ki*t6**2*&
+ &t1**2*t4**4*t3**3*t2**5+208._ki/3._ki*t6**2*t1**2*t4**6*t3**3*t2*&
+ &*3+80._ki/3._ki*t6**2*t1**2*t4**8*t3**3*t2-155._ki/3._ki*t6**2*t1**&
+ &2*t4**5*t3**3*t2**4+108._ki*t6**2*t1**3*t4**7*t3**2*t5*t2-5._ki*t&
+ &6**2*t1**7*t2**2*t3*t4-9._ki*t6**2*t1**7*t4**2*t5*t2**2-1130._ki*&
+ &t6*t1**4*t4**3*t3**2*t5*t2**4+1040._ki*t6*t1**4*t4**4*t3**2*t5*t&
+ &2**3-360._ki*t6*t1**4*t4**5*t3**2*t5*t2**2-205._ki*t6*t1**3*t4**3&
+ &*t5**2*t2**5*t3**2-8305._ki/2._ki*t6**2*t1**5*t4**3*t3**2*t5*t2
+ !
+ stemp11=-910._ki/3._ki*t6*t1**3*t4**2*t3**3*t5*t2**5+440._ki*t6*t1**&
+ &3*t4**4*t3**2*t5**2*t2**4-260._ki*t6*t1**3*t4**5*t3**2*t5*t2**4-&
+ &680._ki/3._ki*t6*t1**2*t4**4*t5*t2**5*t3**3-310._ki/3._ki*t6*t1*t4*&
+ &*5*t3**4*t2**5+146._ki/3._ki*t6*t1*t4**4*t3**4*t2**6+25._ki/3._ki*t&
+ &4*t5**3*t2**7*t1**3*t3**2+125._ki/3._ki*t4**2*t5**2*t2**7*t1**2*t&
+ &3**3+108._ki*t1**5*t4**2*t3**2*t5*t2**4+84._ki*t1**5*t4**3*t5**2*&
+ &t2**4*t3-12._ki*t1**4*t4**4*t3*t2**6*t5+275._ki*t1**4*t3**4*t5*t2&
+ &**3*t4-600._ki*t1**4*t4*t3**3*t2**4*t5**2-195._ki/4._ki*t6*t1**5*t&
+ &4**3*t5**2*t2**5-150._ki*t6*t1**6*t4*t5*t3**2*t2**2-270._ki*t6*t1&
+ &**6*t4**2*t3*t5**2*t2**2-90._ki*t6*t1**5*t4**2*t5**3*t2**5-320._k&
+ &i/3._ki*t6*t1**4*t4**6*t5**3*t3*t2+1000._ki/3._ki*t6*t1**4*t4**3*t&
+ &5**3*t3*t2**4
+ !
+ stemp9=stemp11-775._ki*t1**4*t4**2*t3**2*t5**3*t2**4-340._ki*t1*t4*&
+ &*6*t3**4*t5*t2**4-1980._ki*t6*t1**5*t4**2*t3**2*t5*t2**3+175._ki*&
+ &t1**5*t4**3*t3*t5**4*t2**2+880._ki*t1**4*t4**2*t3**3*t5*t2**4-16&
+ &._ki*t4**2*t3**2*t2**8*t1**3*t5-96._ki*t1**4*t4**4*t5*t2**4*t3**2&
+ &+228._ki*t1**4*t4**3*t5*t2**5*t3**2+100._ki/3._ki*t4*t5*t2**7*t3**&
+ &4*t1**2+13._ki*t1**4*t4**3*t3*t2**7*t5+4._ki*t1**4*t4**5*t3*t2**5&
+ &*t5-500._ki*t1**4*t4**3*t3**3*t5*t2**3+3775._ki/6._ki*t1**3*t4**3*&
+ &t3**4*t2**3*t5+175._ki*t1**3*t4*t3**4*t2**5*t5-76._ki*t1**3*t3**2&
+ &*t4**4*t5*t2**6+56._ki*t1**3*t3**2*t4**5*t5*t2**5-2825._ki/3._ki*t&
+ &1**3*t4**3*t3**3*t5**2*t2**4+540._ki*t1**5*t4**2*t3**2*t5**2*t2*&
+ &*3-132._ki*t1**5*t4*t5*t2**5*t3**2+stemp10
+ !
+ stemp11=-325._ki*t1**5*t4**2*t5**4*t3*t2**3+280._ki*t1**5*t4**3*t3*&
+ &t5**3*t2**3-200._ki/3._ki*t1**2*t4**7*t3**3*t5**2*t2**2+9._ki/2._ki&
+ &*t6*t1**6*t4**2*t3*t2**4+825._ki*t6**2*t1**6*t3**2*t5*t2*t4-1040&
+ &._ki/3._ki*t1**2*t4**5*t3**3*t5*t2**5+1120._ki/3._ki*t6*t1**2*t4**5&
+ &*t3**3*t5*t2**4-55._ki*t6*t1**6*t4*t5*t2**4*t3+2250._ki*t6*t1**5*&
+ &t4**3*t3**2*t5**2*t2-1710._ki*t6*t1**5*t4**3*t3*t5**2*t2**3+720.&
+ &_ki*t6*t1**5*t4**4*t3*t5**2*t2**2+250._ki*t1**5*t4*t3**3*t5**2*t2&
+ &**2+450._ki*t1**5*t4**2*t5**3*t3**2*t2**2-550._ki*t1**5*t4*t5**3*&
+ &t3**2*t2**3-1025._ki/2._ki*t1**3*t4**2*t3**4*t2**4*t5+2080._ki/3._k&
+ &i*t1**3*t4**4*t3**3*t2**4*t5-240._ki*t1**3*t4**5*t3**3*t2**3*t5+&
+ &250._ki*t1**3*t4**3*t3**2*t5**2*t2**6-2260._ki/3._ki*t1**3*t4**3*t&
+ &3**3*t2**5*t5
+ !
+ stemp10=stemp11+380._ki*t1**3*t4**2*t3**3*t2**6*t5-380._ki*t1**3*t4&
+ &**4*t3**2*t5**2*t2**5+280._ki*t1**3*t4**5*t3**2*t5**2*t2**4+50._k&
+ &i*t1**3*t3**2*t4**3*t5*t2**7-16._ki*t1**3*t3**2*t4**6*t5*t2**4-9&
+ &3._ki/4._ki*t6*t1**5*t4**2*t3*t2**6+360._ki*t6*t1**5*t3**3*t5*t2**&
+ &3-375._ki/4._ki*t6*t1**5*t4**3*t3**2*t2**3-40._ki*t6*t1**3*t4**7*t&
+ &3**2*t5*t2**2+220._ki*t6*t1**3*t4**4*t3**2*t5*t2**5+160._ki*t6*t1&
+ &**3*t4**6*t3**2*t5*t2**3+210._ki*t6*t1**3*t4**3*t3**3*t2**5+19._k&
+ &i/3._ki*t6*t1**4*t4**4*t3*t2**6-210._ki*t6*t1**4*t4**3*t3**4*t2-4&
+ &0._ki/3._ki*t6*t1**3*t4**6*t3**2*t2**4-200._ki/3._ki*t6*t1**3*t4**6&
+ &*t3**3*t2**2-425._ki*t6*t1**3*t4**3*t3**4*t2**3-140._ki*t6*t1**3*&
+ &t4**5*t3**4*t2-325._ki/6._ki*t6*t1**3*t3**4*t4*t2**5
+ !
+ stemp11=10._ki/3._ki*t6*t1**3*t4**7*t3**2*t2**3+680._ki/3._ki*t6*t1**&
+ &3*t4**5*t3**3*t2**3-2275._ki/12._ki*t1**2*t4**2*t3**4*t5*t2**6+33&
+ &0._ki*t6*t1**6*t4*t3*t5**2*t2**3-1640._ki*t6*t1**4*t4**2*t3**3*t2&
+ &**3*t5-770._ki/3._ki*t6**2*t1**5*t4**5*t5**3*t2+75._ki*t6**2*t1**7&
+ &*t4*t3*t5**2-45._ki*t6**2*t1**7*t3*t5**2*t2+11._ki*t6**2*t1**7*t4&
+ &*t5*t2**3-55._ki*t6**2*t1**7*t4*t5**3*t2+1650._ki*t6**2*t1**6*t4*&
+ &*2*t3*t5**2*t2+1595._ki/3._ki*t6**2*t1**5*t3**3*t2**2*t4+572._ki/3&
+ &._ki*t6**2*t1**5*t4**4*t3*t2**3+275._ki/6._ki*t6**2*t1**5*t4**3*t5&
+ &*t2**5-130._ki*t6*t4*t3**2*t2**6*t1**4*t5-320._ki/3._ki*t6*t4**2*t&
+ &5**3*t2**5*t1**4*t3+25._ki*t6*t4**2*t5*t3**2*t2**7*t1**3-325._ki/&
+ &2._ki*t1**4*t4**3*t5**4*t3*t2**4+88._ki/3._ki*t1**2*t4**4*t3**3*t2&
+ &**7-455._ki/6._ki*t1**2*t4**2*t3**4*t2**7
+ !
+ stemp8=stemp11+210._ki*t1**2*t4**3*t3**4*t2**6-200._ki/3._ki*t1**2*t&
+ &4**6*t3**4*t2**3-41._ki/3._ki*t1**2*t4**3*t3**3*t2**8-16._ki/3._ki*&
+ &t1**2*t4**7*t3**3*t2**4+64._ki/3._ki*t1**2*t4**6*t3**3*t2**5-104.&
+ &_ki/3._ki*t1**2*t4**5*t3**3*t2**6-920._ki/3._ki*t1**2*t4**4*t3**4*t&
+ &2**5+680._ki/3._ki*t1**2*t4**5*t3**4*t2**4-70._ki*t1**2*t2**2*t3**&
+ &5*t4**5+110._ki*t1**2*t2**5*t3**5*t4**2+590._ki/3._ki*t1**2*t2**3*&
+ &t3**5*t4**4-325._ki/12._ki*t1**2*t4*t3**5*t2**6-425._ki/2._ki*t1**2&
+ &*t2**4*t3**5*t4**3-475._ki/4._ki*t1*t2**6*t3**5*t4**3-6._ki*t4**2*&
+ &t3**4*t2**9*t1-150._ki*t1**5*t3**3*t5**2*t2**3-13._ki*t1**5*t4**2&
+ &*t3*t2**7+11._ki*t1**5*t4*t3**2*t2**6+stemp9+stemp10
+ !
+ stemp11=-50._ki*t1**5*t4**3*t5**4*t2**4+5._ki*t1**5*t4**3*t5**2*t2*&
+ &*6-120._ki*t1**5*t3**3*t5*t2**4+20._ki*t1**5*t4**4*t5**4*t2**3+2.&
+ &_ki*t1**5*t4**4*t5*t2**6+25._ki*t1**5*t3**4*t5*t2**2-25._ki*t1**5*&
+ &t4**3*t5**5*t2**3+416._ki/3._ki*t6*t1*t2**4*t3**4*t4**6-85._ki/6._k&
+ &i*t6*t1*t4**3*t3**4*t2**7-44._ki/3._ki*t6**2*t4**2*t2**6*t1**5*t5&
+ &+220._ki/3._ki*t6**2*t4**2*t5**3*t2**4*t1**5+715._ki/2._ki*t6**2*t4&
+ &*t3*t2**4*t1**5*t5**2-143._ki/6._ki*t6**2*t4*t2**6*t3*t1**5+75._ki&
+ &/2._ki*t6**2*t4**2*t5**2*t2**5*t1**4*t3-9._ki*t6**2*t4**2*t5*t2**&
+ &6*t1**3*t3**2+320._ki*t6*t1**3*t4**6*t3**2*t5**2*t2**2-80._ki*t6*&
+ &t1**3*t4**7*t3**2*t5**2*t2+2720._ki/3._ki*t6*t1**3*t4**5*t3**3*t5&
+ &*t2**2-800._ki/3._ki*t6*t1**3*t4**6*t3**3*t5*t2
+ !
+ stemp10=stemp11+840._ki*t6*t1**3*t4**3*t3**3*t5*t2**4+880._ki/3._ki*&
+ &t1**2*t4**4*t3**3*t5*t2**6-19._ki/4._ki*t6**2*t4*t3**3*t2**6*t1**&
+ &3-t6*t3**4*t4*t2**9*t1/6._ki-t6**2*t3**3*t4*t2**8*t1**2/12._ki-6.&
+ &_ki*t1**4*t4**2*t3*t2**8*t5-325._ki/3._ki*t4*t3**3*t2**6*t1**3*t5*&
+ &*2+10._ki*t4*t3**2*t5**2*t2**8*t1**3-25._ki/2._ki*t1**4*t4*t5**4*t&
+ &3*t2**6-6._ki*t1**4*t3*t5**2*t4*t2**8+t1**4*t2**9*t4*t5*t3+10._ki&
+ &*t1**5*t4**4*t5**5*t2**2-6._ki*t1**4*t3**2*t2**8*t5-25._ki*t1**4*&
+ &t5**3*t2**6*t3**2-t1**4*t3*t4*t2**10/2._ki-30._ki*t1**4*t3**2*t2*&
+ &*7*t5**2-t1**3*t3**2*t4*t2**10/6._ki+8._ki*t1**4*t4**4*t3**2*t2**&
+ &5+31._ki/2._ki*t1**4*t4**2*t3**2*t2**7
+ !
+ stemp11=-48._ki*t1**4*t4*t3**3*t2**6-5._ki*t1**5*t4**3*t5*t2**7-278&
+ &._ki*t1*t2**4*t3**5*t4**5+240._ki*t1*t2**5*t3**5*t4**4+72._ki*t1*t&
+ &4**7*t3**4*t2**4-85._ki*t1*t4**4*t3**4*t2**7+140._ki*t1*t4**5*t3*&
+ &*4*t2**6+61._ki/2._ki*t1*t4**3*t3**4*t2**8+172._ki*t1*t2**3*t3**5*&
+ &t4**6+6._ki*t1**4*t4**4*t3*t2**7-13._ki/2._ki*t1**4*t4**3*t3*t2**8&
+ &-35._ki/2._ki*t1**4*t3**5*t2**2*t4-2._ki*t1**4*t4**5*t3*t2**6-19._k&
+ &i*t1**4*t4**3*t3**2*t2**6+19._ki/3._ki*t1**3*t4**4*t3**2*t2**7+70&
+ &._ki*t1**3*t4*t3**4*t2**6-145._ki/3._ki*t1**3*t3**5*t2**4*t4-136._k&
+ &i*t1*t4**6*t3**4*t2**5-44._ki*t1*t2**2*t3**5*t4**7
+ !
+ stemp9=stemp11+133._ki/4._ki*t1*t2**7*t3**5*t4**2-16._ki*t1*t4**8*t3&
+ &**4*t2**3+7._ki*t1**5*t4**3*t3*t2**6+20._ki*t1**5*t3**3*t2**4*t4+&
+ &40._ki/3._ki*t4*t3**4*t2**8*t1**2-20._ki*t1**5*t4**3*t5**3*t2**5+1&
+ &10._ki*t1**4*t4*t3**4*t2**4-75._ki*t1**4*t3**4*t5*t2**4-9._ki*t1**&
+ &5*t4**2*t3**2*t2**5+88._ki*t1**4*t4**2*t3**3*t2**5-50._ki*t1**4*t&
+ &3**3*t4**3*t2**4-2._ki*t1**5*t4**4*t5**2*t2**5+535._ki/6._ki*t1**3&
+ &*t3**5*t2**3*t4**2+755._ki/3._ki*t1**3*t4**3*t3**4*t2**4+4._ki/3._k&
+ &i*t1**3*t4**6*t3**2*t2**5-110._ki*t1**3*t4**4*t3**4*t2**3+38._ki*&
+ &t1**3*t4**2*t3**3*t2**7-105._ki/2._ki*t1**3*t3**5*t2**2*t4**3-25.&
+ &_ki/6._ki*t1**3*t4**3*t3**2*t2**8+stemp10
+ !
+ stemp11=-14._ki/3._ki*t1**3*t4**5*t3**2*t2**6-205._ki*t1**3*t4**2*t3&
+ &**4*t2**5-226._ki/3._ki*t1**3*t4**3*t3**3*t2**6+208._ki/3._ki*t1**3&
+ &*t4**4*t3**3*t2**5-24._ki*t1**3*t4**5*t3**3*t2**4+25._ki/3._ki*t3*&
+ &*3*t5**2*t2**7*t1**3-t4*t2**10*t1**2*t3**3/3._ki+8._ki*t1**5*t4**&
+ &4*t5**3*t2**4-26._ki/3._ki*t4*t2**8*t3**3*t1**3+t4*t3**4*t2**10*t&
+ &1/2._ki-95._ki*t1**4*t4**2*t3**4*t2**3+150._ki*t1**5*t3**2*t5**3*t&
+ &2**4+7._ki*t1**5*t4*t3*t2**8+40._ki*t1**5*t4**2*t5**4*t2**5+36._ki&
+ &*t1**5*t5*t3**2*t2**6+16._ki*t1**5*t4**2*t5**3*t2**6+100._ki*t1**&
+ &4*t3**3*t5**2*t2**5+10._ki/3._ki*t4**2*t3**3*t2**9*t1**2+80._ki*t1&
+ &**4*t3**3*t5*t2**6
+ !
+ stemp10=stemp11-5._ki*t1**4*t4*t3**2*t2**8+3._ki*t1**4*t4**2*t3*t2*&
+ &*9+950._ki*t1**4*t4**3*t3**2*t5**3*t2**3-80._ki*t1**4*t4**5*t5**3&
+ &*t3*t2**3-80._ki*t1**3*t4**6*t3**2*t5**2*t2**3-455._ki/6._ki*t6*t1&
+ &**3*t4**2*t3**3*t2**6+220._ki*t6*t1**3*t4**2*t3**4*t2**4+65._ki/3&
+ &._ki*t6*t1**3*t4**5*t3**2*t2**5-55._ki/3._ki*t6*t1**3*t4**4*t3**2*&
+ &t2**6+205._ki/24._ki*t6*t1**3*t4**3*t3**2*t2**7+57._ki/2._ki*t6*t1*&
+ &*5*t4**3*t3*t2**5+195._ki*t6*t1**5*t4**3*t5**4*t2**3+60._ki*t6*t1&
+ &**5*t4**5*t5**4*t2-1155._ki*t6**2*t1**5*t3**2*t2**3*t4*t5-1243._k&
+ &i/6._ki*t6**2*t1**5*t4**3*t3*t2**4+1815._ki*t6**2*t1**5*t4**4*t3*&
+ &*2*t5+209._ki/2._ki*t6**2*t1**5*t4**2*t3*t2**5+stemp8+stemp9+195.&
+ &_ki*t6*t1**5*t4**3*t5**3*t2**4
+ !
+ stemp11=stemp10-3._ki/4._ki*t6*t1**5*t4*t2**8*t5-t6*t1**4*t4*t3*t2*&
+ &*9/6._ki+45._ki*t6*t1**5*t4**4*t5**2*t2**4-15._ki*t6*t1**5*t4**5*t&
+ &5**2*t2**3+1140._ki*t6*t1**5*t4**2*t3**3*t5*t2-120._ki*t6*t1**5*t&
+ &4**4*t5*t2**3*t3+1395._ki*t6*t1**5*t4**2*t3*t5**2*t2**4+1125._ki*&
+ &t6*t1**5*t4**3*t3**2*t5*t2**2-465._ki/2._ki*t6*t1**5*t4**2*t5*t2*&
+ &*5*t3-2280._ki*t6*t1**5*t4**3*t3*t5**3*t2**2+9._ki*t6*t1**5*t4**4&
+ &*t5*t2**5-39._ki/4._ki*t6*t1**5*t4**3*t5*t2**6+60._ki*t6*t1**5*t4*&
+ &*5*t5**3*t2**2-180._ki*t6*t1**5*t4**4*t5**3*t2**3-3._ki*t6*t1**5*&
+ &t4**5*t5*t2**4-12._ki*t6*t1**5*t4**4*t3*t2**4-200._ki/3._ki*t1**3*&
+ &t4**6*t3**2*t5**3*t2**2-950._ki/3._ki*t1**3*t4**4*t3**2*t5**3*t2*&
+ &*4-275._ki*t1**3*t4**4*t3**4*t2**2*t5
+ !
+ stemp7=stemp11+2600._ki/3._ki*t1**3*t4**4*t3**3*t5**2*t2**3-300._ki*&
+ &t1**3*t4**5*t3**3*t5**2*t2**2+625._ki/3._ki*t1**3*t4**3*t3**2*t5*&
+ &*3*t2**5+475._ki*t1**3*t4**2*t3**3*t5**2*t2**5-t1**5*t3*t2**9+14&
+ &6._ki/3._ki*t4**4*t3**5*t2**7+8._ki*t1**4*t3**3*t2**7+160._ki/3._ki*&
+ &t2**3*t3**5*t4**8-12._ki*t1**5*t3**3*t2**5-30._ki*t1**4*t3**4*t2*&
+ &*5+25._ki/3._ki*t1**3*t3**5*t2**5-t3**5*t4*t2**10/6._ki+10._ki*t1**&
+ &5*t2**3*t3**4+t1**4*t3**2*t2**9/2._ki+7._ki/3._ki*t4**2*t3**5*t2**&
+ &9+200._ki*t1**5*t4*t5*t3**3*t2**3-128._ki/3._ki*t6*t1**2*t4**8*t3*&
+ &*3*t5*t2+1045._ki/3._ki*t6**2*t1**5*t4**4*t5**3*t2**2+210._ki*t6**&
+ &2*t1**3*t4**5*t3**2*t5*t2**3-615._ki/4._ki*t6**2*t1**4*t4**3*t5**&
+ &2*t2**4*t3
+ !
+ stemp11=stemp7+990._ki*t6**2*t1**5*t4**5*t3*t5**2-1520._ki/3._ki*t6*&
+ &t1**4*t4**4*t5**3*t3*t2**3+1140._ki*t6*t1**4*t4**2*t3**2*t5**2*t&
+ &2**4+40._ki/3._ki*t6*t1**4*t4**6*t3*t2**3*t5+1120._ki/3._ki*t6*t1**&
+ &4*t4**5*t5**3*t3*t2**2-880._ki*t6*t1**4*t4**4*t3**3*t5*t2+1180._k&
+ &i/3._ki*t6*t1**3*t4**4*t3**4*t2**2-272._ki/3._ki*t6*t1**2*t4**6*t3&
+ &**3*t2**4-32._ki/3._ki*t6*t1**2*t4**8*t3**3*t2**2+3._ki/4._ki*t6**2&
+ &*t3**2*t4*t2**7*t1**3*t5-15._ki/4._ki*t6**2*t3*t4*t2**6*t1**4*t5*&
+ &*2+7._ki/6._ki*t6**2*t4**2*t3**3*t2**7*t1**2+10._ki*t6*t5**2*t4*t2&
+ &**7*t1**4*t3-5._ki/3._ki*t6*t4*t5*t3*t2**8*t1**4+t6*t4*t3**3*t2**&
+ &9*t1**2/3._ki+5._ki/24._ki*t6*t4*t2**9*t1**3*t3**2-78._ki*t1**4*t4*&
+ &*3*t3*t2**6*t5**2-24._ki*t1**4*t4**5*t3*t2**4*t5**2
+ !
+ stemp10=stemp11-480._ki*t1**4*t4*t3**3*t5*t2**5-170._ki/3._ki*t6*t1*&
+ &*2*t4**4*t3**3*t2**6-14._ki*t1**5*t4**3*t5*t3*t2**5-1088._ki/3._ki&
+ &*t6*t1**2*t4**6*t3**3*t5*t2**3+192._ki*t6*t1**2*t4**7*t3**3*t5*t&
+ &2**2+26._ki*t1**5*t4**2*t5*t3*t2**6-520._ki*t1**5*t4**2*t3*t5**3*&
+ &t2**4-900._ki*t6**2*t1**6*t4*t3*t5**2*t2**2+350._ki*t1*t4**5*t3**&
+ &4*t5*t2**5-40._ki*t1*t4**8*t3**4*t5*t2**2+180._ki*t1*t4**7*t3**4*&
+ &t5*t2**3+305._ki/4._ki*t1*t4**3*t5*t2**7*t3**4-425._ki/2._ki*t1*t4*&
+ &*4*t5*t2**6*t3**4+50._ki*t6*t4**2*t5**2*t2**6*t1**3*t3**2-55._ki/&
+ &6._ki*t6**2*t4*t5**3*t2**5*t1**5+t6**2*t4*t2**8*t1**4*t3/4._ki-55&
+ &._ki/2._ki*t6**2*t3*t5**2*t2**5*t1**5+11._ki/6._ki*t6**2*t4*t5*t2**&
+ &7*t1**5-360._ki*t6*t1**5*t3**2*t2**4*t5**2
+ !
+ stemp11=stemp10-90._ki*t6*t1**5*t4**2*t5**4*t2**4-200._ki/3._ki*t6*t&
+ &5*t2**5*t3**3*t1**4+40._ki/3._ki*t6*t4*t3**3*t2**7*t1**3+7._ki/2._k&
+ &i*t6*t1**6*t2**6*t4*t5-90._ki*t6*t1**6*t3*t5**2*t2**4+35._ki/2._ki&
+ &*t6*t1**6*t4*t5**2*t2**5-70._ki*t6*t1**6*t4*t5**4*t2**3-120._ki*t&
+ &6*t1**6*t3*t5**3*t2**3+15._ki*t6*t1**6*t3*t5*t2**5-1025._ki/6._ki*&
+ &t1**2*t4**3*t5**2*t2**6*t3**3+700._ki/3._ki*t1**3*t4**5*t3**2*t5*&
+ &*3*t2**3+440._ki*t6*t1**6*t4*t5**3*t3*t2**2-1375._ki/6._ki*t6**2*t&
+ &1**5*t4**3*t5**3*t2**3-3960._ki*t6*t1**5*t4**2*t3**2*t5**2*t2**2&
+ &-410._ki*t6*t1**4*t2**4*t3**3*t4**2-1300._ki/3._ki*t1**2*t4**5*t3*&
+ &*3*t5**2*t2**4-16._ki*t6*t4**2*t5*t2**7*t1**2*t3**3+280._ki/3._ki*&
+ &t6*t1**2*t4**5*t3**3*t2**5
+ !
+ stemp9=stemp11-176._ki/3._ki*t6*t1**2*t4**7*t3**4*t2-1112._ki/3._ki*t&
+ &6*t1**2*t4**5*t3**4*t2**3+133._ki/3._ki*t6*t1**2*t4**2*t3**4*t2**&
+ &6+320._ki*t6*t1**2*t2**4*t4**4*t3**4+61._ki/3._ki*t6*t1**2*t4**3*t&
+ &3**3*t2**7+48._ki*t6*t1**2*t4**7*t3**3*t2**3+688._ki/3._ki*t6*t1**&
+ &2*t4**6*t3**4*t2**2+160._ki/3._ki*t6*t1*t2**2*t3**4*t4**8+244._ki/&
+ &3._ki*t6*t1**2*t4**3*t5*t2**6*t3**3+7._ki/3._ki*t6*t4**2*t3**4*t2*&
+ &*8*t1+15._ki*t6*t1**5*t4*t5**3*t2**6-15._ki/4._ki*t6*t1**5*t4*t5**&
+ &2*t2**7-15._ki/2._ki*t6*t1**5*t5*t2**7*t3-15._ki/4._ki*t6**2*t2**6*&
+ &t3**2*t1**4*t5+150._ki*t6**2*t1**6*t3*t5**2*t2**3+125._ki*t6**2*t&
+ &1**6*t4*t5**3*t2**3-25._ki*t6**2*t1**6*t4*t5*t2**5+275._ki/2._ki*t&
+ &6**2*t5*t2**4*t3**2*t1**5+2._ki*t4*t3**2*t2**9*t1**3*t5+1155._ki/&
+ &2._ki*t6**2*t1**5*t4**3*t3**3
+ !
+ stemp11=stemp9+50._ki*t6**2*t1**6*t3**3*t2-275._ki/3._ki*t6**2*t1**5&
+ &*t2**3*t3**3+220._ki/3._ki*t6**2*t1**5*t4**6*t5**3-210._ki*t6**2*t&
+ &1**4*t4**5*t3**3-44._ki*t6**2*t1**3*t4**7*t3**3-16._ki/3._ki*t6**2&
+ &*t1**2*t4**9*t3**3-10._ki*t6*t1**6*t3**3*t2**2+3._ki/2._ki*t6*t1**&
+ &5*t4**5*t2**5-9._ki/2._ki*t6*t1**5*t4**4*t2**6+39._ki/8._ki*t6*t1**&
+ &5*t4**3*t2**7-60._ki*t6*t1**5*t3**4*t2**2+90._ki*t6*t1**5*t3**3*t&
+ &2**4-7._ki/4._ki*t6*t1**6*t4**3*t2**5+15._ki*t6**2*t1**7*t3**2*t5-&
+ &200._ki*t6**2*t1**6*t4**4*t5**3-9._ki/4._ki*t6*t1**5*t4**2*t2**8+1&
+ &5._ki*t6*t1**5*t3**2*t2**6+5._ki*t6*t3**4*t2**6*t1**3
+ !
+ stemp10=stemp11-50._ki/3._ki*t6*t3**3*t2**6*t1**4+5._ki/2._ki*t6**2*t&
+ &1**6*t5*t2**6+t6*t2**8*t1**2*t3**4/3._ki-5._ki/6._ki*t6*t2**8*t3**&
+ &2*t1**4-5._ki/2._ki*t6*t1**6*t5**2*t2**6-t6*t1**6*t5*t2**7/2._ki+1&
+ &0._ki*t6*t1**6*t5**4*t2**4+10._ki*t6*t1**6*t5**3*t2**5+3._ki/8._ki*&
+ &t6*t1**5*t4*t2**9-3._ki/4._ki*t6*t2**8*t3*t1**5-5._ki/6._ki*t6*t3**&
+ &3*t2**8*t1**3+15._ki*t6**2*t1**7*t5**3*t2**2-3._ki*t6**2*t1**7*t5&
+ &*t2**4-10._ki*t6**2*t1**6*t3*t2**5+15._ki/2._ki*t6**2*t3**3*t2**5*&
+ &t1**4+3._ki/2._ki*t6*t1**6*t3*t2**6-7._ki/4._ki*t6*t1**6*t4*t2**7+t&
+ &6**2*t2**7*t3**3*t1**3/4._ki+11._ki/6._ki*t6**2*t2**7*t3*t1**5-25.&
+ &_ki/2._ki*t6**2*t1**6*t5**3*t2**4
+ !
+ stemp11=stemp10+45._ki*t6**2*t1**7*t4**2*t5**3-10._ki*t1**5*t4*t5**&
+ &4*t2**6-t1**5*t4*t2**9*t5-4._ki*t1**5*t4*t5**3*t2**7+t1**5*t2**8&
+ &*t4*t5**2-5._ki*t1**5*t4*t5**5*t2**5-12._ki*t1**5*t3*t5**2*t2**7-&
+ &40._ki*t1**5*t3*t5**3*t2**6-25._ki*t1**5*t5**4*t2**5*t3+2._ki*t1**&
+ &5*t5*t3*t2**8-25._ki/12._ki*t2**8*t3**4*t1**2*t5-19._ki/4._ki*t4*t3&
+ &**5*t2**8*t1-125._ki/6._ki*t5*t2**6*t3**4*t1**3+20._ki*t1**5*t4**2&
+ &*t5**5*t2**4+4._ki*t1**5*t4**2*t2**8*t5+180._ki*t1**5*t3**2*t2**5&
+ &*t5**2-4._ki*t1**5*t4**2*t5**2*t2**7-110._ki*t6**2*t1**6*t2**3*t3&
+ &*t4**2+1100._ki/3._ki*t1**2*t4**4*t3**3*t5**2*t2**5
+ !
+ stemp8=stemp11-1380._ki*t6**2*t1**4*t4**4*t3**2*t5*t2**2+330._ki*t6&
+ &**2*t1**4*t4**2*t3**3*t2**3+26._ki*t6**2*t1**4*t4**5*t3*t2**4+4.&
+ &_ki*t6**2*t1**4*t4**7*t3*t2**2-180._ki*t6*t1**5*t4**4*t5**4*t2**2&
+ &-330._ki*t6*t1**5*t4*t3**3*t2**3+1070._ki/3._ki*t6*t1**4*t3**4*t2*&
+ &*2*t4**2+30._ki*t6*t1**4*t4**5*t3**2*t2**3+565._ki/6._ki*t6*t1**4*&
+ &t4**3*t3**2*t2**5-95._ki/2._ki*t6*t1**4*t4**2*t3**2*t2**6+140._ki*&
+ &t6*t1**4*t2**5*t3**3*t4-260._ki/3._ki*t6*t1**4*t4**4*t3**2*t2**4-&
+ &580._ki/3._ki*t6*t1**4*t3**4*t2**3*t4-300._ki*t6*t1**6*t4*t3**2*t5&
+ &**2*t2+1080._ki*t6*t1**5*t4*t3**2*t5*t2**4-3680._ki/3._ki*t6*t1**3&
+ &*t4**4*t3**3*t5*t2**3-475._ki/3._ki*t6*t1**2*t3**4*t4**3*t2**5-25&
+ &._ki/6._ki*t6*t1**4*t4**3*t3*t2**7-220._ki*t6*t1**4*t4**4*t3**3*t2&
+ &**2+4._ki/3._ki*t6*t1**4*t4**6*t3*t2**4
+ !
+ stemp11=stemp8+130._ki*t6*t1**6*t4**2*t5**4*t2**2+7._ki/2._ki*t6*t1*&
+ &*6*t4**3*t5*t2**4-40._ki*t6*t1**6*t3**3*t5*t2-13._ki/2._ki*t6*t1**&
+ &6*t4**2*t5*t2**5+130._ki*t6*t1**6*t4**2*t5**3*t2**3-70._ki*t6*t1*&
+ &*6*t4**3*t5**4*t2+35._ki/2._ki*t6*t1**6*t4**3*t5**2*t2**3-70._ki*t&
+ &6*t1**6*t4**3*t5**3*t2**2+285._ki*t6*t1**5*t3**3*t2**2*t4**2+105&
+ &._ki*t6*t1**5*t3**4*t2*t4-90._ki*t6*t1**5*t4*t3**2*t2**5+165._ki*t&
+ &6*t1**5*t4**2*t3**2*t2**4-5._ki/6._ki*t3**4*t2**9*t1**2-14._ki*t1*&
+ &*5*t4*t3*t2**7*t5+280._ki*t1**5*t4*t5**3*t2**5*t3+84._ki*t1**5*t4&
+ &*t5**2*t2**6*t3+300._ki*t1**4*t4*t3**2*t5**2*t2**6+250._ki*t1**4*&
+ &t4*t5**3*t2**5*t3**2
+ !
+ stemp10=stemp11+120._ki*t1**4*t4**2*t3*t5**3*t2**6+60._ki*t1**4*t3*&
+ &*2*t5*t4*t2**7+36._ki*t1**4*t4**2*t5**2*t2**7*t3+75._ki*t1**4*t4*&
+ &*2*t3*t5**4*t2**5+4._ki/3._ki*t1**3*t4**2*t3**2*t2**9+20._ki/3._ki*&
+ &t5*t3**3*t2**8*t1**3+13._ki/4._ki*t6*t1**6*t4**2*t2**6+100._ki/3._k&
+ &i*t6*t1**4*t3**4*t2**4-15._ki/2._ki*t6*t1**6*t3**2*t2**4+3._ki*t6*&
+ &*2*t1**7*t3*t2**3-175._ki/2._ki*t6**2*t1**6*t3**3*t4-140._ki/3._ki*&
+ &t6*t1**4*t4**5*t3*t2**4*t5+190._ki/3._ki*t6*t1**4*t4**4*t3*t2**5*&
+ &t5-2260._ki*t6*t1**4*t4**3*t3**2*t5**2*t2**3-14._ki/3._ki*t6*t1**4&
+ &*t4**5*t3*t2**5-325._ki/4._ki*t6**2*t1**4*t3**3*t2**4*t4-16._ki*t6&
+ &**2*t1**4*t4**6*t3*t2**3-22._ki*t6**2*t1**4*t4**4*t3*t2**5+590._k&
+ &i*t6**2*t1**4*t4**4*t3**3*t2
+ !
+ stemp11=stemp10+240._ki*t6**2*t1**3*t4**4*t3**3*t2**3+133._ki/4._ki*&
+ &t6**2*t1**3*t4**2*t3**3*t2**5+172._ki*t6**2*t1**3*t4**6*t3**3*t2&
+ &-475._ki/4._ki*t6**2*t1**3*t3**3*t4**3*t2**4+945._ki*t6**2*t1**4*t&
+ &4**3*t5*t3**2*t2**3+330._ki*t6**2*t1**4*t4**4*t5**2*t2**3*t3-390&
+ &._ki*t6**2*t1**4*t4**5*t3*t5**2*t2**2-95._ki*t6**2*t1**6*t4**3*t5&
+ &*t2**3-1425._ki/2._ki*t6**2*t1**6*t4**2*t3**2*t5-1875._ki/2._ki*t6*&
+ &*2*t1**6*t4**3*t3*t5**2-225._ki*t6**2*t1**6*t3**2*t5*t2**2+155._k&
+ &i/2._ki*t6**2*t1**6*t4**2*t5*t2**4+60._ki*t6**2*t1**6*t2**4*t3*t4&
+ &+40._ki*t6**2*t1**6*t4**4*t5*t2**2-775._ki/2._ki*t6**2*t1**6*t4**2&
+ &*t5**3*t2**2+475._ki*t6**2*t1**6*t4**3*t5**3*t2+125._ki/2._ki*t6**&
+ &2*t1**6*t2**2*t3*t4**3-209._ki/3._ki*t6**2*t1**5*t4**4*t5*t2**4+4&
+ &0._ki/3._ki*t6*t4*t5**3*t2**6*t1**4*t3
+ !
+ stemp9=stemp11+2160._ki*t6*t1**5*t4*t3**2*t5**2*t2**3-1320._ki*t6*t&
+ &1**5*t3**3*t5*t2**2*t4+285._ki*t6*t1**5*t4**3*t5*t2**4*t3+1860._k&
+ &i*t6*t1**5*t4**2*t5**3*t3*t2**3+960._ki*t6*t1**5*t4**4*t3*t5**3*&
+ &t2+560._ki*t6*t1**4*t4*t3**3*t5*t2**4-80._ki*t6*t1**4*t4**6*t3*t5&
+ &**2*t2**2+250._ki*t6*t1**4*t4**3*t3*t5**2*t2**5+1510._ki/3._ki*t6*&
+ &t1**4*t2**3*t3**3*t4**3-20._ki*t1**4*t4*t5**3*t3*t2**7+2080._ki*t&
+ &6*t1**4*t4**4*t3**2*t5**2*t2**2-720._ki*t6*t1**4*t4**5*t3**2*t5*&
+ &*2*t2-520._ki*t6*t1**3*t4**5*t3**2*t5**2*t2**3-660._ki*t1**5*t4*t&
+ &3**2*t5**2*t2**4+t2**9*t3**5*t1/4._ki+5._ki/2._ki*t3**5*t2**7*t1**&
+ &2+t6*t1**6*t2**8/4._ki-32._ki/3._ki*t2**2*t3**5*t4**9-3._ki*t1**5*t&
+ &3**2*t2**7+10._ki*t1**4*t3**5*t2**3
+ !
+ stemp11=stemp9-85._ki/6._ki*t4**3*t3**5*t2**8-344._ki/3._ki*t2**4*t3*&
+ &*5*t4**7-310._ki/3._ki*t4**5*t3**5*t2**6-25._ki/3._ki*t3**4*t2**7*t&
+ &1**3-70._ki*t6*t1**6*t4*t5**3*t2**4+40._ki/3._ki*t6*t4**2*t2**7*t1&
+ &**4*t3*t5-260._ki*t6*t4*t3**2*t2**5*t1**4*t5**2-80._ki*t6*t4**2*t&
+ &3*t2**6*t1**4*t5**2+160._ki/3._ki*t6*t4*t5*t2**6*t3**3*t1**3-5._ki&
+ &/2._ki*t6**2*t4**2*t3*t2**7*t1**4+60._ki*t6**2*t4*t5*t2**5*t3**2*&
+ &t1**4-4._ki*t6*t4**2*t3**3*t2**8*t1**2+65._ki/6._ki*t6*t4*t2**7*t3&
+ &**2*t1**4+75._ki*t6*t1**5*t4*t5*t2**6*t3-10._ki/3._ki*t4*t5*t3**3*&
+ &t2**9*t1**2-80._ki*t4**2*t3**2*t2**7*t1**3*t5**2-25._ki/6._ki*t3**&
+ &3*t4*t2**8*t1**2*t5**2+5._ki/4._ki*t3**4*t4*t2**9*t1*t5
+ !
+ stemp10=stemp11+175._ki*t1**5*t4*t5**4*t2**4*t3-5885._ki/6._ki*t6**2&
+ &*t1**5*t3**3*t4**2*t2-44._ki/3._ki*t6**2*t1**5*t4**6*t5*t2**2+154&
+ &._ki/3._ki*t6**2*t1**5*t4**5*t5*t2**3-66._ki*t6**2*t1**5*t4**5*t3*&
+ &t2**2-300._ki*t6**2*t1**4*t4**6*t3**2*t5+41._ki/4._ki*t6**2*t1**4*&
+ &t4**3*t3*t2**6-1275._ki/2._ki*t6**2*t1**4*t4**3*t3**3*t2**2+6215.&
+ &_ki/2._ki*t6**2*t1**5*t4**3*t3*t5**2*t2**2-2860._ki*t6**2*t1**5*t4&
+ &**4*t3*t5**2*t2-3135._ki/2._ki*t6**2*t1**5*t4**2*t3*t5**2*t2**3+6&
+ &765._ki/2._ki*t6**2*t1**5*t4**2*t3**2*t5*t2**2-1365._ki/4._ki*t6**2&
+ &*t1**4*t4**2*t3**2*t5*t2**4+1020._ki*t6**2*t1**4*t4**5*t3**2*t5*&
+ &t2-156._ki*t1**5*t4**2*t5**2*t2**5*t3-920._ki/3._ki*t6*t1**3*t4**4&
+ &*t3**3*t2**4-344._ki/3._ki*t6*t1*t2**3*t3**4*t4**7-32._ki/3._ki*t6*&
+ &t1*t2*t3**4*t4**9-125._ki/3._ki*t6*t1**4*t4**3*t3*t2**6*t5+6040._k&
+ &i/3._ki*t6*t1**4*t4**3*t3**3*t2**2*t5
+ !
+ stemp11=stemp10-380._ki*t6*t1**4*t4**4*t3*t5**2*t2**4+570._ki*t6*t1&
+ &**4*t4**2*t3**2*t5*t2**5+280._ki*t6*t1**4*t4**5*t3*t5**2*t2**3-3&
+ &60._ki*t6*t1**6*t4**2*t5**3*t2*t3+45._ki*t6*t1**6*t4**2*t5*t2**3*&
+ &t3+180._ki*t6*t1**6*t3**2*t5**2*t2**2+90._ki*t6*t1**6*t2**3*t3**2&
+ &*t5+25._ki/2._ki*t6*t1**6*t2**3*t4*t3**2-65._ki/2._ki*t6*t1**6*t4**&
+ &2*t5**2*t2**4-11._ki/2._ki*t6*t1**6*t4*t3*t2**5-50._ki*t1**4*t4**5&
+ &*t5**4*t3*t2**2+1140._ki*t1**4*t4**3*t3**2*t5**2*t2**4+72._ki*t1*&
+ &*4*t4**4*t3*t2**5*t5**2-625._ki*t1**4*t4**3*t3**3*t5**2*t2**2+15&
+ &0._ki*t1**4*t4**4*t5**4*t3*t2**3-400._ki*t1**4*t4**4*t3**2*t5**3*&
+ &t2**2-186._ki*t1**4*t4**2*t5*t2**6*t3**2-480._ki*t1**4*t4**4*t3**&
+ &2*t5**2*t2**3-200._ki/3._ki*t4**2*t5**3*t2**6*t1**3*t3**2
+ !
+ stemp6=stemp11-500._ki/3._ki*t1**2*t4**6*t3**4*t5*t2**2-410._ki/3._ki&
+ &*t1**2*t4**3*t5*t3**3*t2**7+2._ki/3._ki*t3**3*t2**9*t1**3-2300._ki&
+ &/3._ki*t1**2*t4**4*t3**4*t5*t2**4+640._ki/3._ki*t1**2*t4**6*t3**3*&
+ &t5*t2**4-205._ki/2._ki*t6*t1**3*t4**3*t5*t3**2*t2**6+1700._ki/3._ki&
+ &*t1**2*t4**5*t3**4*t5*t2**3+416._ki/3._ki*t2**5*t3**5*t4**6+525._k&
+ &i*t1**2*t4**3*t3**4*t5*t2**5+800._ki/3._ki*t1**2*t4**6*t3**3*t5**&
+ &2*t2**3-260._ki/3._ki*t4*t3**3*t2**7*t1**3*t5-15._ki*t4**2*t5*t2**&
+ &8*t1*t3**4+100._ki/3._ki*t4**2*t5*t3**3*t2**8*t1**2+1100._ki*t1**4&
+ &*t4**2*t3**3*t2**3*t5**2-475._ki/2._ki*t1**4*t4**2*t3**4*t5*t2**2&
+ &-930._ki*t1**4*t4**2*t3**2*t5**2*t2**5-260._ki*t1**4*t4**3*t5**3*&
+ &t3*t2**5+240._ki*t1**4*t4**4*t5**3*t3*t2**4-160._ki/3._ki*t1**2*t4&
+ &**7*t3**3*t5*t2**3-60._ki*t6**2*t1**4*t4**7*t3*t5**2
+ !
+ stemp7=t6/t1**5/t2**12
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp5=95._ki/3._ki*t6**3*t3**2*t4**3-5._ki/2._ki*t6**2*t2**2*t3**3+t&
+ &6*t4*t2**8/4._ki+20._ki/3._ki*t6**3*t4**5*t5**2-7._ki/4._ki*t6**3*t4&
+ &**2*t2**5-3._ki/2._ki*t6**3*t1**2*t2**3+2._ki*t6**3*t4**5*t2**2+2.&
+ &_ki*t6**2*t4**4*t2**4-5._ki*t6**3*t4**4*t2**3-3._ki/4._ki*t6*t4**2*&
+ &t2**7+t6*t4**3*t2**6/2._ki+7._ki/12._ki*t6**2*t3*t2**6-t6**2*t4*t2&
+ &**7/2._ki-t6**2*t1*t2**6+t6*t1*t2**7/4._ki+t4*t2**8*t5/12._ki-t4*t&
+ &3*t2**7/6._ki-7._ki/12._ki*t6**2*t1**2*t5*t2**3+5._ki/6._ki*t6**2*t1&
+ &**2*t2*t5**3-7._ki/3._ki*t6**2*t1*t2**4*t3+5._ki*t6**2*t2*t3**3*t4&
+ &+15._ki/2._ki*t6**2*t2**3*t3**2*t5+15._ki/2._ki*t6**3*t1*t3**2*t2-1&
+ &5._ki*t6**3*t3**2*t1*t4-95._ki/2._ki*t6**3*t3**2*t2*t4**2+45._ki/2.&
+ &_ki*t6**3*t2**2*t3**2*t4+27._ki/2._ki*t6**3*t1*t4**2*t2**3
+ !
+ stemp4=-6._ki*t6**3*t1*t4*t2**4-4._ki*t6**2*t4**3*t2**5+t6**3*t4*t2&
+ &**6/4._ki-10._ki/3._ki*t6**3*t2**3*t3**2+16._ki*t6**3*t1*t4*t5*t2**&
+ &3+65._ki*t6**3*t4**2*t3*t5*t2**2-280._ki/3._ki*t6**3*t4**3*t3*t5*t&
+ &2-20._ki*t6**3*t1*t4*t5**2*t2**2+65._ki*t6**3*t1*t3*t5*t2*t4+24._k&
+ &i*t6**3*t1*t4**3*t5*t2+26._ki*t6**3*t1*t2*t3*t4**2-20._ki*t6**2*t&
+ &1*t2*t3*t4*t5**2-5._ki*t6**2*t1*t2*t5*t3**2+14._ki/3._ki*t6**2*t1*&
+ &t2**3*t3*t4+10._ki*t6**2*t1*t5**2*t3*t2**2+65._ki/2._ki*t6**2*t2*t&
+ &3**2*t4**2*t5-8._ki*t6**3*t1**2*t5*t2*t4+35._ki/6._ki*t6**2*t1*t4*&
+ &*2*t5*t2**3-35._ki/6._ki*t6**2*t1*t4*t5*t2**4-45._ki*t6**2*t4**2*t&
+ &5**2*t3*t2**2+20._ki*t6**2*t4*t5**2*t3*t2**3+25._ki/3._ki*t6**2*t1&
+ &*t4*t5**3*t2**2-25._ki/3._ki*t6**2*t1*t4**2*t5**3*t2-65._ki/2._ki*t&
+ &6**2*t3**2*t4*t5*t2**2-55._ki/3._ki*t6**3*t4*t3*t5*t2**3-15._ki*t6&
+ &**3*t1*t3*t5*t2**2-65._ki*t6**3*t1*t4**2*t3*t5+stemp5
+ !
+ stemp5=-5._ki/2._ki*t6**2*t3*t5**2*t2**4-20._ki/3._ki*t6**2*t4**3*t5*&
+ &*3*t2**2+10._ki/3._ki*t6**2*t4**4*t5**3*t2+25._ki/6._ki*t6**2*t4**2&
+ &*t5**3*t2**3-2._ki/3._ki*t6**3*t4*t5*t2**5-5._ki*t6**2*t1*t4**2*t2&
+ &**4+5._ki*t6**2*t1*t4*t2**5-t6*t4*t2**6*t1/2._ki-30._ki*t6**3*t1*t&
+ &4**3*t5**2+6._ki*t6**3*t1*t2**3*t3+5._ki*t6**3*t1**2*t3*t5+3._ki*t&
+ &6**3*t1**2*t2**2*t4-56._ki/3._ki*t6**3*t4**4*t3*t2-26._ki*t6**3*t4&
+ &**2*t3*t2**3-50._ki/3._ki*t6**3*t4**4*t5**2*t2+112._ki/3._ki*t6**3*&
+ &t4**3*t3*t2**2+22._ki/3._ki*t6**3*t4*t3*t2**4+15._ki*t6**3*t4**3*t&
+ &5**2*t2**2-9._ki*t6**3*t1*t4**3*t2**2-16._ki/3._ki*t6**3*t4**5*t5*&
+ &t2-35._ki/6._ki*t6**3*t4**2*t5**2*t2**3-12._ki*t6**3*t4**3*t5*t2**&
+ &3+40._ki/3._ki*t6**3*t4**4*t5*t2**2+14._ki/3._ki*t6**3*t4**2*t5*t2*&
+ &*4+140._ki/3._ki*t6**3*t4**4*t3*t5+10._ki*t6**3*t1**2*t5**2*t4-5._k&
+ &i*t6**3*t1**2*t5**2*t2
+ !
+ stemp3=-2._ki*t6**3*t1**2*t2*t3+5._ki/3._ki*t6**3*t3*t2**4*t5+5._ki/6&
+ &._ki*t6**3*t4*t5**2*t2**4+4._ki*t6**3*t1**2*t5*t2**2+5._ki/2._ki*t6&
+ &**3*t1*t5**2*t2**3+7._ki/12._ki*t6**2*t2**6*t4*t5-t4**2*t5*t2**7/&
+ &12._ki+3._ki/4._ki*t6**3*t1*t2**5+9._ki/2._ki*t6**3*t4**3*t2**4+5._ki&
+ &/2._ki*t6**2*t4**2*t2**6+t1**2*t2**4*t6**2/2._ki-2._ki/3._ki*t6**3*&
+ &t2**5*t3+30._ki*t6**2*t4**3*t5**2*t3*t2-5._ki/6._ki*t6**2*t4*t5**3&
+ &*t2**4-5._ki/3._ki*t6**2*t1*t5**3*t2**3+7._ki/6._ki*t6**2*t1*t5*t2*&
+ &*5+stemp4+stemp5+t3*t2**8/12._ki+45._ki*t6**3*t1*t4**2*t5**2*t2-2&
+ &6._ki*t6**3*t1*t2**2*t3*t4-36._ki*t6**3*t1*t4**2*t5*t2**2+21._ki/2&
+ &._ki*t6**2*t4**2*t3*t2**4-35._ki/12._ki*t6**2*t4**2*t5*t2**5+14._ki&
+ &/3._ki*t6**2*t4**3*t5*t2**4-7._ki/3._ki*t6**2*t4**4*t5*t2**3-7._ki*&
+ &t6**2*t4**3*t3*t2**3-14._ki/3._ki*t6**2*t4*t3*t2**5-2._ki*t6**3*t1&
+ &*t5*t2**4
+ !
+ stemp4=1._ki/t2**10*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=-(t4*t3*t5*t2**2-4._ki*t4*t2*t1*t6*t5-t3*t2*t1*t6+3._ki*t4*t&
+ &3*t6*t2**2-9._ki*t4**2*t3*t6*t2+4._ki*t4**2*t5*t1*t6-2._ki*t4*t3**&
+ &2*t2+2._ki*t4*t3*t1*t6+t3**2*t2**2+6._ki*t3*t4**3*t6-t3*t4**2*t2*&
+ &t5)/t3/t2**4*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/12._ki
+ !
+ stemp9=195._ki/4._ki*t6**2*t1**3*t3**2*t5*t2*t4**2-195._ki/4._ki*t6**&
+ &2*t1**3*t3**2*t5*t2**2*t4-21._ki/2._ki*t6**2*t1**3*t4**3*t3*t2**3&
+ &-7._ki*t6**2*t1**3*t4*t3*t2**5+25._ki/6._ki*t6**2*t1**4*t4*t5**3*t&
+ &2**2+7._ki/3._ki*t6**2*t1**4*t2**3*t3*t4-10._ki*t6**2*t1**4*t5**2*&
+ &t3*t2*t4-5._ki/2._ki*t6**2*t1**4*t3**2*t5*t2-275._ki/9._ki*t6**3*t1&
+ &**3*t4**4*t5**2*t2+55._ki/2._ki*t6**3*t1**3*t4**3*t5**2*t2**2+25.&
+ &_ki/4._ki*t6**3*t1**4*t3**2*t2+10._ki*t6**2*t1*t4**5*t3**2*t5*t2**&
+ &2-10._ki/3._ki*t6**2*t1*t4**6*t3**2*t5*t2-35._ki/3._ki*t6**2*t1*t4*&
+ &*4*t3**2*t5*t2**3-95._ki/9._ki*t6**2*t1*t2**3*t3**3*t4**3+5._ki*t6&
+ &**2*t1**4*t5**2*t3*t2**2+11._ki/24._ki*t6**3*t1*t4**2*t3**2*t2**5&
+ &+55._ki/18._ki*t6**3*t1**3*t3*t2**4*t5+40._ki/3._ki*t6**3*t1**4*t4*&
+ &t5*t2**3-308._ki/9._ki*t6**3*t1**3*t4**4*t3*t2
+ !
+ stemp8=stemp9-t6**3*t1**5*t2**3/2._ki+5._ki/8._ki*t6**3*t1**4*t2**5+&
+ &715._ki/6._ki*t6**3*t1**3*t4**2*t3*t5*t2**2+45._ki/4._ki*t6**2*t1**&
+ &3*t2**3*t3**2*t5+63._ki/4._ki*t6**2*t1**3*t4**2*t3*t2**4-35._ki/8.&
+ &_ki*t6**2*t1**3*t4**2*t5*t2**5+7._ki*t6**2*t1**3*t4**3*t5*t2**4-7&
+ &._ki/2._ki*t6**2*t1**3*t4**4*t5*t2**3+20._ki/3._ki*t6**2*t1*t4**3*t&
+ &3**2*t5*t2**4+t1**3*t3*t2**8/36._ki+15._ki/2._ki*t6**2*t1**3*t3**3&
+ &*t2*t4-15._ki*t6**2*t1**2*t4**3*t3*t5**2*t2**3+20._ki*t6**3*t1**4&
+ &*t4**3*t5*t2+65._ki/3._ki*t6**3*t1**4*t2*t3*t4**2-22._ki*t6**3*t1*&
+ &*3*t4**3*t5*t2**3-50._ki/3._ki*t6**3*t1**4*t4*t5**2*t2**2+5._ki/24&
+ &._ki*t6**2*t1*t4*t3**2*t2**6*t5+7._ki/36._ki*t6**2*t1**2*t4*t3*t2*&
+ &*7-5._ki/6._ki*t6**2*t1**2*t2**5*t3**2*t5+3._ki/2._ki*t6**3*t1**2*t&
+ &4**2*t3*t2**5+55._ki/6._ki*t6**2*t1**2*t4*t3**2*t5*t2**4
+ !
+ stemp9=stemp8-15._ki/2._ki*t6**2*t1**2*t4*t3**3*t2**3-5._ki/6._ki*t6*&
+ &*2*t1**2*t3*t5**2*t2**5*t4+5._ki/12._ki*t6**3*t1**2*t4*t5*t2**5*t&
+ &3-t6**3*t1**2*t4*t3*t2**6/6._ki-t6**3*t1*t4*t3**2*t2**6/24._ki-49&
+ &._ki/36._ki*t6**2*t1**2*t4**2*t3*t2**6-35._ki/9._ki*t6**2*t1**2*t4*&
+ &*4*t3*t2**4+7._ki/2._ki*t6**2*t1**2*t4**3*t3*t2**5-25._ki/12._ki*t6&
+ &**3*t1*t4**3*t3**2*t2**4-20._ki/3._ki*t6**2*t1**2*t4**5*t3*t5**2*&
+ &t2-15._ki/8._ki*t6**2*t1*t4**2*t3**2*t2**5*t5-88._ki/9._ki*t6**3*t1&
+ &**3*t4**5*t5*t2-70._ki/3._ki*t6**2*t1**2*t3**2*t4**4*t5*t2+14._ki/&
+ &9._ki*t6**2*t1**2*t4**5*t3*t2**3+140._ki/3._ki*t6**2*t1**2*t3**2*t&
+ &4**3*t5*t2**2-65._ki/2._ki*t6**2*t1**2*t3**2*t4**2*t5*t2**3+20._ki&
+ &*t6**3*t1**2*t4**5*t3*t5*t2-70._ki/3._ki*t6**3*t1**2*t4**4*t3*t5*&
+ &t2**2-16._ki/3._ki*t6**3*t1**2*t4**3*t3*t2**4+85._ki/6._ki*t6**3*t1&
+ &**2*t4**2*t3**2*t2**3
+ !
+ stemp7=stemp9-20._ki/3._ki*t6**3*t1**2*t4**6*t3*t5+8._ki/3._ki*t6**3*&
+ &t1**2*t4**6*t3*t2+28._ki/3._ki*t6**3*t1**2*t4**4*t3*t2**3-325._ki/&
+ &6._ki*t6**3*t1**4*t4**2*t3*t5+325._ki/6._ki*t6**3*t1**4*t3*t5*t2*t&
+ &4+40._ki/3._ki*t6**3*t1**2*t4**3*t3*t5*t2**3+100._ki/3._ki*t6**3*t1&
+ &**2*t4**4*t3**2*t2-605._ki/18._ki*t6**3*t1**3*t4*t3*t5*t2**3-95._k&
+ &i/3._ki*t6**3*t1**2*t4**3*t3**2*t2**2-8._ki*t6**3*t1**2*t4**5*t3*&
+ &t2**2-35._ki/12._ki*t6**3*t1**2*t4*t3**2*t2**4+7._ki/8._ki*t6**2*t1&
+ &**3*t2**6*t4*t5-15._ki/4._ki*t6**3*t1**2*t4**2*t5*t2**4*t3-5._ki/4&
+ &._ki*t6**2*t1**3*t4*t5**3*t2**4-15._ki/4._ki*t6**2*t1**3*t3*t5**2*&
+ &t2**4-135._ki/2._ki*t6**2*t1**3*t4**2*t5**2*t3*t2**2+45._ki*t6**2*&
+ &t1**3*t4**3*t5**2*t3*t2-t1**3*t4**2*t5*t2**7/9._ki-40._ki/3._ki*t6&
+ &**3*t1**2*t4**5*t3**2-4._ki/3._ki*t6**3*t1*t4**7*t3**2+5._ki/3._ki*&
+ &t6**3*t1**5*t3*t5+t6**3*t1**5*t2**2*t4
+ !
+ stemp9=10._ki/3._ki*t6**3*t1**5*t5**2*t4-5._ki/3._ki*t6**3*t1**5*t5**&
+ &2*t2+4._ki/3._ki*t6**3*t1**5*t5*t2**2-2._ki/3._ki*t6**3*t1**5*t2*t3&
+ &-15._ki/2._ki*t6**3*t1**4*t4**3*t2**2+45._ki/4._ki*t6**3*t1**4*t4**&
+ &2*t2**3-5._ki*t6**3*t1**4*t4*t2**4-25._ki/2._ki*t6**3*t1**4*t3**2*&
+ &t4-25._ki*t6**3*t1**4*t4**3*t5**2+5._ki*t6**3*t1**4*t2**3*t3+33._k&
+ &i/4._ki*t6**3*t1**3*t4**3*t2**4+11._ki/3._ki*t6**3*t1**3*t4**5*t2*&
+ &*2-55._ki/9._ki*t6**3*t1**3*t3**2*t2**3-t1**3*t4*t3*t2**7/18._ki+t&
+ &1**3*t4*t2**8*t5/9._ki+110._ki/9._ki*t6**3*t1**3*t4**5*t5**2-77._ki&
+ &/24._ki*t6**3*t1**3*t4**2*t2**5-55._ki/6._ki*t6**3*t1**3*t4**4*t2*&
+ &*3-15._ki/4._ki*t6**2*t1**3*t3**3*t2**2-5._ki/2._ki*t6**2*t1**4*t4*&
+ &*2*t2**4-7._ki/6._ki*t6**2*t1**4*t2**4*t3
+ !
+ stemp8=stemp9+5._ki/24._ki*t6**3*t1**2*t3**2*t2**5-t6**2*t2**7*t3**&
+ &3*t4/36._ki-5._ki/3._ki*t6**3*t1**4*t5*t2**4+10._ki/9._ki*t6**2*t1**&
+ &2*t3**3*t2**4+10._ki/3._ki*t6**2*t4**4*t3**3*t2**4-40._ki/9._ki*t6*&
+ &*2*t4**5*t3**3*t2**3+28._ki/9._ki*t6**2*t4**6*t3**3*t2**2-8._ki/9.&
+ &_ki*t6**2*t4**7*t3**3*t2+5._ki/2._ki*t6**2*t1**4*t4*t2**5+15._ki/4.&
+ &_ki*t6**2*t1**3*t4**2*t2**6+3._ki*t6**2*t1**3*t4**4*t2**4-6._ki*t6&
+ &**2*t1**3*t4**3*t2**5+t6*t1**3*t4**3*t2**6/2._ki-3._ki/4._ki*t6*t1&
+ &**3*t4**2*t2**7+25._ki/12._ki*t6**3*t1**4*t5**2*t2**3+7._ki/8._ki*t&
+ &6**2*t1**3*t3*t2**6-5._ki/6._ki*t6**2*t1**4*t5**3*t2**3+7._ki/12._k&
+ &i*t6**2*t1**4*t5*t2**5-3._ki/4._ki*t6**2*t1**3*t4*t2**7+t6*t1**3*&
+ &t4*t2**8/4._ki+11._ki/36._ki*t6**2*t2**6*t3**3*t4**2
+ !
+ stemp9=stemp8+5._ki/72._ki*t6**2*t1*t2**6*t3**3-25._ki/18._ki*t6**2*t&
+ &2**5*t3**3*t4**3-11._ki/9._ki*t6**3*t1**3*t2**5*t3+11._ki/24._ki*t6&
+ &**3*t1**3*t4*t2**6+1045._ki/18._ki*t6**3*t1**3*t3**2*t4**3+50._ki/&
+ &3._ki*t6**2*t1**2*t4**4*t3*t5**2*t2**2-40._ki/9._ki*t6**2*t1*t4**5&
+ &*t3**3*t2+100._ki/9._ki*t6**2*t1*t4**4*t3**3*t2**2-11._ki/9._ki*t6*&
+ &*3*t1**3*t4*t5*t2**5+55._ki/36._ki*t6**3*t1**3*t4*t5**2*t2**4+85.&
+ &_ki/18._ki*t6**2*t1*t2**4*t3**3*t4**2-35._ki/12._ki*t6**2*t1**4*t4*&
+ &t5*t2**4-20._ki/3._ki*t6**3*t1*t4**5*t3**2*t2**2-8._ki/3._ki*t6**3*&
+ &t1**5*t5*t2*t4+14._ki/3._ki*t6**3*t1*t4**6*t3**2*t2-t6**2*t1**4*t&
+ &2**6/2._ki-25._ki/6._ki*t6**2*t1**4*t4**2*t5**3*t2+35._ki/12._ki*t6*&
+ &*2*t1**4*t4**2*t5*t2**3+stemp7+35._ki/6._ki*t6**2*t1**2*t4**2*t3*&
+ &t5**2*t2**4
+ !
+ stemp6=stemp9+220._ki/9._ki*t6**3*t1**3*t4**4*t5*t2**2+165._ki/4._ki*&
+ &t6**3*t1**3*t4*t3**2*t2**2+121._ki/9._ki*t6**3*t1**3*t4*t3*t2**4+&
+ &770._ki/9._ki*t6**3*t1**3*t4**4*t3*t5+77._ki/9._ki*t6**3*t1**3*t4**&
+ &2*t5*t2**4-1540._ki/9._ki*t6**3*t1**3*t4**3*t3*t5*t2-1045._ki/12._k&
+ &i*t6**3*t1**3*t3**2*t4**2*t2-385._ki/36._ki*t6**3*t1**3*t4**2*t5*&
+ &*2*t2**3-143._ki/3._ki*t6**3*t1**3*t4**2*t3*t2**3+616._ki/9._ki*t6*&
+ &*3*t1**3*t4**3*t3*t2**2+5._ki*t6**3*t1*t4**4*t3**2*t2**3-25._ki/2&
+ &._ki*t6**3*t1**4*t3*t5*t2**2+75._ki/2._ki*t6**3*t1**4*t4**2*t5**2*&
+ &t2-65._ki/3._ki*t6**3*t1**4*t2**2*t3*t4-30._ki*t6**3*t1**4*t4**2*t&
+ &5*t2**2-10._ki*t6**2*t1**3*t4**3*t5**3*t2**2+5._ki*t6**2*t1**3*t4&
+ &**4*t5**3*t2-35._ki/36._ki*t6**2*t1*t2**5*t3**3*t4+25._ki/4._ki*t6*&
+ &*2*t1**3*t4**2*t5**3*t2**3+30._ki*t6**2*t1**3*t4*t5**2*t3*t2**3-&
+ &95._ki/9._ki*t6**2*t1**2*t3**3*t4**3*t2+95._ki/6._ki*t6**2*t1**2*t3&
+ &**3*t4**2*t2**2
+ !
+ stemp7=1._ki/t1**3/t2**10
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ stemp2=-(-24._ki*t6**3*t2**2*t5*t4**2+48._ki*t6**3*t4**3*t5*t2-24._k&
+ &i*t6**3*t3*t2*t1+60._ki*t6**3*t4*t1*t3+96._ki*t6**3*t3*t2*t4**2-3&
+ &6._ki*t6**3*t3*t2**2*t4+2._ki*t6*t1*t2**4*t5+2._ki*t6*t2**5*t4*t5-&
+ &4._ki*t6*t2**4*t4**2*t5-6._ki*t3*t4*t6*t2**4-18._ki*t6**2*t1*t2**3&
+ &*t4+2._ki*t3*t5*t2**5+6._ki*t6**2*t1*t2**4-12._ki*t6**3*t1**2*t5-3&
+ &2._ki*t6**3*t4**4*t5-12._ki*t6**2*t2**4*t4**2+96._ki*t6**3*t1*t5*t&
+ &4**2+12._ki*t1*t6**3*t2**2*t5+4._ki*t6**3*t2**3*t5*t4-72._ki*t1*t6&
+ &**3*t4*t5*t2+t4*t5**2*t2**5+12._ki*t6**2*t2**3*t4**3+3._ki*t6**2*&
+ &t2**5*t4-80._ki*t6**3*t3*t4**3+4._ki*t6**3*t3*t2**3+2._ki*t6*t2**5&
+ &*t3)/t2**8*z_log(t1*t6/t2**2,1._ki)/12._ki
+ !
+ stemp4=(-6._ki*t2*t6*t3**3*t4+2._ki*t2**2*t5*t3**3-4._ki*t3**2*t4**2&
+ &*t5*t2*t6+2._ki*t4*t5*t3**2*t6*t2**2+6._ki*t1*t6**2*t3**2*t4-8._ki&
+ &*t3*t4*t5*t2*t6**2*t1+4._ki*t5*t1**2*t6**2*t3-6._ki*t2*t5*t1*t6*t&
+ &3**2-4._ki*t3*t4*t5**2*t2*t1*t6+t3**2*t4*t5**2*t2**2+16._ki*t3*t4&
+ &**2*t5*t6**2*t1+2._ki*t6*t3**3*t2**2-12._ki*t2*t4**2*t3**2*t6**2+&
+ &12._ki*t4**3*t3**2*t6**2-2._ki*t2*t1*t6**2*t3**2+3._ki*t2**2*t4*t3&
+ &**2*t6**2+6._ki*t4*t5**2*t6**2*t1**2)/t3**2/t2**5*q(4,(t2*t3-t1*&
+ &t6)/t2/t3,sign_arg)/12._ki
+ !
+ stemp5=-(-8._ki*t6*t1**2*t2**4*t5*t3-56._ki*t6*t1*t2**4*t3*t4**2*t5&
+ &+28._ki*t6*t1*t2**5*t3*t4*t5-48._ki*t6*t1*t4*t3**2*t2**4-360._ki*t&
+ &6**3*t1**2*t3*t4*t5*t2+44._ki*t6**3*t1*t3*t2**3*t5*t4+96._ki*t6**&
+ &3*t3**2*t4**5-352._ki*t6**3*t1*t3*t4**4*t5-396._ki*t6**3*t1*t2**2&
+ &*t4*t3**2+480._ki*t6**3*t1**2*t3*t5*t4**2+60._ki*t6**3*t1**2*t3*t&
+ &2**2*t5+6._ki*t6**3*t4*t3**2*t2**4+44._ki*t6**3*t1*t3**2*t2**3+14&
+ &4._ki*t6**3*t3**2*t2**2*t4**3+18._ki*t6**2*t1**2*t3*t2**4+16._ki*t&
+ &1*t2**5*t3**2*t5-48._ki*t6**3*t3**2*t2**3*t4**2-192._ki*t6**3*t3*&
+ &*2*t4**4*t2+14._ki*t1*t2**5*t3*t4*t5**2+528._ki*t6**3*t1*t3*t4**3&
+ &*t5*t2+108._ki*t6**2*t1*t3*t2**3*t4**3-108._ki*t6**2*t1*t3*t2**4*&
+ &t4**2-54._ki*t6**2*t1**2*t3*t2**3*t4+27._ki*t6**2*t1*t3*t2**5*t4-&
+ &12._ki*t6*t1**2*t2**4*t4*t5**2+1056._ki*t6**3*t1*t2*t4**2*t3**2-2&
+ &64._ki*t6**3*t1*t3*t2**2*t5*t4**2+16._ki*t6*t1*t2**5*t3**2-24._ki*&
+ &t6**3*t3*t5*t1**3+300._ki*t6**3*t1**2*t4*t3**2-120._ki*t6**3*t1**&
+ &2*t2*t3**2-880._ki*t6**3*t1*t4**3*t3**2)/t1/t2**8/t3/72._ki
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3_glob)
+ !
+ case(3)
+ !
+ select case(par4_glob)
+ !
+ case(3)
+ !
+ stemp6=-3._ki/4._ki*t4**2*t2**10+t4**3*t2**9/4._ki-132._ki*t6**3*t4**&
+ &2*t3*t2**5+36._ki*t6**3*t4**5*t3*t2**2+180._ki*t6**3*t4**5*t5**3*&
+ &t2-330._ki*t6**3*t4**4*t5**3*t2**2+66._ki*t6**3*t4**4*t5*t2**4-13&
+ &2._ki*t6**3*t4**4*t3*t2**3+189._ki*t6**3*t4**3*t3*t2**4-540._ki*t6&
+ &**3*t4**5*t3*t5**2-36._ki*t6**3*t4**5*t5*t2**3-135._ki*t6**3*t1**&
+ &2*t4**2*t5**3+240._ki*t6**3*t1*t4**4*t5**3-3._ki/4._ki*t6**2*t1**2&
+ &*t4*t2**5-9._ki*t6**2*t1*t4**2*t2**6+7._ki/2._ki*t6**2*t1*t4**3*t2&
+ &**5+105._ki*t6**2*t4*t3**2*t2**5-285._ki/2._ki*t6**2*t4**2*t3**2*t&
+ &2**4+57._ki/2._ki*t6**2*t4**2*t3*t2**6-25._ki*t6**2*t4**3*t3*t2**5&
+ &-250._ki*t6**2*t4**3*t5**4*t2**3+160._ki*t6**2*t4**4*t5**4*t2**2-&
+ &40._ki*t6**2*t4**5*t5**4*t2+125._ki/2._ki*t6**2*t4**3*t3**2*t2**3+&
+ &8._ki*t6**2*t4**4*t3*t2**4-250._ki*t6**2*t4**3*t5**3*t2**4+160._ki&
+ &*t6**2*t4**4*t5**3*t2**3-40._ki*t6**2*t4**5*t5**3*t2**2+25._ki/2.&
+ &_ki*t6**2*t4**3*t5*t2**6-8._ki*t6**2*t4**4*t5*t2**5+2._ki*t6**2*t4&
+ &**5*t5*t2**4+10._ki*t6**2*t4**5*t5**2*t2**3-40._ki*t6**2*t4**4*t5&
+ &**2*t2**4+125._ki/2._ki*t6**2*t4**3*t5**2*t2**5+70._ki*t6*t4**3*t5&
+ &**4*t2**4-20._ki*t6*t4**4*t5**4*t2**3
+ !
+ stemp5=7._ki*t6*t4**3*t5*t2**7-2._ki*t6*t4**4*t5*t2**6+35._ki*t6*t4*&
+ &*3*t5**5*t2**3-10._ki*t6*t4**4*t5**5*t2**2-8._ki*t6*t4**4*t5**3*t&
+ &2**4+18._ki*t6*t4**2*t3*t2**7+28._ki*t6*t4**3*t5**3*t2**5-7._ki*t6&
+ &*t4**3*t3*t2**6-15._ki*t6*t4*t3**2*t2**6+9._ki*t6*t4**2*t3**2*t2*&
+ &*5-7._ki*t6*t4**3*t5**2*t2**6+2._ki*t6*t4**4*t5**2*t2**5-9._ki*t6*&
+ &*3*t4*t5*t2**7+45._ki*t6**3*t4*t5**3*t2**5+90._ki*t6**3*t3*t5**2*&
+ &t2**5+75._ki*t6**3*t1*t5**3*t2**4-15._ki*t6**3*t1*t5*t2**6-70._ki*&
+ &t6**2*t4*t5**3*t2**6+35._ki/2._ki*t6**2*t4*t5**2*t2**7+25._ki*t6**&
+ &2*t5*t2**7*t3-70._ki*t6**2*t4*t5**4*t2**5-150._ki*t6**2*t3*t5**2*&
+ &t2**6-200._ki*t6**2*t5**3*t2**5*t3+stemp6+45._ki*t6**3*t4*t3*t2**&
+ &6+600._ki*t6**2*t3**2*t2**4*t5**2+190._ki*t6**2*t4**2*t5**4*t2**4&
+ &-3._ki/2._ki*t6**2*t1**2*t5*t2**5-15._ki/2._ki*t6**2*t1**2*t5**2*t2&
+ &**4+30._ki*t6**2*t1**2*t5**3*t2**3+30._ki*t6**2*t1**2*t5**4*t2**2&
+ &-165._ki*t6**3*t4**2*t5**3*t2**4+33._ki*t6**3*t4**2*t5*t2**6-t6*t&
+ &1*t2**5*t3**2+280._ki*t3**3*t2**3*t6**2*t4+160._ki*t3**3*t2**4*t6&
+ &*t5-190._ki*t3**3*t2**2*t6**2*t4**2-12._ki*t3*t2**3*t6**3*t1**2
+ !
+ stemp6=stemp5+20._ki*t3**2*t2**4*t1*t6**2-20._ki*t3**3*t2**4*t6*t4-&
+ &25._ki*t6*t5*t2**2*t3**4+660._ki*t2*t3**3*t6**3*t4**2-450._ki*t2**&
+ &2*t3**3*t6**3*t4+105._ki*t3**3*t6**3*t1*t4-6._ki*t6**2*t2**6*t1*t&
+ &3-3._ki*t6*t1*t3*t2**7-t2**2*t1**3*t6**3*t5-45._ki*t6**3*t5*t1**2&
+ &*t3**2+200._ki*t2**3*t3**3*t6*t5**2-400._ki*t2**3*t3**3*t6**2*t5-&
+ &9._ki*t6*t4**2*t2**8*t5-360._ki*t6*t3**2*t2**5*t5**2+9._ki*t6*t4**&
+ &2*t5**2*t2**7-300._ki*t6*t3**2*t5**3*t2**4-15._ki*t6*t4*t3*t2**8-&
+ &90._ki*t6*t4**2*t5**4*t2**5+190._ki*t6**2*t4**2*t5**3*t2**5-19._ki&
+ &/2._ki*t6**2*t4**2*t5*t2**7-14._ki*t6**2*t4*t3*t2**7+300._ki*t6**2&
+ &*t2**5*t3**2*t5+15._ki/2._ki*t6**2*t1*t4*t2**7-225._ki*t6**3*t3**2&
+ &*t2**4*t5-90._ki*t6**3*t1**2*t5**3*t2**2+18._ki*t6**3*t1**2*t5*t2&
+ &**4+30._ki*t6**3*t1*t3*t2**5+t6**2*t1**2*t3*t2**4/2._ki-75._ki*t3*&
+ &*3*t2*t6**3*t1-70._ki*t3**4*t2*t6**2*t4+20._ki*t6**2*t2**2*t1*t3*&
+ &*3-72._ki*t6*t5*t3**2*t2**6-36._ki*t6*t4**2*t5**3*t2**6-95._ki/2._k&
+ &i*t6**2*t4**2*t5**2*t2**6+1120._ki*t2**2*t3**3*t6**2*t5*t4-760._k&
+ &i*t2*t3**3*t6**2*t5*t4**2
+ !
+ stemp7=stemp6-375._ki*t6*t4*t5**4*t2**4*t3+30._ki*t6*t4*t3*t2**7*t5&
+ &-600._ki*t6*t4*t5**3*t2**5*t3-250._ki*t2**2*t3**3*t6*t4*t5**2-420&
+ &._ki*t6**3*t1*t4*t5**3*t2**3-450._ki*t6**3*t1*t3*t5**2*t2**3-180.&
+ &_ki*t6*t4*t5**2*t2**6*t3-75._ki*t6*t1*t5**4*t3*t2**3+1350._ki*t6**&
+ &3*t3**2*t2**3*t4*t5+1890._ki*t6**3*t1*t4*t3*t5**2*t2**2-2565._ki*&
+ &t6**3*t1*t4**2*t3*t5**2*t2+1125._ki*t6**3*t1*t4**3*t3*t5**2-126.&
+ &_ki*t6**3*t1*t2**4*t3*t4+855._ki*t6**3*t1*t4**2*t5**3*t2**2+171._k&
+ &i*t6**3*t1*t2**3*t3*t4**2-750._ki*t6**3*t1*t4**3*t5**3*t2+150._ki&
+ &*t6**3*t1*t4**3*t5*t2**3-171._ki*t6**3*t1*t4**2*t5*t2**4
+ !
+ stemp4=stemp7+36._ki*t6*t1*t4*t3*t2**4*t5**2+750._ki*t6*t4*t5**3*t3&
+ &**2*t2**3+720._ki*t6*t4**2*t3*t5**3*t2**4+450._ki*t6*t4**2*t5**4*&
+ &t3*t2**3+180._ki*t6*t4*t5*t2**5*t3**2-108._ki*t6*t4**2*t3**2*t5*t&
+ &2**4+216._ki*t6*t4**2*t5**2*t2**5*t3-84._ki*t6*t4**3*t5**2*t2**4*&
+ &t3-540._ki*t6*t4**2*t3**2*t5**2*t2**3-175._ki*t6*t4**3*t3*t5**4*t&
+ &2**2-280._ki*t6*t4**3*t3*t5**3*t2**3+120._ki*t6*t1*t4*t5**3*t3*t2&
+ &**3-45._ki*t6*t4**2*t5**5*t2**4+14._ki*t6*t4**3*t5*t3*t2**5-36._ki&
+ &*t6*t4**2*t5*t3*t2**6+900._ki*t6*t4*t3**2*t5**2*t2**4-450._ki*t6*&
+ &t4**2*t5**3*t3**2*t2**2+12._ki*t6*t1*t4**2*t5**3*t2**4-3._ki*t6*t&
+ &1*t4**2*t5**2*t2**5
+ !
+ stemp7=15._ki*t6*t1*t4**2*t5**5*t2**2+30._ki*t6*t1*t4**2*t5**4*t2**&
+ &3+3._ki*t6*t1*t4**2*t2**6*t5+300._ki*t6**2*t1*t4*t5**3*t2**4+1120&
+ &._ki*t6**2*t4*t5**3*t2**4*t3+1980._ki*t6**3*t4**2*t3*t5**2*t2**3-&
+ &2835._ki*t6**3*t4**3*t3*t5**2*t2**2+1980._ki*t6**3*t4**4*t3*t5**2&
+ &*t2+3._ki/4._ki*t4*t2**11+2835._ki*t6**3*t4**3*t3**2*t5*t2-2970._ki&
+ &*t6**3*t4**2*t3**2*t5*t2**2-30._ki*t6**2*t1**2*t4*t5**4*t2+15._ki&
+ &/2._ki*t6**2*t1**2*t4*t5**2*t2**3-30._ki*t6**2*t1**2*t4*t5**3*t2*&
+ &*2-35._ki*t6**2*t1*t4**3*t5**2*t2**3-360._ki*t6**2*t1*t4**2*t5**4&
+ &*t2**2-7._ki*t6**2*t1*t4**3*t5*t2**4+140._ki*t6**2*t1*t4**3*t5**4&
+ &*t2
+ !
+ stemp6=stemp7+18._ki*t6**2*t1*t4**2*t5*t2**5+3._ki*t6*t1*t5*t2**8+1&
+ &60._ki*t6*t3*t5**3*t2**6+100._ki*t6*t5**4*t2**5*t3-8._ki*t6*t5*t3*&
+ &t2**8+7._ki/2._ki*t6**2*t4*t2**8*t5+20._ki*t6**2*t1*t5**2*t2**6+4.&
+ &_ki*t6**2*t1*t5*t2**7-80._ki*t6**2*t1*t5**4*t2**4-80._ki*t6**2*t1*&
+ &t5**3*t2**5+50._ki*t6*t4*t5**4*t2**6+5._ki*t6*t4*t2**9*t5+20._ki*t&
+ &6*t4*t5**3*t2**7-5._ki*t6*t2**8*t4*t5**2+25._ki*t6*t4*t5**5*t2**5&
+ &+48._ki*t6*t3*t5**2*t2**7+30._ki*t6*t1*t5**4*t2**5+15._ki*t6*t1*t5&
+ &**5*t2**4+12._ki*t6*t1*t5**3*t2**6
+ !
+ stemp5=stemp6-3._ki*t6*t1*t5**2*t2**7-990._ki*t6**3*t4**4*t3**2*t5-&
+ &63._ki*t6**3*t4**3*t5*t2**5+8._ki*t6**3*t4**6*t5*t2**2+315._ki*t6*&
+ &*3*t4**3*t5**3*t2**3-10._ki*t6*t2**3*t3**4+90._ki*t6**2*t1*t4**2*&
+ &t5**2*t2**4-360._ki*t6**2*t1*t4**2*t5**3*t2**3+140._ki*t6**2*t1*t&
+ &4**3*t5**3*t2**2+3._ki/2._ki*t6**2*t1**2*t4*t5*t2**4-90._ki*t6**2*&
+ &t1*t4**2*t5*t2**3*t3-900._ki*t6**2*t1*t4*t3*t5**2*t2**3+150._ki*t&
+ &6**2*t1*t4*t5*t2**4*t3+540._ki*t6**2*t1*t4**2*t3*t5**2*t2**2+720&
+ &._ki*t6**2*t1*t4**2*t5**3*t2*t3-t2**12/4._ki-6._ki*t6**3*t3*t2**7+&
+ &4._ki*t6**2*t4**4*t2**6-10._ki*t6*t5**4*t2**7+50._ki*t3**4*t2**2*t&
+ &6**2-25._ki*t6**2*t3**2*t2**6+10._ki*t6**2*t5**4*t2**6+4._ki*t6*t3&
+ &*t2**9+3._ki/4._ki*t6**2*t1**2*t2**6-t6**2*t4**5*t2**5+16._ki*t3**&
+ &3*t6*t2**5-5._ki*t6*t5**5*t2**6-t6*t2**10*t5+5._ki/2._ki*t6**2*t3*&
+ &t2**8-25._ki/4._ki*t6**2*t4**3*t2**7+19._ki/4._ki*t6**2*t4**2*t2**8&
+ &-7._ki/4._ki*t6**2*t4*t2**9-100._ki*t3**3*t2**4*t6**2-4._ki*t6*t5**&
+ &3*t2**8+100._ki*t2**3*t3**3*t6**3-2._ki*t6**2*t1*t2**8-315._ki*t3*&
+ &*3*t6**3*t4**3
+ !
+ stemp7=stemp5+10._ki*t6**2*t5**3*t2**7-5._ki/2._ki*t6**2*t5**2*t2**8&
+ &-40._ki*t6**3*t4**6*t5**3+t6*t5**2*t2**9+t6**3*t5*t2**8-5._ki*t6*&
+ &*3*t5**3*t2**6+5._ki*t1**3*t6**3*t5**3-t6**2*t2**9*t5/2._ki+6._ki*&
+ &t6*t3**2*t2**7+360._ki*t6**2*t1*t3*t5**2*t2**4-9._ki*t6**2*t1*t3*&
+ &t2**4*t4**2+15._ki*t6**2*t1*t3*t2**5*t4-30._ki*t3*t5**2*t2**2*t1*&
+ &*2*t6**2+60._ki*t3**2*t5**2*t2**3*t1*t6-240._ki*t3**2*t2**3*t6**2&
+ &*t5*t1+300._ki*t3**2*t2**2*t6**2*t4*t5*t1-200._ki*t3**3*t2**3*t6*&
+ &t4*t5
+ !
+ stemp6=stemp7+15._ki*t3*t2**2*t6**3*t4*t1**2-25._ki*t3**2*t2**3*t1*&
+ &t6**2*t4+5._ki*t3*t2**3*t1**2*t6**2*t5-6._ki*t6*t1*t2**5*t3*t4*t5&
+ &-1200._ki*t6**2*t1*t4*t5**3*t3*t2**2-2520._ki*t6**2*t4*t3**2*t5**&
+ &2*t2**3-1500._ki*t6**2*t4**3*t3**2*t5**2*t2-1260._ki*t6**2*t4*t3*&
+ &*2*t5*t2**4+1710._ki*t6**2*t4**2*t3**2*t5*t2**3+2000._ki*t6**2*t4&
+ &**3*t3*t5**3*t2**2+3420._ki*t6**2*t4**2*t3**2*t5**2*t2**2-750._ki&
+ &*t6**2*t4**3*t3**2*t5*t2**2-640._ki*t6**2*t4**4*t3*t5**3*t2+285.&
+ &_ki*t6**2*t4**2*t5*t2**5*t3-2280._ki*t6**2*t4**2*t5**3*t3*t2**3+1&
+ &500._ki*t6**2*t4**3*t3*t5**2*t2**3-480._ki*t6**2*t4**4*t3*t5**2*t&
+ &2**2+80._ki*t6**2*t4**4*t5*t2**3*t3-1710._ki*t6**2*t4**2*t3*t5**2&
+ &*t2**4
+ !
+ stemp7=stemp6+75._ki*t6*t1*t4*t5**4*t2**2*t3-15._ki*t6**2*t1*t2**6*&
+ &t4*t5+3._ki*t6*t1*t2**6*t4*t3+12._ki*t3**2*t2**4*t1*t6*t5+80._ki*t&
+ &6**2*t5*t2*t1*t3**3+180._ki*t2*t3*t1**2*t6**3*t5**2-480._ki*t2**2&
+ &*t3**2*t1*t6**2*t5**2+855._ki*t3**2*t1*t6**3*t5*t4**2+50._ki*t2**&
+ &2*t3**2*t1*t6*t5**3-40._ki*t2*t3*t1**2*t6**2*t5**3-225._ki*t3*t1*&
+ &*2*t6**3*t4*t5**2+450._ki*t2**2*t3**2*t1*t6**3*t5-1260._ki*t2*t3*&
+ &*2*t1*t6**3*t5*t4+600._ki*t2*t3**2*t1*t6**2*t4*t5**2-120._ki*t6*t&
+ &1*t5**3*t3*t2**4+840._ki*t6**2*t4*t3*t5**2*t2**5-75._ki*t6**2*t1*&
+ &t4*t5**2*t2**5+300._ki*t6**2*t1*t4*t5**4*t2**3
+ !
+ stemp3=stemp7-45._ki*t6**3*t1**2*t4*t5*t2**3+27._ki*t6**3*t1**2*t4*&
+ &*2*t5*t2**2+225._ki*t6**3*t1**2*t4*t5**3*t2-75._ki*t6**3*t1*t2**2&
+ &*t3*t4**3-48._ki*t6**3*t1*t4**4*t5*t2**2-140._ki*t6**2*t4*t5*t2**&
+ &6*t3+t6**2*t2**10/4._ki+stemp4-250._ki*t6**2*t4**3*t5*t2**4*t3-6.&
+ &_ki*t6*t1*t4*t5*t2**7-36._ki*t6*t1*t3*t5**2*t2**5+6._ki*t6*t1*t4*t&
+ &5**2*t2**6-675._ki*t6**3*t4*t3*t5**2*t2**4+84._ki*t6**3*t1*t4*t5*&
+ &t2**5+480._ki*t6**2*t1*t3*t5**3*t2**3-60._ki*t6**2*t1*t3*t5*t2**5&
+ &+6._ki*t6*t1*t2**6*t3*t5-24._ki*t6*t1*t4*t5**3*t2**5-60._ki*t6*t1*&
+ &t4*t5**4*t2**4-30._ki*t6*t1*t4*t5**5*t2**3
+ !
+ stemp4=1._ki/t2**12*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=(-t4+t2)**3/t2**3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/4._ki
+ !
+ stemp11=-300._ki*t6*t1**4*t2**5*t3**3*t4+110._ki*t6*t1**4*t4**4*t3*&
+ &*2*t2**4+660._ki*t6*t1**4*t2**4*t3**3*t4**2+300._ki*t6*t1**4*t3**&
+ &4*t2**3*t4-600._ki*t6*t1**6*t4*t5**3*t3*t2**2-450._ki*t6*t1**6*t4&
+ &*t3*t5**2*t2**3+300._ki*t6*t1**6*t4*t3**2*t5**2*t2-1890._ki*t6*t1&
+ &**5*t4*t3**2*t5*t2**4-3780._ki*t6*t1**5*t4*t3**2*t5**2*t2**3+256&
+ &5._ki*t6*t1**5*t4**2*t3**2*t5*t2**3+1680._ki*t6*t1**5*t3**3*t5*t2&
+ &**2*t4-375._ki*t6*t1**5*t4**3*t5*t2**4*t3-3420._ki*t6*t1**5*t4**2&
+ &*t5**3*t3*t2**3-32._ki*t6**2*t1**2*t4**8*t3**3*t2+121._ki*t6**2*t&
+ &1**2*t4**5*t3**3*t2**4-414._ki*t6**2*t1**3*t4**5*t3**2*t5*t2**3+&
+ &5._ki*t6**2*t1**7*t2**2*t3*t4+9._ki*t6**2*t1**7*t4**2*t5*t2**2+12&
+ &5._ki*t6**2*t1**6*t4**3*t5*t2**3+1425._ki/2._ki*t6**2*t1**6*t4**2*&
+ &t3**2*t5
+ !
+ stemp10=stemp11+285._ki/2._ki*t6**2*t1**6*t2**3*t3*t4**2+1875._ki/2.&
+ &_ki*t6**2*t1**6*t4**3*t3*t5**2-285._ki/2._ki*t6**2*t1**6*t4**2*t5*&
+ &t2**4-55._ki*t6*t4**2*t2**7*t1**4*t3*t5-840._ki*t6*t1**4*t4**3*t5&
+ &**3*t3*t2**4-1050._ki*t6**2*t1**6*t3**2*t5*t2*t4-600._ki*t1**5*t4&
+ &*t5**3*t2**5*t3-180._ki*t1**5*t4*t5**2*t2**6*t3-840._ki*t1**4*t4*&
+ &t3**2*t5**2*t2**6+70._ki*t6*t1**6*t4**3*t5**3*t2**2-285._ki*t6*t1&
+ &**5*t3**3*t2**2*t4**2-105._ki*t6*t1**5*t3**4*t2*t4+315._ki/2._ki*t&
+ &6*t1**5*t4*t3**2*t2**5-855._ki/4._ki*t6*t1**5*t4**2*t3**2*t2**4+1&
+ &50._ki*t6*t1**6*t4*t5*t3**2*t2**2+2160._ki*t6**2*t1**4*t4**4*t3**&
+ &2*t5*t2**2-4._ki*t6**2*t1**4*t4**7*t3*t2**2+240._ki*t6*t1**5*t4**&
+ &4*t5**4*t2**2+420._ki*t6*t1**5*t4*t3**3*t2**3-440._ki*t6*t1**4*t3&
+ &**4*t2**2*t4**2
+ !
+ stemp11=-30._ki*t6*t1**4*t4**5*t3**2*t2**3-315._ki/2._ki*t6*t1**4*t4&
+ &**3*t3**2*t2**5+110._ki*t6*t1**4*t4**2*t3**2*t2**6+165._ki*t6**2*&
+ &t3*t5**2*t2**5*t1**5-33._ki/2._ki*t6**2*t4*t5*t2**7*t1**5+900._ki*&
+ &t6*t1**5*t3**2*t2**4*t5**2+285._ki*t6*t1**5*t4**2*t5**4*t2**4+20&
+ &0._ki*t6*t5*t2**5*t3**3*t1**4-55._ki*t6*t4*t3**3*t2**7*t1**3-15._k&
+ &i/2._ki*t6*t1**6*t2**6*t4*t5+180._ki*t6*t1**6*t3*t5**2*t2**4-75._k&
+ &i/2._ki*t6*t1**6*t4*t5**2*t2**5+150._ki*t6*t1**6*t4*t5**4*t2**3+2&
+ &40._ki*t6*t1**6*t3*t5**3*t2**3-30._ki*t6*t1**6*t3*t5*t2**5+150._ki&
+ &*t6*t1**6*t4*t5**3*t2**4+900._ki*t6*t4*t3**2*t2**5*t1**4*t5**2+3&
+ &30._ki*t6*t4**2*t3*t2**6*t1**4*t5**2+stemp10-1720._ki*t6*t1**3*t4&
+ &**3*t3**3*t5*t2**4-64._ki*t1**2*t4**4*t3**3*t2**7
+ !
+ stemp9=stemp11+425._ki/2._ki*t1**2*t4**2*t3**4*t2**7-430._ki*t1**2*t&
+ &4**3*t3**4*t2**6+200._ki/3._ki*t1**2*t4**6*t3**4*t2**3+43._ki*t1**&
+ &2*t4**3*t3**3*t2**8+16._ki/3._ki*t1**2*t4**7*t3**3*t2**4-80._ki/3.&
+ &_ki*t1**2*t4**6*t3**3*t2**5+56._ki*t1**2*t4**5*t3**3*t2**6+480._ki&
+ &*t1**2*t4**4*t3**4*t2**5-280._ki*t1**2*t4**5*t3**4*t2**4+70._ki*t&
+ &1**2*t2**2*t3**5*t4**5-425._ki/2._ki*t1**2*t2**5*t3**5*t4**2-240.&
+ &_ki*t1**2*t2**3*t3**5*t4**4+275._ki/4._ki*t1**2*t4*t3**5*t2**6+645&
+ &._ki/2._ki*t1**2*t2**4*t3**5*t4**3+1155._ki/4._ki*t1*t2**6*t3**5*t4&
+ &**3+73._ki/2._ki*t4**2*t3**4*t2**9*t1+200._ki*t1**5*t3**3*t5**2*t2&
+ &**3+18._ki*t1**5*t4**2*t3*t2**7-15._ki*t1**5*t4*t3**2*t2**6+70._ki&
+ &*t1**5*t4**3*t5**4*t2**4-7._ki*t1**5*t4**3*t5**2*t2**6
+ !
+ stemp11=stemp9+15._ki*t6*t1**5*t4**5*t5**2*t2**3-1140._ki*t6*t1**5*&
+ &t4**2*t3**3*t5*t2+120._ki*t6*t1**5*t4**4*t5*t2**3*t3-1125._ki*t6*&
+ &t1**5*t4**3*t3**2*t5*t2**2+855._ki/2._ki*t6*t1**5*t4**2*t5*t2**5*&
+ &t3+3000._ki*t6*t1**5*t4**3*t3*t5**3*t2**2-12._ki*t6*t1**5*t4**4*t&
+ &5*t2**5-60._ki*t6*t1**5*t4**5*t5**3*t2**2+240._ki*t6*t1**5*t4**4*&
+ &t5**3*t2**3+3._ki*t6*t1**5*t4**5*t5*t2**4+12._ki*t6*t1**5*t4**4*t&
+ &3*t2**4+171._ki/4._ki*t6*t1**5*t4**2*t3*t2**6+110._ki/3._ki*t4*t5*t&
+ &3**3*t2**9*t1**2+720._ki*t1**5*t4**2*t3*t5**3*t2**4-690._ki*t1*t4&
+ &**5*t3**4*t5*t2**5+40._ki*t1*t4**8*t3**4*t5*t2**2-1155._ki/4._ki*t&
+ &1*t4**3*t5*t2**7*t3**4+1125._ki/2._ki*t1*t4**4*t5*t2**6*t3**4-4._k&
+ &i*t3**3*t2**9*t1**3
+ !
+ stemp10=stemp11-5._ki/2._ki*t6*t3**2*t5*t2**9*t1**3+73._ki/3._ki*t6*t&
+ &4**2*t3**3*t2**8*t1**2+160._ki*t1**5*t3**3*t5*t2**4-20._ki*t1**5*&
+ &t4**4*t5**4*t2**3-2._ki*t1**5*t4**4*t5*t2**6-25._ki*t1**5*t3**4*t&
+ &5*t2**2+35._ki*t1**5*t4**3*t5**5*t2**3-10._ki*t1**5*t4**4*t5**5*t&
+ &2**2+30._ki*t1**4*t3**2*t2**8*t5+125._ki*t1**4*t5**3*t2**6*t3**2+&
+ &7._ki/2._ki*t1**4*t3*t4*t2**10+150._ki*t1**4*t3**2*t2**7*t5**2-50.&
+ &_ki/3._ki*t1**3*t3**5*t2**5-18._ki*t4*t3**2*t2**9*t1**3*t5+32._ki/3&
+ &._ki*t6*t1**2*t4**8*t3**3*t2**2-39._ki/4._ki*t6**2*t3**2*t4*t2**7*&
+ &t1**3*t5+165._ki/4._ki*t6**2*t3*t4*t2**6*t1**4*t5**2+44._ki/3._ki*t&
+ &6**2*t1**5*t4**6*t5*t2**2-33._ki/4._ki*t6**2*t4**2*t3**3*t2**7*t1&
+ &**2-90._ki*t6*t5**2*t4*t2**7*t1**4*t3-120._ki*t6*t4*t5**3*t2**6*t&
+ &1**4*t3
+ !
+ stemp11=stemp10+15._ki*t6*t4*t5*t3*t2**8*t1**4-13._ki/3._ki*t6*t4*t3&
+ &**3*t2**9*t1**2-55._ki/24._ki*t6*t4*t2**9*t1**3*t3**2-120._ki*t6*t&
+ &3**2*t5**2*t2**6*t1**4-5._ki*t1**5*t5**5*t2**6+5._ki/2._ki*t6*t3**&
+ &4*t4*t2**9*t1+5._ki/4._ki*t6**2*t3**3*t4*t2**8*t1**2+3._ki/4._ki*t6&
+ &**2*t3**2*t5*t2**8*t1**3+275._ki*t4**2*t5**3*t2**6*t1**3*t3**2+5&
+ &00._ki/3._ki*t1**2*t4**6*t3**4*t5*t2**2+160._ki/3._ki*t1**2*t4**7*t&
+ &3**3*t5*t2**3-7._ki/2._ki*t6*t1**6*t4**3*t5*t2**4+t3**4*t2**11*t1&
+ &/2._ki+430._ki*t1**2*t4**3*t5*t3**3*t2**7+2125._ki/4._ki*t1**2*t4**&
+ &2*t3**4*t5*t2**6+1200._ki*t1**2*t4**4*t3**4*t5*t2**4+1075._ki/2._k&
+ &i*t1**2*t4**3*t5**2*t2**6*t3**3-1120._ki*t6*t1**3*t4**5*t3**3*t5&
+ &*t2**2+800._ki/3._ki*t6*t1**3*t4**6*t3**3*t5*t2-168._ki*t1**4*t3**&
+ &2*t5*t4*t2**7
+ !
+ stemp8=stemp11-t3**5*t2**11/6._ki+60._ki*t6**2*t1**7*t3*t5**2*t2-13&
+ &2._ki*t6**2*t1**3*t4**7*t3**2*t5*t2-15._ki/4._ki*t6**2*t5**2*t2**7&
+ &*t1**4*t3+375._ki/4._ki*t6*t1**5*t4**3*t5**2*t2**5+55._ki/2._ki*t6*&
+ &t4*t5*t3**2*t2**8*t1**3+55._ki*t6*t3**2*t4*t2**7*t1**3*t5**2-52.&
+ &_ki/3._ki*t6*t3**3*t4*t2**8*t1**2*t5-105._ki*t6*t1**5*t4*t5**4*t2*&
+ &*5-225._ki*t6*t1**5*t3*t5**2*t2**6-495._ki/2._ki*t6**2*t4*t5*t2**5&
+ &*t3**2*t1**4-300._ki*t6*t1**5*t5**3*t2**5*t3-60._ki*t6*t5*t3**2*t&
+ &2**7*t1**4-75._ki/2._ki*t6*t4*t2**7*t3**2*t1**4-210._ki*t6*t1**5*t&
+ &4*t5*t2**6*t3+285._ki*t6*t1**5*t4**2*t5**3*t2**5+320._ki/3._ki*t6*&
+ &t1**4*t4**6*t5**3*t3*t2+24._ki*t6**2*t1**3*t4**8*t3**2*t5+880._ki&
+ &*t6*t1**4*t4**4*t5**3*t3*t2**3-2640._ki*t6*t1**4*t4**2*t3**2*t5*&
+ &*2*t2**4-960._ki*t6*t1**5*t4**4*t3*t5**3*t2
+ !
+ stemp11=stemp8+80._ki*t6*t1**4*t4**6*t3*t5**2*t2**2-630._ki*t6*t1**&
+ &4*t4**3*t3*t5**2*t2**5-630._ki*t6*t1**4*t2**3*t3**3*t4**3+2640._k&
+ &i*t6*t1**4*t4**2*t3**3*t2**3*t5-2640._ki*t6*t1**4*t4**4*t3**2*t5&
+ &**2*t2**2+720._ki*t6*t1**4*t4**5*t3**2*t5**2*t2+60._ki*t6*t1**4*t&
+ &4**5*t3*t2**4*t5-110._ki*t6*t1**4*t4**4*t3*t2**5*t5+3780._ki*t6*t&
+ &1**4*t4**3*t3**2*t5**2*t2**3+6._ki*t6*t1**4*t4**5*t3*t2**5+19._ki&
+ &*t1**4*t4**2*t3*t2**8*t5+375._ki*t4*t3**3*t2**6*t1**3*t5**2-736.&
+ &_ki*t6*t1**2*t4**5*t3**3*t5*t2**4+600._ki*t6*t1**2*t4**4*t5*t2**5&
+ &*t3**3+242._ki*t6*t1*t4**5*t3**4*t2**5-275._ki/2._ki*t4*t5*t2**7*t&
+ &3**4*t1**2+1920._ki*t6*t1**3*t4**4*t3**3*t5*t2**3+385._ki*t6*t1**&
+ &2*t3**4*t4**3*t2**5+21._ki/2._ki*t6*t1**4*t4**3*t3*t2**7
+ !
+ stemp10=stemp11+220._ki*t6*t1**4*t4**4*t3**3*t2**2-4._ki/3._ki*t6*t1&
+ &**4*t4**6*t3*t2**4-180._ki*t6*t1**6*t4**2*t5**4*t2**2+1425._ki*t1&
+ &**4*t4**2*t3**2*t5**3*t2**4-240._ki*t6*t1**6*t3**2*t5**2*t2**2-1&
+ &20._ki*t6*t1**6*t2**3*t3**2*t5-25._ki/2._ki*t6*t1**6*t2**3*t4*t3**&
+ &2-9._ki/2._ki*t6*t1**6*t4**2*t3*t2**4+45._ki*t6*t1**6*t4**2*t5**2*&
+ &t2**4+15._ki/2._ki*t6*t1**6*t4*t3*t2**5+1890._ki*t6*t1**4*t4**3*t3&
+ &**2*t5*t2**4-1320._ki*t6*t1**4*t4**4*t3**2*t5*t2**3+360._ki*t6*t1&
+ &**4*t4**5*t3**2*t5*t2**2+3._ki/8._ki*t6*t1**5*t2**10-90._ki*t4*t3*&
+ &*2*t5**2*t2**8*t1**3+175._ki/2._ki*t1**4*t4*t5**4*t3*t2**6+140._ki&
+ &*t1**4*t4*t5**3*t3*t2**7+42._ki*t1**4*t3*t5**2*t4*t2**8-7._ki*t1*&
+ &*4*t2**9*t4*t5*t3+3630._ki*t6**2*t1**5*t4**2*t3*t5**2*t2**3-5445&
+ &._ki*t6**2*t1**5*t4**2*t3**2*t5*t2**2
+ !
+ stemp11=stemp10+3825._ki/4._ki*t6**2*t1**4*t4**2*t3**2*t5*t2**4+105&
+ &._ki*t6*t1**4*t4**3*t3*t2**6*t5+300._ki*t4*t3**3*t2**7*t1**3*t5+8&
+ &0._ki*t1**3*t4**6*t3**2*t5**2*t2**3-146._ki*t6*t1**2*t4**2*t3**4*&
+ &t2**6-600._ki*t6*t1**2*t2**4*t4**4*t3**4-77._ki*t6*t1**2*t4**3*t3&
+ &**3*t2**7+150._ki*t6*t1**2*t4**4*t3**3*t2**6-176._ki/3._ki*t6*t1**&
+ &2*t4**7*t3**3*t2**3-704._ki/3._ki*t6*t1**2*t4**7*t3**3*t5*t2**2+1&
+ &28._ki/3._ki*t6*t1**2*t4**8*t3**3*t5*t2-64._ki*t6*t1*t2**2*t3**4*t&
+ &4**8-308._ki*t6*t1**2*t4**3*t5*t2**6*t3**3-33._ki/2._ki*t6*t4**2*t&
+ &3**4*t2**8*t1+645._ki*t6*t1**3*t4**3*t5**2*t2**5*t3**2+10395._ki/&
+ &2._ki*t6**2*t1**5*t4**3*t3**2*t5*t2+425._ki/2._ki*t6*t1**3*t4**2*t&
+ &3**3*t2**6-425._ki*t6*t1**3*t4**2*t3**4*t2**4-35._ki*t6*t1**3*t4*&
+ &*5*t3**2*t2**5+40._ki*t6*t1**3*t4**4*t3**2*t2**6
+ !
+ stemp9=stemp11-215._ki/8._ki*t6*t1**3*t4**3*t3**2*t2**7+630._ki*t6**&
+ &2*t1**4*t4**5*t3*t5**2*t2**2-300._ki*t6**2*t1**4*t4**6*t3*t5**2*&
+ &t2+675._ki/2._ki*t6**2*t1**3*t4**4*t5*t2**4*t3**2+312._ki*t6**2*t1&
+ &**3*t4**6*t3**2*t5*t2**2-693._ki/4._ki*t6**2*t1**3*t4**3*t5*t2**5&
+ &*t3**2+414._ki*t6**2*t1**3*t4**5*t3**3*t2**2+84._ki*t6**2*t1**2*t&
+ &4**7*t3**3*t2**2-76._ki*t6**2*t1**2*t4**4*t3**3*t2**5-380._ki/3._k&
+ &i*t6**2*t1**2*t4**6*t3**3*t2**3-25._ki/2._ki*t1**4*t3**5*t2**3+4.&
+ &_ki*t1**5*t3*t2**9+40._ki*t6*t1**6*t3**3*t5*t2+9._ki*t6*t1**6*t4**&
+ &2*t5*t2**5-180._ki*t6*t1**6*t4**2*t5**3*t2**3+70._ki*t6*t1**6*t4*&
+ &*3*t5**4*t2-35._ki/2._ki*t6*t1**6*t4**3*t5**2*t2**3+330._ki*t4**2*&
+ &t3**2*t2**7*t1**3*t5**2+275._ki/6._ki*t3**3*t4*t2**8*t1**2*t5**2-&
+ &65._ki/4._ki*t3**4*t4*t2**9*t1*t5-375._ki*t1**5*t4*t5**4*t2**4*t3
+ !
+ stemp11=stemp9+30._ki*t1**5*t4*t3*t2**7*t5+625._ki*t1**4*t4**3*t3**&
+ &3*t5**2*t2**2-200._ki*t1**4*t4**4*t5**4*t3*t2**3-960._ki*t6*t1**3&
+ &*t4**4*t3**2*t5**2*t2**4+400._ki*t1**4*t4**4*t3**2*t5**3*t2**2+3&
+ &42._ki*t1**4*t4**2*t5*t2**6*t3**2+480._ki*t1**4*t4**4*t3**2*t5**2&
+ &*t2**3+1664._ki/3._ki*t6*t1**2*t4**6*t3**3*t5*t2**3+3._ki/2._ki*t1*&
+ &*3*t3**2*t4*t2**10-8._ki*t1**4*t4**4*t3**2*t2**5-57._ki/2._ki*t1**&
+ &4*t4**2*t3**2*t2**7+84._ki*t1**4*t4*t3**3*t2**6+7._ki*t1**5*t4**3&
+ &*t5*t2**7+414._ki*t1*t2**4*t3**5*t4**5-450._ki*t1*t2**5*t3**5*t4*&
+ &*4-88._ki*t1*t4**7*t3**4*t2**4+225._ki*t1*t4**4*t3**4*t2**7-276._k&
+ &i*t1*t4**5*t3**4*t2**6-231._ki/2._ki*t1*t4**3*t3**4*t2**8
+ !
+ stemp10=stemp11-208._ki*t1*t2**3*t3**5*t4**6-8._ki*t1**4*t4**4*t3*t&
+ &2**7+25._ki/2._ki*t1**4*t4**3*t3*t2**8+35._ki/2._ki*t1**4*t3**5*t2*&
+ &*2*t4+2._ki*t1**4*t4**5*t3*t2**6+25._ki*t1**4*t4**3*t3**2*t2**6-1&
+ &1._ki*t1**3*t4**4*t3**2*t2**7-150._ki*t1**3*t4*t3**4*t2**6+75._ki*&
+ &t1**3*t3**5*t2**4*t4+5._ki/4._ki*t3**4*t5*t2**10*t1-25._ki/6._ki*t3&
+ &**3*t5**2*t2**9*t1**2+t1**5*t5**2*t2**9-220._ki*t6*t4*t5*t2**6*t&
+ &3**3*t1**3+51._ki/4._ki*t6**2*t4**2*t3*t2**7*t1**4-10._ki*t1**5*t2&
+ &**3*t3**4-2._ki*t2**9*t3**5*t1-t1**5*t2**10*t5-20._ki*t1**4*t3**3&
+ &*t2**7+32._ki/3._ki*t2**2*t3**5*t4**9+6._ki*t1**5*t3**2*t2**7-152.&
+ &_ki*t4**4*t3**5*t2**7
+ !
+ stemp11=stemp10-10._ki*t1**5*t5**4*t2**7+25._ki*t3**4*t2**7*t1**3+1&
+ &68._ki*t2**4*t3**5*t4**7-35._ki/4._ki*t3**5*t2**7*t1**2-t1**3*t3**&
+ &2*t2**11/6._ki-5._ki/2._ki*t1**4*t3**2*t2**9-4._ki*t1**5*t5**3*t2**&
+ &8+50._ki*t1**4*t3**4*t2**5+35._ki/6._ki*t3**4*t2**9*t1**2+16._ki*t1&
+ &**5*t3**3*t2**5-64._ki*t2**3*t3**5*t4**8-t2**11*t1**2*t3**3/3._ki&
+ &-760._ki/3._ki*t2**5*t3**5*t4**6+5._ki/2._ki*t3**5*t4*t2**10-t1**4*&
+ &t3*t2**11/2._ki+242._ki*t4**5*t3**5*t2**6-33._ki/2._ki*t4**2*t3**5*&
+ &t2**9-152._ki*t6*t1*t4**4*t3**4*t2**6-760._ki/3._ki*t6*t1*t2**4*t3&
+ &**4*t4**6+377._ki/6._ki*t6*t1*t4**3*t3**4*t2**7
+ !
+ stemp7=stemp11+121._ki/2._ki*t6**2*t4**2*t2**6*t1**5*t5-605._ki/2._ki&
+ &*t6**2*t4**2*t5**3*t2**4*t1**5+165._ki/2._ki*t6**2*t4*t2**6*t3*t1&
+ &**5-765._ki/4._ki*t6**2*t4**2*t5**2*t2**5*t1**4*t3+219._ki/4._ki*t6&
+ &**2*t4**2*t5*t2**6*t1**3*t3**2-605._ki*t6**2*t1**5*t4**4*t5**3*t&
+ &2**2-400._ki*t6*t1**3*t4**6*t3**2*t5**2*t2**2+80._ki*t6*t1**3*t4*&
+ &*7*t3**2*t5**2*t2+825._ki/4._ki*t6**2*t1**4*t3**3*t2**4*t4+20._ki*&
+ &t6**2*t1**4*t4**6*t3*t2**3+48._ki*t6**2*t1**4*t4**4*t3*t2**5+60.&
+ &_ki*t6**2*t1**4*t4**7*t3*t5**2-720._ki*t6**2*t1**4*t4**4*t3**3*t2&
+ &-219._ki/2._ki*t6**2*t1**3*t4**2*t3**3*t2**5-208._ki*t6**2*t1**3*t&
+ &4**6*t3**3*t2+1155._ki/4._ki*t6**2*t1**3*t3**3*t4**3*t2**4-1935._k&
+ &i*t6**2*t1**4*t4**3*t5*t3**2*t2**3+1935._ki/4._ki*t6**2*t1**4*t4*&
+ &*3*t5**2*t2**4*t3-720._ki*t6**2*t1**4*t4**4*t5**2*t2**3*t3+275._k&
+ &i*t1**3*t4**4*t3**4*t2**2*t5-1100._ki*t1**3*t4**4*t3**3*t5**2*t2&
+ &**3+300._ki*t1**3*t4**5*t3**3*t5**2*t2**2
+ !
+ stemp11=stemp7-525._ki*t1**3*t4**3*t3**2*t5**3*t2**5+440._ki*t6*t4*&
+ &*2*t5**3*t2**5*t1**4*t3-255._ki/2._ki*t6*t4**2*t5*t3**2*t2**7*t1*&
+ &*3-1100._ki*t1**3*t4**2*t3**3*t5**2*t2**5+377._ki/6._ki*t4**3*t3**&
+ &5*t2**8-630._ki*t1**3*t4**3*t3**2*t5**2*t2**6+1260._ki*t1**3*t4**&
+ &3*t3**3*t2**5*t5-880._ki*t1**3*t4**2*t3**3*t2**6*t5+660._ki*t1**3&
+ &*t4**4*t3**2*t5**2*t2**5-360._ki*t1**3*t4**5*t3**2*t5**2*t2**4-1&
+ &26._ki*t1**3*t3**2*t4**3*t5*t2**7+16._ki*t1**3*t3**2*t4**6*t5*t2*&
+ &*4-1260._ki*t6**2*t1**4*t4**5*t3**2*t5*t2-42._ki*t6**2*t1**4*t4**&
+ &5*t3*t2**4-66._ki*t6**2*t1**5*t4**5*t5*t2**3+66._ki*t6**2*t1**5*t&
+ &4**5*t3*t2**2+300._ki*t6**2*t1**4*t4**6*t3**2*t5-129._ki/4._ki*t6*&
+ &*2*t1**4*t4**3*t3*t2**6+1935._ki/2._ki*t6**2*t1**4*t4**3*t3**3*t2&
+ &**2
+ !
+ stemp10=stemp11-5._ki*t6*t3**2*t5**2*t2**8*t1**3+4._ki/3._ki*t6*t3**&
+ &3*t5*t2**9*t1**2+40._ki/3._ki*t6*t3*t5**3*t2**7*t1**4+10._ki*t6*t3&
+ &*t2**8*t1**4*t5**2-10395._ki/2._ki*t6**2*t1**5*t4**3*t3*t5**2*t2*&
+ &*2+3630._ki*t6**2*t1**5*t4**4*t3*t5**2*t2-105._ki*t6**2*t1**6*t2*&
+ &*4*t3*t4-40._ki*t6**2*t1**6*t4**4*t5*t2**2+1575._ki*t6**2*t1**6*t&
+ &4*t3*t5**2*t2**2+1425._ki/2._ki*t6**2*t1**6*t4**2*t5**3*t2**2-625&
+ &._ki*t6**2*t1**6*t4**3*t5**3*t2-125._ki/2._ki*t6**2*t1**6*t2**2*t3&
+ &*t4**3+121._ki*t6**2*t1**5*t4**4*t5*t2**4+330._ki*t6**2*t1**5*t4*&
+ &*5*t5**3*t2-75._ki*t6**2*t1**7*t4*t3*t5**2-800._ki/3._ki*t1**2*t4*&
+ &*6*t3**3*t5*t2**4-700._ki*t1**2*t4**5*t3**4*t5*t2**3-640._ki*t1**&
+ &2*t4**4*t3**3*t5*t2**6-1075._ki*t1**2*t4**3*t3**4*t5*t2**5-1000.&
+ &_ki/3._ki*t1**2*t4**6*t3**3*t5**2*t2**3
+ !
+ stemp11=stemp10+365._ki/4._ki*t4**2*t5*t2**8*t1*t3**4-170._ki*t4**2*&
+ &t5*t3**3*t2**8*t1**2-1425._ki*t1**4*t4**2*t3**3*t2**3*t5**2+16._k&
+ &i*t1**4*t4**4*t3*t2**6*t5-350._ki*t1**4*t3**4*t5*t2**3*t4+1050._k&
+ &i*t1**4*t4*t3**3*t2**4*t5**2-25._ki*t1**4*t4**3*t3*t2**7*t5-4._ki&
+ &*t1**4*t4**5*t3*t2**5*t5+500._ki*t1**4*t4**3*t3**3*t5*t2**3-1575&
+ &._ki/2._ki*t1**3*t4**3*t3**4*t2**3*t5-375._ki*t1**3*t4*t3**4*t2**5&
+ &*t5-72._ki*t1**3*t3**2*t4**5*t5*t2**5+1575._ki*t1**3*t4**3*t3**3*&
+ &t5**2*t2**4-540._ki*t1**5*t4**2*t3**2*t5**2*t2**3-2475._ki/2._ki*t&
+ &6**2*t4*t3*t2**4*t1**5*t5**2-832._ki/3._ki*t6*t1**2*t4**6*t3**4*t&
+ &2**2-2565._ki*t6*t1**5*t4**2*t3*t5**2*t2**4+475._ki/2._ki*t1**4*t4&
+ &**2*t3**4*t5*t2**2+1710._ki*t1**4*t4**2*t3**2*t5**2*t2**5+500._ki&
+ &*t1**4*t4**3*t5**3*t3*t2**5
+ !
+ stemp9=stemp11-320._ki*t1**4*t4**4*t5**3*t3*t2**4+150._ki*t1**4*t4*&
+ &*3*t3*t2**6*t5**2+24._ki*t1**4*t4**5*t3*t2**4*t5**2+420._ki*t6*t1&
+ &**3*t4**5*t3**2*t5*t2**4+840._ki*t1**4*t4*t3**3*t5*t2**5+75._ki/4&
+ &._ki*t6*t1**5*t4**3*t5*t2**6+14._ki*t1**5*t4**3*t5*t3*t2**5-36._ki&
+ &*t1**5*t4**2*t5*t3*t2**6+840._ki*t6*t1**3*t4**5*t3**2*t5**2*t2**&
+ &3+645._ki/2._ki*t6*t1**3*t4**3*t5*t3**2*t2**6-75._ki/2._ki*t6*t1**5&
+ &*t4**3*t3*t2**5-375._ki*t6*t1**5*t4**3*t5**4*t2**3-60._ki*t6*t1**&
+ &5*t4**5*t5**4*t2+2475._ki*t6**2*t1**5*t3**2*t2**3*t4*t5+693._ki/2&
+ &._ki*t6**2*t1**5*t4**3*t3*t2**4-1815._ki*t6**2*t1**5*t4**4*t3**2*&
+ &t5-242._ki*t6**2*t1**5*t4**2*t3*t2**5+1210._ki*t6**2*t1**5*t3**3*&
+ &t4**2*t2-800._ki*t1**2*t4**4*t3**3*t5**2*t2**5-1200._ki*t6*t1**4*&
+ &t4*t3**3*t5*t2**4+208._ki*t1*t4**6*t3**4*t2**5
+ !
+ stemp11=stemp9+216._ki*t1**5*t4**2*t5**2*t2**5*t3+180._ki*t1**5*t4*&
+ &t5*t2**5*t3**2+450._ki*t1**5*t4**2*t5**4*t3*t2**3-280._ki*t1**5*t&
+ &4**3*t3*t5**3*t2**3-300._ki*t1**3*t4**5*t3**2*t5**3*t2**3+200._ki&
+ &/3._ki*t1**3*t4**6*t3**2*t5**3*t2**2+550._ki*t1**3*t4**4*t3**2*t5&
+ &**3*t2**4+176._ki/3._ki*t6*t1**2*t4**7*t3**4*t2+520._ki*t1*t4**6*t&
+ &3**4*t5*t2**4+44._ki*t1*t2**2*t3**5*t4**7-219._ki/2._ki*t1*t2**7*t&
+ &3**5*t4**2+16._ki*t1*t4**8*t3**4*t2**3-7._ki*t1**5*t4**3*t3*t2**6&
+ &-20._ki*t1**5*t3**3*t2**4*t4-55._ki*t4*t3**4*t2**8*t1**2+28._ki*t1&
+ &**5*t4**3*t5**3*t2**5-140._ki*t1**4*t4*t3**4*t2**4+125._ki*t1**4*&
+ &t3**4*t5*t2**4+9._ki*t1**5*t4**2*t3**2*t2**5
+ !
+ stemp10=stemp11-114._ki*t1**4*t4**2*t3**3*t2**5+50._ki*t1**4*t3**3*&
+ &t4**3*t2**4+2._ki*t1**5*t4**4*t5**2*t2**5-110._ki*t1**3*t3**5*t2*&
+ &*3*t4**2-10._ki/3._ki*t3**3*t5*t2**10*t1**2+25._ki/3._ki*t3**2*t5**&
+ &3*t2**8*t1**3-315._ki*t1**3*t4**3*t3**4*t2**4-4._ki/3._ki*t1**3*t4&
+ &**6*t3**2*t2**5+110._ki*t1**3*t4**4*t3**4*t2**3-88._ki*t1**3*t4**&
+ &2*t3**3*t2**7+105._ki/2._ki*t1**3*t3**5*t2**2*t4**3+21._ki/2._ki*t1&
+ &**3*t4**3*t3**2*t2**8+6._ki*t1**3*t4**5*t3**2*t2**6+330._ki*t1**3&
+ &*t4**2*t3**4*t2**5+126._ki*t1**3*t4**3*t3**3*t2**6-88._ki*t1**3*t&
+ &4**4*t3**3*t2**5+24._ki*t1**3*t4**5*t3**3*t2**4+11._ki/6._ki*t6**2&
+ &*t2**8*t1**5*t5-55._ki/6._ki*t6**2*t5**3*t2**6*t1**5-25._ki/2._ki*t&
+ &6**2*t1**6*t5*t2**6-8._ki/3._ki*t6*t2**8*t1**2*t3**4
+ !
+ stemp11=stemp10+5._ki*t6*t2**8*t3**2*t1**4+10._ki*t6*t1**6*t5**2*t2&
+ &**6+2._ki*t6*t1**6*t5*t2**7-40._ki*t6*t1**6*t5**4*t2**4-40._ki*t6*&
+ &t1**6*t5**3*t2**5-21._ki/8._ki*t6*t1**5*t4*t2**9+15._ki/4._ki*t6*t2&
+ &**8*t3*t1**5+35._ki/6._ki*t6*t3**3*t2**8*t1**3-30._ki*t6**2*t1**7*&
+ &t5**3*t2**2+6._ki*t6**2*t1**7*t5*t2**4+25._ki*t6**2*t1**6*t3*t2**&
+ &5-105._ki/4._ki*t6**2*t3**3*t2**5*t1**4-3._ki*t6*t1**6*t3*t2**6+15&
+ &._ki/4._ki*t6*t1**6*t4*t2**7-2._ki*t6**2*t2**7*t3**3*t1**3-t6**2*t&
+ &3**3*t2**9*t1**2/12._ki-11._ki*t6**2*t2**7*t3*t1**5+125._ki/2._ki*t&
+ &6**2*t1**6*t5**3*t2**4-50._ki*t3**3*t5**2*t2**7*t1**3+11._ki/3._ki&
+ &*t4*t2**10*t1**2*t3**3
+ !
+ stemp8=stemp11-8._ki*t1**5*t4**4*t5**3*t2**4+30._ki*t4*t2**8*t3**3*&
+ &t1**3-13._ki/2._ki*t4*t3**4*t2**10*t1-25._ki/2._ki*t1**4*t5**4*t2**&
+ &7*t3-6._ki*t1**4*t3*t2**9*t5**2-20._ki*t1**4*t5**3*t3*t2**8+95._ki&
+ &*t1**4*t4**2*t3**4*t2**3-9._ki/2._ki*t6*t1**6*t4**2*t2**6-200._ki/&
+ &3._ki*t6*t1**4*t3**4*t2**4+10._ki*t6*t1**6*t3**2*t2**4-4._ki*t6**2&
+ &*t1**7*t3*t2**3-45._ki*t6**2*t1**7*t4**2*t5**3+175._ki/2._ki*t6**2&
+ &*t1**6*t3**3*t4-1155._ki/2._ki*t6**2*t1**5*t4**3*t3**3-125._ki/2._k&
+ &i*t6**2*t1**6*t3**3*t2+550._ki/3._ki*t6**2*t1**5*t2**3*t3**3-220.&
+ &_ki/3._ki*t6**2*t1**5*t4**6*t5**3+210._ki*t6**2*t1**4*t4**5*t3**3+&
+ &44._ki*t6**2*t1**3*t4**7*t3**3+16._ki/3._ki*t6**2*t1**2*t4**9*t3**&
+ &3+132._ki*t1**3*t3**2*t4**4*t5*t2**6-600._ki*t6*t1**5*t3**3*t5*t2&
+ &**3
+ !
+ stemp11=stemp8+375._ki/4._ki*t6*t1**5*t4**3*t3**2*t2**3+40._ki*t6*t1&
+ &**3*t4**7*t3**2*t5*t2**2-480._ki*t6*t1**3*t4**4*t3**2*t5*t2**5-2&
+ &00._ki*t6*t1**3*t4**6*t3**2*t5*t2**3-430._ki*t6*t1**3*t4**3*t3**3&
+ &*t2**5-11._ki*t6*t1**4*t4**4*t3*t2**6+210._ki*t6*t1**4*t4**3*t3**&
+ &4*t2+50._ki/3._ki*t6*t1**3*t4**6*t3**2*t2**4+200._ki/3._ki*t6*t1**3&
+ &*t4**6*t3**3*t2**2-40._ki/3._ki*t6*t1**4*t4**6*t3*t2**3*t5-480._ki&
+ &*t6*t1**4*t4**5*t5**3*t3*t2**2+880._ki*t6*t1**4*t4**4*t3**3*t5*t&
+ &2-480._ki*t6*t1**3*t4**4*t3**4*t2**2+416._ki/3._ki*t6*t1**2*t4**6*&
+ &t3**3*t2**4+377._ki/12._ki*t6**2*t1**2*t4**3*t3**3*t2**6+66._ki*t4&
+ &**2*t3**2*t2**8*t1**3*t5+96._ki*t1**4*t4**4*t5*t2**4*t3**2-300._k&
+ &i*t1**4*t4**3*t5*t2**5*t3**2+270._ki*t6*t1**6*t4**2*t3*t5**2*t2*&
+ &*2
+ !
+ stemp10=stemp11+75._ki*t6*t1**6*t4*t5*t2**4*t3+5130._ki*t6*t1**5*t4&
+ &**2*t3**2*t5**2*t2**2-2250._ki*t6*t1**5*t4**3*t3**2*t5**2*t2+225&
+ &0._ki*t6*t1**5*t4**3*t3*t5**2*t2**3-720._ki*t6*t1**5*t4**4*t3*t5*&
+ &*2*t2**2-375._ki*t6*t1**5*t4**3*t5**3*t2**4+21._ki/4._ki*t6*t1**5*&
+ &t4*t2**8*t5+3._ki/2._ki*t6*t1**4*t4*t3*t2**9-60._ki*t6*t1**5*t4**4&
+ &*t5**2*t2**4+292._ki/3._ki*t6*t4**2*t5*t2**7*t1**2*t3**3+552._ki*t&
+ &6*t1**2*t4**5*t3**4*t2**3+660._ki*t6*t1**4*t4**4*t3*t5**2*t2**4-&
+ &15._ki*t6**2*t1**7*t4*t5*t2**3+75._ki*t6**2*t1**7*t4*t5**3*t2-427&
+ &5._ki/2._ki*t6**2*t1**6*t4**2*t3*t5**2*t2-990._ki*t6**2*t1**5*t4**&
+ &5*t3*t5**2-825._ki*t6**2*t1**5*t3**3*t2**2*t4-242._ki*t6**2*t1**5&
+ &*t4**4*t3*t2**3-231._ki/2._ki*t6**2*t1**5*t4**3*t5*t2**5+450._ki*t&
+ &6*t4*t3**2*t2**6*t1**4*t5-255._ki*t6*t4**2*t5**2*t2**6*t1**3*t3*&
+ &*2
+ !
+ stemp11=stemp10-700._ki*t1**4*t4*t5**3*t2**5*t3**2-380._ki*t1**4*t4&
+ &**2*t3*t5**3*t2**6-114._ki*t1**4*t4**2*t5**2*t2**7*t3-475._ki/2._k&
+ &i*t1**4*t4**2*t3*t5**4*t2**5-175._ki*t1**5*t4**3*t3*t5**4*t2**2+&
+ &900._ki*t1**5*t4*t3**2*t5**2*t2**4-1140._ki*t1**4*t4**2*t3**3*t5*&
+ &t2**4+1155._ki/2._ki*t6**2*t1**5*t4**3*t5**3*t2**3+165._ki/2._ki*t6&
+ &**2*t4*t5**3*t2**5*t1**5-11._ki/4._ki*t6**2*t4*t2**8*t1**4*t3+850&
+ &._ki*t6*t1**3*t4**2*t3**3*t5*t2**5-220._ki*t1*t4**7*t3**4*t5*t2**&
+ &3+200._ki/3._ki*t1**2*t4**7*t3**3*t5**2*t2**2+560._ki*t1**2*t4**5*&
+ &t3**3*t5*t2**5+700._ki*t1**2*t4**5*t3**3*t5**2*t2**4-75._ki*t4*t5&
+ &**3*t2**7*t1**3*t3**2-425._ki/2._ki*t4**2*t5**2*t2**7*t1**2*t3**3&
+ &+375._ki*t6**2*t1**6*t3**2*t5*t2**2-108._ki*t1**5*t4**2*t3**2*t5*&
+ &t2**4-450._ki*t6**2*t1**3*t4**4*t3**3*t2**3
+ !
+ stemp9=stemp11-84._ki*t1**5*t4**3*t5**2*t2**4*t3-250._ki*t1**5*t4*t&
+ &3**3*t5**2*t2**2-450._ki*t1**5*t4**2*t5**3*t3**2*t2**2-200._ki*t1&
+ &**5*t4*t5*t3**3*t2**3+750._ki*t1**5*t4*t5**3*t3**2*t2**3+825._ki*&
+ &t1**3*t4**2*t3**4*t2**4*t5-1275._ki/2._ki*t6**2*t1**4*t4**2*t3**3&
+ &*t2**3-t6*t1**6*t2**8-880._ki*t1**3*t4**4*t3**3*t2**4*t5+240._ki*&
+ &t1**3*t4**5*t3**3*t2**3*t5+70._ki/3._ki*t6*t2**7*t3**3*t1**3*t5-1&
+ &1._ki/2._ki*t6*t1**4*t4**2*t3*t2**8+91._ki/3._ki*t6*t4*t3**4*t2**7*&
+ &t1**2+1680._ki*t6*t1**5*t4*t5**3*t2**4*t3+85._ki/8._ki*t6*t4**2*t3&
+ &**2*t2**8*t1**3+1260._ki*t6*t1**5*t4*t3*t5**2*t2**5-57._ki/4._ki*t&
+ &6*t1**5*t4**2*t5*t2**7-21._ki*t6*t1**5*t4*t3*t2**7+450._ki*t6*t1*&
+ &*5*t2**5*t3**2*t5-285._ki/4._ki*t6*t1**5*t4**2*t5**2*t2**6-5._ki/3&
+ &._ki*t6*t2**9*t1**4*t3*t5
+ !
+ stemp11=stemp9-184._ki*t6*t1**2*t4**5*t3**3*t2**5-1250._ki*t1**4*t4&
+ &**3*t3**2*t5**3*t2**3+80._ki*t1**4*t4**5*t5**3*t3*t2**3+50._ki*t1&
+ &**4*t4**5*t5**4*t3*t2**2+625._ki/2._ki*t1**4*t4**3*t5**4*t3*t2**4&
+ &-1500._ki*t1**4*t4**3*t3**2*t5**2*t2**4-96._ki*t1**4*t4**4*t3*t2*&
+ &*5*t5**2+10._ki*t6*t1**6*t3**3*t2**2-3._ki/2._ki*t6*t1**5*t4**5*t2&
+ &**5+6._ki*t6*t1**5*t4**4*t2**6-75._ki/8._ki*t6*t1**5*t4**3*t2**7+7&
+ &5._ki*t6*t1**5*t3**4*t2**2-150._ki*t6*t1**5*t3**3*t2**4+7._ki/4._ki&
+ &*t6*t1**6*t4**3*t2**5-15._ki*t6**2*t1**7*t3**2*t5+200._ki*t6**2*t&
+ &1**6*t4**4*t5**3-t6*t3**4*t2**10*t1/6._ki+57._ki/8._ki*t6*t1**5*t4&
+ &**2*t2**8-75._ki/2._ki*t6*t1**5*t3**2*t2**6
+ !
+ stemp10=stemp11-35._ki/2._ki*t6*t3**4*t2**6*t1**3+50._ki*t6*t3**3*t2&
+ &**6*t1**4-15._ki/4._ki*t6*t1**5*t5**2*t2**8+15._ki*t6*t1**5*t5**4*&
+ &t2**6+15._ki*t6*t1**5*t5**3*t2**7-3._ki/4._ki*t6*t1**5*t2**9*t5-t6&
+ &*t1**4*t3*t2**10/6._ki+5._ki/24._ki*t6*t2**10*t1**3*t3**2+t6*t3**3&
+ &*t2**10*t1**2/3._ki+t6**2*t2**9*t1**4*t3/4._ki-300._ki*t1**5*t3**2&
+ &*t5**3*t2**4-15._ki*t1**5*t4*t3*t2**8-90._ki*t1**5*t4**2*t5**4*t2&
+ &**5-72._ki*t1**5*t5*t3**2*t2**6-36._ki*t1**5*t4**2*t5**3*t2**6-25&
+ &0._ki*t1**4*t3**3*t5**2*t2**5+2._ki*t2**10*t1**3*t3**2*t5+10._ki*t&
+ &5**2*t3**2*t2**9*t1**3-17._ki*t4**2*t3**3*t2**9*t1**2-200._ki*t1*&
+ &*4*t3**3*t5*t2**6+14._ki*t1**4*t4*t3**2*t2**8
+ !
+ stemp11=stemp10-19._ki/2._ki*t1**4*t4**2*t3*t2**9-11._ki/2._ki*t1**3*&
+ &t4**2*t3**2*t2**9-40._ki*t5*t3**3*t2**8*t1**3+50._ki*t1**5*t4*t5*&
+ &*4*t2**6+5._ki*t1**5*t4*t2**9*t5+20._ki*t1**5*t4*t5**3*t2**7-5._ki&
+ &*t1**5*t2**8*t4*t5**2+25._ki*t1**5*t4*t5**5*t2**5+48._ki*t1**5*t3&
+ &*t5**2*t2**7+160._ki*t1**5*t3*t5**3*t2**6+100._ki*t1**5*t5**4*t2*&
+ &*5*t3-8._ki*t1**5*t5*t3*t2**8+175._ki/12._ki*t2**8*t3**4*t1**2*t5+&
+ &91._ki/4._ki*t4*t3**5*t2**8*t1+125._ki/2._ki*t5*t2**6*t3**4*t1**3-4&
+ &5._ki*t1**5*t4**2*t5**5*t2**4-9._ki*t1**5*t4**2*t2**8*t5-360._ki*t&
+ &1**5*t3**2*t2**5*t5**2+9._ki*t1**5*t4**2*t5**2*t2**7+t1**4*t3*t2&
+ &**10*t5
+ !
+ stemp6=stemp11+645._ki*t6*t1**3*t4**3*t3**4*t2**3+140._ki*t6*t1**3*&
+ &t4**5*t3**4*t2+275._ki/2._ki*t6*t1**3*t3**4*t4*t2**5-10._ki/3._ki*t&
+ &6*t1**3*t4**7*t3**2*t2**3-280._ki*t6*t1**3*t4**5*t3**3*t2**3+480&
+ &._ki*t6*t1**3*t4**4*t3**3*t2**4+168._ki*t6*t1*t2**3*t3**4*t4**7+3&
+ &2._ki/3._ki*t6*t1*t2*t3**4*t4**9-2520._ki*t6*t1**4*t4**3*t3**3*t2*&
+ &*2*t5-1320._ki*t6*t1**4*t4**2*t3**2*t5*t2**5-360._ki*t6*t1**4*t4*&
+ &*5*t3*t5**2*t2**3+360._ki*t6*t1**6*t4**2*t5**3*t2*t3-45._ki*t6*t1&
+ &**6*t4**2*t5*t2**3*t3-105._ki*t6*t1**5*t4*t5**3*t2**6+105._ki/4._k&
+ &i*t6*t1**5*t4*t5**2*t2**7+75._ki/2._ki*t6*t1**5*t5*t2**7*t3+105._k&
+ &i/4._ki*t6**2*t2**6*t3**2*t1**4*t5-375._ki*t6**2*t1**6*t3*t5**2*t&
+ &2**3-350._ki*t6**2*t1**6*t4*t5**3*t2**3+70._ki*t6**2*t1**6*t4*t5*&
+ &t2**5-825._ki/2._ki*t6**2*t5*t2**4*t3**2*t1**5+91._ki/4._ki*t6**2*t&
+ &4*t3**3*t2**6*t1**3
+ !
+ stemp7=t6/t1**5/t2**12
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp5=-t4*t2**8*t5/6._ki+t4**2*t5*t2**7/12._ki+25._ki/4._ki*t6**3*t4&
+ &**2*t2**5+t4*t3*t2**7/6._ki-13._ki/2._ki*t6**2*t4**2*t2**6-95._ki/3&
+ &._ki*t6**3*t3**2*t4**3+7._ki/12._ki*t6**2*t5*t2**7-2._ki*t6**3*t4*t&
+ &2**6-t6*t4**3*t2**6/2._ki-2._ki/3._ki*t6**3*t5*t2**6+25._ki/3._ki*t6&
+ &**3*t2**3*t3**2+10._ki/3._ki*t6**3*t2**5*t3+6._ki*t6**2*t4**3*t2**&
+ &5-24._ki*t6**3*t1*t4**3*t5*t2-26._ki*t6**3*t1*t2*t3*t4**2+8._ki*t6&
+ &**3*t1**2*t5*t2*t4-35._ki/6._ki*t6**2*t1*t4**2*t5*t2**3+28._ki/3._k&
+ &i*t6**2*t1*t4*t5*t2**4+65._ki*t6**2*t4**2*t5**2*t3*t2**2-30._ki*t&
+ &6**2*t4**3*t5**2*t3*t2+7._ki/12._ki*t6**2*t1**2*t5*t2**3-5._ki/6._k&
+ &i*t6**2*t1**2*t2*t5**3+7._ki/2._ki*t6**2*t1*t2**4*t3-5._ki*t6**2*t&
+ &2*t3**3*t4-15._ki*t6**2*t2**3*t3**2*t5-10._ki*t6**3*t1*t3**2*t2+1&
+ &5._ki*t6**3*t3**2*t1*t4+125._ki/2._ki*t6**3*t3**2*t2*t4**2-40._ki*t&
+ &6**3*t2**2*t3**2*t4
+ !
+ stemp4=stemp5-39._ki/2._ki*t6**3*t1*t4**2*t2**3+27._ki/2._ki*t6**3*t1&
+ &*t4*t2**4+30._ki*t6**3*t1*t4**3*t5**2-12._ki*t6**3*t1*t2**3*t3+7.&
+ &_ki*t6**2*t4**3*t3*t2**3+21._ki/2._ki*t6**2*t4*t3*t2**5+8._ki*t6**3&
+ &*t1*t5*t2**4-10._ki*t6**3*t1*t5**2*t2**3-7._ki/2._ki*t6**2*t2**6*t&
+ &4*t5+5._ki*t6**2*t4*t5**3*t2**4-7._ki/2._ki*t6**2*t1*t5*t2**5+5._ki&
+ &*t6**2*t1*t5**3*t2**3+10._ki*t6**2*t3*t5**2*t2**4+10._ki*t6**2*t4&
+ &**3*t5**3*t2**2-10._ki/3._ki*t6**2*t4**4*t5**3*t2-65._ki/6._ki*t6**&
+ &2*t4**2*t5**3*t2**3+16._ki/3._ki*t6**3*t4*t5*t2**5+5._ki*t6**2*t1*&
+ &t4**2*t2**4-8._ki*t6**2*t1*t4*t2**5+t6*t4*t2**6*t1/2._ki+10._ki/3.&
+ &_ki*t6**2*t2**2*t3**3-t6*t4*t2**8-20._ki/3._ki*t6**3*t4**5*t5**2-1&
+ &9._ki/2._ki*t6**3*t4**3*t2**4+9._ki/4._ki*t6**3*t1**2*t2**3-2._ki*t6&
+ &**3*t4**5*t2**2-2._ki*t6**2*t4**4*t2**4+7._ki*t6**3*t4**4*t2**3-t&
+ &1**2*t2**4*t6**2/2._ki
+ !
+ stemp5=stemp4+5._ki/4._ki*t6*t4**2*t2**7-7._ki/3._ki*t6**2*t3*t2**6+3&
+ &._ki*t6**2*t4*t2**7+3._ki*t6**2*t1*t2**6-t6*t1*t2**7/2._ki-3._ki*t6&
+ &**3*t1*t2**5+5._ki/6._ki*t6**3*t5**2*t2**5-5._ki/6._ki*t6**2*t5**3*&
+ &t2**5+20._ki*t6**2*t1*t2*t3*t4*t5**2+5._ki*t6**2*t1*t2*t5*t3**2-1&
+ &4._ki/3._ki*t6**2*t1*t2**3*t3*t4-15._ki*t6**2*t1*t5**2*t3*t2**2-65&
+ &._ki/2._ki*t6**2*t2*t3**2*t4**2*t5+45._ki*t6**2*t3**2*t4*t5*t2**2+&
+ &160._ki/3._ki*t6**3*t4*t3*t5*t2**3+30._ki*t6**3*t1*t3*t5*t2**2+65.&
+ &_ki*t6**3*t1*t4**2*t3*t5-t3*t2**8/6._ki+t2**9*t5/12._ki-t6**2*t2**&
+ &8/2._ki+t6*t2**9/4._ki+t6**3*t2**7/4._ki-45._ki*t6**2*t4*t5**2*t3*t&
+ &2**3-40._ki/3._ki*t6**2*t1*t4*t5**3*t2**2+25._ki/3._ki*t6**2*t1*t4*&
+ &*2*t5**3*t2-65._ki*t6**3*t1*t4**2*t5**2*t2+36._ki*t6**3*t1*t2**2*&
+ &t3*t4+52._ki*t6**3*t1*t4**2*t5*t2**2
+ !
+ stemp3=stemp5-36._ki*t6**3*t1*t4*t5*t2**3-125._ki*t6**3*t4**2*t3*t5&
+ &*t2**2+380._ki/3._ki*t6**3*t4**3*t3*t5*t2-90._ki*t6**3*t1*t3*t5*t2&
+ &*t4+45._ki*t6**3*t1*t4*t5**2*t2**2-5._ki*t6**3*t1**2*t3*t5-3._ki*t&
+ &6**3*t1**2*t2**2*t4+56._ki/3._ki*t6**3*t4**4*t3*t2+50._ki*t6**3*t4&
+ &**2*t3*t2**3+70._ki/3._ki*t6**3*t4**4*t5**2*t2-152._ki/3._ki*t6**3*&
+ &t4**3*t3*t2**2-64._ki/3._ki*t6**3*t4*t3*t2**4-95._ki/3._ki*t6**3*t4&
+ &**3*t5**2*t2**2+9._ki*t6**3*t1*t4**3*t2**2+16._ki/3._ki*t6**3*t4**&
+ &5*t5*t2+125._ki/6._ki*t6**3*t4**2*t5**2*t2**3+76._ki/3._ki*t6**3*t4&
+ &**3*t5*t2**3-56._ki/3._ki*t6**3*t4**4*t5*t2**2-50._ki/3._ki*t6**3*t&
+ &4**2*t5*t2**4-140._ki/3._ki*t6**3*t4**4*t3*t5-10._ki*t6**3*t1**2*t&
+ &5**2*t4+15._ki/2._ki*t6**3*t1**2*t5**2*t2+2._ki*t6**3*t1**2*t2*t3-&
+ &25._ki/3._ki*t6**3*t3*t2**4*t5-20._ki/3._ki*t6**3*t4*t5**2*t2**4-6.&
+ &_ki*t6**3*t1**2*t5*t2**2-91._ki/6._ki*t6**2*t4**2*t3*t2**4+91._ki/1&
+ &2._ki*t6**2*t4**2*t5*t2**5-7._ki*t6**2*t4**3*t5*t2**4+7._ki/3._ki*t&
+ &6**2*t4**4*t5*t2**3
+ !
+ stemp4=1._ki/t2**10*z_log(t1*t6/t2**2,1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=-(-t4+t2)*(t3*t5*t2**2+3._ki*t3*t6*t2**2-t3*t5*t2*t4-4._ki*t&
+ &5*t2*t1*t6-9._ki*t6*t4*t2*t3-2._ki*t3**2*t2+6._ki*t4**2*t3*t6+4._ki&
+ &*t4*t1*t6*t5+2._ki*t3*t1*t6)/t3/t2**4*q(4,(t2*t3-t1*t6)/t2/t3,si&
+ &gn_arg)/12._ki
+ !
+ stemp9=-125._ki/6._ki*t6**2*t1**2*t3**3*t4**2*t2**2-40._ki/3._ki*t6**&
+ &2*t1*t4**5*t3**2*t5*t2**2+10._ki/3._ki*t6**2*t1*t4**6*t3**2*t5*t2&
+ &+65._ki/3._ki*t6**2*t1*t4**4*t3**2*t5*t2**3+55._ki/3._ki*t6**2*t1*t&
+ &2**3*t3**3*t4**3+195._ki/2._ki*t6**2*t1**3*t4**2*t5**2*t3*t2**2-4&
+ &5._ki*t6**2*t1**3*t4**3*t5**2*t3*t2-195._ki/4._ki*t6**2*t1**3*t3**&
+ &2*t5*t2*t4**2+135._ki/2._ki*t6**2*t1**3*t3**2*t5*t2**2*t4+21._ki/2&
+ &._ki*t6**2*t1**3*t4**3*t3*t2**3-35._ki/12._ki*t6**2*t1**4*t4**2*t5&
+ &*t2**3-20._ki/3._ki*t6**2*t1**4*t4*t5**3*t2**2-7._ki/3._ki*t6**2*t1&
+ &**4*t2**3*t3*t4+10._ki*t6**2*t1**4*t5**2*t3*t2*t4+5._ki/2._ki*t6**&
+ &2*t1**4*t3**2*t5*t2-15._ki/2._ki*t6**2*t1**4*t5**2*t3*t2**2-25._ki&
+ &/12._ki*t6**2*t1*t4*t3**2*t2**6*t5-14._ki/9._ki*t6**2*t1**2*t4*t3*&
+ &t2**7+25._ki/6._ki*t6**2*t1**2*t2**5*t3**2*t5+125._ki/12._ki*t6**3*&
+ &t1**2*t4*t3**2*t2**4-21._ki/4._ki*t6**2*t1**3*t2**6*t4*t5+205._ki/&
+ &12._ki*t6**3*t1**2*t4**2*t5*t2**4*t3
+ !
+ stemp8=stemp9-25._ki/3._ki*t6**3*t1**4*t5**2*t2**3-7._ki/2._ki*t6**2*&
+ &t1**3*t3*t2**6+5._ki/2._ki*t6**2*t1**4*t5**3*t2**3-7._ki/4._ki*t6**&
+ &2*t1**4*t5*t2**5+9._ki/2._ki*t6**2*t1**3*t4*t2**7-t6*t1**3*t4*t2*&
+ &*8-61._ki/36._ki*t6**2*t2**6*t3**3*t4**2-5._ki/12._ki*t6**2*t1*t2**&
+ &6*t3**3+85._ki/18._ki*t6**2*t2**5*t3**3*t4**3+55._ki/36._ki*t6**3*t&
+ &1**3*t5**2*t2**5-11._ki/9._ki*t6**3*t1**3*t5*t2**6+55._ki/9._ki*t6*&
+ &*3*t1**3*t2**5*t3-11._ki/3._ki*t6**3*t1**3*t4*t2**6-t6**3*t1**2*t&
+ &2**7*t3/6._ki-5._ki/4._ki*t6**2*t1**3*t5**3*t2**5+7._ki/8._ki*t6**2*&
+ &t1**3*t5*t2**7+63._ki/4._ki*t6**2*t1**3*t4*t3*t2**5-15._ki/2._ki*t6&
+ &**2*t1**3*t3**3*t2*t4+95._ki/3._ki*t6**2*t1**2*t4**3*t3*t5**2*t2*&
+ &*3-125._ki/6._ki*t6**2*t1**2*t4**2*t3*t5**2*t2**4-80._ki/3._ki*t6**&
+ &2*t1**2*t4*t3**2*t5*t2**4+40._ki/3._ki*t6**2*t1**2*t4*t3**3*t2**3&
+ &+175._ki/36._ki*t6**2*t1**2*t4**2*t3*t2**6
+ !
+ stemp9=stemp8+49._ki/9._ki*t6**2*t1**2*t4**4*t3*t2**4+3._ki/2._ki*t6*&
+ &*2*t1**4*t2**6+3._ki/4._ki*t6**3*t1**5*t2**3-t1**3*t3*t2**8/18._ki&
+ &+t6*t1**3*t2**9/4._ki-5._ki/2._ki*t6**3*t1**4*t2**5-t6**2*t2**8*t3&
+ &**3/36._ki+t1**3*t2**9*t5/9._ki+11._ki/24._ki*t6**3*t1**3*t2**7+275&
+ &._ki/18._ki*t6**3*t1**3*t3**2*t2**3-110._ki/9._ki*t6**3*t1**3*t4**5&
+ &*t5**2-1045._ki/18._ki*t6**3*t1**3*t3**2*t4**3+275._ki/24._ki*t6**3&
+ &*t1**3*t4**2*t2**5+77._ki/6._ki*t6**3*t1**3*t4**4*t2**3+5._ki*t6**&
+ &2*t1**3*t3**3*t2**2+5._ki/2._ki*t6**2*t1**4*t4**2*t2**4+7._ki/4._ki&
+ &*t6**2*t1**4*t2**4*t3-5._ki/4._ki*t6**3*t1**2*t3**2*t2**5+t6**2*t&
+ &2**7*t3**3*t4/3._ki+20._ki/3._ki*t6**3*t1**4*t5*t2**4-25._ki/9._ki*t&
+ &6**2*t1**2*t3**3*t2**4-t6**3*t1*t3**2*t2**7/24._ki
+ !
+ stemp7=stemp9-70._ki/9._ki*t6**2*t4**4*t3**3*t2**4+68._ki/9._ki*t6**2&
+ &*t4**5*t3**3*t2**3-4._ki*t6**2*t4**6*t3**3*t2**2+8._ki/9._ki*t6**2&
+ &*t4**7*t3**3*t2-4._ki*t6**2*t1**4*t4*t2**5-39._ki/4._ki*t6**2*t1**&
+ &3*t4**2*t2**6-3._ki*t6**2*t1**3*t4**4*t2**4+9._ki*t6**2*t1**3*t4*&
+ &*3*t2**5-t6*t1**3*t4**3*t2**6/2._ki+5._ki/4._ki*t6*t1**3*t4**2*t2*&
+ &*7+2090._ki/9._ki*t6**3*t1**3*t4**3*t3*t5*t2+1375._ki/12._ki*t6**3*&
+ &t1**3*t3**2*t4**2*t2+1375._ki/36._ki*t6**3*t1**3*t4**2*t5**2*t2**&
+ &3+275._ki/3._ki*t6**3*t1**3*t4**2*t3*t2**3-836._ki/9._ki*t6**3*t1**&
+ &3*t4**3*t3*t2**2+308._ki/9._ki*t6**3*t1**3*t4**4*t3*t2-45._ki/2._ki&
+ &*t6**2*t1**3*t2**3*t3**2*t5-20._ki*t6**3*t1**4*t4**3*t5*t2-65._ki&
+ &/3._ki*t6**3*t1**4*t2*t3*t4**2+418._ki/9._ki*t6**3*t1**3*t4**3*t5*&
+ &t2**3+75._ki/2._ki*t6**3*t1**4*t4*t5**2*t2**2-308._ki/9._ki*t6**3*t&
+ &1**3*t4**4*t5*t2**2-220._ki/3._ki*t6**3*t1**3*t4*t3**2*t2**2
+ !
+ stemp9=stemp7-352._ki/9._ki*t6**3*t1**3*t4*t3*t2**4-770._ki/9._ki*t6*&
+ &*3*t1**3*t4**4*t3*t5-275._ki/9._ki*t6**3*t1**3*t4**2*t5*t2**4+5._k&
+ &i/24._ki*t6**2*t1*t2**7*t3**2*t5+20._ki/3._ki*t6**2*t1**2*t3*t5**2&
+ &*t2**5*t4-25._ki/6._ki*t6**3*t1**2*t4*t5*t2**5*t3+5._ki/3._ki*t6**3&
+ &*t1**2*t4*t3*t2**6+t6**3*t1*t4*t3**2*t2**6/2._ki+88._ki/9._ki*t6**&
+ &3*t1**3*t4**5*t5*t2+385._ki/9._ki*t6**3*t1**3*t4**4*t5**2*t2-1045&
+ &._ki/18._ki*t6**3*t1**3*t4**3*t5**2*t2**2-1375._ki/6._ki*t6**3*t1**&
+ &3*t4**2*t3*t5*t2**2-80._ki/3._ki*t6**3*t1**2*t4**5*t3*t5*t2+130._k&
+ &i/3._ki*t6**3*t1**2*t4**4*t3*t5*t2**2-110._ki/3._ki*t6**3*t1**2*t4&
+ &**3*t3*t5*t2**3-130._ki/3._ki*t6**3*t1**2*t4**4*t3**2*t2+880._ki/9&
+ &._ki*t6**3*t1**3*t4*t3*t5*t2**3+55._ki*t6**3*t1**2*t4**3*t3**2*t2&
+ &**2-133._ki/18._ki*t6**2*t1**2*t4**3*t3*t2**5+85._ki/12._ki*t6**3*t&
+ &1*t4**3*t3**2*t2**4+20._ki/3._ki*t6**2*t1**2*t4**5*t3*t5**2*t2+70&
+ &._ki/3._ki*t6**2*t1**2*t3**2*t4**4*t5*t2
+ !
+ stemp8=stemp9-14._ki/9._ki*t6**2*t1**2*t4**5*t3*t2**3-190._ki/3._ki*t&
+ &6**2*t1**2*t3**2*t4**3*t5*t2**2+125._ki/2._ki*t6**2*t1**2*t3**2*t&
+ &4**2*t5*t2**3+t1**3*t4*t3*t2**7/18._ki-2._ki/9._ki*t1**3*t4*t2**8*&
+ &t5+t1**3*t4**2*t5*t2**7/9._ki+7._ki/36._ki*t6**2*t1**2*t3*t2**8+40&
+ &._ki/3._ki*t6**3*t1**2*t4**5*t3**2+4._ki/3._ki*t6**3*t1*t4**7*t3**2&
+ &-5._ki/3._ki*t6**3*t1**5*t3*t5-t6**3*t1**5*t2**2*t4-10._ki/3._ki*t6&
+ &**3*t1**5*t5**2*t4+5._ki/2._ki*t6**3*t1**5*t5**2*t2-2._ki*t6**3*t1&
+ &**5*t5*t2**2+2._ki/3._ki*t6**3*t1**5*t2*t3+15._ki/2._ki*t6**3*t1**4&
+ &*t4**3*t2**2-65._ki/4._ki*t6**3*t1**4*t4**2*t2**3+45._ki/4._ki*t6**&
+ &3*t1**4*t4*t2**4+25._ki/2._ki*t6**3*t1**4*t3**2*t4+25._ki*t6**3*t1&
+ &**4*t4**3*t5**2-10._ki*t6**3*t1**4*t2**3*t3-25._ki/3._ki*t6**3*t1*&
+ &*4*t3**2*t2-209._ki/12._ki*t6**3*t1**3*t4**3*t2**4
+ !
+ stemp9=stemp8-11._ki/3._ki*t6**3*t1**3*t4**5*t2**2+32._ki/3._ki*t6**3&
+ &*t1**2*t4**5*t3*t2**2-3._ki/4._ki*t6**2*t1**3*t2**8-70._ki/3._ki*t6&
+ &**2*t1**2*t4**4*t3*t5**2*t2**2+40._ki/9._ki*t6**2*t1*t4**5*t3**3*&
+ &t2-130._ki/9._ki*t6**2*t1*t4**4*t3**3*t2**2+88._ki/9._ki*t6**3*t1**&
+ &3*t4*t5*t2**5-110._ki/9._ki*t6**3*t1**3*t4*t5**2*t2**4-205._ki/18.&
+ &_ki*t6**2*t1*t2**4*t3**3*t4**2+14._ki/3._ki*t6**2*t1**4*t4*t5*t2**&
+ &4+25._ki/6._ki*t6**2*t1**4*t4**2*t5**3*t2+15._ki/2._ki*t6**2*t1**3*&
+ &t4*t5**3*t2**4+15._ki*t6**2*t1**3*t3*t5**2*t2**4+125._ki/36._ki*t6&
+ &**2*t1*t2**5*t3**3*t4+205._ki/24._ki*t6**2*t1*t4**2*t3**2*t2**5*t&
+ &5+5._ki/12._ki*t6**3*t1**2*t2**6*t3*t5-5._ki/6._ki*t6**2*t1**2*t3*t&
+ &5**2*t2**6-91._ki/4._ki*t6**2*t1**3*t4**2*t3*t2**4+91._ki/8._ki*t6*&
+ &*2*t1**3*t4**2*t5*t2**5-21._ki/2._ki*t6**2*t1**3*t4**3*t5*t2**4+7&
+ &._ki/2._ki*t6**2*t1**3*t4**4*t5*t2**3-55._ki/3._ki*t6**2*t1*t4**3*t&
+ &3**2*t5*t2**4
+ !
+ stemp6=stemp9+15._ki*t6**2*t1**3*t4**3*t5**3*t2**2-5._ki*t6**2*t1**&
+ &3*t4**4*t5**3*t2-65._ki/4._ki*t6**2*t1**3*t4**2*t5**3*t2**3-135._k&
+ &i/2._ki*t6**2*t1**3*t4*t5**2*t3*t2**3+95._ki/9._ki*t6**2*t1**2*t3*&
+ &*3*t4**3*t2-41._ki/6._ki*t6**3*t1**2*t4**2*t3*t2**5-325._ki/6._ki*t&
+ &6**3*t1**4*t4**2*t5**2*t2+30._ki*t6**3*t1**4*t2**2*t3*t4+130._ki/&
+ &3._ki*t6**3*t1**4*t4**2*t5*t2**2+325._ki/6._ki*t6**3*t1**4*t4**2*t&
+ &3*t5-75._ki*t6**3*t1**4*t3*t5*t2*t4-61._ki/24._ki*t6**3*t1*t4**2*t&
+ &3**2*t2**5-275._ki/18._ki*t6**3*t1**3*t3*t2**4*t5-30._ki*t6**3*t1*&
+ &*4*t4*t5*t2**3+44._ki/3._ki*t6**3*t1**2*t4**3*t3*t2**4-205._ki/6._k&
+ &i*t6**3*t1**2*t4**2*t3**2*t2**3+20._ki/3._ki*t6**3*t1**2*t4**6*t3&
+ &*t5-8._ki/3._ki*t6**3*t1**2*t4**6*t3*t2-52._ki/3._ki*t6**3*t1**2*t4&
+ &**4*t3*t2**3+34._ki/3._ki*t6**3*t1*t4**5*t3**2*t2**2+8._ki/3._ki*t6&
+ &**3*t1**5*t5*t2*t4-6._ki*t6**3*t1*t4**6*t3**2*t2-35._ki/3._ki*t6**&
+ &3*t1*t4**4*t3**2*t2**3+25._ki*t6**3*t1**4*t3*t5*t2**2
+ !
+ stemp7=1._ki/t1**3/t2**10
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ stemp2=-(-6._ki*t6*t2**5*t4*t5+4._ki*t6*t2**4*t4**2*t5+6._ki*t3*t4*t&
+ &6*t2**4+18._ki*t6**2*t1*t2**3*t4-96._ki*t6**3*t1*t5*t4**2-36._ki*t&
+ &1*t6**3*t2**2*t5+36._ki*t6**3*t3*t2*t1-60._ki*t6**3*t4*t1*t3-144.&
+ &_ki*t6**3*t3*t2*t4**2+84._ki*t6**3*t3*t2**2*t4-12._ki*t6**2*t1*t2*&
+ &*4+72._ki*t6**3*t2**2*t5*t4**2-80._ki*t6**3*t4**3*t5*t2-28._ki*t6*&
+ &*3*t2**3*t5*t4+12._ki*t6**3*t1**2*t5+4._ki*t6**3*t5*t2**4+2._ki*t6&
+ &*t2**6*t5+32._ki*t6**3*t4**4*t5-t4*t5**2*t2**5+120._ki*t1*t6**3*t&
+ &4*t5*t2-2._ki*t6*t1*t2**4*t5-12._ki*t6**2*t2**3*t4**3+80._ki*t6**3&
+ &*t3*t4**3-16._ki*t6**3*t3*t2**3+3._ki*t6**2*t2**6-4._ki*t6*t2**5*t&
+ &3-15._ki*t6**2*t2**5*t4+24._ki*t6**2*t2**4*t4**2-2._ki*t3*t5*t2**5&
+ &+t5**2*t2**6)/t2**8*z_log(t1*t6/t2**2,1._ki)/12._ki
+ !
+ stemp4=(-16._ki*t3*t4**2*t5*t6**2*t1+4._ki*t3**2*t4**2*t5*t2*t6-12.&
+ &_ki*t4**3*t3**2*t6**2+24._ki*t3*t4*t5*t2*t6**2*t1+4._ki*t2*t1*t6**&
+ &2*t3**2+4._ki*t3*t4*t5**2*t2*t1*t6-t3**2*t4*t5**2*t2**2+6._ki*t2*&
+ &t6*t3**3*t4-6._ki*t4*t5*t3**2*t6*t2**2-15._ki*t2**2*t4*t3**2*t6**&
+ &2+24._ki*t2*t4**2*t3**2*t6**2-8._ki*t3*t2**2*t6**2*t5*t1-6._ki*t1*&
+ &t6**2*t3**2*t4-4._ki*t6*t3**3*t2**2+6._ki*t2*t5*t1*t6*t3**2-2._ki*&
+ &t2**2*t5*t3**3-6._ki*t4*t5**2*t6**2*t1**2-4._ki*t5*t1**2*t6**2*t3&
+ &+3._ki*t3**2*t2**3*t6**2+2._ki*t5*t3**2*t6*t2**3+6._ki*t2*t5**2*t1&
+ &**2*t6**2-4._ki*t3*t2**2*t5**2*t1*t6+t3**2*t5**2*t2**3)/t3**2/t2&
+ &**5*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/12._ki
+ !
+ stemp7=-44._ki/9._ki*t6**3*t1*t3*t4**4*t5-t6*t1**2*t2**4*t5*t3/9._ki&
+ &-7._ki/9._ki*t6*t1*t2**4*t3*t4**2*t5+7._ki/6._ki*t6*t1*t2**5*t3*t4*&
+ &t5-11._ki/18._ki*t6**3*t1*t3*t5*t2**4-5._ki/2._ki*t6**3*t1**2*t2*t3&
+ &**2+4._ki/9._ki*t6*t1*t2**5*t3**2-3._ki/8._ki*t6**2*t2**6*t1*t3+t6*&
+ &t1**2*t2**5*t5**2/6._ki-t6**3*t3*t5*t1**3/3._ki+25._ki/6._ki*t6**3*&
+ &t1**2*t4*t3**2-77._ki/6._ki*t6**3*t1*t2**2*t4*t3**2-t6*t1**2*t2**&
+ &4*t4*t5**2/6._ki+5._ki/2._ki*t6**3*t1**2*t3*t2**2*t5+20._ki/3._ki*t6&
+ &**3*t1**2*t3*t5*t4**2-2._ki/3._ki*t6*t1*t4*t3**2*t2**4-25._ki/3._ki&
+ &*t6**3*t1**2*t3*t4*t5*t2+110._ki/9._ki*t6**3*t1*t3*t4**3*t5*t2+77&
+ &._ki/18._ki*t6**3*t1*t3*t2**3*t5*t4
+ !
+ stemp6=stemp7+22._ki*t6**3*t1*t2*t4**2*t3**2-110._ki/9._ki*t6**3*t1*&
+ &t4**3*t3**2+3._ki/4._ki*t6**3*t4*t3**2*t2**4+22._ki/9._ki*t6**3*t1*&
+ &t3**2*t2**3+t6**2*t1**2*t3*t2**4/2._ki-8._ki/3._ki*t6**3*t3**2*t2*&
+ &*3*t4**2+14._ki/3._ki*t6**3*t3**2*t2**2*t4**3-t6**3*t3**2*t2**5/1&
+ &2._ki-11._ki*t6**3*t1*t3*t2**2*t5*t4**2+4._ki/3._ki*t6**3*t3**2*t4*&
+ &*5+3._ki/2._ki*t6**2*t1*t3*t2**3*t4**3-7._ki/18._ki*t6*t1*t2**6*t3*&
+ &t5+15._ki/8._ki*t6**2*t1*t3*t2**5*t4+7._ki/36._ki*t1*t2**5*t3*t4*t5&
+ &**2-3._ki/4._ki*t6**2*t1**2*t3*t2**3*t4-3._ki*t6**2*t1*t3*t2**4*t4&
+ &**2-4._ki*t6**3*t3**2*t4**4*t2+2._ki/9._ki*t1*t2**5*t3**2*t5-7._ki/&
+ &36._ki*t1*t2**6*t3*t5**2
+ !
+ stemp7=1._ki/t1/t2**8/t3
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par3_glob)
+ !
+ case(4)
+ !
+ select case(par4_glob)
+ !
+ case(4)
+ !
+ stemp2=(-6._ki*t6**3*t1*t2+12._ki*t6**3*t1*t4+t6**3*t2**3-8._ki*t6**&
+ &3*t4**3+12._ki*t6**3*t4**2*t2-6._ki*t6**3*t2**2*t4-2._ki*t6**2*t1*&
+ &t5*t2+4._ki*t6**2*t5*t2*t4**2+4._ki*t6**2*t2*t3*t4+t6**2*t5*t2**3&
+ &-4._ki*t6**2*t5*t2**2*t4-2._ki*t6**2*t2**2*t3+t6*t2**3*t5**2-2._ki&
+ &*t6*t4*t5**2*t2**2-2._ki*t6*t2**2*t3*t5+t5**3*t2**3)/t2**6*z_log&
+ &(t1*t6/t2**2,1._ki)/4._ki
+ !
+ stemp3=-(-2._ki*t1*t6*t5+t3*t6*t2+t3*t2*t5-2._ki*t6*t3*t4)*(t3**2*t&
+ &6**2*t2**2-4._ki*t3**2*t6**2*t4*t2-2._ki*t3*t1*t6**2*t5*t2+2._ki*t&
+ &3**2*t1*t6**2+4._ki*t3**2*t6**2*t4**2+4._ki*t3*t6**2*t4*t1*t5+2._k&
+ &i*t6**2*t1**2*t5**2-2._ki*t2*t3**3*t6-2._ki*t6*t1*t3*t5**2*t2+t3*&
+ &*2*t5**2*t2**2)/t2**6/t3**3*q(4,(t2*t3-t1*t6)/t2/t3,sign_arg)/4&
+ &._ki+(60._ki*t6**3*t3**2*t1*t4-30._ki*t6**3*t1*t3**2*t2+11._ki*t6**&
+ &3*t2**3*t3**2-88._ki*t6**3*t3**2*t4**3-66._ki*t6**3*t2**2*t3**2*t&
+ &4+132._ki*t6**3*t3**2*t2*t4**2+8._ki*t6**2*t1**2*t2*t5**3-12._ki*t&
+ &6**2*t1*t5**2*t3*t2**2+24._ki*t6**2*t1*t2*t3*t4*t5**2+2._ki*t6**2&
+ &*t1*t2*t5*t3**2-68._ki*t6**2*t3**2*t4*t5*t2**2+44._ki*t6**2*t2*t3&
+ &**3*t4+68._ki*t6**2*t2*t3**2*t4**2*t5-22._ki*t6**2*t2**2*t3**3+17&
+ &._ki*t6**2*t2**3*t3**2*t5-16._ki*t6*t1*t3*t2**2*t5**3-40._ki*t6*t3&
+ &**2*t2**2*t4*t5**2+20._ki*t6*t3**2*t2**3*t5**2-28._ki*t6*t3**3*t2&
+ &**2*t5+22._ki*t3**2*t2**3*t5**3)/t3**2/t2**6/24._ki
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ end select
+ !
+ end select
+ !
+ end if
+ !
+ else if (dim_glob == "n+4") then
+ if (nb_par == 0) then
+ !
+ temp0=(-1._ki/6._ki*(-4._ki*t6**2*t1*t3+4._ki*t6**2*t1*t5*t2-8._ki*t5*&
+ &t4*t6**2*t1-2._ki*t6**2*t1*t2**2+4._ki*t6**2*t1*t2*t4+2._ki*t6**2*&
+ &t3*t2**2-8._ki*t6**2*t3*t2*t4+8._ki*t6**2*t3*t4**2+2._ki*t2**3*t1*&
+ &t6+t2**4*t3)/t2**5*z_log(-t1*t6/t2**2,-1._ki)+1._ki/6._ki*t3/t2*q(&
+ &2,(t2*t3-t1*t6)/t2/t3,sign_arg)-1._ki/6._ki*(-2._ki*t1*t3+2._ki*t1*&
+ &t2*t4+2._ki*t1*t5*t2-4._ki*t1*t5*t4-t1*t2**2+12._ki*t3*t4**2-12._ki&
+ &*t3*t2*t4+3._ki*t3*t2**2)*t6**2/t2**5)/t2
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par4_glob)
+ !
+ case(1)
+ !
+ stemp2=(9._ki*t1**2*t5*t6**3-3._ki*t1**2*t6**3*t2+3._ki*t1*t6**3*t2*&
+ &*3-36._ki*t1*t5*t6**3*t4**2+12._ki*t1*t6**3*t2*t4**2-12._ki*t1*t6*&
+ &*3*t2**2*t4+36._ki*t1*t5*t6**3*t2*t4+18._ki*t1*t3*t6**3*t2-36._ki*&
+ &t1*t3*t6**3*t4-9._ki*t1*t5*t6**3*t2**2-3._ki*t1*t2**4*t6**2+6._ki*&
+ &t1*t2**3*t6**2*t4-t1*t5*t2**4*t6-t1*t2**5*t6-3._ki*t3*t6**3*t2**&
+ &3+24._ki*t3*t6**3*t4**3+18._ki*t3*t6**3*t2**2*t4-36._ki*t3*t6**3*t&
+ &2*t4**2-t3*t2**5*t6+2._ki*t3*t2**4*t6*t4-t3*t2**6-t3*t5*t2**5)/t&
+ &2**7*z_log(-t1*t6/t2**2,-1._ki)/12._ki
+ !
+ stemp3=-(2._ki*t5*t1*t6-t3*t5*t2+2._ki*t2*t1*t6-t3*t2*t6+2._ki*t3*t6&
+ &*t4-t3*t2**2)/t2**3*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/12._ki+(-2&
+ &._ki*t1**2*t6**3*t2+6._ki*t1**2*t5*t6**3-15._ki*t1*t5*t6**3*t2**2-&
+ &20._ki*t1*t6**3*t2**2*t4+60._ki*t1*t5*t6**3*t2*t4-60._ki*t1*t5*t6*&
+ &*3*t4**2+30._ki*t1*t3*t6**3*t2-60._ki*t1*t3*t6**3*t4+20._ki*t1*t6*&
+ &*3*t2*t4**2+5._ki*t1*t6**3*t2**3-3._ki*t1*t2**4*t6**2+6._ki*t1*t2*&
+ &*3*t6**2*t4-132._ki*t3*t6**3*t2*t4**2+66._ki*t3*t6**3*t2**2*t4+88&
+ &._ki*t3*t6**3*t4**3-11._ki*t3*t6**3*t2**3-2._ki*t3*t2**5*t6+4._ki*t&
+ &3*t2**4*t6*t4-2._ki*t3*t2**6-2._ki*t3*t5*t2**5)/t2**7/24._ki
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(2)
+ !
+ stemp4=-6._ki*t6**2*t4**2*t5**2*t3*t2**2-9._ki*t6**2*t4*t3**2*t2**2&
+ &*t5-9._ki/2._ki*t1**2*t6**3*t4*t5*t2+6._ki*t6**3*t4**2*t2**2*t3*t5&
+ &+12._ki*t1*t3*t6**3*t2*t4**2-5._ki/6._ki*t1*t6**2*t4*t2**4*t5+3._ki&
+ &/2._ki*t1*t6**3*t4*t5*t2**3+12._ki*t6**2*t4**2*t3**2*t5*t2+6._ki*t&
+ &6**2*t4**3*t5**2*t3*t2+3._ki/2._ki*t6**2*t4*t5**2*t3*t2**3-3._ki/2&
+ &._ki*t1*t6**3*t5**2*t2**2*t4-24._ki*t1*t6**3*t3*t5*t4**2-2._ki*t1*&
+ &t6**2*t4**2*t5**3*t2+10._ki*t6**3*t4**3*t3**2+t1**2*t6**2*t2**4/&
+ &2._ki-t6**2*t3**3*t2**2-3._ki/4._ki*t1**2*t2**3*t6**3+3._ki*t1*t6**&
+ &2*t5**2*t2**2*t3-3._ki*t1*t6**2*t3**2*t5*t2+6._ki*t1*t6**3*t4**2*&
+ &t5**2*t2-3._ki*t1*t6**3*t3*t5*t2**2+6._ki*t1*t6**3*t4**3*t5*t2-6.&
+ &_ki*t1*t6**3*t4**2*t5*t2**2+18._ki*t1*t6**3*t3*t5*t2*t4+9._ki/2._ki&
+ &*t1**2*t6**3*t5**2*t4+9._ki/4._ki*t1**2*t6**3*t2**2*t4+3._ki*t1**2&
+ &*t6**3*t5*t3-3._ki/2._ki*t1**2*t2*t6**3*t5**2-5._ki/12._ki*t1**2*t2&
+ &**3*t6**2*t5+t1**2*t6**2*t5**3*t2/2._ki-3._ki/4._ki*t1*t6**3*t4*t2&
+ &**4-5._ki/6._ki*t1*t6**2*t3*t2**4
+ !
+ stemp3=stemp4+3._ki*t1*t6**3*t3**2*t2-6._ki*t1*t6**3*t4**3*t5**2-15&
+ &._ki/2._ki*t1*t6**3*t4*t3**2-3._ki*t1*t6**3*t4**3*t2**2+9._ki/2._ki*&
+ &t6**3*t2**2*t3**2*t4+3._ki/2._ki*t1**2*t5*t6**3*t2**2-3._ki/2._ki*t&
+ &1**2*t6**3*t2*t3+t1*t6**2*t2**5*t4-2._ki*t1*t6**2*t4**2*t2**4+8.&
+ &_ki*t6**3*t4**4*t5*t3+t6**3*t4*t2**4*t3/2._ki-12._ki*t6**3*t4**2*t&
+ &3**2*t2-3._ki*t6**3*t4**2*t2**3*t3+6._ki*t6**3*t4**3*t3*t2**2-4._k&
+ &i*t6**3*t4**4*t3*t2+3._ki/2._ki*t6**2*t2**3*t3**2*t5+5._ki/2._ki*t6&
+ &**2*t4*t3**3*t2-5._ki/3._ki*t6**2*t4**3*t2**3*t3+5._ki/3._ki*t6**2*&
+ &t4**2*t2**4*t3-5._ki/12._ki*t6**2*t4*t2**5*t3+3._ki/2._ki*t1*t6**3*&
+ &t3*t2**3+3._ki*t1*t6**3*t4**2*t2**3-t1*t6*t4*t2**6/4._ki-9._ki*t1*&
+ &t6**2*t5**2*t2*t3*t4+5._ki/3._ki*t1*t6**2*t4**2*t2**3*t5+5._ki/2._k&
+ &i*t1*t6**2*t4*t3*t2**3-12._ki*t6**3*t4**3*t5*t3*t2-t6**3*t4*t2**&
+ &3*t3*t5-9._ki*t4*t1*t6**3*t3*t2**2+t1*t6**2*t4*t5**3*t2**2-t4*t3&
+ &*t2**7/12._ki-t3**2*t6**3*t2**3/2._ki
+ !
+ stemp4=1._ki/t2**9*z_log(-t1*t6/t2**2,-1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=t4*t3/t2**2*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/12._ki
+ !
+ stemp8=11._ki*t1**2*t6*t4**2*t2**2*t3*t5-t1**3*t4**2*t5**3*t2+5._ki&
+ &*t1**3*t6*t4**3*t5*t2-5._ki*t1**3*t6*t4**2*t5*t2**2+5._ki*t1**3*t&
+ &6*t4**2*t5**2*t2-20._ki*t1**3*t6*t3*t5*t4**2-5._ki/2._ki*t1**3*t6*&
+ &t3*t5*t2**2-11._ki/2._ki*t1**2*t6*t4**2*t2**3*t3-22._ki/3._ki*t1**2&
+ &*t6*t4**4*t3*t2+4._ki*t1*t6*t4**4*t3**2*t2-3._ki/2._ki*t1**2*t3**3&
+ &*t2**2-2._ki/3._ki*t4**5*t3**3*t2-t4**3*t3**3*t2**3+4._ki/3._ki*t4*&
+ &*4*t3**3*t2**2-t4*t3**3*t2**5/24._ki+10._ki*t1**3*t6*t4**2*t3*t2-&
+ &2._ki*t1*t6*t4**5*t3**2+3._ki/2._ki*t1**4*t6*t5**2*t4-t1**4*t3*t2*&
+ &t6/2._ki
+ !
+ stemp7=stemp8+t1**4*t5*t6*t2**2/2._ki-3._ki/2._ki*t1*t2**3*t3**3*t4-&
+ &5._ki/12._ki*t1**3*t4*t5*t2**4+5._ki/6._ki*t1**3*t4**2*t5*t2**3+33.&
+ &_ki/4._ki*t1**2*t6*t4*t3**2*t2**2-22._ki*t1**2*t6*t4**3*t5*t3*t2-2&
+ &2._ki*t1**2*t6*t4**2*t3**2*t2-11._ki/6._ki*t1**2*t6*t4*t2**3*t3*t5&
+ &+11._ki/12._ki*t1**2*t3*t2**4*t6*t4+44._ki/3._ki*t1**2*t6*t4**4*t5*&
+ &t3-3._ki/2._ki*t1**4*t6*t4*t5*t2+15._ki*t1**3*t6*t3*t5*t2*t4+11._ki&
+ &*t1**2*t6*t4**3*t3*t2**2-t1*t3**2*t2**4*t6*t4/8._ki-9._ki/2._ki*t1&
+ &**3*t5**2*t2*t3*t4-9._ki*t1**2*t4**2*t5**2*t3*t2**2+9._ki*t1**2*t&
+ &4**3*t5**2*t3*t2+18._ki*t1**2*t4**2*t3**2*t5*t2+9._ki/4._ki*t1**2*&
+ &t4*t5**2*t3*t2**3
+ !
+ stemp8=stemp7-27._ki/2._ki*t1**2*t4*t3**2*t2**2*t5-3._ki*t1*t4**2*t5&
+ &*t3**2*t2**3-4._ki*t1*t4**4*t5*t3**2*t2+6._ki*t1*t4**3*t5*t3**2*t&
+ &2**2+t1*t4*t5*t3**2*t2**4/2._ki-5._ki/4._ki*t1**3*t6*t4*t5**2*t2**&
+ &2+5._ki/4._ki*t1**3*t6*t4*t5*t2**3-t1**4*t2**3*t6/4._ki+t4**2*t3**&
+ &3*t2**4/3._ki+t1**3*t4*t2**5/2._ki-t1**3*t4**2*t2**4-5._ki/12._ki*t&
+ &1**3*t2**4*t3-11._ki/12._ki*t1**2*t2**3*t3**2*t6+t1**4*t6*t5*t3-t&
+ &1**4*t2*t6*t5**2/2._ki+3._ki/4._ki*t1**4*t4*t6*t2**2-5._ki/2._ki*t1*&
+ &*3*t6*t4**3*t2**2-25._ki/4._ki*t1**3*t6*t4*t3**2+5._ki/2._ki*t1**3*&
+ &t6*t4**2*t2**3
+ !
+ stemp6=stemp8-5._ki/8._ki*t1**3*t6*t4*t2**4+5._ki/4._ki*t1**3*t6*t3*t&
+ &2**3+5._ki/2._ki*t1**3*t6*t3**2*t2-5._ki*t1**3*t6*t4**3*t5**2+55._k&
+ &i/3._ki*t1**2*t6*t4**3*t3**2+5._ki/4._ki*t1**3*t4*t3*t2**3+3._ki/2.&
+ &_ki*t1**3*t5**2*t2**2*t3-3._ki/2._ki*t1**3*t3**2*t5*t2+t1**3*t4*t5&
+ &**3*t2**2/2._ki-5._ki/8._ki*t1**2*t4*t2**5*t3+5._ki/2._ki*t1**2*t4**&
+ &2*t2**4*t3-5._ki/2._ki*t1**2*t4**3*t2**3*t3+9._ki/4._ki*t1**2*t2**3&
+ &*t3**2*t5+15._ki/4._ki*t1**2*t4*t3**3*t2-10._ki/3._ki*t1*t4**3*t3**&
+ &3*t2+4._ki*t1*t4**2*t3**3*t2**2-3._ki*t1*t6*t4**3*t2**2*t3**2+t1*&
+ &t3**2*t2**3*t6*t4**2-15._ki/2._ki*t1**3*t6*t4*t3*t2**2+t1*t2**4*t&
+ &3**3/6._ki
+ !
+ stemp7=t6**2/t2**9/t1**2
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(3)
+ !
+ stemp5=5._ki/2._ki*t1*t6**2*t4*t2**4*t5+15._ki/2._ki*t1*t6**3*t5**2*t&
+ &2**2*t4+t4*t3*t2**7/12._ki-15._ki/2._ki*t1*t6**3*t4*t5*t2**3-18._ki&
+ &*t6**3*t4**2*t2**2*t3*t5+24._ki*t1*t6**3*t3*t5*t4**2-3._ki*t1*t6*&
+ &*2*t4*t5**3*t2**2-5._ki/6._ki*t1*t6**2*t2**5*t5+3._ki/2._ki*t1*t6**&
+ &3*t5*t2**4-3._ki/2._ki*t1*t6**3*t5**2*t2**3+3._ki/2._ki*t6**2*t5**2&
+ &*t2**4*t3+25._ki/12._ki*t6**2*t4*t2**5*t3+5._ki/3._ki*t6**2*t4**3*t&
+ &2**3*t3-10._ki/3._ki*t6**2*t4**2*t2**4*t3+3._ki/2._ki*t1**2*t2**3*t&
+ &6**3+t6**3*t3*t2**5/2._ki-5._ki/12._ki*t6**2*t3*t2**6-10._ki*t6**3*&
+ &t4**3*t3**2+12._ki*t6**2*t4**2*t5**2*t3*t2**2
+ !
+ stemp4=stemp5+2._ki*t1*t6**2*t4**2*t5**3*t2-6._ki*t1*t6**2*t5**2*t2&
+ &**2*t3+3._ki*t1*t6**2*t3**2*t5*t2+3._ki/2._ki*t6**2*t3**3*t2**2-t1&
+ &**2*t6**2*t2**4/2._ki-3._ki/4._ki*t1*t6**3*t2**5+2._ki*t3**2*t6**3*&
+ &t2**3-t1*t6*t2**7/4._ki-12._ki*t1*t6**3*t4**2*t5**2*t2+9._ki*t1*t6&
+ &**3*t3*t5*t2**2-12._ki*t6**2*t4**2*t3**2*t5*t2-6._ki*t6**2*t4**3*&
+ &t5**2*t3*t2+9._ki/2._ki*t1**2*t6**3*t4*t5*t2-6._ki*t1*t6**3*t4**3*&
+ &t5*t2-9._ki/2._ki*t1**2*t6**3*t5**2*t4-9._ki/4._ki*t1**2*t6**3*t2**&
+ &2*t4-3._ki*t1**2*t6**3*t5*t3+3._ki*t1**2*t2*t6**3*t5**2+5._ki/12._k&
+ &i*t1**2*t2**3*t6**2*t5
+ !
+ stemp5=stemp4-t1**2*t6**2*t5**3*t2/2._ki-15._ki/2._ki*t6**2*t4*t5**2&
+ &*t3*t2**3+15._ki*t4*t1*t6**3*t3*t2**2+15._ki/4._ki*t1*t6**3*t4*t2*&
+ &*4+5._ki/3._ki*t1*t6**2*t3*t2**4-9._ki/2._ki*t1*t6**3*t3**2*t2+6._ki&
+ &*t1*t6**3*t4**3*t5**2+15._ki/2._ki*t1*t6**3*t4*t3**2-6._ki*t1*t6**&
+ &3*t4**2*t2**3+20._ki*t6**3*t4**3*t5*t3*t2-30._ki*t1*t6**3*t3*t5*t&
+ &2*t4+12._ki*t1*t6**3*t4**2*t5*t2**2+9._ki*t1*t6**2*t5**2*t2*t3*t4&
+ &+15._ki*t6**2*t4*t3**2*t2**2*t5+3._ki*t1*t6**3*t4**3*t2**2-21._ki/&
+ &2._ki*t6**3*t2**2*t3**2*t4-3._ki*t1**2*t5*t6**3*t2**2+3._ki/2._ki*t&
+ &1**2*t6**3*t2*t3
+ !
+ stemp3=stemp5-3._ki*t1*t6**2*t2**5*t4+2._ki*t1*t6**2*t4**2*t2**4-t6&
+ &**3*t5*t3*t2**4+t1*t6*t4*t2**6/4._ki+7._ki*t6**3*t4*t2**3*t3*t5-t&
+ &3*t2**8/12._ki-5._ki/3._ki*t1*t6**2*t4**2*t2**3*t5+t1*t6**2*t5**3*&
+ &t2**3-9._ki/2._ki*t1*t6**3*t3*t2**3-8._ki*t6**3*t4**4*t5*t3-7._ki/2&
+ &._ki*t6**3*t4*t2**4*t3+18._ki*t6**3*t4**2*t3**2*t2+9._ki*t6**3*t4*&
+ &*2*t2**3*t3-10._ki*t6**3*t4**3*t3*t2**2+4._ki*t6**3*t4**4*t3*t2-9&
+ &._ki/2._ki*t6**2*t2**3*t3**2*t5-5._ki/2._ki*t6**2*t4*t3**3*t2+t1*t6&
+ &**2*t2**6-12._ki*t1*t3*t6**3*t2*t4**2-5._ki/2._ki*t1*t6**2*t4*t3*t&
+ &2**3
+ !
+ stemp4=1._ki/t2**9*z_log(-t1*t6/t2**2,-1._ki)
+ !
+ stemp2=stemp3*stemp4
+ !
+ stemp4=-(-t2+t4)*t3/t2**2*q(3,(t2*t3-t1*t6)/t2/t3,sign_arg)/12._ki
+ !
+ !
+ stemp8=33._ki/2._ki*t1**2*t6*t4**2*t2**3*t3-44._ki/3._ki*t1**2*t6*t4*&
+ &*4*t5*t3-2._ki*t4**4*t3**3*t2**2+9._ki/2._ki*t1**3*t5**2*t2*t3*t4+&
+ &18._ki*t1**2*t4**2*t5**2*t3*t2**2-9._ki*t1**2*t4**3*t5**2*t3*t2+5&
+ &._ki/4._ki*t1**3*t6*t5*t2**4-2._ki/3._ki*t1*t2**4*t3**3-5._ki/8._ki*t&
+ &1**2*t3*t2**6+3._ki/8._ki*t4*t3**3*t2**5+9._ki/8._ki*t1*t3**2*t2**4&
+ &*t6*t4+9._ki/4._ki*t1**2*t3**3*t2**2+7._ki/3._ki*t4**3*t3**3*t2**3+&
+ &2._ki/3._ki*t4**5*t3**3*t2-18._ki*t1**2*t4**2*t3**2*t5*t2-45._ki/4.&
+ &_ki*t1**2*t4*t5**2*t3*t2**3+11._ki/12._ki*t1**2*t3*t2**5*t6-t1*t6*&
+ &t3**2*t2**5/8._ki-t1**4*t6*t5*t3+t1**4*t2*t6*t5**2-3._ki/4._ki*t1*&
+ &*4*t4*t6*t2**2+5._ki/2._ki*t1**3*t6*t4**3*t2**2
+ !
+ stemp7=stemp8+11._ki/3._ki*t1**2*t2**3*t3**2*t6-4._ki*t1*t3**2*t2**3&
+ &*t6*t4**2-11._ki/6._ki*t1**2*t6*t5*t3*t2**4-55._ki/3._ki*t1**2*t6*t&
+ &4**3*t3*t2**2-33._ki*t1**2*t6*t4**2*t2**2*t3*t5+25._ki/4._ki*t1**3&
+ &*t6*t4*t5**2*t2**2+25._ki/2._ki*t1**3*t6*t4*t3*t2**2-5._ki*t1**3*t&
+ &6*t4**3*t5*t2-25._ki/4._ki*t1**3*t6*t4*t5*t2**3+9._ki*t1*t4**2*t5*&
+ &t3**2*t2**3+t1**3*t4**2*t5**3*t2-3._ki/2._ki*t1**3*t4*t5**3*t2**2&
+ &+25._ki/8._ki*t1**2*t4*t2**5*t3-5._ki*t1**2*t4**2*t2**4*t3+5._ki/2.&
+ &_ki*t1**2*t4**3*t2**3*t3-27._ki/4._ki*t1**2*t2**3*t3**2*t5-15._ki/4&
+ &._ki*t1**2*t4*t3**3*t2+10._ki/3._ki*t1*t4**3*t3**3*t2-6._ki*t1*t4**&
+ &2*t3**3*t2**2+10._ki*t1**3*t6*t4**2*t5*t2**2+45._ki/2._ki*t1**2*t4&
+ &*t3**2*t2**2*t5+t1**3*t5**3*t2**3/2._ki+4._ki*t1*t4**4*t5*t3**2*t&
+ &2
+ !
+ stemp8=stemp7+3._ki/2._ki*t1**4*t6*t4*t5*t2-10._ki*t1**3*t6*t4**2*t3&
+ &*t2-10._ki*t1**3*t6*t4**2*t5**2*t2-3._ki/2._ki*t1**3*t4*t2**5+t1**&
+ &3*t4**2*t2**4-5._ki/8._ki*t1**3*t6*t2**5+t1**4*t2**3*t6/2._ki+20._k&
+ &i*t1**3*t6*t3*t5*t4**2+5._ki/6._ki*t1**3*t2**4*t3+22._ki/3._ki*t1**&
+ &2*t6*t4**4*t3*t2+7._ki*t1*t6*t4**3*t2**2*t3**2+15._ki/2._ki*t1**3*&
+ &t6*t3*t5*t2**2-77._ki/4._ki*t1**2*t6*t4*t3**2*t2**2-25._ki*t1**3*t&
+ &6*t3*t5*t2*t4-5._ki/12._ki*t1**3*t2**5*t5-5._ki/4._ki*t1**3*t6*t5**&
+ &2*t2**3+25._ki/4._ki*t1**3*t6*t4*t3**2+25._ki/8._ki*t1**3*t6*t4*t2*&
+ &*4-15._ki/4._ki*t1**3*t6*t3*t2**3+110._ki/3._ki*t1**2*t6*t4**3*t5*t&
+ &3*t2+33._ki*t1**2*t6*t4**2*t3**2*t2-6._ki*t1*t6*t4**4*t3**2*t2
+ !
+ stemp6=stemp8-10._ki*t1*t4**3*t5*t3**2*t2**2-7._ki/2._ki*t1*t4*t5*t3&
+ &**2*t2**4+77._ki/6._ki*t1**2*t6*t4*t2**3*t3*t5-3._ki/2._ki*t1**4*t6&
+ &*t5**2*t4-15._ki/4._ki*t1**3*t6*t3**2*t2+5._ki*t1**3*t6*t4**3*t5**&
+ &2-55._ki/3._ki*t1**2*t6*t4**3*t3**2+2._ki*t1*t6*t4**5*t3**2-5._ki*t&
+ &1**3*t6*t4**2*t2**3+9._ki/4._ki*t1**2*t5**2*t2**4*t3+t1*t3**2*t5*&
+ &t2**5/2._ki-t3**3*t2**6/24._ki+7._ki/2._ki*t1*t2**3*t3**3*t4+5._ki/4&
+ &._ki*t1**3*t4*t5*t2**4-5._ki/6._ki*t1**3*t4**2*t5*t2**3+t1**4*t3*t&
+ &2*t6/2._ki-t1**4*t5*t6*t2**2-5._ki/4._ki*t1**3*t4*t3*t2**3-3._ki*t1&
+ &**3*t5**2*t2**2*t3+3._ki/2._ki*t1**3*t3**2*t5*t2-4._ki/3._ki*t4**2*&
+ &t3**3*t2**4-77._ki/12._ki*t1**2*t3*t2**4*t6*t4+t1**3*t2**6/2._ki
+ !
+ stemp7=t6**2/t2**9/t1**2
+ !
+ stemp5=stemp6*stemp7
+ !
+ stemp3=stemp4+stemp5
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ case(4)
+ !
+ stemp2=-(-3._ki*t1**2*t6**3*t2+9._ki*t1**2*t5*t6**3+36._ki*t1*t5*t6*&
+ &*3*t2*t4+18._ki*t1*t3*t6**3*t2+3._ki*t1*t6**3*t2**3-9._ki*t1*t5*t6&
+ &**3*t2**2-36._ki*t1*t3*t6**3*t4+12._ki*t1*t6**3*t2*t4**2-36._ki*t1&
+ &*t5*t6**3*t4**2-12._ki*t1*t6**3*t2**2*t4-6._ki*t1*t2**4*t6**2+12.&
+ &_ki*t1*t2**3*t6**2*t4-2._ki*t1*t5*t2**4*t6+24._ki*t3*t6**3*t4**3-3&
+ &._ki*t3*t6**3*t2**3+18._ki*t3*t6**3*t2**2*t4-36._ki*t3*t6**3*t2*t4&
+ &**2+4._ki*t3*t2**4*t6*t4-2._ki*t3*t2**5*t6-2._ki*t3*t5*t2**5)/t2**&
+ &7*z_log(-t1*t6/t2**2,-1._ki)/24._ki
+ !
+ stemp3=(2._ki*t5*t1*t6-t3*t2*t6-t3*t5*t2+2._ki*t3*t6*t4)/t2**3*q(3,&
+ &(t2*t3-t1*t6)/t2/t3,sign_arg)/12._ki-(6._ki*t1**2*t5*t6**3-2._ki*t&
+ &1**2*t6**3*t2+30._ki*t1*t3*t6**3*t2-15._ki*t1*t5*t6**3*t2**2-60._k&
+ &i*t1*t5*t6**3*t4**2+20._ki*t1*t6**3*t2*t4**2-20._ki*t1*t6**3*t2**&
+ &2*t4+60._ki*t1*t5*t6**3*t2*t4-60._ki*t1*t3*t6**3*t4+5._ki*t1*t6**3&
+ &*t2**3-6._ki*t1*t2**4*t6**2+12._ki*t1*t2**3*t6**2*t4+88._ki*t3*t6*&
+ &*3*t4**3-132._ki*t3*t6**3*t2*t4**2+66._ki*t3*t6**3*t2**2*t4-11._ki&
+ &*t3*t6**3*t2**3+8._ki*t3*t2**4*t6*t4-4._ki*t3*t2**5*t6-4._ki*t3*t5&
+ &*t2**5)/t2**7/48._ki
+ !
+ stemp1=stemp2+stemp3
+ !
+ stemp2=1._ki/t2
+ !
+ temp0=stemp1*stemp2
+ !
+ end select
+ !
+ end if
+ !
+ end if
+ !
+ compute_residue = temp0
+ !
+ end function compute_residue
+ !
+ !****if* src/integrals/four_point/function_4p3m/fg
+ ! NAME
+ !
+ ! function fg
+ !
+ ! USAGE
+ !
+ ! complex = fg(z,s24,s13,s12,s23,s34,par1,par2,par3,par4,flag,dim)
+ !
+ ! DESCRIPTION
+ !
+ ! This function contains the one dimensional integral representation of
+ ! the six/eight dimensional three mass four point function
+ !
+ !
+ ! INPUTS
+ !
+ ! * z -- a real (type ki), integration variable
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! three mass four point function, dim="n+4" eight dimensional
+ ! three mass four point function
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki) corresponding to the
+ ! one dimensional integral representation of the six/eight dimensional
+ ! three mass four point function
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function fg(z,s24,s13,s12,s23,s34,par1,par2,par3,par4,flag,dim)
+ !
+ complex(ki), intent (in) :: z
+ real(ki), intent (in) :: s24,s13,s12,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4,flag
+ character (len=3) :: dim
+ complex(ki) :: fg
+ !
+ integer, dimension(4) :: par
+ integer :: nb_par
+ complex(ki) :: c_var,d_var,e_var,f_var,g_var,h_var
+ !
+ par = (/par1,par2,par3,par4/)
+ nb_par = count(mask=par/=0)
+ !
+ c_var = z*s12+(1._ki-z)*s13
+ !
+ f_var = z*(s24-s12)+(1._ki-z)*(s34-s13)
+ !
+ g_var = z*(1._ki-z)*s23-z*s24-(1._ki-z)*s34
+ !
+ d_var = z*(1._ki-z)*s23-z*s12-(1._ki-z)*s13
+ !
+ e_var = z*s24+(1._ki-z)*s34
+ !
+ h_var = z*(1._ki-z)*s23
+ !
+ if (dim == "n+2") then
+ if (nb_par == 0) then
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=(-(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_var+log(e_var)&
+ &*e_var)/f_var/g_var
+ !
+ case(2)
+ !
+ fg=((log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_var-c_var*log(c&
+ &_var))/f_var/d_var
+ !
+ end select
+ else if (nb_par == 1) then
+ select case(par4)
+ !
+ case(1)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/2._ki*(-(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_var*&
+ &*2+log(e_var)*e_var**2)/f_var**2/g_var
+ !
+ case(2)
+ !
+ fg=-(1._ki/2._ki*c_var**2/f_var*log(c_var)-1._ki/2._ki*(log(z)&
+ &+log(1._ki-z)+z_log(s23,1._ki))*h_var**2/f_var)/d_var**2-(&
+ &1._ki/2._ki*c_var/f_var**2*log(c_var)*(2._ki*f_var+c_var)+1&
+ &._ki/2._ki*(c_var*f_var-(log(z)+log(1._ki-z)+z_log(s23,1._ki&
+ &))*h_var**2)/f_var**2)/d_var
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-(-1._ki/2._ki*z*(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_v&
+ &ar**2/f_var**2*d_var+1._ki/2._ki*z*log(e_var)/f_var*e_var*&
+ &*2)/g_var**2-(-1._ki/2._ki*z*(log(z)+log(1._ki-z)+z_log(s23&
+ &,1._ki))*h_var/f_var**2*(c_var-d_var)+z*(log(z)+log(1._ki-&
+ &z)+z_log(s23,1._ki))*h_var**2/f_var**3*d_var+1._ki/2._ki*z*&
+ &(c_var+f_var)/f_var)/g_var-z*(log(z)+log(1._ki-z)+z_log(s&
+ &23,1._ki))*h_var*(-d_var-h_var+g_var+c_var)/f_var**3
+ !
+ case(2)
+ !
+ fg=-(-1._ki/2._ki*z*(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_v&
+ &ar/f_var**2*c_var*g_var-1._ki/2._ki*z*c_var**2/f_var*log(c&
+ &_var))/d_var**2-(-1._ki/2._ki*z*(log(z)+log(1._ki-z)+z_log(&
+ &s23,1._ki))*h_var/f_var**2*(h_var-g_var)-z*(log(z)+log(1.&
+ &_ki-z)+z_log(s23,1._ki))*h_var/f_var**3*c_var*g_var-1._ki/2&
+ &._ki*z*c_var/f_var)/d_var
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-(1._ki/2._ki*(-1._ki+z)*(log(z)+log(1._ki-z)+z_log(s23,1._k&
+ &i))*h_var**2/f_var**2*d_var-1._ki/2._ki*(-1._ki+z)*log(e_va&
+ &r)/f_var*e_var**2)/g_var**2-(1._ki/2._ki*(-1._ki+z)*(log(z)&
+ &+log(1._ki-z)+z_log(s23,1._ki))*h_var/f_var**2*(c_var-d_va&
+ &r)-(-1._ki+z)*(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_var*&
+ &*2/f_var**3*d_var-1._ki/2._ki*(-c_var+z*c_var-f_var+z*f_va&
+ &r)/f_var)/g_var+(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_v&
+ &ar*(-d_var-h_var+g_var+c_var)*(-1._ki+z)/f_var**3
+ !
+ case(2)
+ !
+ fg=-(1._ki/2._ki*(-1._ki+z)*(log(z)+log(1._ki-z)+z_log(s23,1._k&
+ &i))*h_var/f_var**2*c_var*g_var+1._ki/2._ki*c_var**2*(-1._ki&
+ &+z)/f_var*log(c_var))/d_var**2-(1._ki/2._ki*(-1._ki+z)*(log&
+ &(z)+log(1._ki-z)+z_log(s23,1._ki))*h_var/f_var**2*(h_var-g&
+ &_var)+(-1._ki+z)*(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_v&
+ &ar/f_var**3*c_var*g_var+1._ki/2._ki*(-1._ki+z)*c_var/f_var)&
+ &/d_var
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-(-1._ki/2._ki*log(e_var)/f_var*e_var**2+1._ki/2._ki*(log(z&
+ &)+log(1._ki-z)+z_log(s23,1._ki))*h_var**2/f_var)/g_var**2-&
+ &(-1._ki/2._ki*log(e_var)/f_var**2*e_var*(-c_var+f_var)-1._k&
+ &i/2._ki*h_var*((log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_var&
+ &+f_var)/f_var**2)/g_var-1._ki/2._ki/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/2._ki*(-(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_var*&
+ &*2+c_var**2*log(c_var))/f_var**2/d_var
+ !
+ end select
+ !
+ end select
+ else if (nb_par == 2) then
+ select case(par3)
+ !
+ case(1)
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki*h_var**3/f_var**3/g_var*(log(z)+log(1._ki-z)+&
+ &z_log(s23,1._ki))+1._ki/3._ki/g_var*log(e_var)/f_var**3*e_v&
+ &ar**3-5._ki/6._ki*c_var/f_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/3._ki/f_var**3*log(c_var)*c_var/d_var**3*(3._ki*d_v&
+ &ar*f_var**2*h_var+3._ki*c_var*d_var**2*f_var+c_var**2*d_v&
+ &ar**2+c_var**2*d_var*f_var+c_var**2*f_var**2)+1._ki/3._ki*&
+ &h_var**3*(d_var**2+d_var*f_var+f_var**2)/d_var**3/f_var*&
+ &*3*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/6._ki*c_var*&
+ &(2._ki*c_var*d_var+2._ki*c_var*f_var-5._ki*d_var**2+5._ki*d_&
+ &var*f_var)/d_var**2/f_var**2
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/6._ki*z*h_var**2*(-2._ki*f_var*h_var*g_var+f_var**2*&
+ &h_var+2._ki*c_var*f_var*g_var-g_var**2*f_var-f_var**2*g_v&
+ &ar-3._ki*h_var*g_var**2)/f_var**4/g_var**2*(log(z)+log(1.&
+ &_ki-z)+z_log(s23,1._ki))-1._ki/6._ki*z/g_var**2*log(e_var)/f&
+ &_var**2*e_var**3-1._ki/6._ki*z*(g_var*f_var+f_var**2+c_var&
+ &**2+2._ki*c_var*f_var)/f_var**2/g_var-1._ki/2._ki*z*h_var**&
+ &2*(-d_var-h_var+g_var+2._ki*c_var)/f_var**4*(log(z)+log(1&
+ &._ki-z)+z_log(s23,1._ki))+1._ki/6._ki*z/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*c_var**2*z*(3._ki*d_var*f_var+c_var*d_var+2._ki&
+ &*c_var*f_var)/d_var**3/f_var**2*log(c_var)+1._ki/6._ki*z*h&
+ &_var**2*(-2._ki*c_var*d_var*f_var**2-2._ki*c_var*f_var**3+&
+ &d_var*f_var**2*h_var+d_var**2*f_var**2+d_var*f_var**3-2.&
+ &_ki*c_var*d_var**2*f_var+2._ki*d_var**2*f_var*h_var-2._ki*f&
+ &_var*d_var**3+6._ki*c_var*d_var**3)/d_var**3/f_var**4*(lo&
+ &g(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/6._ki*c_var*z*(2._k&
+ &i*c_var*f_var+c_var*d_var+2._ki*d_var*f_var)/d_var**2/f_v&
+ &ar**2
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/6._ki*(z-1)*h_var**2*(-2._ki*f_var*h_var*g_var+f_va&
+ &r**2*h_var+2._ki*c_var*f_var*g_var-g_var**2*f_var-f_var**&
+ &2*g_var-3._ki*h_var*g_var**2)/f_var**4/g_var**2*(log(z)+l&
+ &og(1._ki-z)+z_log(s23,1._ki))+1._ki/6._ki*(z-1)/g_var**2*log&
+ &(e_var)/f_var**2*e_var**3+1._ki/6._ki*(z-1)*(g_var*f_var+f&
+ &_var**2+c_var**2+2._ki*c_var*f_var)/f_var**2/g_var+1._ki/2&
+ &._ki*(z-1)*h_var**2*(-d_var-h_var+g_var+2._ki*c_var)/f_var&
+ &**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/6._ki*(z-1)&
+ &/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/6._ki*c_var**2*(z-1)*(3._ki*d_var*f_var+c_var*d_var&
+ &+2._ki*c_var*f_var)/d_var**3/f_var**2*log(c_var)-1._ki/6._k&
+ &i*(z-1)*h_var**2*(-2._ki*c_var*d_var*f_var**2-2._ki*c_var*&
+ &f_var**3+d_var*f_var**2*h_var+d_var**2*f_var**2+d_var*f_&
+ &var**3-2._ki*c_var*d_var**2*f_var+2._ki*d_var**2*f_var*h_v&
+ &ar-2._ki*f_var*d_var**3+6._ki*c_var*d_var**3)/d_var**3/f_v&
+ &ar**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/6._ki*(z-&
+ &1)*c_var*(2._ki*c_var*f_var+c_var*d_var+2._ki*d_var*f_var)&
+ &/d_var**2/f_var**2
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/6._ki*h_var**3*(-2._ki*g_var+f_var)/g_var**2/f_var*&
+ &*3*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/6._ki*e_var*&
+ &*2*(-f_var*e_var+2._ki*c_var*g_var-g_var*f_var)/g_var**2/&
+ &f_var**3*log(e_var)+1._ki/6._ki*(g_var+f_var+c_var)**2/f_v&
+ &ar**2/g_var+1._ki/6._ki/f_var**2*(g_var-2._ki*h_var)
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*c_var**2*(2._ki*c_var*d_var+c_var*f_var+3._ki*d&
+ &_var*f_var)/d_var**2/f_var**3*log(c_var)-1._ki/6._ki*h_var&
+ &**3*(2._ki*d_var+f_var)/d_var**2/f_var**3*(log(z)+log(1._k&
+ &i-z)+z_log(s23,1._ki))+1._ki/6._ki/d_var/f_var**2*c_var**2
+ !
+ end select
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki*z**2*h_var*(f_var**6+27._ki*g_var**5*f_var+f_&
+ &var**4*c_var**2-f_var**5*g_var+f_var**4*g_var**2+24._ki*f&
+ &_var**3*g_var**3+42._ki*f_var**2*g_var**4+2._ki*f_var**5*c&
+ &_var+24._ki*f_var**2*g_var**3*c_var-f_var**4*c_var*g_var+&
+ &33._ki*g_var**4*f_var*c_var+6._ki*g_var**3*f_var*c_var**2+&
+ &6._ki*g_var**6+6._ki*g_var**4*c_var**2+12._ki*g_var**5*c_va&
+ &r)/f_var**5/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,1._ki)&
+ &)+1._ki/3._ki*z**2/g_var**3*log(e_var)/f_var*e_var**3+1._ki&
+ &/6._ki*z**2*(c_var+f_var)*(2._ki*c_var+2._ki*f_var-g_var)/g&
+ &_var**2/f_var+1._ki/3._ki*z**2*(log(z)+log(1._ki-z)+z_log(s&
+ &23,1._ki))*h_var*(18._ki*c_var*d_var**2+6._ki*d_var**2*f_va&
+ &r+6._ki*f_var*c_var**2+3._ki*c_var*d_var*f_var+18._ki*d_var&
+ &**3-18._ki*g_var*d_var**2+6._ki*g_var**2*d_var-6._ki*c_var*&
+ &g_var**2-6._ki*g_var*d_var*f_var+3._ki*g_var**2*f_var+d_va&
+ &r*f_var**2-2._ki*f_var**2*g_var-3._ki*c_var*f_var*g_var+2.&
+ &_ki*c_var*f_var**2)/f_var**5
+ !
+ case(2)
+ !
+ fg=-1._ki/3._ki*c_var**3*z**2/d_var**3/f_var*log(c_var)+1._ki&
+ &/3._ki*z**2*h_var*(f_var**4*c_var**2+4._ki*c_var*d_var**3*&
+ &f_var**2-6._ki*c_var**2*d_var**3*f_var-c_var*f_var**4*d_v&
+ &ar+d_var**4*f_var**2-2._ki*d_var**3*f_var**3+f_var**4*d_v&
+ &ar**2-3._ki*d_var**4*c_var*f_var+6._ki*d_var**4*c_var**2)/&
+ &d_var**3/f_var**5*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1&
+ &._ki/6._ki*c_var*z**2*(2._ki*c_var-d_var)/d_var**2/f_var
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/3._ki*z*(z-1)*h_var*(f_var**6+27._ki*g_var**5*f_var+&
+ &f_var**4*c_var**2-f_var**5*g_var+f_var**4*g_var**2+24._ki&
+ &*f_var**3*g_var**3+42._ki*f_var**2*g_var**4+2._ki*f_var**5&
+ &*c_var+24._ki*f_var**2*g_var**3*c_var-f_var**4*c_var*g_va&
+ &r+33._ki*g_var**4*f_var*c_var+6._ki*g_var**3*f_var*c_var**&
+ &2+6._ki*g_var**6+6._ki*g_var**4*c_var**2+12._ki*g_var**5*c_&
+ &var)/f_var**5/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,1._k&
+ &i))-1._ki/3._ki*z*(z-1)/g_var**3*log(e_var)/f_var*e_var**3&
+ &-1._ki/6._ki*z*(z-1)*(c_var+f_var)*(2._ki*c_var+2._ki*f_var-&
+ &g_var)/g_var**2/f_var-1._ki/3._ki*z*(log(z)+log(1._ki-z)+z_&
+ &log(s23,1._ki))*h_var*(18._ki*c_var*d_var**2+6._ki*d_var**2&
+ &*f_var+6._ki*f_var*c_var**2+3._ki*c_var*d_var*f_var+18._ki*&
+ &d_var**3-18._ki*g_var*d_var**2+6._ki*g_var**2*d_var-6._ki*c&
+ &_var*g_var**2-6._ki*g_var*d_var*f_var+3._ki*g_var**2*f_var&
+ &+d_var*f_var**2-2._ki*f_var**2*g_var-3._ki*c_var*f_var*g_v&
+ &ar+2._ki*c_var*f_var**2)*(z-1)/f_var**5
+ !
+ case(2)
+ !
+ fg=1._ki/3._ki*z*c_var**3*(z-1)/d_var**3/f_var*log(c_var)-1.&
+ &_ki/3._ki*z*(z-1)*h_var*(f_var**4*c_var**2+4._ki*c_var*d_va&
+ &r**3*f_var**2-6._ki*c_var**2*d_var**3*f_var-c_var*f_var**&
+ &4*d_var+d_var**4*f_var**2-2._ki*d_var**3*f_var**3+f_var**&
+ &4*d_var**2-3._ki*d_var**4*c_var*f_var+6._ki*d_var**4*c_var&
+ &**2)/d_var**3/f_var**5*(log(z)+log(1._ki-z)+z_log(s23,1._k&
+ &i))+1._ki/6._ki*z*(z-1)*c_var*(2._ki*c_var-d_var)/d_var**2/&
+ &f_var
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/6._ki*z*h_var**2*(-2._ki*f_var**2*h_var*g_var+2._ki*f&
+ &_var**3*h_var+c_var*g_var*f_var**2+2._ki*f_var**2*g_var**&
+ &2-2._ki*f_var**3*g_var+2._ki*g_var**2*f_var*h_var-2._ki*g_v&
+ &ar**2*c_var*f_var+4._ki*g_var**3*f_var+6._ki*g_var**3*h_va&
+ &r)/g_var**3/f_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki)&
+ &)+1._ki/6._ki*z*e_var**2*(-2._ki*f_var*e_var+c_var*g_var-2.&
+ &_ki*g_var*f_var)/g_var**3/f_var**2*log(e_var)-1._ki/6._ki*z&
+ &*(4._ki*c_var*f_var**2+2._ki*f_var*c_var**2-g_var**2*f_var&
+ &+f_var**2*g_var+2._ki*f_var**3-c_var**2*g_var)/f_var**2/g&
+ &_var**2+1._ki/2._ki*z*h_var**2*(-2._ki*d_var+c_var-2._ki*h_v&
+ &ar+2._ki*g_var)/f_var**4*(log(z)+log(1._ki-z)+z_log(s23,1.&
+ &_ki))-1._ki/6._ki*z/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/6._ki*z*c_var**3/d_var**2/f_var**2*log(c_var)-1._ki&
+ &/6._ki*z*h_var**2*(-2._ki*c_var*d_var*f_var-c_var*f_var**2&
+ &+2._ki*d_var*f_var*h_var-2._ki*d_var**2*f_var+2._ki*d_var*f&
+ &_var**2+3._ki*c_var*d_var**2)/f_var**4/d_var**2*(log(z)+l&
+ &og(1._ki-z)+z_log(s23,1._ki))-1._ki/6._ki/f_var**2*z*c_var**&
+ &2/d_var
+ !
+ end select
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki*(z-1)**2*h_var*(f_var**6+27._ki*g_var**5*f_va&
+ &r+f_var**4*c_var**2-f_var**5*g_var+f_var**4*g_var**2+24.&
+ &_ki*f_var**3*g_var**3+42._ki*f_var**2*g_var**4+2._ki*f_var*&
+ &*5*c_var+24._ki*f_var**2*g_var**3*c_var-f_var**4*c_var*g_&
+ &var+33._ki*g_var**4*f_var*c_var+6._ki*g_var**3*f_var*c_var&
+ &**2+6._ki*g_var**6+6._ki*g_var**4*c_var**2+12._ki*g_var**5*&
+ &c_var)/f_var**5/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,1&
+ &._ki))+1._ki/3._ki*(z-1)**2/g_var**3*log(e_var)/f_var*e_var&
+ &**3+1._ki/6._ki*(z-1)**2*(c_var+f_var)*(2._ki*c_var+2._ki*f_&
+ &var-g_var)/g_var**2/f_var+1._ki/3._ki*(log(z)+log(1._ki-z)+&
+ &z_log(s23,1._ki))*h_var*(z-1)**2*(18._ki*c_var*d_var**2+6.&
+ &_ki*d_var**2*f_var+6._ki*f_var*c_var**2+3._ki*c_var*d_var*f&
+ &_var+18._ki*d_var**3-18._ki*g_var*d_var**2+6._ki*g_var**2*d&
+ &_var-6._ki*c_var*g_var**2-6._ki*g_var*d_var*f_var+3._ki*g_v&
+ &ar**2*f_var+d_var*f_var**2-2._ki*f_var**2*g_var-3._ki*c_va&
+ &r*f_var*g_var+2._ki*c_var*f_var**2)/f_var**5
+ !
+ case(2)
+ !
+ fg=-1._ki/3._ki*c_var**3*(z-1)**2/f_var/d_var**3*log(c_var)+&
+ &1._ki/3._ki*(z-1)**2*h_var*(f_var**4*c_var**2+4._ki*c_var*d&
+ &_var**3*f_var**2-6._ki*c_var**2*d_var**3*f_var-c_var*f_va&
+ &r**4*d_var+d_var**4*f_var**2-2._ki*d_var**3*f_var**3+f_va&
+ &r**4*d_var**2-3._ki*d_var**4*c_var*f_var+6._ki*d_var**4*c_&
+ &var**2)/d_var**3/f_var**5*(log(z)+log(1._ki-z)+z_log(s23,&
+ &1._ki))-1._ki/6._ki*(z-1)**2*c_var*(2._ki*c_var-d_var)/d_var&
+ &**2/f_var
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/6._ki*(z-1)*h_var**2*(-2._ki*f_var**2*h_var*g_var+2&
+ &._ki*f_var**3*h_var+c_var*g_var*f_var**2+2._ki*f_var**2*g_&
+ &var**2-2._ki*f_var**3*g_var+2._ki*g_var**2*f_var*h_var-2._k&
+ &i*g_var**2*c_var*f_var+4._ki*g_var**3*f_var+6._ki*g_var**3&
+ &*h_var)/f_var**4/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,&
+ &1._ki))-1._ki/6._ki*(z-1)*e_var**2*(-2._ki*f_var*e_var+c_var&
+ &*g_var-2._ki*g_var*f_var)/f_var**2/g_var**3*log(e_var)+1.&
+ &_ki/6._ki*(z-1)*(4._ki*c_var*f_var**2+2._ki*f_var*c_var**2-g&
+ &_var**2*f_var+f_var**2*g_var+2._ki*f_var**3-c_var**2*g_va&
+ &r)/f_var**2/g_var**2-1._ki/2._ki*(z-1)*h_var**2*(-2._ki*d_v&
+ &ar+c_var-2._ki*h_var+2._ki*g_var)/f_var**4*(log(z)+log(1._k&
+ &i-z)+z_log(s23,1._ki))+1._ki/6._ki*(z-1)/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*c_var**3/d_var**2*(z-1)/f_var**2*log(c_var)+1&
+ &._ki/6._ki*(z-1)*h_var**2*(-2._ki*c_var*d_var*f_var-c_var*f&
+ &_var**2+2._ki*d_var*f_var*h_var-2._ki*d_var**2*f_var+2._ki*&
+ &d_var*f_var**2+3._ki*c_var*d_var**2)/f_var**4/d_var**2*(l&
+ &og(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/6._ki*(z-1)*c_var&
+ &**2/f_var**2/d_var
+ !
+ end select
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki*h_var**3*(-g_var*f_var+f_var**2+g_var**2)/f_&
+ &var**3/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._k&
+ &i/3._ki/g_var**3*log(e_var)/f_var**3*e_var*(-c_var**2*g_v&
+ &ar*f_var+c_var**2*f_var**2+c_var**2*g_var**2+2._ki*c_var*&
+ &f_var**3+c_var*g_var*f_var**2-g_var**2*c_var*f_var+2._ki*&
+ &f_var**3*g_var+f_var**4+f_var**2*g_var**2)+1._ki/6._ki*(g_&
+ &var+f_var+c_var)*(2._ki*f_var**2+g_var*f_var+2._ki*c_var*f&
+ &_var-2._ki*c_var*g_var-g_var**2)/f_var**2/g_var**2+1._ki/6&
+ &._ki/f_var**2*(3._ki*c_var+g_var)
+ !
+ case(2)
+ !
+ fg=-1._ki/3._ki*c_var**3/d_var/f_var**3*log(c_var)+1._ki/3._ki&
+ &*(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_var**3/f_var**3/&
+ &d_var
+ !
+ end select
+ !
+ end select
+ !
+ end select
+ !
+ else if (nb_par == 3) then
+ !
+ select case(par2)
+ !
+ case(1)
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/4._ki*h_var**4/f_var**4/g_var*(log(z)+log(1._ki-z)+&
+ &z_log(s23,1._ki))+1._ki/4._ki/g_var*log(e_var)/f_var**4*e_v&
+ &ar**4-1._ki/12._ki*c_var/f_var**3*(-13._ki*g_var+13._ki*f_va&
+ &r+21._ki*c_var)
+ !
+ case(2)
+ !
+ fg=-1._ki/4._ki/f_var**4*log(c_var)*c_var/d_var**4*(2._ki*d_v&
+ &ar*f_var+c_var*d_var+c_var*f_var)*(2._ki*d_var*f_var**2*h&
+ &_var+c_var**2*d_var**2+2._ki*c_var*d_var**2*f_var+c_var**&
+ &2*f_var**2)+1._ki/4._ki*h_var**4*(d_var+f_var)*(d_var**2+f&
+ &_var**2)/f_var**4/d_var**4*(log(z)+log(1._ki-z)+z_log(s23&
+ &,1._ki))-1._ki/24._ki*c_var*(6._ki*c_var**2*d_var**2+6._ki*c_&
+ &var**2*d_var*f_var+6._ki*c_var**2*f_var**2-42._ki*c_var*d_&
+ &var**3+21._ki*c_var*d_var**2*f_var+21._ki*c_var*f_var**2*d&
+ &_var+26._ki*d_var**4-52._ki*d_var**3*f_var+26._ki*f_var**2*&
+ &d_var**2)/f_var**3/d_var**3
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*z*h_var**3*(-3._ki*h_var*f_var*g_var+f_var**2&
+ &*h_var+3._ki*c_var*f_var*g_var+3._ki*g_var**2*f_var-g_var*&
+ &f_var**2-12._ki*c_var*g_var**2)/f_var**5/g_var**2*(log(z)&
+ &+log(1._ki-z)+z_log(s23,1._ki))-1._ki/12._ki*z/g_var**2*log(&
+ &e_var)/f_var**3*e_var**4-1._ki/12._ki*z/f_var**3*(f_var**3&
+ &+c_var**3+3._ki*c_var*h_var*f_var-6._ki*c_var*f_var*g_var)&
+ &/g_var
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*z*c_var**2*(4._ki*c_var*d_var**2*f_var+8._ki*c&
+ &_var*f_var**2*d_var+6._ki*f_var**2*d_var**2+c_var**2*d_va&
+ &r**2+2._ki*c_var**2*d_var*f_var+3._ki*c_var**2*f_var**2)/d&
+ &_var**4/f_var**3*log(c_var)+1._ki/12._ki*z*h_var**3*(-3._ki&
+ &*c_var*f_var**3*d_var-3._ki*c_var*f_var**4+f_var**3*d_var&
+ &*h_var+f_var**3*d_var**2+f_var**4*d_var-3._ki*c_var*d_var&
+ &**2*f_var**2+2._ki*d_var**2*f_var**2*h_var+f_var**2*d_var&
+ &**3-3._ki*d_var**3*f_var*c_var+3._ki*f_var*d_var**3*h_var-&
+ &3._ki*f_var*d_var**4+12._ki*c_var*d_var**4)/d_var**4/f_var&
+ &**5*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/24._ki*z*c_&
+ &var*(4._ki*c_var**2*d_var*f_var+6._ki*c_var**2*f_var**2+6.&
+ &_ki*c_var*d_var**2*f_var+13._ki*c_var*f_var**2*d_var+2._ki*&
+ &c_var**2*d_var**2-6._ki*d_var**3*f_var+6._ki*f_var**2*d_va&
+ &r**2)/f_var**3/d_var**3
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*(-1._ki+z)*h_var**3*(-3._ki*h_var*f_var*g_var&
+ &+f_var**2*h_var+3._ki*c_var*f_var*g_var+3._ki*g_var**2*f_v&
+ &ar-g_var*f_var**2-12._ki*c_var*g_var**2)/f_var**5/g_var**&
+ &2*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/12._ki*(-1._ki&
+ &+z)/g_var**2*log(e_var)/f_var**3*e_var**4+1._ki/12._ki*(-1&
+ &._ki+z)/f_var**3*(f_var**3+c_var**3+3._ki*c_var*h_var*f_va&
+ &r-6._ki*c_var*f_var*g_var)/g_var
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*c_var**2*(4._ki*c_var*d_var**2*f_var+8._ki*c_&
+ &var*f_var**2*d_var+6._ki*f_var**2*d_var**2+c_var**2*d_var&
+ &**2+2._ki*c_var**2*d_var*f_var+3._ki*c_var**2*f_var**2)*(-&
+ &1._ki+z)/d_var**4/f_var**3*log(c_var)-1._ki/12._ki*(-1._ki+z&
+ &)*h_var**3*(-3._ki*c_var*f_var**3*d_var-3._ki*c_var*f_var*&
+ &*4+f_var**3*d_var*h_var+f_var**3*d_var**2+f_var**4*d_var&
+ &-3._ki*c_var*d_var**2*f_var**2+2._ki*d_var**2*f_var**2*h_v&
+ &ar+f_var**2*d_var**3-3._ki*d_var**3*f_var*c_var+3._ki*f_va&
+ &r*d_var**3*h_var-3._ki*f_var*d_var**4+12._ki*c_var*d_var**&
+ &4)/d_var**4/f_var**5*(log(z)+log(1._ki-z)+z_log(s23,1._ki)&
+ &)-1._ki/24._ki*(-1._ki+z)*c_var*(4._ki*c_var**2*d_var*f_var+&
+ &6._ki*c_var**2*f_var**2+6._ki*c_var*d_var**2*f_var+13._ki*c&
+ &_var*f_var**2*d_var+2._ki*c_var**2*d_var**2-6._ki*d_var**3&
+ &*f_var+6._ki*f_var**2*d_var**2)/d_var**3/f_var**3
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*h_var**4*(-3._ki*g_var+f_var)/g_var**2/f_var&
+ &**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/12._ki*e_va&
+ &r**3*(-f_var*e_var+3._ki*c_var*g_var-g_var*f_var)/g_var**&
+ &2/f_var**4*log(e_var)+1._ki/24._ki*(-6._ki*g_var**3-6._ki*g_&
+ &var**2*f_var+2._ki*f_var**3+6._ki*c_var*h_var*g_var+6._ki*c&
+ &_var*h_var*f_var+2._ki*c_var**3+c_var**2*g_var-12._ki*c_va&
+ &r*g_var**2-12._ki*c_var*f_var*g_var+6._ki*g_var**2*h_var)/&
+ &f_var**3/g_var
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*c_var**2*(3._ki*c_var**2*d_var**2+2._ki*c_var*&
+ &*2*d_var*f_var+c_var**2*f_var**2+8._ki*c_var*d_var**2*f_v&
+ &ar+4._ki*c_var*f_var**2*d_var+6._ki*f_var**2*d_var**2)/d_v&
+ &ar**3/f_var**4*log(c_var)-1._ki/12._ki*h_var**4*(3._ki*d_va&
+ &r**2+2._ki*d_var*f_var+f_var**2)/d_var**3/f_var**4*(log(z&
+ &)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/24._ki*c_var**2*(4._ki&
+ &*c_var*d_var+2._ki*c_var*f_var-7._ki*d_var**2+7._ki*d_var*f&
+ &_var)/f_var**3/d_var**2
+ !
+ end select
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*z**2*h_var**2*(-4._ki*f_var**3*g_var**3+f_va&
+ &r**4*c_var**2+2._ki*c_var*f_var**5+6._ki*f_var**2*g_var**3&
+ &*c_var-2._ki*f_var**4*g_var*c_var-12._ki*g_var**4*f_var*c_&
+ &var+f_var**6+3._ki*f_var**2*g_var**4+3._ki*f_var**4*g_var*&
+ &*2-2._ki*f_var**5*g_var+30._ki*g_var**4*c_var**2)/f_var**6&
+ &/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/12._k&
+ &i*z**2/g_var**3*log(e_var)/f_var**2*e_var**4+1._ki/24._ki*&
+ &z**2*(-g_var*f_var**2+2._ki*f_var**3+6._ki*c_var*h_var*f_v&
+ &ar+2._ki*c_var**3-c_var**2*g_var-8._ki*c_var*f_var*g_var)/&
+ &f_var**2/g_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*z**2*c_var**3*(c_var*d_var+4._ki*d_var*f_var&
+ &+3._ki*c_var*f_var)/d_var**4/f_var**2*log(c_var)+1._ki/12.&
+ &_ki*z**2*h_var**2*(18._ki*c_var*d_var**4*f_var**2-30._ki*d_&
+ &var**4*c_var**2*f_var-12._ki*d_var**5*c_var*f_var-2._ki*c_&
+ &var*f_var**5*d_var+f_var**5*d_var**2+f_var**4*c_var**2*d&
+ &_var-2._ki*f_var**4*c_var*d_var**2-7._ki*f_var**3*d_var**4&
+ &+3._ki*f_var**4*d_var**3+3._ki*d_var**5*f_var**2+3._ki*c_va&
+ &r**2*f_var**5+30._ki*d_var**5*c_var**2)/f_var**6/d_var**4&
+ &*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/24._ki*c_var*z&
+ &**2*(-2._ki*d_var**2*f_var-c_var*d_var**2+6._ki*f_var*c_va&
+ &r**2+5._ki*d_var*c_var*f_var+2._ki*d_var*c_var**2)/f_var**&
+ &2/d_var**3
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*z*(-1._ki+z)*h_var**2*(-4._ki*f_var**3*g_var**&
+ &3+f_var**4*c_var**2+2._ki*c_var*f_var**5+6._ki*f_var**2*g_&
+ &var**3*c_var-2._ki*f_var**4*g_var*c_var-12._ki*g_var**4*f_&
+ &var*c_var+f_var**6+3._ki*f_var**2*g_var**4+3._ki*f_var**4*&
+ &g_var**2-2._ki*f_var**5*g_var+30._ki*g_var**4*c_var**2)/f_&
+ &var**6/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._k&
+ &i/12._ki*z*(-1._ki+z)/g_var**3*log(e_var)/f_var**2*e_var**&
+ &4-1._ki/24._ki*z*(-1._ki+z)*(-g_var*f_var**2+2._ki*f_var**3+&
+ &6._ki*c_var*h_var*f_var+2._ki*c_var**3-c_var**2*g_var-8._ki&
+ &*c_var*f_var*g_var)/f_var**2/g_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*z*c_var**3*(c_var*d_var+4._ki*d_var*f_var+3._k&
+ &i*c_var*f_var)*(-1._ki+z)/d_var**4/f_var**2*log(c_var)-1.&
+ &_ki/12._ki*z*(-1._ki+z)*h_var**2*(18._ki*c_var*d_var**4*f_va&
+ &r**2-30._ki*d_var**4*c_var**2*f_var-12._ki*d_var**5*c_var*&
+ &f_var-2._ki*c_var*f_var**5*d_var+f_var**5*d_var**2+f_var*&
+ &*4*c_var**2*d_var-2._ki*f_var**4*c_var*d_var**2-7._ki*f_va&
+ &r**3*d_var**4+3._ki*f_var**4*d_var**3+3._ki*d_var**5*f_var&
+ &**2+3._ki*c_var**2*f_var**5+30._ki*d_var**5*c_var**2)/f_va&
+ &r**6/d_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/&
+ &24._ki*z*(-1._ki+z)*c_var*(-2._ki*d_var**2*f_var-c_var*d_va&
+ &r**2+6._ki*f_var*c_var**2+5._ki*d_var*c_var*f_var+2._ki*d_v&
+ &ar*c_var**2)/f_var**2/d_var**3
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*z*h_var**3*(-2._ki*f_var**2*h_var*g_var+f_var&
+ &**3*h_var+g_var*f_var**2*c_var+2._ki*f_var**2*g_var**2-f_&
+ &var**3*g_var+3._ki*g_var**2*f_var*h_var-3._ki*g_var**2*c_v&
+ &ar*f_var-3._ki*g_var**3*f_var+6._ki*g_var**3*c_var)/f_var*&
+ &*5/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/12&
+ &._ki*z*e_var**3*(-f_var*e_var+c_var*g_var-g_var*f_var)/f_&
+ &var**3/g_var**3*log(e_var)-1._ki/24._ki*z/f_var**3*(-6._ki*&
+ &g_var**2*c_var*f_var+6._ki*f_var*c_var*h_var*g_var+6._ki*c&
+ &_var*h_var*f_var**2+2._ki*f_var*c_var**3+f_var**3*g_var+2&
+ &._ki*f_var**4-2._ki*g_var*c_var**3-9._ki*g_var*f_var*c_var*&
+ &*2-12._ki*g_var*f_var**2*c_var)/g_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*z*c_var**3*(2._ki*d_var*f_var+c_var*d_var+c_&
+ &var*f_var)/d_var**3/f_var**3*log(c_var)-1._ki/12._ki*z*h_v&
+ &ar**3*(-2._ki*c_var*f_var**2*d_var-c_var*f_var**3+d_var*f&
+ &_var**2*h_var+2._ki*f_var**2*d_var**2+f_var**3*d_var-3._ki&
+ &*c_var*d_var**2*f_var+3._ki*d_var**2*f_var*h_var-3._ki*d_v&
+ &ar**3*f_var+6._ki*c_var*d_var**3)/d_var**3/f_var**5*(log(&
+ &z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/24._ki*z*c_var**2*(2&
+ &._ki*c_var*f_var+2._ki*c_var*d_var+3._ki*d_var*f_var)/f_var&
+ &**3/d_var**2
+ !
+ end select
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*(-1._ki+z)**2*h_var**2*(-4._ki*f_var**3*g_var&
+ &**3+f_var**4*c_var**2+2._ki*c_var*f_var**5+6._ki*f_var**2*&
+ &g_var**3*c_var-2._ki*f_var**4*g_var*c_var-12._ki*g_var**4*&
+ &f_var*c_var+f_var**6+3._ki*f_var**2*g_var**4+3._ki*f_var**&
+ &4*g_var**2-2._ki*f_var**5*g_var+30._ki*g_var**4*c_var**2)/&
+ &f_var**6/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1&
+ &._ki/12._ki*(-1._ki+z)**2/g_var**3*log(e_var)/f_var**2*e_va&
+ &r**4+1._ki/24._ki*(-1._ki+z)**2*(-g_var*f_var**2+2._ki*f_var&
+ &**3+6._ki*c_var*h_var*f_var+2._ki*c_var**3-c_var**2*g_var-&
+ &8._ki*c_var*f_var*g_var)/f_var**2/g_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*c_var**3*(-1._ki+z)**2*(c_var*d_var+4._ki*d_v&
+ &ar*f_var+3._ki*c_var*f_var)/f_var**2/d_var**4*log(c_var)+&
+ &1._ki/12._ki*(-1._ki+z)**2*h_var**2*(18._ki*c_var*d_var**4*f&
+ &_var**2-30._ki*d_var**4*c_var**2*f_var-12._ki*d_var**5*c_v&
+ &ar*f_var-2._ki*c_var*f_var**5*d_var+f_var**5*d_var**2+f_v&
+ &ar**4*c_var**2*d_var-2._ki*f_var**4*c_var*d_var**2-7._ki*f&
+ &_var**3*d_var**4+3._ki*f_var**4*d_var**3+3._ki*d_var**5*f_&
+ &var**2+3._ki*c_var**2*f_var**5+30._ki*d_var**5*c_var**2)/f&
+ &_var**6/d_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1.&
+ &_ki/24._ki*(-1._ki+z)**2*c_var*(-2._ki*d_var**2*f_var-c_var*&
+ &d_var**2+6._ki*f_var*c_var**2+5._ki*d_var*c_var*f_var+2._ki&
+ &*d_var*c_var**2)/f_var**2/d_var**3
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*(-1._ki+z)*h_var**3*(-2._ki*f_var**2*h_var*g_&
+ &var+f_var**3*h_var+g_var*f_var**2*c_var+2._ki*f_var**2*g_&
+ &var**2-f_var**3*g_var+3._ki*g_var**2*f_var*h_var-3._ki*g_v&
+ &ar**2*c_var*f_var-3._ki*g_var**3*f_var+6._ki*g_var**3*c_va&
+ &r)/f_var**5/g_var**3*(log(z)+log(1._ki-z)+z_log(s23,1._ki)&
+ &)-1._ki/12._ki*(-1._ki+z)*e_var**3*(-f_var*e_var+c_var*g_va&
+ &r-g_var*f_var)/f_var**3/g_var**3*log(e_var)+1._ki/24._ki*(&
+ &-1._ki+z)/f_var**3*(-6._ki*g_var**2*c_var*f_var+6._ki*f_var&
+ &*c_var*h_var*g_var+6._ki*c_var*h_var*f_var**2+2._ki*f_var*&
+ &c_var**3+f_var**3*g_var+2._ki*f_var**4-2._ki*g_var*c_var**&
+ &3-9._ki*g_var*f_var*c_var**2-12._ki*g_var*f_var**2*c_var)/&
+ &g_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*c_var**3*(2._ki*d_var*f_var+c_var*d_var+c_var&
+ &*f_var)*(-1._ki+z)/d_var**3/f_var**3*log(c_var)+1._ki/12._k&
+ &i*(-1._ki+z)*h_var**3*(-2._ki*c_var*f_var**2*d_var-c_var*f&
+ &_var**3+d_var*f_var**2*h_var+2._ki*f_var**2*d_var**2+f_va&
+ &r**3*d_var-3._ki*c_var*d_var**2*f_var+3._ki*d_var**2*f_var&
+ &*h_var-3._ki*d_var**3*f_var+6._ki*c_var*d_var**3)/f_var**5&
+ &/d_var**3*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/24._k&
+ &i*(-1._ki+z)*c_var**2*(2._ki*c_var*f_var+2._ki*c_var*d_var+&
+ &3._ki*d_var*f_var)/f_var**3/d_var**2
+ !
+ end select
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*h_var**4*(f_var**2-2._ki*g_var*f_var+3._ki*g_&
+ &var**2)/g_var**3/f_var**4*(log(z)+log(1._ki-z)+z_log(s23,&
+ &1._ki))+1._ki/12._ki/g_var**3*log(e_var)/f_var**4*e_var**2*&
+ &(c_var**2*f_var**2-2._ki*g_var*f_var*c_var**2+3._ki*c_var*&
+ &*2*g_var**2-2._ki*g_var**2*c_var*f_var+2._ki*c_var*f_var**&
+ &3+f_var**4+2._ki*f_var**3*g_var+f_var**2*g_var**2)+1._ki/2&
+ &4._ki*(-6._ki*c_var**2*g_var**2-16._ki*g_var*f_var**2*c_var&
+ &+6._ki*c_var*h_var*f_var**2-17._ki*g_var*f_var*c_var**2-18&
+ &._ki*g_var**2*c_var*f_var+2._ki*f_var*c_var**3+12._ki*f_var&
+ &*c_var*h_var*g_var-4._ki*g_var*c_var**3-6._ki*g_var**3*c_v&
+ &ar+6._ki*c_var*h_var*g_var**2+3._ki*f_var**3*g_var+2._ki*f_&
+ &var**4)/f_var**3/g_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*c_var**3*(3._ki*c_var*d_var+c_var*f_var+4._ki&
+ &*d_var*f_var)/f_var**4/d_var**2*log(c_var)+1._ki/12._ki*h_&
+ &var**4*(3._ki*d_var+f_var)/f_var**4/d_var**2*(log(z)+log(&
+ &1._ki-z)+z_log(s23,1._ki))-1._ki/12._ki/d_var/f_var**3*c_var&
+ &**3
+ !
+ end select
+ !
+ end select
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ select case(par4)
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/4._ki*z**3*h_var*(2._ki*f_var**7*h_var*c_var+4._ki*f_&
+ &var**4*h_var*g_var**3*c_var+f_var**6*h_var*c_var**2+2._ki&
+ &*g_var**4*f_var**3*h_var**2-2._ki*g_var*f_var**6*h_var**2&
+ &+2._ki*g_var**2*f_var**5*h_var**2-2._ki*g_var**3*f_var**4*&
+ &h_var**2-3._ki*f_var**3*h_var*g_var**5+3._ki*f_var**4*h_va&
+ &r*g_var**4-3._ki*f_var**5*h_var*g_var**3+3._ki*f_var**6*h_&
+ &var*g_var**2+f_var**7*h_var*g_var+f_var**8*h_var-4._ki*f_&
+ &var**3*h_var*g_var**3*c_var**2+2._ki*f_var**4*h_var*c_var&
+ &**2*g_var**2-f_var**5*h_var*g_var*c_var**2-2._ki*f_var**5&
+ &*h_var*c_var*g_var**2+6._ki*g_var**4*f_var**2*h_var*c_var&
+ &**2+8._ki*g_var**5*f_var**2*h_var*c_var-10._ki*g_var**5*f_&
+ &var*h_var*c_var**2-6._ki*f_var**3*h_var*c_var*g_var**4+g_&
+ &var**3*f_var**5*c_var-g_var**2*f_var**5*c_var**2+10._ki*g&
+ &_var**6*c_var**2*f_var+10._ki*g_var**5*c_var**3*f_var-4._k&
+ &i*g_var**6*f_var**2*c_var+3._ki*f_var**3*g_var**5*c_var-8&
+ &._ki*g_var**4*f_var**2*c_var**3-6._ki*g_var**5*f_var**2*c_&
+ &var**2-g_var*f_var**7*c_var-2._ki*g_var**2*f_var**4*c_var&
+ &**3-2._ki*g_var**4*f_var**4*c_var+g_var*f_var**5*c_var**3&
+ &+g_var*f_var**6*c_var**2+2._ki*g_var**4*f_var**3*c_var**2&
+ &+4._ki*g_var**3*f_var**3*c_var**3-g_var**5*f_var**4-g_var&
+ &*f_var**8-20._ki*g_var**6*c_var**3-g_var**3*f_var**6-g_va&
+ &r**2*f_var**7+g_var**4*f_var**5+g_var**6*f_var**3)/f_var&
+ &**7/g_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/4&
+ &._ki*z**3/g_var**4*log(e_var)/f_var*e_var**4-1._ki/24._ki*z&
+ &**3*(2._ki*g_var**2*f_var-3._ki*g_var*f_var**2+6._ki*f_var*&
+ &*3+6._ki*c_var**3+18._ki*c_var*h_var*f_var-24._ki*c_var*f_v&
+ &ar*g_var-3._ki*c_var**2*g_var+2._ki*c_var*g_var**2)/g_var*&
+ &*3/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/4._ki*z**3*c_var**4/d_var**4/f_var*log(c_var)+1._ki/&
+ &4._ki*z**3*h_var*(2._ki*d_var**3*f_var**4*h_var**2+3._ki*d_&
+ &var**3*f_var**5*h_var-2._ki*d_var**4*f_var**3*h_var**2-6.&
+ &_ki*d_var**4*f_var**4*h_var+3._ki*f_var**3*d_var**5*h_var-&
+ &4._ki*c_var*d_var**3*f_var**4*h_var+10._ki*d_var**5*c_var*&
+ &*2*f_var*h_var+4._ki*f_var**3*d_var**3*c_var**2*h_var+2._k&
+ &i*f_var**4*d_var**2*c_var**2*h_var-8._ki*d_var**5*f_var**&
+ &2*h_var*c_var-f_var**6*c_var**3+20._ki*d_var**6*c_var**3-&
+ &3._ki*d_var**4*f_var**5+3._ki*d_var**5*f_var**4-d_var**6*f&
+ &_var**3+d_var**3*f_var**6+f_var**5*d_var*c_var**2*h_var-&
+ &2._ki*c_var*d_var**2*f_var**5*h_var-16._ki*c_var**2*d_var*&
+ &*4*f_var**2*h_var+14._ki*c_var*d_var**4*f_var**3*h_var+4.&
+ &_ki*d_var**6*f_var**2*c_var-c_var*d_var**2*f_var**6-50._ki&
+ &*c_var**3*d_var**5*f_var-c_var*d_var**3*f_var**5+9._ki*c_&
+ &var*d_var**4*f_var**4-11._ki*c_var*d_var**5*f_var**3+26._k&
+ &i*c_var**2*d_var**5*f_var**2-10._ki*d_var**6*c_var**2*f_v&
+ &ar-4._ki*f_var**3*c_var**3*d_var**3-2._ki*f_var**4*c_var**&
+ &3*d_var**2-f_var**5*c_var**3*d_var-18._ki*f_var**3*d_var*&
+ &*4*c_var**2+f_var**5*d_var**2*c_var**2+f_var**6*d_var*c_&
+ &var**2+38._ki*f_var**2*d_var**4*c_var**3)/f_var**7/d_var*&
+ &*4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/24._ki*c_var&
+ &*z**3*(6._ki*c_var**2-3._ki*c_var*d_var+2._ki*d_var**2)/d_v&
+ &ar**3/f_var
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/4._ki*z**2*(-1._ki+z)*h_var*(2._ki*f_var**7*h_var*c_&
+ &var+4._ki*f_var**4*h_var*g_var**3*c_var+f_var**6*h_var*c_&
+ &var**2+2._ki*g_var**4*f_var**3*h_var**2-2._ki*g_var*f_var*&
+ &*6*h_var**2+2._ki*g_var**2*f_var**5*h_var**2-2._ki*g_var**&
+ &3*f_var**4*h_var**2-3._ki*f_var**3*h_var*g_var**5+3._ki*f_&
+ &var**4*h_var*g_var**4-3._ki*f_var**5*h_var*g_var**3+3._ki*&
+ &f_var**6*h_var*g_var**2+f_var**7*h_var*g_var+f_var**8*h_&
+ &var-4._ki*f_var**3*h_var*g_var**3*c_var**2+2._ki*f_var**4*&
+ &h_var*c_var**2*g_var**2-f_var**5*h_var*g_var*c_var**2-2.&
+ &_ki*f_var**5*h_var*c_var*g_var**2+6._ki*g_var**4*f_var**2*&
+ &h_var*c_var**2+8._ki*g_var**5*f_var**2*h_var*c_var-10._ki*&
+ &g_var**5*f_var*h_var*c_var**2-6._ki*f_var**3*h_var*c_var*&
+ &g_var**4+g_var**3*f_var**5*c_var-g_var**2*f_var**5*c_var&
+ &**2+10._ki*g_var**6*c_var**2*f_var+10._ki*g_var**5*c_var**&
+ &3*f_var-4._ki*g_var**6*f_var**2*c_var+3._ki*f_var**3*g_var&
+ &**5*c_var-8._ki*g_var**4*f_var**2*c_var**3-6._ki*g_var**5*&
+ &f_var**2*c_var**2-g_var*f_var**7*c_var-2._ki*g_var**2*f_v&
+ &ar**4*c_var**3-2._ki*g_var**4*f_var**4*c_var+g_var*f_var*&
+ &*5*c_var**3+g_var*f_var**6*c_var**2+2._ki*g_var**4*f_var*&
+ &*3*c_var**2+4._ki*g_var**3*f_var**3*c_var**3-g_var**5*f_v&
+ &ar**4-g_var*f_var**8-20._ki*g_var**6*c_var**3-g_var**3*f_&
+ &var**6-g_var**2*f_var**7+g_var**4*f_var**5+g_var**6*f_va&
+ &r**3)/f_var**7/g_var**4*(log(z)+log(1._ki-z)+z_log(s23,1.&
+ &_ki))+1._ki/4._ki*z**2*(-1._ki+z)/g_var**4*log(e_var)/f_var*&
+ &e_var**4+1._ki/24._ki*z**2*(2._ki*g_var**2*f_var-3._ki*g_var&
+ &*f_var**2+6._ki*f_var**3+6._ki*c_var**3+18._ki*c_var*h_var*&
+ &f_var-24._ki*c_var*f_var*g_var-3._ki*c_var**2*g_var+2._ki*c&
+ &_var*g_var**2)*(-1._ki+z)/g_var**3/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/4._ki*z**2*c_var**4*(-1._ki+z)/f_var/d_var**4*log(c&
+ &_var)-1._ki/4._ki*z**2*(-1._ki+z)*h_var*(2._ki*d_var**3*f_va&
+ &r**4*h_var**2+3._ki*d_var**3*f_var**5*h_var-2._ki*d_var**4&
+ &*f_var**3*h_var**2-6._ki*d_var**4*f_var**4*h_var+3._ki*f_v&
+ &ar**3*d_var**5*h_var-4._ki*c_var*d_var**3*f_var**4*h_var+&
+ &10._ki*d_var**5*c_var**2*f_var*h_var+4._ki*f_var**3*d_var*&
+ &*3*c_var**2*h_var+2._ki*f_var**4*d_var**2*c_var**2*h_var-&
+ &8._ki*d_var**5*f_var**2*h_var*c_var-f_var**6*c_var**3+20.&
+ &_ki*d_var**6*c_var**3-3._ki*d_var**4*f_var**5+3._ki*d_var**&
+ &5*f_var**4-d_var**6*f_var**3+d_var**3*f_var**6+f_var**5*&
+ &d_var*c_var**2*h_var-2._ki*c_var*d_var**2*f_var**5*h_var-&
+ &16._ki*c_var**2*d_var**4*f_var**2*h_var+14._ki*c_var*d_var&
+ &**4*f_var**3*h_var+4._ki*d_var**6*f_var**2*c_var-c_var*d_&
+ &var**2*f_var**6-50._ki*c_var**3*d_var**5*f_var-c_var*d_va&
+ &r**3*f_var**5+9._ki*c_var*d_var**4*f_var**4-11._ki*c_var*d&
+ &_var**5*f_var**3+26._ki*c_var**2*d_var**5*f_var**2-10._ki*&
+ &d_var**6*c_var**2*f_var-4._ki*f_var**3*c_var**3*d_var**3-&
+ &2._ki*f_var**4*c_var**3*d_var**2-f_var**5*c_var**3*d_var-&
+ &18._ki*f_var**3*d_var**4*c_var**2+f_var**5*d_var**2*c_var&
+ &**2+f_var**6*d_var*c_var**2+38._ki*f_var**2*d_var**4*c_va&
+ &r**3)/f_var**7/d_var**4*(log(z)+log(1._ki-z)+z_log(s23,1.&
+ &_ki))-1._ki/24._ki*z**2*(-1._ki+z)*c_var*(6._ki*c_var**2-3._ki&
+ &*c_var*d_var+2._ki*d_var**2)/d_var**3/f_var
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*z**2*h_var**2*(3._ki*f_var**7-3._ki*f_var**6*&
+ &g_var+3._ki*f_var**5*g_var**2-3._ki*f_var**4*g_var**3+3._ki&
+ &*f_var**3*g_var**4+6._ki*f_var**6*c_var+2._ki*f_var**4*g_v&
+ &ar**2*c_var-f_var**4*g_var*c_var**2-4._ki*f_var**5*g_var*&
+ &c_var-3._ki*g_var**5*f_var**2-10._ki*g_var**5*c_var**2+3._k&
+ &i*c_var**2*f_var**5-2._ki*g_var**4*f_var**2*c_var-2._ki*g_&
+ &var**4*f_var*c_var**2+8._ki*g_var**5*f_var*c_var)/f_var**&
+ &6/g_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/12.&
+ &_ki*z**2*e_var**3*(-3._ki*f_var*e_var+c_var*g_var-3._ki*g_v&
+ &ar*f_var)/f_var**2/g_var**4*log(e_var)+1._ki/24._ki*z**2*(&
+ &-18._ki*g_var**2*c_var*f_var+c_var**2*g_var**2-f_var**2*g&
+ &_var**2+18._ki*f_var*c_var*h_var*g_var+18._ki*c_var*h_var*&
+ &f_var**2+6._ki*f_var*c_var**3+3._ki*f_var**3*g_var+6._ki*f_&
+ &var**4-32._ki*g_var*f_var**2*c_var-19._ki*g_var*f_var*c_va&
+ &r**2-2._ki*g_var*c_var**3)/f_var**2/g_var**3
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*c_var**4*z**2/d_var**3/f_var**2*log(c_var)-1&
+ &._ki/12._ki*z**2*h_var**2*(f_var**4*c_var**2+10._ki*d_var**&
+ &3*c_var*f_var**2-8._ki*d_var**3*c_var**2*f_var-2._ki*d_var&
+ &*c_var*f_var**4+3._ki*f_var**2*d_var**4-6._ki*d_var**3*f_v&
+ &ar**3+3._ki*f_var**4*d_var**2-8._ki*d_var**4*c_var*f_var+1&
+ &0._ki*d_var**4*c_var**2)/d_var**3/f_var**6*(log(z)+log(1.&
+ &_ki-z)+z_log(s23,1._ki))+1._ki/24._ki*c_var**2*z**2*(2._ki*c_&
+ &var-d_var)/f_var**2/d_var**2
+ !
+ end select
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/4._ki*z*(-1._ki+z)**2*h_var*(2._ki*f_var**7*h_var*c_v&
+ &ar+4._ki*f_var**4*h_var*g_var**3*c_var+f_var**6*h_var*c_v&
+ &ar**2+2._ki*g_var**4*f_var**3*h_var**2-2._ki*g_var*f_var**&
+ &6*h_var**2+2._ki*g_var**2*f_var**5*h_var**2-2._ki*g_var**3&
+ &*f_var**4*h_var**2-3._ki*f_var**3*h_var*g_var**5+3._ki*f_v&
+ &ar**4*h_var*g_var**4-3._ki*f_var**5*h_var*g_var**3+3._ki*f&
+ &_var**6*h_var*g_var**2+f_var**7*h_var*g_var+f_var**8*h_v&
+ &ar-4._ki*f_var**3*h_var*g_var**3*c_var**2+2._ki*f_var**4*h&
+ &_var*c_var**2*g_var**2-f_var**5*h_var*g_var*c_var**2-2._k&
+ &i*f_var**5*h_var*c_var*g_var**2+6._ki*g_var**4*f_var**2*h&
+ &_var*c_var**2+8._ki*g_var**5*f_var**2*h_var*c_var-10._ki*g&
+ &_var**5*f_var*h_var*c_var**2-6._ki*f_var**3*h_var*c_var*g&
+ &_var**4+g_var**3*f_var**5*c_var-g_var**2*f_var**5*c_var*&
+ &*2+10._ki*g_var**6*c_var**2*f_var+10._ki*g_var**5*c_var**3&
+ &*f_var-4._ki*g_var**6*f_var**2*c_var+3._ki*f_var**3*g_var*&
+ &*5*c_var-8._ki*g_var**4*f_var**2*c_var**3-6._ki*g_var**5*f&
+ &_var**2*c_var**2-g_var*f_var**7*c_var-2._ki*g_var**2*f_va&
+ &r**4*c_var**3-2._ki*g_var**4*f_var**4*c_var+g_var*f_var**&
+ &5*c_var**3+g_var*f_var**6*c_var**2+2._ki*g_var**4*f_var**&
+ &3*c_var**2+4._ki*g_var**3*f_var**3*c_var**3-g_var**5*f_va&
+ &r**4-g_var*f_var**8-20._ki*g_var**6*c_var**3-g_var**3*f_v&
+ &ar**6-g_var**2*f_var**7+g_var**4*f_var**5+g_var**6*f_var&
+ &**3)/f_var**7/g_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._k&
+ &i))-1._ki/4._ki*z*(-1._ki+z)**2/g_var**4*log(e_var)/f_var*e&
+ &_var**4-1._ki/24._ki*z*(-1._ki+z)**2*(2._ki*g_var**2*f_var-3&
+ &._ki*g_var*f_var**2+6._ki*f_var**3+6._ki*c_var**3+18._ki*c_v&
+ &ar*h_var*f_var-24._ki*c_var*f_var*g_var-3._ki*c_var**2*g_v&
+ &ar+2._ki*c_var*g_var**2)/g_var**3/f_var
+ !
+ case(2)
+ !
+ fg=1._ki/4._ki*z*c_var**4*(-1._ki+z)**2/f_var/d_var**4*log(c_&
+ &var)+1._ki/4._ki*z*(-1._ki+z)**2*h_var*(2._ki*d_var**3*f_var&
+ &**4*h_var**2+3._ki*d_var**3*f_var**5*h_var-2._ki*d_var**4*&
+ &f_var**3*h_var**2-6._ki*d_var**4*f_var**4*h_var+3._ki*f_va&
+ &r**3*d_var**5*h_var-4._ki*c_var*d_var**3*f_var**4*h_var+1&
+ &0._ki*d_var**5*c_var**2*f_var*h_var+4._ki*f_var**3*d_var**&
+ &3*c_var**2*h_var+2._ki*f_var**4*d_var**2*c_var**2*h_var-8&
+ &._ki*d_var**5*f_var**2*h_var*c_var-f_var**6*c_var**3+20._k&
+ &i*d_var**6*c_var**3-3._ki*d_var**4*f_var**5+3._ki*d_var**5&
+ &*f_var**4-d_var**6*f_var**3+d_var**3*f_var**6+f_var**5*d&
+ &_var*c_var**2*h_var-2._ki*c_var*d_var**2*f_var**5*h_var-1&
+ &6._ki*c_var**2*d_var**4*f_var**2*h_var+14._ki*c_var*d_var*&
+ &*4*f_var**3*h_var+4._ki*d_var**6*f_var**2*c_var-c_var*d_v&
+ &ar**2*f_var**6-50._ki*c_var**3*d_var**5*f_var-c_var*d_var&
+ &**3*f_var**5+9._ki*c_var*d_var**4*f_var**4-11._ki*c_var*d_&
+ &var**5*f_var**3+26._ki*c_var**2*d_var**5*f_var**2-10._ki*d&
+ &_var**6*c_var**2*f_var-4._ki*f_var**3*c_var**3*d_var**3-2&
+ &._ki*f_var**4*c_var**3*d_var**2-f_var**5*c_var**3*d_var-1&
+ &8._ki*f_var**3*d_var**4*c_var**2+f_var**5*d_var**2*c_var*&
+ &*2+f_var**6*d_var*c_var**2+38._ki*f_var**2*d_var**4*c_var&
+ &**3)/f_var**7/d_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._k&
+ &i))+1._ki/24._ki*z*(-1._ki+z)**2*c_var*(6._ki*c_var**2-3._ki*&
+ &c_var*d_var+2._ki*d_var**2)/d_var**3/f_var
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*z*(-1._ki+z)*h_var**2*(3._ki*f_var**7-3._ki*f_v&
+ &ar**6*g_var+3._ki*f_var**5*g_var**2-3._ki*f_var**4*g_var**&
+ &3+3._ki*f_var**3*g_var**4+6._ki*f_var**6*c_var+2._ki*f_var*&
+ &*4*g_var**2*c_var-f_var**4*g_var*c_var**2-4._ki*f_var**5*&
+ &g_var*c_var-3._ki*g_var**5*f_var**2-10._ki*g_var**5*c_var*&
+ &*2+3._ki*c_var**2*f_var**5-2._ki*g_var**4*f_var**2*c_var-2&
+ &._ki*g_var**4*f_var*c_var**2+8._ki*g_var**5*f_var*c_var)/f&
+ &_var**6/g_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1.&
+ &_ki/12._ki*z*(-1._ki+z)*e_var**3*(-3._ki*f_var*e_var+c_var*g&
+ &_var-3._ki*g_var*f_var)/f_var**2/g_var**4*log(e_var)-1._ki&
+ &/24._ki*z*(-1._ki+z)*(-18._ki*g_var**2*c_var*f_var+c_var**2&
+ &*g_var**2-f_var**2*g_var**2+18._ki*f_var*c_var*h_var*g_va&
+ &r+18._ki*c_var*h_var*f_var**2+6._ki*f_var*c_var**3+3._ki*f_&
+ &var**3*g_var+6._ki*f_var**4-32._ki*g_var*f_var**2*c_var-19&
+ &._ki*g_var*f_var*c_var**2-2._ki*g_var*c_var**3)/f_var**2/g&
+ &_var**3
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*z*c_var**4/d_var**3*(-1._ki+z)/f_var**2*log(&
+ &c_var)+1._ki/12._ki*z*(-1._ki+z)*h_var**2*(f_var**4*c_var**&
+ &2+10._ki*d_var**3*c_var*f_var**2-8._ki*d_var**3*c_var**2*f&
+ &_var-2._ki*d_var*c_var*f_var**4+3._ki*f_var**2*d_var**4-6.&
+ &_ki*d_var**3*f_var**3+3._ki*f_var**4*d_var**2-8._ki*d_var**&
+ &4*c_var*f_var+10._ki*d_var**4*c_var**2)/d_var**3/f_var**6&
+ &*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/24._ki*z*(-1._k&
+ &i+z)*c_var**2*(2._ki*c_var-d_var)/f_var**2/d_var**2
+ !
+ end select
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*z*h_var**3*(-3._ki*f_var**3*h_var*g_var+3._ki*&
+ &f_var**4*h_var+f_var**3*g_var*c_var+3._ki*f_var**3*g_var*&
+ &*2-3._ki*f_var**4*g_var+3._ki*h_var*f_var**2*g_var**2-2._ki&
+ &*c_var*g_var**2*f_var**2-3._ki*f_var**2*g_var**3-3._ki*g_v&
+ &ar**3*f_var*h_var+3._ki*f_var*g_var**3*c_var+3._ki*g_var**&
+ &4*f_var-4._ki*g_var**4*c_var)/g_var**4/f_var**5*(log(z)+l&
+ &og(1._ki-z)+z_log(s23,1._ki))-1._ki/12._ki*z/g_var**4*log(e_&
+ &var)/f_var**3*e_var**2*(-2._ki*g_var*f_var*c_var**2+c_var&
+ &**2*g_var**2+3._ki*c_var**2*f_var**2+6._ki*c_var*f_var**3+&
+ &4._ki*g_var*f_var**2*c_var-2._ki*g_var**2*c_var*f_var+3._ki&
+ &*f_var**4+6._ki*f_var**3*g_var+3._ki*f_var**2*g_var**2)-1.&
+ &_ki/24._ki*z/f_var**3*(9._ki*f_var**4*g_var+6._ki*f_var**5+2&
+ &._ki*g_var**2*c_var**3-18._ki*f_var*g_var**3*c_var+18._ki*h&
+ &_var*f_var*g_var**2*c_var-4._ki*f_var*g_var*c_var**3-35._k&
+ &i*f_var**2*g_var*c_var**2+18._ki*h_var*f_var**3*c_var-40.&
+ &_ki*f_var**3*g_var*c_var+6._ki*f_var**2*c_var**3+2._ki*f_va&
+ &r**3*g_var**2-18._ki*c_var**2*g_var**2*f_var-54._ki*c_var*&
+ &g_var**2*f_var**2+36._ki*f_var**2*c_var*h_var*g_var)/g_va&
+ &r**3
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*z*c_var**4/d_var**2/f_var**3*log(c_var)+1._ki&
+ &/12._ki*z*h_var**3*(-3._ki*d_var*c_var*f_var-f_var**2*c_va&
+ &r+3._ki*d_var*f_var*h_var-3._ki*d_var**2*f_var+3._ki*f_var*&
+ &*2*d_var+4._ki*c_var*d_var**2)/f_var**5/d_var**2*(log(z)+&
+ &log(1._ki-z)+z_log(s23,1._ki))+1._ki/12._ki*z/f_var**3*c_var&
+ &**3/d_var
+ !
+ end select
+ !
+ end select
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ select case(par4)
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/4._ki*(-1._ki+z)**3*h_var*(2._ki*f_var**7*h_var*c_va&
+ &r+4._ki*f_var**4*h_var*g_var**3*c_var+f_var**6*h_var*c_va&
+ &r**2+2._ki*g_var**4*f_var**3*h_var**2-2._ki*g_var*f_var**6&
+ &*h_var**2+2._ki*g_var**2*f_var**5*h_var**2-2._ki*g_var**3*&
+ &f_var**4*h_var**2-3._ki*f_var**3*h_var*g_var**5+3._ki*f_va&
+ &r**4*h_var*g_var**4-3._ki*f_var**5*h_var*g_var**3+3._ki*f_&
+ &var**6*h_var*g_var**2+f_var**7*h_var*g_var+f_var**8*h_va&
+ &r-4._ki*f_var**3*h_var*g_var**3*c_var**2+2._ki*f_var**4*h_&
+ &var*c_var**2*g_var**2-f_var**5*h_var*g_var*c_var**2-2._ki&
+ &*f_var**5*h_var*c_var*g_var**2+6._ki*g_var**4*f_var**2*h_&
+ &var*c_var**2+8._ki*g_var**5*f_var**2*h_var*c_var-10._ki*g_&
+ &var**5*f_var*h_var*c_var**2-6._ki*f_var**3*h_var*c_var*g_&
+ &var**4+g_var**3*f_var**5*c_var-g_var**2*f_var**5*c_var**&
+ &2+10._ki*g_var**6*c_var**2*f_var+10._ki*g_var**5*c_var**3*&
+ &f_var-4._ki*g_var**6*f_var**2*c_var+3._ki*f_var**3*g_var**&
+ &5*c_var-8._ki*g_var**4*f_var**2*c_var**3-6._ki*g_var**5*f_&
+ &var**2*c_var**2-g_var*f_var**7*c_var-2._ki*g_var**2*f_var&
+ &**4*c_var**3-2._ki*g_var**4*f_var**4*c_var+g_var*f_var**5&
+ &*c_var**3+g_var*f_var**6*c_var**2+2._ki*g_var**4*f_var**3&
+ &*c_var**2+4._ki*g_var**3*f_var**3*c_var**3-g_var**5*f_var&
+ &**4-g_var*f_var**8-20._ki*g_var**6*c_var**3-g_var**3*f_va&
+ &r**6-g_var**2*f_var**7+g_var**4*f_var**5+g_var**6*f_var*&
+ &*3)/f_var**7/g_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki&
+ &))+1._ki/4._ki*(-1._ki+z)**3/g_var**4*log(e_var)/f_var*e_va&
+ &r**4+1._ki/24._ki*(-1._ki+z)**3*(2._ki*g_var**2*f_var-3._ki*g&
+ &_var*f_var**2+6._ki*f_var**3+6._ki*c_var**3+18._ki*c_var*h_&
+ &var*f_var-24._ki*c_var*f_var*g_var-3._ki*c_var**2*g_var+2.&
+ &_ki*c_var*g_var**2)/g_var**3/f_var
+ !
+ case(2)
+ !
+ fg=-1._ki/4._ki*c_var**4*(-1._ki+z)**3/f_var/d_var**4*log(c_v&
+ &ar)-1._ki/4._ki*(-1._ki+z)**3*h_var*(2._ki*d_var**3*f_var**4&
+ &*h_var**2+3._ki*d_var**3*f_var**5*h_var-2._ki*d_var**4*f_v&
+ &ar**3*h_var**2-6._ki*d_var**4*f_var**4*h_var+3._ki*f_var**&
+ &3*d_var**5*h_var-4._ki*c_var*d_var**3*f_var**4*h_var+10._k&
+ &i*d_var**5*c_var**2*f_var*h_var+4._ki*f_var**3*d_var**3*c&
+ &_var**2*h_var+2._ki*f_var**4*d_var**2*c_var**2*h_var-8._ki&
+ &*d_var**5*f_var**2*h_var*c_var-f_var**6*c_var**3+20._ki*d&
+ &_var**6*c_var**3-3._ki*d_var**4*f_var**5+3._ki*d_var**5*f_&
+ &var**4-d_var**6*f_var**3+d_var**3*f_var**6+f_var**5*d_va&
+ &r*c_var**2*h_var-2._ki*c_var*d_var**2*f_var**5*h_var-16._k&
+ &i*c_var**2*d_var**4*f_var**2*h_var+14._ki*c_var*d_var**4*&
+ &f_var**3*h_var+4._ki*d_var**6*f_var**2*c_var-c_var*d_var*&
+ &*2*f_var**6-50._ki*c_var**3*d_var**5*f_var-c_var*d_var**3&
+ &*f_var**5+9._ki*c_var*d_var**4*f_var**4-11._ki*c_var*d_var&
+ &**5*f_var**3+26._ki*c_var**2*d_var**5*f_var**2-10._ki*d_va&
+ &r**6*c_var**2*f_var-4._ki*f_var**3*c_var**3*d_var**3-2._ki&
+ &*f_var**4*c_var**3*d_var**2-f_var**5*c_var**3*d_var-18._k&
+ &i*f_var**3*d_var**4*c_var**2+f_var**5*d_var**2*c_var**2+&
+ &f_var**6*d_var*c_var**2+38._ki*f_var**2*d_var**4*c_var**3&
+ &)/f_var**7/d_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))&
+ &-1._ki/24._ki*(-1._ki+z)**3*c_var*(6._ki*c_var**2-3._ki*c_var&
+ &*d_var+2._ki*d_var**2)/d_var**3/f_var
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*(-1._ki+z)**2*h_var**2*(3._ki*f_var**7-3._ki*f&
+ &_var**6*g_var+3._ki*f_var**5*g_var**2-3._ki*f_var**4*g_var&
+ &**3+3._ki*f_var**3*g_var**4+6._ki*f_var**6*c_var+2._ki*f_va&
+ &r**4*g_var**2*c_var-f_var**4*g_var*c_var**2-4._ki*f_var**&
+ &5*g_var*c_var-3._ki*g_var**5*f_var**2-10._ki*g_var**5*c_va&
+ &r**2+3._ki*c_var**2*f_var**5-2._ki*g_var**4*f_var**2*c_var&
+ &-2._ki*g_var**4*f_var*c_var**2+8._ki*g_var**5*f_var*c_var)&
+ &/f_var**6/g_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-&
+ &1._ki/12._ki*(-1._ki+z)**2*e_var**3*(-3._ki*f_var*e_var+c_va&
+ &r*g_var-3._ki*g_var*f_var)/f_var**2/g_var**4*log(e_var)+1&
+ &._ki/24._ki*(-1._ki+z)**2*(-18._ki*g_var**2*c_var*f_var+c_va&
+ &r**2*g_var**2-f_var**2*g_var**2+18._ki*f_var*c_var*h_var*&
+ &g_var+18._ki*c_var*h_var*f_var**2+6._ki*f_var*c_var**3+3._k&
+ &i*f_var**3*g_var+6._ki*f_var**4-32._ki*g_var*f_var**2*c_va&
+ &r-19._ki*g_var*f_var*c_var**2-2._ki*g_var*c_var**3)/f_var*&
+ &*2/g_var**3
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*c_var**4*(-1._ki+z)**2/f_var**2/d_var**3*log(&
+ &c_var)-1._ki/12._ki*(-1._ki+z)**2*h_var**2*(f_var**4*c_var*&
+ &*2+10._ki*d_var**3*c_var*f_var**2-8._ki*d_var**3*c_var**2*&
+ &f_var-2._ki*d_var*c_var*f_var**4+3._ki*f_var**2*d_var**4-6&
+ &._ki*d_var**3*f_var**3+3._ki*f_var**4*d_var**2-8._ki*d_var*&
+ &*4*c_var*f_var+10._ki*d_var**4*c_var**2)/d_var**3/f_var**&
+ &6*(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/24._ki*(-1._ki&
+ &+z)**2*c_var**2*(2._ki*c_var-d_var)/f_var**2/d_var**2
+ !
+ end select
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*(-1._ki+z)*h_var**3*(-3._ki*f_var**3*h_var*g_&
+ &var+3._ki*f_var**4*h_var+f_var**3*g_var*c_var+3._ki*f_var*&
+ &*3*g_var**2-3._ki*f_var**4*g_var+3._ki*h_var*f_var**2*g_va&
+ &r**2-2._ki*c_var*g_var**2*f_var**2-3._ki*f_var**2*g_var**3&
+ &-3._ki*g_var**3*f_var*h_var+3._ki*f_var*g_var**3*c_var+3._k&
+ &i*g_var**4*f_var-4._ki*g_var**4*c_var)/g_var**4/f_var**5*&
+ &(log(z)+log(1._ki-z)+z_log(s23,1._ki))+1._ki/12._ki*(-1._ki+z&
+ &)/g_var**4*log(e_var)/f_var**3*e_var**2*(-2._ki*g_var*f_v&
+ &ar*c_var**2+c_var**2*g_var**2+3._ki*c_var**2*f_var**2+6._k&
+ &i*c_var*f_var**3+4._ki*g_var*f_var**2*c_var-2._ki*g_var**2&
+ &*c_var*f_var+3._ki*f_var**4+6._ki*f_var**3*g_var+3._ki*f_va&
+ &r**2*g_var**2)+1._ki/24._ki*(-1._ki+z)/f_var**3*(9._ki*f_var&
+ &**4*g_var+6._ki*f_var**5+2._ki*g_var**2*c_var**3-18._ki*f_v&
+ &ar*g_var**3*c_var+18._ki*h_var*f_var*g_var**2*c_var-4._ki*&
+ &f_var*g_var*c_var**3-35._ki*f_var**2*g_var*c_var**2+18._ki&
+ &*h_var*f_var**3*c_var-40._ki*f_var**3*g_var*c_var+6._ki*f_&
+ &var**2*c_var**3+2._ki*f_var**3*g_var**2-18._ki*c_var**2*g_&
+ &var**2*f_var-54._ki*c_var*g_var**2*f_var**2+36._ki*f_var**&
+ &2*c_var*h_var*g_var)/g_var**3
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*c_var**4/d_var**2*(-1._ki+z)/f_var**3*log(c_&
+ &var)-1._ki/12._ki*(-1._ki+z)*h_var**3*(-3._ki*d_var*c_var*f_&
+ &var-f_var**2*c_var+3._ki*d_var*f_var*h_var-3._ki*d_var**2*&
+ &f_var+3._ki*f_var**2*d_var+4._ki*c_var*d_var**2)/f_var**5/&
+ &d_var**2*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1._ki/12._ki&
+ &*(-1._ki+z)/f_var**3*c_var**3/d_var
+ !
+ end select
+ !
+ end select
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(par3)
+ !
+ case(4)
+ !
+ select case(par4)
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/4._ki*h_var**4*(-g_var+f_var)*(f_var**2+g_var**2)/&
+ &f_var**4/g_var**4*(log(z)+log(1._ki-z)+z_log(s23,1._ki))-1&
+ &._ki/4._ki*e_var*(2._ki*g_var*f_var**2*e_var+c_var**2*g_var&
+ &**2+f_var**2*g_var**2+c_var**2*f_var**2+2._ki*c_var*f_var&
+ &**3+f_var**4)*(-f_var*e_var+c_var*g_var-g_var*f_var)/f_v&
+ &ar**4/g_var**4*log(e_var)+1._ki/24._ki*(15._ki*f_var**4*g_v&
+ &ar-18._ki*g_var**4*c_var+6._ki*f_var**5+6._ki*g_var**2*c_va&
+ &r**3-18._ki*g_var**3*c_var**2-72._ki*f_var*g_var**3*c_var+&
+ &54._ki*h_var*f_var*g_var**2*c_var+18._ki*g_var**3*c_var*h_&
+ &var-6._ki*f_var*g_var*c_var**3-51._ki*f_var**2*g_var*c_var&
+ &**2+18._ki*h_var*f_var**3*c_var-48._ki*f_var**3*g_var*c_va&
+ &r+6._ki*f_var**2*c_var**3+11._ki*f_var**3*g_var**2-57._ki*c&
+ &_var**2*g_var**2*f_var-106._ki*c_var*g_var**2*f_var**2+54&
+ &._ki*f_var**2*c_var*h_var*g_var)/f_var**3/g_var**3
+ !
+ case(2)
+ !
+ fg=1._ki/4._ki*c_var**4/d_var/f_var**4*log(c_var)-1._ki/4._ki*&
+ &(log(z)+log(1._ki-z)+z_log(s23,1._ki))*h_var**4/f_var**4/d&
+ &_var
+ !
+ end select
+ !
+ end select
+ !
+ end select
+ !
+ end select
+ !
+ end if
+ !
+ else if (dim == "n+4") then
+ !
+ if (nb_par == 0) then
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/6._ki*h_var**2*(f_var*h_var*g_var-f_var**2*h_var-g&
+ &_var*f_var*c_var-2._ki*f_var*g_var**2+2._ki*g_var*f_var**2&
+ &+2._ki*c_var*g_var**2)/f_var**3/g_var**2*(log(z)+log(1._ki&
+ &-z)+z_log(-s23,-1._ki))-1._ki/6._ki/g_var**2*log(-e_var)/f_&
+ &var*e_var**3-1._ki/18._ki*(6._ki*f_var*c_var+3._ki*c_var**2-&
+ &5._ki*f_var*g_var+3._ki*f_var**2)/f_var/g_var
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*c_var**3/d_var**2/f_var*log(-c_var)-1._ki/6._ki&
+ &*h_var**2*(c_var*f_var*d_var+f_var**2*c_var-d_var*f_var*&
+ &h_var+2._ki*d_var**2*f_var-2._ki*d_var*f_var**2-2._ki*c_var&
+ &*d_var**2)/f_var**3/d_var**2*(log(z)+log(1._ki-z)+z_log(-&
+ &s23,-1._ki))+1._ki/6._ki*c_var**2/f_var/d_var
+ !
+ end select
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par4)
+ !
+ case(1)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/24._ki*h_var**3*(-2._ki*f_var*h_var*g_var+f_var**2*h&
+ &_var+2._ki*c_var*g_var*f_var+4._ki*f_var*g_var**2-2._ki*f_v&
+ &ar**2*g_var-6._ki*c_var*g_var**2)/f_var**4/g_var**2*(log(&
+ &z)+log(1._ki-z)+z_log(-s23,-1._ki))-1._ki/24._ki/g_var**2*lo&
+ &g(-e_var)/f_var**2*e_var**4-1._ki/144._ki/f_var**2*(-13._ki&
+ &*f_var**2*g_var+6._ki*f_var**3+6._ki*c_var**3+18._ki*c_var*&
+ &h_var*f_var-18._ki*c_var*g_var*f_var)/g_var
+ !
+ case(2)
+ !
+ fg=1._ki/24._ki*c_var**3*(c_var*d_var+2._ki*c_var*f_var+4._ki*&
+ &d_var*f_var)/d_var**3/f_var**2*log(-c_var)+1._ki/24._ki*h_&
+ &var**3*(-2._ki*f_var**2*c_var*d_var-2._ki*c_var*f_var**3+d&
+ &_var*f_var**2*h_var+2._ki*d_var**2*f_var**2+2._ki*f_var**3&
+ &*d_var-2._ki*c_var*d_var**2*f_var+2._ki*f_var*d_var**2*h_v&
+ &ar-4._ki*d_var**3*f_var+6._ki*c_var*d_var**3)/f_var**4/d_v&
+ &ar**3*(log(z)+log(1._ki-z)+z_log(-s23,-1._ki))+1._ki/24._ki*&
+ &c_var**2*(2._ki*c_var*f_var+c_var*d_var+3._ki*d_var*f_var)&
+ &/d_var**2/f_var**2
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=-1._ki/12._ki*z*h_var**2*(-2._ki*f_var**5*g_var+3._ki*f_var&
+ &**4*g_var**2-3._ki*f_var**3*g_var**3+f_var**6+3._ki*f_var*&
+ &*2*g_var**4+6._ki*g_var**4*c_var**2+2._ki*f_var**2*c_var*g&
+ &_var**3-2._ki*f_var**4*c_var*g_var-6._ki*f_var*g_var**4*c_&
+ &var+c_var**2*f_var**4+2._ki*c_var*f_var**5)/f_var**5/g_va&
+ &r**3*(log(z)+log(1._ki-z)+z_log(-s23,-1._ki))+1._ki/12._ki*z&
+ &/g_var**3*log(-e_var)/f_var*e_var**4+1._ki/72._ki*z*(7._ki*&
+ &f_var*g_var**2-3._ki*f_var**2*g_var+6._ki*f_var**3+6._ki*c_&
+ &var**3+18._ki*c_var*h_var*f_var-24._ki*c_var*g_var*f_var-3&
+ &._ki*c_var**2*g_var)/f_var/g_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/12._ki*z*c_var**4/d_var**3/f_var*log(-c_var)+1._ki/&
+ &12._ki*z*h_var**2*(c_var**2*f_var**4+8._ki*c_var*f_var**2*&
+ &d_var**3-6._ki*c_var**2*d_var**3*f_var-2._ki*c_var*f_var**&
+ &4*d_var+3._ki*f_var**2*d_var**4-6._ki*f_var**3*d_var**3+3.&
+ &_ki*f_var**4*d_var**2-6._ki*d_var**4*c_var*f_var+6._ki*c_va&
+ &r**2*d_var**4)/f_var**5/d_var**3*(log(z)+log(1._ki-z)+z_l&
+ &og(-s23,-1._ki))-1._ki/24._ki*z*c_var**2*(2._ki*c_var-d_var)&
+ &/f_var/d_var**2
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/12._ki*(z-1)*h_var**2*(-2._ki*f_var**5*g_var+3._ki*f_&
+ &var**4*g_var**2-3._ki*f_var**3*g_var**3+f_var**6+3._ki*f_v&
+ &ar**2*g_var**4+6._ki*g_var**4*c_var**2+2._ki*f_var**2*c_va&
+ &r*g_var**3-2._ki*f_var**4*c_var*g_var-6._ki*f_var*g_var**4&
+ &*c_var+c_var**2*f_var**4+2._ki*c_var*f_var**5)/f_var**5/g&
+ &_var**3*(log(z)+log(1._ki-z)+z_log(-s23,-1._ki))-1._ki/12._k&
+ &i*(z-1)/g_var**3*log(-e_var)/f_var*e_var**4-1._ki/72._ki*(&
+ &z-1)*(7._ki*f_var*g_var**2-3._ki*f_var**2*g_var+6._ki*f_var&
+ &**3+6._ki*c_var**3+18._ki*c_var*h_var*f_var-24._ki*c_var*g_&
+ &var*f_var-3._ki*c_var**2*g_var)/f_var/g_var**2
+ !
+ case(2)
+ !
+ fg=1._ki/12._ki*c_var**4/d_var**3*(z-1)/f_var*log(-c_var)-1.&
+ &_ki/12._ki*(z-1)*h_var**2*(c_var**2*f_var**4+8._ki*c_var*f_&
+ &var**2*d_var**3-6._ki*c_var**2*d_var**3*f_var-2._ki*c_var*&
+ &f_var**4*d_var+3._ki*f_var**2*d_var**4-6._ki*f_var**3*d_va&
+ &r**3+3._ki*f_var**4*d_var**2-6._ki*d_var**4*c_var*f_var+6.&
+ &_ki*c_var**2*d_var**4)/f_var**5/d_var**3*(log(z)+log(1._ki&
+ &-z)+z_log(-s23,-1._ki))+1._ki/24._ki*(z-1)*c_var**2*(2._ki*c&
+ &_var-d_var)/f_var/d_var**2
+ !
+ end select
+ !
+ case(4)
+ !
+ select case(flag)
+ !
+ case(1)
+ !
+ fg=1._ki/24._ki*h_var**3*(-2._ki*f_var**2*h_var*g_var+2._ki*f_&
+ &var**3*h_var+c_var*f_var**2*g_var+3._ki*g_var**2*f_var**2&
+ &-3._ki*g_var*f_var**3+2._ki*f_var*g_var**2*h_var-2._ki*c_va&
+ &r*g_var**2*f_var-3._ki*g_var**3*f_var+3._ki*g_var**3*c_var&
+ &)/g_var**3/f_var**4*(log(z)+log(1._ki-z)+z_log(-s23,-1._ki&
+ &))+1._ki/24._ki*e_var**3*(-2._ki*f_var*e_var+c_var*g_var-3.&
+ &_ki*f_var*g_var)/g_var**3/f_var**2*log(-e_var)-1._ki/144._k&
+ &i/f_var**2*(-13._ki*g_var**2*f_var**2-36._ki*c_var*g_var**&
+ &2*f_var+36._ki*f_var*c_var*h_var*g_var+36._ki*c_var*h_var*&
+ &f_var**2+12._ki*f_var*c_var**3+12._ki*g_var*f_var**3+12._ki&
+ &*f_var**4-36._ki*c_var**2*g_var*f_var-6._ki*c_var**3*g_var&
+ &-54._ki*c_var*f_var**2*g_var)/g_var**2
+ !
+ case(2)
+ !
+ fg=-1._ki/24._ki*c_var**4/d_var**2/f_var**2*log(-c_var)-1._ki&
+ &/24._ki*h_var**3*(-2._ki*c_var*f_var*d_var-c_var*f_var**2+&
+ &2._ki*f_var*d_var*h_var-3._ki*f_var*d_var**2+3._ki*f_var**2&
+ &*d_var+3._ki*d_var**2*c_var)/f_var**4/d_var**2*(log(z)+lo&
+ &g(1._ki-z)+z_log(-s23,-1._ki))-1._ki/24._ki/f_var**2*c_var**&
+ &3/d_var
+ !
+ end select
+ !
+ end select
+ !
+ end if
+ !
+ end if
+ end function fg
+ !
+end module function_4p3m
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p4m.f90 b/golem95c-1.2.1/integrals/four_point/function_4p4m.f90
new file mode 100644
index 0000000..56beba9
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p4m.f90
@@ -0,0 +1,1077 @@
+!
+!****h* src/integrals/four_point/function_4p4m
+! NAME
+!
+! Module function_4p4m
+!
+! USAGE
+!
+! use function_4p4m
+!
+! DESCRIPTION
+!
+! This module computes the six-dimensional and eight dimensional
+! three mass four point function with or without Feynman parameters
+! in the numerator.
+!
+! OUTPUT
+!
+! This module exports three functions f4p4m, f4p4m_c and f4
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+!
+!*****
+module function_4p4m
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ implicit none
+ !
+ private
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p4m,f4,f4p4m_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p4m/f4p4m
+ ! NAME
+ !
+ ! Function f4p4m
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p4m(dim,s24,s13,s12,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the six dimensional/eight dimensional
+ ! three mass four point function with or without Feynman parameters
+ ! in the numerator.
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! three mass four point function, dim="n+4" eight dimensional
+ ! three mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! If the user wants to compute:
+ ! * a six dimensional three mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p4m("n+2",s24,s13,s12,s23,s34,0,0,0,0)
+ ! * a eight dimensional three mass four point function
+ ! with no Feynman parameters in the numerator:
+ ! real_dim_4 = f4p4m("n+4",s24,s13,s12,s23,s34,0,0,0,0)
+ ! * a six dimensional three mass four point function
+ ! with the Feynman parameter z1 in the numerator:
+ ! real_dim_4 = f4p4m("n+2",s24,s13,s12,s23,s34,0,0,0,1)
+ ! * a six dimensional three mass four point function
+ ! with the Feynman parameters z1^2*z2 in the numerator:
+ ! real_dim_4 = f4p4m("n+2",s24,s13,s12,s23,s34,0,2,1,1)
+ !
+ !*****
+ function f4p4m(dim,s24,s13,s14,s12,s23,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s14,s12,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: f4p4m
+ !
+ integer :: nb_par
+ real(ki) :: lamb,det_s
+ real(ki) :: plus_grand
+ real(ki) :: norma
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/0._ki,s12,s13,s14/)
+ s_mat(2,:) = (/s12,0._ki,s23,s24/)
+ s_mat(3,:) = (/s13,s23,0._ki,s34/)
+ s_mat(4,:) = (/s14,s24,s34,0._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ plus_grand = maxval(array=abs(s_mat))
+ s_mat = s_mat/plus_grand
+ !
+ det_s = (-2._ki*s_mat(2,3)*s_mat(1,3)*s_mat(2,4)*s_mat(1,4)+s_mat(1,2&
+ &)**2*s_mat(3,4)**2-2._ki*s_mat(1,2)*s_mat(3,4)*s_mat(2,3)*s_mat(&
+ &1,4)-2._ki*s_mat(1,2)*s_mat(3,4)*s_mat(1,3)*s_mat(2,4)+s_mat(2,4&
+ &)**2*s_mat(1,3)**2+s_mat(1,4)**2*s_mat(2,3)**2)
+ !
+ b(1)=-(-s_mat(1,4)*s_mat(2,3)**2-s_mat(2,4)**2*s_mat(1,3)+s_mat(1&
+ &,2)*s_mat(3,4)*s_mat(2,3)-s_mat(1,2)*s_mat(3,4)**2+s_mat(3,4)*s&
+ &_mat(2,3)*s_mat(1,4)+s_mat(3,4)*s_mat(1,3)*s_mat(2,4)+s_mat(1,2&
+ &)*s_mat(3,4)*s_mat(2,4)-2._ki*s_mat(2,4)*s_mat(3,4)*s_mat(2,3)+s&
+ &_mat(2,3)*s_mat(1,3)*s_mat(2,4)+s_mat(2,3)*s_mat(2,4)*s_mat(1,4&
+ &))/det_s
+ !
+ b(2)=-(-s_mat(1,4)**2*s_mat(2,3)-s_mat(2,4)*s_mat(1,3)**2+s_mat(1&
+ &,2)*s_mat(3,4)*s_mat(1,4)+s_mat(1,2)*s_mat(3,4)*s_mat(1,3)-s_ma&
+ &t(1,2)*s_mat(3,4)**2+s_mat(3,4)*s_mat(2,3)*s_mat(1,4)+s_mat(3,4&
+ &)*s_mat(1,3)*s_mat(2,4)+s_mat(2,3)*s_mat(1,3)*s_mat(1,4)-2._ki*s&
+ &_mat(1,3)*s_mat(3,4)*s_mat(1,4)+s_mat(2,4)*s_mat(1,3)*s_mat(1,4&
+ &))/det_s
+ !
+ b(3)=(s_mat(1,4)**2*s_mat(2,3)+s_mat(2,4)**2*s_mat(1,3)-s_mat(1,2&
+ &)*s_mat(3,4)*s_mat(2,4)+s_mat(1,2)**2*s_mat(3,4)-s_mat(2,4)*s_m&
+ &at(1,3)*s_mat(1,2)-s_mat(2,4)*s_mat(1,3)*s_mat(1,4)-s_mat(2,3)*&
+ &s_mat(2,4)*s_mat(1,4)-s_mat(1,4)*s_mat(2,3)*s_mat(1,2)-s_mat(1,&
+ &2)*s_mat(3,4)*s_mat(1,4)+2._ki*s_mat(2,4)*s_mat(1,4)*s_mat(1,2))&
+ &/det_s
+ !
+ b(4)=(2._ki*s_mat(2,3)*s_mat(1,3)*s_mat(1,2)-s_mat(1,4)*s_mat(2,3)&
+ &*s_mat(1,2)-s_mat(2,3)*s_mat(1,3)*s_mat(2,4)-s_mat(2,3)*s_mat(1&
+ &,3)*s_mat(1,4)+s_mat(1,2)**2*s_mat(3,4)-s_mat(1,2)*s_mat(3,4)*s&
+ &_mat(1,3)+s_mat(2,4)*s_mat(1,3)**2-s_mat(1,2)*s_mat(3,4)*s_mat(&
+ &2,3)-s_mat(2,4)*s_mat(1,3)*s_mat(1,2)+s_mat(1,4)*s_mat(2,3)**2)&
+ &/det_s
+ !
+ lamb=2._ki*(-s_mat(1,4)*s_mat(2,3)*s_mat(1,2)+s_mat(1,4)**2*s_mat(&
+ &2,3)-s_mat(3,4)*s_mat(2,3)*s_mat(1,4)-s_mat(2,3)*s_mat(1,3)*s_m&
+ &at(2,4)-s_mat(1,2)*s_mat(3,4)*s_mat(1,3)+s_mat(1,2)**2*s_mat(3,&
+ &4)+s_mat(2,4)*s_mat(1,3)**2+s_mat(1,4)*s_mat(2,3)**2+s_mat(2,3)&
+ &*s_mat(1,3)*s_mat(1,2)-s_mat(2,3)*s_mat(1,3)*s_mat(1,4)-s_mat(1&
+ &,2)*s_mat(3,4)*s_mat(2,3)-s_mat(2,4)*s_mat(1,3)*s_mat(1,2)-s_ma&
+ &t(3,4)*s_mat(1,3)*s_mat(2,4)-s_mat(2,3)*s_mat(2,4)*s_mat(1,4)+s&
+ &_mat(2,4)*s_mat(3,4)*s_mat(2,3)+s_mat(2,4)**2*s_mat(1,3)-s_mat(&
+ &2,4)*s_mat(1,3)*s_mat(1,4)-s_mat(1,2)*s_mat(3,4)*s_mat(2,4)-s_m&
+ &at(1,2)*s_mat(3,4)*s_mat(1,4)+s_mat(2,4)*s_mat(1,4)*s_mat(1,2)+&
+ &s_mat(1,3)*s_mat(3,4)*s_mat(1,4)+s_mat(1,2)*s_mat(3,4)**2)
+ !
+ sumb=lamb/det_s
+ !
+ invs(1,1)=2._ki*s_mat(2,4)*s_mat(3,4)*s_mat(2,3)/det_s
+ !
+ invs(1,2)=s_mat(3,4)*(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3)&
+ &-s_mat(1,4)*s_mat(2,3))/det_s
+ !
+ invs(1,3)=-s_mat(2,4)*(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3&
+ &)+s_mat(1,4)*s_mat(2,3))/det_s
+ !
+ invs(1,4)=-s_mat(2,3)*(s_mat(2,4)*s_mat(1,3)+s_mat(1,2)*s_mat(3,4&
+ &)-s_mat(1,4)*s_mat(2,3))/det_s
+ !
+ invs(2,1) = invs(1,2)
+ !
+ invs(2,2)=2._ki*s_mat(1,3)*s_mat(3,4)*s_mat(1,4)/det_s
+ !
+ invs(2,3)=-s_mat(1,4)*(s_mat(2,4)*s_mat(1,3)+s_mat(1,2)*s_mat(3,4&
+ &)-s_mat(1,4)*s_mat(2,3))/det_s
+ !
+ invs(2,4)=-s_mat(1,3)*(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3&
+ &)+s_mat(1,4)*s_mat(2,3))/det_s
+ !
+ invs(3,1) = invs(1,3)
+ !
+ invs(3,2) = invs(2,3)
+ !
+ invs(3,3)=2._ki*s_mat(2,4)*s_mat(1,4)*s_mat(1,2)/det_s
+ !
+ invs(3,4)=s_mat(1,2)*(s_mat(1,2)*s_mat(3,4)-s_mat(2,4)*s_mat(1,3)&
+ &-s_mat(1,4)*s_mat(2,3))/det_s
+ !
+ invs(4,1) = invs(1,4)
+ !
+ invs(4,2) = invs(2,4)
+ !
+ invs(4,3) = invs(3,4)
+ !
+ invs(4,4)=2._ki*s_mat(2,3)*s_mat(1,3)*s_mat(1,2)/det_s
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p4m = 0._ki
+ !
+ !~ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p4m) ) then
+ if ( (rat_or_tot_par%rat_selected) .and. (4._ki <= 2._ki) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p4m (in file f4p4m.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p4m'
+ call catch_exception(0)
+ end if
+ !
+ !~ if (abs(sumb) > coupure_4p4m) then
+ if (4._ki > 2._ki) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n+2") then
+ !
+ f4p4m(3:4)= a4p4m_np2(s_mat(2,4),s_mat(1,3),&
+ &s_mat(1,4),s_mat(1,2),s_mat(2,3),s_mat(3,4),&
+ &par1,par2,par3,par4)/plus_grand
+ !
+ else if (dim == "n+4") then
+ !
+ f4p4m = a4p4m_np4(s_mat(2,4),s_mat(1,3),&
+ &s_mat(1,4),s_mat(1,2),s_mat(2,3),s_mat(3,4),&
+ &par1,par2,par3,par4)
+ f4p4m(3) = f4p4m(3)-log(plus_grand)*norma
+ !
+ end if
+ !
+ else
+ !
+ ! numerical computation
+ !
+ ! not implemented
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p4m
+ !
+ !****f* src/integrals/four_point/function_4p4m/f4p4m_c
+ ! NAME
+ !
+ ! Function f4p4m_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_2 = f4p4m_c(dim,s24,s13,s14,s12,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the same thing that the function f4p4m
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (dimension 3), dim="n+2" six dimensional
+ ! two adjacent mass four point function, dim="n+4" eight dimensional
+ ! two adjacent mass four point function
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s14 -- a real (type ki), the S matrix element 1,4
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p4m
+ !
+ !*****
+ function f4p4m_c(dim,s24,s13,s14,s12,s23,s34,par1,par2,par3,par4)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s24,s13,s14,s12,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(2) :: f4p4m_c
+ !
+ real(ki), dimension(4) :: res4
+ !
+ res4 = f4p4m(dim,s24,s13,s14,s12,s23,s34,par1,par2,par3,par4)
+ call to_complex(res4,f4p4m_c)
+ !
+ end function f4p4m_c
+ !
+ !****if* src/integrals/four_point/function_4p4m/a4p4m_np2
+ ! NAME
+ !
+ ! recursive function a4p4m_np2
+ !
+ ! USAGE
+ !
+ ! real_dim_2 = a4p4m_np2(s24,s13,s14,s12,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the six dimensional
+ ! three mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s14 -- a real (type ki), the S matrix element 1,4
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two reals (type ki) corresponding to the
+ ! real and imaginary part of the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p4m_np2(s24,s13,s14,s12,s23,s34,par1,par2,par3,par4) result(res_4p4m_np2)
+ !
+ real(ki), intent (in) :: s24,s13,s14,s12,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(2) :: res_4p4m_np2
+ !
+ integer, dimension(3) :: smj
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(6) :: truc1,truc2,truc3,truc4
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(6) :: temp1,temp2,temp3,temp4
+ real(ki), dimension(2) :: temp10,temp11,temp12,temp13,temp14,temp15
+ complex(ki) :: ctemp
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule3(1,1)) then
+ !
+ truc1 = resultat3(1,1,:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,unpackb(ibclr(b_pro,1),3))
+ resultat3(1,1,:) = truc1
+ deja_calcule3(1,1) = .true.
+ !
+ end if
+ !
+ if (deja_calcule3(4,1)) then
+ !
+ truc4 = resultat3(4,1,:)
+ !
+ else
+ !
+ truc4 = f3p_sc(s_mat,unpackb(ibclr(b_pro,4),3))
+ resultat3(4,1,:) = truc4
+ deja_calcule3(4,1) = .true.
+ !
+ end if
+ !
+ if (deja_calcule3(3,1)) then
+ !
+ truc3 = resultat3(3,1,:)
+ !
+ else
+ !
+ truc3 = f3p_sc(s_mat,unpackb(ibclr(b_pro,3),3))
+ resultat3(3,1,:) = truc3
+ deja_calcule3(3,1) = .true.
+ !
+ end if
+ !
+ if (deja_calcule3(2,1)) then
+ !
+ truc2 = resultat3(2,1,:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,unpackb(ibclr(b_pro,2),3))
+ resultat3(2,1,:) = truc2
+ deja_calcule3(2,1) = .true.
+ !
+ end if
+ !
+ ctemp = f4(s24,s13,s14,s12,s23,s34)
+ res_4p4m_np2(1) = (real(ctemp,ki) - b(1)*truc1(5) - b(2)*truc2(5) - b(3)*truc3(5) - b(4)*truc4(5))/sumb
+ res_4p4m_np2(2) = (aimag(ctemp) - b(1)*truc1(6) - b(2)*truc2(6) - b(3)*truc3(6) - b(4)*truc4(6))/sumb
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p4m_np2(s24,s13,s14,s12,s23,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp0 = b(par4)*temp0
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3(j,1)) then
+ !
+ truc1 = resultat3(j,1,:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,smj)
+ resultat3(j,1,:) = truc1
+ deja_calcule3(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/2._ki
+ !
+ if (j /= par4) then
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 - b(j)*truc2/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p4m_np2(1) = (temp0(1) + temp1(5) + temp2(5))/sumb
+ res_4p4m_np2(2) = (temp0(2) + temp1(6) + temp2(6))/sumb
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ if (deja_calcule(par_plus(4))) then
+ !
+ temp10 = resultat(par_plus(4),:)
+ !
+ else
+ !
+ temp10 = a4p4m_np2(s24,s13,s14,s12,s23,s34,0,0,0,par4)
+ resultat(par_plus(4),:) = temp10
+ deja_calcule(par_plus(4)) = .true.
+ !
+ end if
+ !
+ if (deja_calcule(par_plus(3))) then
+ !
+ temp11 = resultat(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a4p4m_np2(s24,s13,s14,s12,s23,s34,0,0,0,par3)
+ resultat(par_plus(3),:) = temp11
+ deja_calcule(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp12 = resultat(1,:)
+ temp0 = b(par3)*temp10+b(par4)*temp11 - invs(par3,par4)*temp12/2._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule3(j,par_plus(3))) then
+ !
+ truc1 = resultat3(j,par_plus(3),:)
+ !
+ else
+ !
+ truc1 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj))
+ resultat3(j,par_plus(3),:) = truc1
+ deja_calcule3(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs(j,par4)*truc1/4._ki
+ !
+ end if
+ !
+ if (j /= par4) then
+ !
+ if (deja_calcule3(j,par_plus(4))) then
+ !
+ truc2 = resultat3(j,par_plus(4),:)
+ !
+ else
+ !
+ truc2 = f3p_sc(s_mat,smj,locateb(par4,b_pro_mj))
+ resultat3(j,par_plus(4),:) = truc2
+ deja_calcule3(j,par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + invs(j,par3)*truc2/4._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ if (deja_calcule33(j,par_plus(3),par_plus(4))) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ !
+ else
+ !
+ truc3 = f3p_sc(s_mat,smj,locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))
+ resultat33(j,par_plus(3),par_plus(4),:) = truc3
+ deja_calcule33(j,par_plus(3),par_plus(4)) = .true.
+ !
+ end if
+ !
+ temp3 = temp3 - b(j)*truc3/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p4m_np2(1) = (temp0(1) + temp1(5) + temp2(5) + temp3(5)) &
+ *2._ki/3._ki/sumb
+ res_4p4m_np2(2) = (temp0(2) + temp1(6) + temp2(6) + temp3(6)) &
+ *2._ki/3._ki/sumb
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ temp10 = a4p4m_np2(s24,s13,s14,s12,s23,s34,0,0,par2,par3)
+ temp11 = a4p4m_np2(s24,s13,s14,s12,s23,s34,0,0,par2,par4)
+ temp12 = a4p4m_np2(s24,s13,s14,s12,s23,s34,0,0,par3,par4)
+ !
+ temp13 = resultat(par_plus(4),:)
+ temp14 = resultat(par_plus(3),:)
+ temp15 = resultat(par_plus(2),:)
+ !
+ temp0 = b(par4)*temp10+b(par3)*temp11+b(par2)*temp12 &
+ - ( invs(par2,par3)*temp13+invs(par2,par4)*temp14&
+ +invs(par3,par4)*temp15 )/3._ki
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ temp3 = 0._ki
+ temp4 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if ( (j /= par2) .and. (j /= par3) ) then
+ !
+ truc1 = resultat33(j,par_plus(2),par_plus(3),:)
+ temp1 = temp1 + invs(j,par4)*truc1/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par4) ) then
+ !
+ truc2 = resultat33(j,par_plus(2),par_plus(4),:)
+ temp2 = temp2 + invs(j,par3)*truc2/6._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ truc3 = resultat33(j,par_plus(3),par_plus(4),:)
+ temp3 = temp3 + invs(j,par2)*truc3/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par3) .and. (j /= par4) ) then
+ !
+ temp4 = temp4 - b(j)*f3p_sc(s_mat,smj,locateb(par2,b_pro_mj), &
+ locateb(par3,b_pro_mj),locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p4m_np2(1) = ( temp0(1) + temp1(5) + temp2(5) + temp3(5) &
+ + temp4(5) )/2._ki/sumb
+ res_4p4m_np2(2) = ( temp0(2) + temp1(6) + temp2(6) + temp3(6) &
+ + temp4(6) )/2._ki/sumb
+ end if
+ !
+ end function a4p4m_np2
+ !
+ !****if* src/integrals/four_point/function_4p4m/a4p4m_np4
+ ! NAME
+ !
+ ! recursive function a4p4m_np4
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p4m_np4(s24,s13,s14,s12,s23,s34,par1,par2,par3,par4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the eight dimensional
+ ! three mass four point function. It is recursive and implement the formulae
+ ! of JHEP 10 (2005) 015.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s24 -- a real (type ki), the S matrix element 2,4
+ ! * s13 -- a real (type ki), the S matrix element 1,3
+ ! * s14 -- a real (type ki), the S matrix element 1,4
+ ! * s12 -- a real (type ki), the S matrix element 1,2
+ ! * s23 -- a real (type ki), the S matrix element 2,3
+ ! * s34 -- a real (type ki), the S matrix element 3,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p4m_np4(s24,s13,s14,s12,s23,s34,par1,par2,par3,par4) result(res_4p4m_np4)
+ !
+ real(ki), intent (in) :: s24,s13,s14,s12,s23,s34
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(4) :: res_4p4m_np4
+ !
+ integer, dimension(3) :: smj
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki), dimension(4) :: truc1
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(4) :: temp1,temp2,temp3
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a4p4m_np2(s24,s13,s14,s12,s23,s34,0,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp1 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ if (deja_calcule3_np2(j,1)) then
+ !
+ truc1 = resultat3_np2(j,1,:)
+ !
+ else
+ !
+ truc1 = f3p_np2_sc(s_mat,smj)
+ resultat3_np2(j,1,:) = truc1
+ deja_calcule3_np2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b(j)*truc1
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p4m_np4(1) = (-temp1(1))/(3._ki*sumb)
+ res_4p4m_np4(2) = (-temp1(2))/(3._ki*sumb)
+ res_4p4m_np4(3) = (temp0(1)-temp1(3)-2._ki/3._ki*temp1(1))/(3._ki*sumb)
+ res_4p4m_np4(4) = (temp0(2)-temp1(4)-2._ki/3._ki*temp1(2))/(3._ki*sumb)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ temp0 = a4p4m_np2(s24,s13,s14,s12,s23,s34,0,0,0,par4)/3._ki
+ temp1 = b(par4)*a4p4m_np4(s24,s13,s14,s12,s23,s34,0,0,0,0)
+ temp2 = 0._ki
+ temp3 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ smj = unpackb(b_pro_mj,countb(b_pro_mj))
+ !
+ truc1 = resultat3_np2(j,1,:)
+ temp2 = temp2 + invs(j,par4)*truc1/6._ki
+ !
+ if (j /= par4) then
+ !
+ temp3 = temp3 - b(j)*f3p_np2_sc(s_mat,smj,locateb(par4,b_pro_mj))/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p4m_np4(1) = ( temp1(1)+temp2(1)+temp3(1) )/(2._ki*sumb)
+ res_4p4m_np4(2) = ( temp1(2)+temp2(2)+temp3(2) )/(2._ki*sumb)
+ res_4p4m_np4(3) = ( temp1(3)+temp1(1)/6._ki+temp2(3)+temp2(1)/2._ki &
+ +temp3(3)+temp3(1)/2._ki+temp0(1) )/(2._ki*sumb)
+ res_4p4m_np4(4) = ( temp1(4)+temp1(2)/6._ki+temp2(4)+temp2(2)/2._ki &
+ +temp3(4)+temp3(2)/2._ki+temp0(2) )/(2._ki*sumb)
+ !
+ ! cas avec plus de un parametre de feynman au numerateur
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a4p4m_np4:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of four-point integrals in n+4 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb(par),4/)
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p4m_np4
+ !
+ !****f* src/integrals/four_point/function_4p4m/f4
+ ! NAME
+ !
+ ! function f4
+ !
+ ! USAGE
+ !
+ ! complex = f4(s,t,s1,s2,s3,s4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the "finite part" of the scalar four dimensional three
+ ! mass four point function.
+ !
+ !
+ ! INPUTS
+ !
+ ! * s -- a real (type ki), (p1+p2)^2
+ ! * t -- a real (type ki), (p2+p3)^2
+ ! * s1 -- a real (type ki), p1^2
+ ! * s2 -- a real (type ki), p2^2
+ ! * s3 -- a real (type ki), p3^2
+ ! * s4 -- a real (type ki), p4^2
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ ! Affected by the variable rat_or_tot_par (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !**********************************************************************
+ !
+ ! the _ki massless box function !!
+ !
+ ! note: parameters adapted for double precision
+ ! from Binoth et al.
+ !
+ function f4(s,t,s1,s2,s3,s4)
+ !
+ real(ki), intent(in) :: s,t,s1,s2,s3,s4
+ complex(ki) :: f4
+ !
+ complex(ki) :: k12,k13,k14,k23,k24,k34
+ complex(ki) :: a, b, c, d, e, f, discr, srdelta
+ complex(ki) :: x1, x2
+ complex(ki) :: eta
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ ! parameters:
+ !
+ eta= (1.e-25_ki,0._ki)
+ !
+ ! scaled momenta:
+ ! kij = - ( p_{i} + ... + p_{j-1} )^2
+ !
+ k12 = -s1
+ k13 = -s
+ k14 = -s4
+ k23 = -s2
+ k24 = -t
+ k34 = -s3
+ !
+ ! short hands:
+ !
+ a = k24*k34
+ b = k13*k24+k12*k34-k14*k23
+ c = k12*k13
+ d = k23
+ !
+ e = (k34-i_*eta)/(k13-i_*eta)
+ f = (k24-i_*eta)/(k12-i_*eta)
+ !
+ ! the discriminant:
+ !
+ discr = (b/a)**2 - 4._ki*( c + i_*eta*d*1._ki )/( a )
+ srdelta = sqrt( discr )
+ !
+ ! the roots:
+ !
+ x1 = -( b/a - srdelta )/2._ki
+ x2 = -( b/a + srdelta )/2._ki
+ !
+ ! the massless box function:
+ !
+ f4 = 1._ki /a / srdelta*&
+ ( + log(-x1)**2/2._ki &
+ + cdilog(1._ki+x1*e) + pheta(-x1,e)*log(1._ki+x1*e)&
+ + cdilog(1._ki+x1*f) + pheta(-x1,f)*log(1._ki+x1*f)&
+ - log(-x1)*( log(k12-i_*eta)+log(k13-i_*eta)&
+ -log(k14-i_*eta)-log(k23-i_*eta) )&
+ - log(-x2)**2/2._ki &
+ - cdilog(1._ki+x2*e) - pheta(-x2,e)*log(1._ki+x2*e)&
+ - cdilog(1._ki+x2*f) - pheta(-x2,f)*log(1._ki+x2*f)&
+ + log(-x2)*( log(k12-i_*eta)+log(k13-i_*eta)&
+ - log(k14-i_*eta)-log(k23-i_*eta) ) )
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f4 = 0._ki
+ !
+ end if
+ !
+ end function f4
+!**********************************************************************
+ function pheta(u,v)
+ !
+ complex(ki) :: u,v
+ complex(ki) :: pheta
+ !
+ complex(ki) :: w
+ !
+ w = u*v
+ ! pheta = i*2._ki*pi*(
+ ! & +theta(-dimag(u))*theta(-dimag(v))*theta( dimag(w))
+ ! & -theta( dimag(u))*theta( dimag(v))*theta(-dimag(w)) )
+ ! if (dimag(w).eq.0._ki.and.dble(w).le.0._ki) write (*,*) 'pheta !'
+ pheta = log( w ) - log( u ) - log( v )
+ !
+ end function pheta
+ !
+ !
+end module function_4p4m
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql10.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql10.f90
new file mode 100644
index 0000000..cb6f897
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql10.f90
@@ -0,0 +1,829 @@
+!
+!****h* src/integrals/four_point/function_4p_ql10
+! NAME
+!
+! Module function_4p_ql10
+!
+! USAGE
+!
+! use function_4p_ql10
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 10
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql10, f4p_ql10_c,f4p_ql10a, f4p_ql10a_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql10
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql10,f4p_ql10_c,f4p_ql10a,f4p_ql10a_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql10/f4p_ql10
+ ! NAME
+ !
+ ! Function f4p_ql10
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql10(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 10
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql10(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql10
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: coupure_4p_ql10
+ real(ki) :: norma
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql10 = 0._ki
+ coupure_4p_ql10 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql10) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql10 (in file f4p_ql10.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql10'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql10) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql10_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql10= a4p_ql10_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql10: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql10: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql10 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql10 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql10
+ !
+ !****f* src/integrals/four_point/function_4p_ql10/f4p_ql10_c
+ ! NAME
+ !
+ ! Function f4p_ql10_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql10_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql10
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql10
+ !
+ !*****
+ function f4p_ql10_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql10_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql10(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql10_c)
+ !
+ end function f4p_ql10_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql10/a4p_ql10_n
+ ! NAME
+ !
+ ! recursive function a4p_ql10_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql10_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql10_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql10_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql10_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,msq,deno
+ complex(ki) :: ds12,ds23,dm,dp2,dp3,dp4,di1,di2,di3,logp2mu,logs23mu,logp4mu,logsmu
+ complex(ki) :: eta1,eta2,eta3,etatt1,etatt2,etatt3
+ !
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ !
+ msq=m3s
+ deno=-s12*(msq-s23)-s2*(s4-msq)
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dm=msq-i_*del
+ dp2= s2 +i_*del
+ dp3= s3 +i_*del
+ dp4= s4 +i_*del
+ di1 = cdilog(1._ki-(dm-dp3)*(dm-ds23)/dm/(-dp2))
+ di2 = cdilog(1._ki-(dm-dp3)*(dm-dp4)/dm/(-ds12))
+ di3 = cdilog(1._ki-(-dp2)/(-ds12)*(dm-dp4)/(dm-ds23))
+ logp2mu=log(-dp2/mu2)
+ logsmu=log(-ds12/mu2)
+ logs23mu=log((msq-ds23)/mu2)
+ logp4mu=log((msq-dp4)/mu2)
+ eta1=log((dm-dp3)/dm*(dm-ds23)/(-dp2))-log((dm-dp3)/dm)-log((dm-ds23)/(-dp2))
+ eta2=log((dm-dp3)/dm*(dm-dp4)/(-ds12))-log((dm-dp3)/dm)-log((dm-dp4)/(-ds12))
+ eta3=log((dm-dp4)/(dm-ds23)*(-dp2)/(-ds12))-log((dm-dp4)/(dm-ds23))-log((-dp2)/(-ds12))
+ etatt1=eta1*log(1._ki-(dm-dp3)*(dm-ds23)/(-dp2*dm))
+ etatt2=eta2*log(1._ki-(dm-dp3)*(dm-dp4)/(-ds12*dm))
+ etatt3=eta3*log(1._ki-(dm-dp4)/(dm-ds23)*dp2/ds12)
+ !
+ res_4p_ql10_n(1) = 0._ki
+ res_4p_ql10_n(2) = 0._ki
+ res_4p_ql10_n(3) = real( -(log((-ds12)/mu2)-log((-dp2)/mu2)+log((msq-ds23)/mu2)-&
+ & log((msq-dp4)/mu2) )/deno )
+ res_4p_ql10_n(4) = aimag( -(log((-ds12)/mu2)-log((-dp2)/mu2)+log((msq-ds23)/mu2)-&
+ & log((msq-dp4)/mu2) )/deno )
+ res_4p_ql10_n(5) = real( (di1+etatt1-di2-etatt2+2*(di3+etatt3) + &
+ & 2*cdilog(1._ki-(dm-ds23)/(dm-dp4))-2*cdilog(1._ki-dp2/ds12) + &
+ & 2*(log(msq/(msq-ds23))+log(mu2/msq)/2._ki)* &
+ & (-logsmu-logs23mu+logp2mu+logp4mu) )/deno )
+ res_4p_ql10_n(6) = aimag( (di1+etatt1-di2-etatt2+2*(di3+etatt3) + &
+ & 2*cdilog(1._ki-(dm-ds23)/(dm-dp4))-2*cdilog(1._ki-dp2/ds12) + &
+ & 2*(log(msq/(msq-ds23))+log(mu2/msq)/2._ki)* &
+ & (-logsmu-logs23mu+logp2mu+logp4mu) )/deno )
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql10: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql10_n
+ !
+ !****f* src/integrals/four_point/function_4p_ql10a/f4p_ql10a
+ ! NAME
+ !
+ ! Function f4p_ql10a
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql10a(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql10a(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql10a
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: coupure_4p_ql10
+ real(ki) :: norma
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql10a = 0._ki
+ coupure_4p_ql10 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql10) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql10 (in file f4p_ql10.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql10'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql10) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql10a_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql10a= a4p_ql10a_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql10: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql10a: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql10 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql10 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql10a
+ !
+ !****f* src/integrals/four_point/function_4p_ql10/f4p_ql10a_c
+ ! NAME
+ !
+ ! Function f4p_ql10a_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql10a_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql10
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql10
+ !
+ !*****
+ function f4p_ql10a_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql10a_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql10(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql10a_c)
+ !
+ end function f4p_ql10a_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql10a/a4p_ql10a_n
+ ! NAME
+ !
+ ! recursive function a4p_ql10a_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql10a_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql10a_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql10a_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql10a_n
+ !
+ !integer, dimension(3) :: smj
+ !integer, dimension(3) :: sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,msq,deno
+ complex(ki) :: ds12,ds23,dm,dp2,dp3,dp4,di3,logs23mu,logm2mu,logsmu
+ !complex(ki) :: logp2mu
+ !complex(ki) :: eta3,etatt3,c1,c2,c3,c4,c5
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ !
+ msq=m3s
+ deno=s12*s23-s12*msq+msq**2
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dm=msq-i_*del
+ dp2= s2 +i_*del
+ dp3= s3 +i_*del
+ dp4= s4 +i_*del
+ di3 = cdilog(1._ki-msq**2/(ds12)/(dm-ds23))
+ logsmu=log(-ds12/mu2)
+ logs23mu=log((msq-ds23)/mu2)
+ logm2mu=log(msq/mu2)
+ !
+ res_4p_ql10a_n(1) = 0._ki
+ res_4p_ql10a_n(2) = 0._ki
+ res_4p_ql10a_n(3) = real( -(log((-ds12)/mu2)+log((ds23-msq)/mu2)-&
+ & 2*logm2mu )/deno )
+ res_4p_ql10a_n(4) = aimag( -(log((-ds12)/mu2)+log((ds23-msq)/mu2)-&
+ & 2*logm2mu )/deno )
+ res_4p_ql10a_n(5) = real( (2*di3 + &
+ & 2*cdilog(1._ki-(dm-ds23)/dm)-2*cdilog(1._ki-msq/ds12) + &
+ & 2*(log(msq/(msq-ds23))+log(mu2/msq)/2._ki)* &
+ & (-logsmu-log((ds23-msq)/mu2) +2*logm2mu) )/deno )
+ res_4p_ql10a_n(6) = aimag( (2*di3 + &
+ & 2*cdilog(1._ki-(dm-ds23)/dm)-2*cdilog(1._ki-msq/ds12) + &
+ & 2*(log(msq/(msq-ds23))+log(mu2/msq)/2._ki)* &
+ & (-logsmu-log((ds23-msq)/mu2)+2*logm2mu) )/deno )
+ !
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql10: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql10a_n
+ !
+ !
+ !
+end module function_4p_ql10
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql11.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql11.f90
new file mode 100644
index 0000000..75d1559
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql11.f90
@@ -0,0 +1,466 @@
+!
+!****h* src/integrals/four_point/function_4p_ql11
+! NAME
+!
+! Module function_4p_ql11
+!
+! USAGE
+!
+! use function_4p_ql11
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 11
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql11, f4p_ql11_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql11
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ !
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql11,f4p_ql11_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql11/f4p_ql11
+ ! NAME
+ !
+ ! Function f4p_ql11
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql11(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql11(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql11
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: coupure_4p_ql11
+ real(ki) :: norma
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql11 = 0._ki
+ coupure_4p_ql11 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql11) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql11 (in file f4p_ql11.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql11'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql11) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql11_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql11= a4p_ql11_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql11: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql11: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql11 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql11 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql11
+ !
+ !****f* src/integrals/four_point/function_4p_ql11/f4p_ql11_c
+ ! NAME
+ !
+ ! Function f4p_ql11_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql11_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql11
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql11
+ !
+ !*****
+ function f4p_ql11_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql11_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql11(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql11_c)
+ !
+ end function f4p_ql11_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql11/a4p_ql11_n
+ ! NAME
+ !
+ ! recursive function a4p_ql11_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql11_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql11_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql11_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql11_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,deno,s3cut
+ !real(ki) :: msq
+ complex(ki) :: ds12,ds23,dp3,dp4,logm3,logm4,logmu3,logmu4
+ complex(ki) :: dm3,dm4,m34p3,gaplus,gaminus
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ s3cut=1.e-8_ki
+ !
+ deno=(m2s-s12)*(m3s-s23)
+ ! relabel masses to LoopTools conventions
+ dm3=m2s-i_*del
+ dm4=m3s-i_*del
+ !
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dp3= s3 +i_*del
+ dp4= s4 +i_*del
+ logm3=log((dm3-ds12)/dm3)
+ logm4=log((dm4-ds23)/dm4)
+ logmu3=log(dm3/mu2)
+ logmu4=log(dm4/mu2)
+ m34p3=1._ki-(dm3-dm4)/dp3
+ gaplus=(m34p3+Sqrt(m34p3**2-4*dm4/dp3))/2._ki
+ gaminus=(m34p3-Sqrt(m34p3**2-4*dm4/dp3))/2._ki
+ !
+ ! case p3^2 > s3cut
+ if (abs(s3) > s3cut) then
+ res_4p_ql11_n(1) = 1._ki/deno
+ res_4p_ql11_n(2) = 0._ki
+ res_4p_ql11_n(3) = real( -(logm3+logm4+logmu3/2._ki+logmu4/2._ki)/deno )
+ res_4p_ql11_n(4) = aimag(-(logm3+logm4+logmu3/2._ki+logmu4/2._ki)/deno )
+ res_4p_ql11_n(5) = real( ( 2*(logm3+logmu3/2._ki)*(logm4+logmu4/2._ki) &
+ & - Pi**2/2+Log(dm3/dm4)**2/4._ki-Log(gaplus/(gaplus-1.0_ki))**2/2._ki &
+ & - Log(gaminus/(gaminus-1._ki))**2/2._ki )/deno )
+ res_4p_ql11_n(6) = aimag( ( 2*(logm3+logmu3/2._ki)*(logm4+logmu4/2._ki) &
+ & +Log(dm3/dm4)**2/4._ki-Log(gaplus/(gaplus-1.0_ki))**2/2._ki &
+ & - Log(gaminus/(gaminus-1._ki))**2/2._ki )/deno )
+ !
+ else ! limit p3^2 -> 0
+ res_4p_ql11_n(1) = 1._ki/deno
+ res_4p_ql11_n(2) = 0._ki
+ res_4p_ql11_n(3) = real( -(logm3+logm4+logmu3/2._ki+logmu4/2._ki)/deno )
+ res_4p_ql11_n(4) = aimag(-(logm3+logm4+logmu3/2._ki+logmu4/2._ki)/deno )
+ res_4p_ql11_n(5) = real( ( 2*(logm3+logmu3/2._ki)*(logm4+logmu4/2._ki) &
+ & - Pi**2/2 - Log(dm3/dm4)**2/4._ki )/deno )
+ res_4p_ql11_n(6) = aimag( ( 2*(logm3+logmu3/2._ki)*(logm4+logmu4/2._ki) &
+ & -Log(dm3/dm4)**2/4._ki )/deno )
+ !
+ end if ! end p3^2 > s3cut
+ !
+ else ! QL11 shouldn't be called in non-scalar case
+ !
+ !~ call print_error('In function f4p_ql11: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql11: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if ! end if (nb_par_loc == 0)
+ !
+ end function a4p_ql11_n
+ !
+ !
+end module function_4p_ql11
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql12.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql12.f90
new file mode 100644
index 0000000..86b569b
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql12.f90
@@ -0,0 +1,507 @@
+!
+!****h* src/integrals/four_point/function_4p_ql12
+! NAME
+!
+! Module function_4p_ql12
+!
+! USAGE
+!
+! use function_4p_ql12
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 12
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql12, f4p_ql12_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql12
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ !~ use more_integ_info
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ !
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ !
+ public :: f4p_ql12,f4p_ql12_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql12/f4p_ql12
+ ! NAME
+ !
+ ! Function f4p_ql12
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql12(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql12(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql12
+ !
+ integer :: nb_par
+ real(ki) :: norma,coupure_4p_ql12
+ !real(ki) :: plus_grand
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql12 = 0._ki
+ coupure_4p_ql12 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql12) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql12 (in file f4p_ql12.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql12'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql12) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql12_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql12= a4p_ql12_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql12: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql12: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql12 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql12 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql12
+ !
+ !****f* src/integrals/four_point/function_4p_ql12/f4p_ql12_c
+ ! NAME
+ !
+ ! Function f4p_ql12_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql12_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql12
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql12
+ !
+ !*****
+ function f4p_ql12_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql12_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql12(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql12_c)
+ !
+ end function f4p_ql12_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql12/a4p_ql12_n
+ ! NAME
+ !
+ ! recursive function a4p_ql12_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql12_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql12_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql12_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql12_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ real(ki) :: del,m3sq,m4sq,deno,m3mu,s3cut
+ complex(ki) :: ds12,ds23,dp3,dp4,dm3,dm4,logm3,logm4
+ complex(ki) :: logmu3,logmu4
+ !complex(ki) :: logsmu, logsm, test1,test2,test3,test4,test0
+ complex(ki) :: eta1,eta2,anacon1,anacon2,eta3,anacon3
+ complex(ki) :: gaplus43,gaplus34,gaminus43,gaminus34,m34,m43
+!
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ s3cut=1.e-8_ki
+ !
+ ! relabel to QCDL conventions
+ m3sq=m2s
+ m4sq=m3s
+ dm3=m2s-i_*del
+ dm4=m3s-i_*del
+ !
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dp3= s3 +i_*del;
+ dp4= s4 +i_*del;
+!
+ logm3=log((dm3-ds12)/dm3)
+ logm4=log((dm4-ds23)/dm3)
+ logmu3=log(dm3/mu2)
+ logmu4=log(dm4/mu2)
+ m3mu=sqrt(m3sq*mu2)
+!
+ deno=(s12-m3sq)*(s23-m4sq)
+ m34=1._ki-(dm3-dm4)/dp3
+ m43=1._ki-(dm4-dm3)/dp3
+ gaplus34=(m34+Sqrt(m34**2-4*dm4/dp3))/2._ki
+ gaminus34=(m34-Sqrt(m34**2-4*dm4/dp3))/2._ki
+ gaplus43=(m43+Sqrt(m43**2-4*dm3/dp3))/2._ki
+ gaminus43=(m43-Sqrt(m43**2-4*dm3/dp3))/2._ki
+ !
+ eta1=log( (dm4-dp4)/(dm3-ds12)*gaplus43/(gaplus43-1._ki) ) &
+ & - log( (dm4-dp4)/(dm3-ds12) ) - log( gaplus43/(gaplus43-1._ki) )
+ eta2=log( (dm4-dp4)/(dm3-ds12)*gaminus43/(gaminus43-1._ki) ) &
+ & - log( (dm4-dp4)/(dm3-ds12) ) - log( gaminus43/(gaminus43-1._ki) )
+ eta3=log( (dm4-dp4)/(dm3-ds12)*dm3/dm4 ) &
+ & - log( (dm4-dp4)/(dm3-ds12) ) - log( dm3/dm4 )
+ anacon1=cdilog(1._ki-(dm4-dp4)/(dm3-ds12)*gaplus43/(gaplus43-1._ki))+ &
+ & eta1*log(1._ki-(dm4-dp4)/(dm3-ds12)*gaplus43/(gaplus43-1._ki))
+ anacon2=cdilog(1._ki-(dm4-dp4)/(dm3-ds12)*gaminus43/(gaminus43-1._ki))+ &
+ & eta2*log(1._ki-(dm4-dp4)/(dm3-ds12)*gaminus43/(gaminus43-1._ki))
+ anacon3=cdilog(1._ki-(dm4-dp4)/(dm3-ds12)*dm3/dm4)+ &
+ & eta3*log(1._ki-(dm4-dp4)/(dm3-ds12)*dm3/dm4)
+ !
+ ! case p3^2 > delta
+ if (abs(s3) > s3cut) then
+ !
+ res_4p_ql12_n(1) = 1._ki/2._ki/deno
+ res_4p_ql12_n(2) = 0._ki
+ res_4p_ql12_n(3) = real( -(logm3+log((dm4-ds23)/(dm4-dp4))+logmu3/2._ki )/deno )
+ res_4p_ql12_n(4) = aimag( -(logm3+log((dm4-ds23)/(dm4-dp4))+logmu3/2._ki )/deno )
+ res_4p_ql12_n(5) = real( (2*log((dm4-ds23)/m3mu)*log((dm3-ds12)/m3mu) &
+ & -(log((dm4-dp4)/m3mu))**2 - Pi**2/12 &
+ & +log((dm4-dp4)/(dm3-ds12))*log(dm4/dm3) &
+ & -log(gaplus34/(gaplus34-1._ki))**2/2._ki &
+ & -log(gaminus34/(gaminus34-1._ki))**2/2._ki &
+ & -2*cdilog(1._ki-(dm4-dp4)/(dm4-ds23))-anacon1-anacon2)/deno )
+ res_4p_ql12_n(6) = aimag( (2*log((dm4-ds23)/m3mu)*log((dm3-ds12)/m3mu) &
+ & -(log((dm4-dp4)/m3mu))**2 &
+ & +log((dm4-dp4)/(dm3-ds12))*log(dm4/dm3) &
+ & -log(gaplus34/(gaplus34-1._ki))**2/2._ki &
+ & -log(gaminus34/(gaminus34-1._ki))**2/2._ki &
+ & -2*cdilog(1._ki-(dm4-dp4)/(dm4-ds23))-anacon1-anacon2)/deno )
+ !
+ else ! limit p3^2 -> 0
+ !
+ res_4p_ql12_n(1) = 1._ki/2._ki/deno
+ res_4p_ql12_n(2) = 0._ki
+ res_4p_ql12_n(3) = real( -(logm3+log((dm4-ds23)/(dm4-dp4))+logmu3/2._ki )/deno )
+ res_4p_ql12_n(4) = aimag( -(logm3+log((dm4-ds23)/(dm4-dp4))+logmu3/2._ki )/deno )
+ res_4p_ql12_n(5) = real( (2*log((dm4-ds23)/m3mu)*log((dm3-ds12)/m3mu) &
+ & -(log((dm4-dp4)/m3mu))**2 - Pi**2/12 &
+ & +log((dm4-dp4)/(dm3-ds12))*log(dm4/dm3) &
+ & -log(dm4/dm3)**2/2._ki &
+ & -2*cdilog(1._ki-(dm4-dp4)/(dm4-ds23)) &
+ & - cdilog(1._ki-(dm4-dp4)/(dm3-ds12)) &
+ & - cdilog(1._ki-(dm4-dp4)/(dm3-ds12)*dm3/dm4) )/deno )
+ res_4p_ql12_n(6) = aimag( (2*log((dm4-ds23)/m3mu)*log((dm3-ds12)/m3mu) &
+ & -(log((dm4-dp4)/m3mu))**2 &
+ & +log((dm4-dp4)/(dm3-ds12))*log(dm4/dm3) &
+ & -log(dm4/dm3)**2/2._ki &
+ & -2*cdilog(1._ki-(dm4-dp4)/(dm4-ds23)) &
+ & - cdilog(1._ki-(dm4-dp4)/(dm3-ds12)) &
+ & - anacon3 )/deno )
+ !
+ end if ! end p3^2 > s3cut
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql12: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql12: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql12_n
+ !
+ !
+end module function_4p_ql12
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql13.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql13.f90
new file mode 100644
index 0000000..2937481
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql13.f90
@@ -0,0 +1,537 @@
+!
+!****h* src/integrals/four_point/function_4p_ql13
+! NAME
+!
+! Module function_4p_ql13
+!
+! USAGE
+!
+! use function_4p_ql13
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 12
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql13, f4p_ql13_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql13
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ !~ use more_integ_info
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql13,f4p_ql13_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql13/f4p_ql13
+ ! NAME
+ !
+ ! Function f4p_ql13
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql13(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql13(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql13
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: norma,coupure_4p_ql13
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql13 = 0._ki
+ coupure_4p_ql13 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql13) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql13 (in file f4p_ql13.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql13'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql13) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql13_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql13= a4p_ql13_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql13: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql13: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql13 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql13 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql13
+ !
+ !****f* src/integrals/four_point/function_4p_ql13/f4p_ql13_c
+ ! NAME
+ !
+ ! Function f4p_ql13_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql13_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql13
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql13
+ !
+ !*****
+ function f4p_ql13_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql13_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql13(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql13_c)
+ !
+ end function f4p_ql13_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql13/a4p_ql13_n
+ ! NAME
+ !
+ ! recursive function a4p_ql13_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql13_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql13_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql13_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql13_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,m3sq,m4sq,deno,m3mu,s3cut
+ complex(ki) :: ds12,ds23,dp2,dp3,dp4,dm3,dm4,logm3,logm4,logmu3,logmu4!,logsm,logsmu
+ complex(ki) :: gaplus43,gaplus34,gaminus43,gaminus34,m34,m43
+ complex(ki) :: anacon1,anacon2,anacon3,anacon4,anacon5,anacon6,anacon7,eta1,eta2,eta3,eta4,eta5,eta6,eta7
+!
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ s3cut=1.e-8_ki
+ !
+ ! relabel to QCDL conventions
+ m3sq=m2s
+ m4sq=m3s
+ dm3=m2s-i_*del
+ dm4=m3s-i_*del
+ !
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dp2= s2 +i_*del;
+ dp3= s3 +i_*del;
+ dp4= s4 +i_*del;
+!
+ logm3=log((dm3-ds12)/dm3)
+ logm4=log((dm4-ds23)/dm3)
+ logmu3=log(dm3/mu2)
+ logmu4=log(dm4/mu2)
+ m3mu=sqrt(m3sq*mu2)
+!
+ deno=(s12-m3sq)*(s23-m4sq)-(m3sq-s2)*(m4sq-s4)
+ m34=1._ki-(dm3-dm4)/dp3
+ m43=1._ki-(dm4-dm3)/dp3
+ gaplus34=(m34+Sqrt(m34**2-4*dm4/dp3))/2._ki
+ gaminus34=(m34-Sqrt(m34**2-4*dm4/dp3))/2._ki
+ gaplus43=(m43+Sqrt(m43**2-4*dm3/dp3))/2._ki
+ gaminus43=(m43-Sqrt(m43**2-4*dm3/dp3))/2._ki
+ !
+ eta1=log( (dm3-dp2)/(dm4-ds23)*gaplus34/(gaplus34-1._ki) ) &
+ & - log( (dm3-dp2)/(dm4-ds23) ) - log( gaplus34/(gaplus34-1._ki) )
+ eta2=log( (dm3-dp2)/(dm4-ds23)*gaminus34/(gaminus34-1._ki) ) &
+ & - log( (dm3-dp2)/(dm4-ds23) ) - log( gaminus34/(gaminus34-1._ki) )
+ eta3=log( (dm4-dp4)/(dm3-ds12)*gaplus43/(gaplus43-1._ki) ) &
+ & - log( (dm4-dp4)/(dm3-ds12) ) - log( gaplus43/(gaplus43-1._ki) )
+ eta4=log( (dm4-dp4)/(dm3-ds12)*gaminus43/(gaminus43-1._ki) ) &
+ & - log( (dm4-dp4)/(dm3-ds12) ) - log( gaminus43/(gaminus43-1._ki) )
+ eta5=log( (dm3-dp2)/(dm3-ds12)*(dm4-dp4)/(dm4-ds23) ) &
+ & - log( (dm3-dp2)/(dm3-ds12) ) - log( (dm4-dp4)/(dm4-ds23) )
+
+ anacon1=cdilog(1._ki-(dm3-dp2)/(dm4-ds23)*gaplus34/(gaplus34-1._ki))+ &
+ & eta1*Log(1._ki-(dm3-dp2)/(dm4-ds23)*gaplus34/(gaplus34-1._ki))
+ anacon2=cdilog(1._ki-(dm3-dp2)/(dm4-ds23)*gaminus34/(gaminus34-1._ki))+ &
+ & eta2*Log(1._ki-(dm3-dp2)/(dm4-ds23)*gaminus34/(gaminus34-1._ki))
+ anacon3=cdilog(1._ki-(dm4-dp4)/(dm3-ds12)*gaplus43/(gaplus43-1._ki))+ &
+ & eta3*log(1-(dm4-dp4)/(dm3-ds12)*gaplus43/(gaplus43-1._ki))
+ anacon4=cdilog(1._ki-(dm4-dp4)/(dm3-ds12)*gaminus43/(gaminus43-1._ki))+ &
+ & eta4*log(1-(dm4-dp4)/(dm3-ds12)*gaminus43/(gaminus43-1._ki))
+ anacon5=cdilog(1._ki-(dm3-dp2)/(dm3-ds12)*(dm4-dp4)/(dm4-ds23))+ &
+ eta5*Log(1._ki-(dm3-dp2)/(dm3-ds12)*(dm4-dp4)/(dm4-ds23))
+ !
+ res_4p_ql13_n(1) = 0._ki
+ res_4p_ql13_n(2) = 0._ki
+ ! case p3^2 > delta
+ if (abs(s3) > s3cut) then
+ !
+ res_4p_ql13_n(3) = real( (log((dm3-dp2)/mu2)+log((dm4-dp4)/mu2) &
+ & -log((dm4-ds23)/mu2)-log((dm3-ds12)/mu2))/deno )
+ res_4p_ql13_n(4) = aimag( (log((dm3-dp2)/mu2)+log((dm4-dp4)/mu2) &
+ & -log((dm4-ds23)/mu2)-log((dm3-ds12)/mu2))/deno )
+ res_4p_ql13_n(5) = real( ( -2*cdilog(1._ki-(dm3-dp2)/(dm3-ds12)) &
+ & -2*cdilog(1._ki-(dm4-dp4)/(dm4-ds23)) &
+ & -anacon1-anacon2-anacon3-anacon4+2*anacon5 &
+ & +2*log((dm3-ds12)/mu2)*log((dm4-ds23)/mu2) &
+ & -log((dm3-dp2)/mu2)**2-log((dm4-dp4)/mu2)**2 &
+ & +log((dm3-dp2)/(dm4-ds23))*log(dm3/mu2) &
+ & +log((dm4-dp4)/(dm3-ds12))*log(dm4/mu2) &
+ & - log(gaplus34/(gaplus34-1._ki))**2/2._ki &
+ & - log(gaminus34/(gaminus34-1._ki))**2/2._ki )/deno )
+ res_4p_ql13_n(6) = aimag( ( -2*cdilog(1._ki-(dm3-dp2)/(dm3-ds12)) &
+ & -2*cdilog(1._ki-(dm4-dp4)/(dm4-ds23)) &
+ & -anacon1-anacon2-anacon3-anacon4+2*anacon5 &
+ & +2*log((dm3-ds12)/mu2)*log((dm4-ds23)/mu2) &
+ & -log((dm3-dp2)/mu2)**2-log((dm4-dp4)/mu2)**2 &
+ & +log((dm3-dp2)/(dm4-ds23))*log(dm3/mu2) &
+ & +log((dm4-dp4)/(dm3-ds12))*log(dm4/mu2) &
+ & - log(gaplus34/(gaplus34-1._ki))**2/2._ki &
+ & - log(gaminus34/(gaminus34-1._ki))**2/2._ki )/deno )
+ !
+ else ! limit p3^2 -> 0
+ !
+ eta6=log( (dm3-dp2)/(dm4-ds23)*dm4/dm3 ) &
+ & - log( (dm3-dp2)/(dm4-ds23) ) - log( dm4/dm3 )
+ eta7=log( (dm4-dp4)/(dm3-ds12)*dm3/dm4 ) &
+ & - log( (dm4-dp4)/(dm3-ds12) ) - log( dm3/dm4 )
+ anacon6=cdilog(1._ki-(dm3-dp2)/(dm4-ds23)*dm4/dm3)+ &
+ & eta6*Log(1._ki-(dm3-dp2)/(dm4-ds23)*dm4/dm3)
+ anacon7=cdilog(1._ki-(dm4-dp4)/(dm3-ds12)*dm3/dm4)+ &
+ & eta7*log(1-(dm4-dp4)/(dm3-ds12)*dm3/dm4)
+!
+ res_4p_ql13_n(3) = real( (log((dm3-dp2)/mu2)+log((dm4-dp4)/mu2) &
+ & -log((dm4-ds23)/mu2)-log((dm3-ds12)/mu2))/deno )
+ res_4p_ql13_n(4) = aimag( (log((dm3-dp2)/mu2)+log((dm4-dp4)/mu2) &
+ & -log((dm4-ds23)/mu2)-log((dm3-ds12)/mu2))/deno )
+ res_4p_ql13_n(5) = real( ( -2*cdilog(1._ki-(dm3-dp2)/(dm3-ds12)) &
+ & -2*cdilog(1._ki-(dm4-dp4)/(dm4-ds23)) &
+ & - cdilog(1._ki-(dm4-dp4)/(dm3-ds12)) &
+ & - cdilog(1._ki-(dm3-dp2)/(dm4-ds23)) &
+ & - anacon6 - anacon7 +2*anacon5 &
+ & +2*log((dm3-ds12)/mu2)*log((dm4-ds23)/mu2) &
+ & -log((dm3-dp2)/mu2)**2-log((dm4-dp4)/mu2)**2 &
+ & +log((dm3-dp2)/(dm4-ds23))*log(dm3/mu2) &
+ & +log((dm4-dp4)/(dm3-ds12))*log(dm4/mu2) &
+ & - log(dm4/dm3)**2/2._ki )/deno )
+ res_4p_ql13_n(6) = aimag( ( -2*cdilog(1._ki-(dm3-dp2)/(dm3-ds12)) &
+ & -2*cdilog(1._ki-(dm4-dp4)/(dm4-ds23)) &
+ & - cdilog(1._ki-(dm4-dp4)/(dm3-ds12)) &
+ & - cdilog(1._ki-(dm3-dp2)/(dm4-ds23)) &
+ & - anacon6 - anacon7 +2*anacon5 &
+ & +2*log((dm3-ds12)/mu2)*log((dm4-ds23)/mu2) &
+ & -log((dm3-dp2)/mu2)**2-log((dm4-dp4)/mu2)**2 &
+ & +log((dm3-dp2)/(dm4-ds23))*log(dm3/mu2) &
+ & +log((dm4-dp4)/(dm3-ds12))*log(dm4/mu2) &
+ & - log(dm4/dm3)**2/2._ki )/deno )
+ !
+ end if ! end p3^2 > s3cut
+ !
+ else ! non-scalar case
+ !
+ !~ call print_error('In function f4p_ql13: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql13: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql13_n
+ !
+ !
+end module function_4p_ql13
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql14.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql14.f90
new file mode 100644
index 0000000..c8607f3
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql14.f90
@@ -0,0 +1,456 @@
+!
+!****h* src/integrals/four_point/function_4p_ql14
+! NAME
+!
+! Module function_4p_ql14
+!
+! USAGE
+!
+! use function_4p_ql14
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 14
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql14, f4p_ql14_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql14
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql14,f4p_ql14_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql14/f4p_ql14
+ ! NAME
+ !
+ ! Function f4p_ql14
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql14(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql14(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql14
+ !
+ integer :: nb_par
+ real(ki) :: norma,coupure_4p_ql14
+ !real(ki) :: plus_grand
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql14 = 0._ki
+ coupure_4p_ql14 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql14) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql14 (in file f4p_ql14.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql14'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql14) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql14_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql14= a4p_ql14_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql14: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql14: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql14 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql14 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql14
+ !
+ !****f* src/integrals/four_point/function_4p_ql14/f4p_ql14_c
+ ! NAME
+ !
+ ! Function f4p_ql14_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql14_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql14
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql14
+ !
+ !*****
+ function f4p_ql14_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql14_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql14(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql14_c)
+ !
+ end function f4p_ql14_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql14/a4p_ql14_n
+ ! NAME
+ !
+ ! recursive function a4p_ql14_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql14_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql14_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql14_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql14_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ !real(k9) :: msq
+ real(ki) :: del,deno,cut,lim
+ complex(ki) :: ds12,ds23,dm2,dm4,beta23,x23,logsmu,fac,rm2,rm4
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ cut=1.e-8_ki
+ lim=abs(s23-(sqrt(m1s)-sqrt(m3s))**2)
+ !
+ dm2=m1s-i_*del
+ dm4=m3s-i_*del
+ rm2=sqrt(m1s)
+ rm4=sqrt(m3s)
+ !
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ !
+ logsmu=log(mu2/(-ds12))
+ beta23=Sqrt(1._ki-4*rm2*rm4/(ds23-(rm2-rm4)**2))
+ x23=-(1._ki-beta23)/(1._ki+beta23)
+ deno=rm2*rm4*s12
+ fac=-2*x23*log(x23)/(1-x23**2)/deno
+ !
+ res_4p_ql14_n(1) = 0._ki
+ res_4p_ql14_n(2) = 0._ki
+ !
+ ! case lim > cut
+ if (lim > cut) then
+ !
+ res_4p_ql14_n(3) = real(fac)
+ res_4p_ql14_n(4) = aimag(fac)
+ res_4p_ql14_n(5) = real( fac*logsmu )
+ res_4p_ql14_n(6) = aimag( fac*logsmu )
+ !
+ else ! use approximation for x23->1
+ !
+ res_4p_ql14_n(3) = real(1._ki/deno)
+ res_4p_ql14_n(4) = 0._ki
+ res_4p_ql14_n(5) = real( logsmu/deno )
+ res_4p_ql14_n(6) = aimag( logsmu/deno )
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql14: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql14: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql14_n
+ !
+ !
+end module function_4p_ql14
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql15.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql15.f90
new file mode 100644
index 0000000..6612d15
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql15.f90
@@ -0,0 +1,508 @@
+!
+!****h* src/integrals/four_point/function_4p_ql15
+! NAME
+!
+! Module function_4p_ql15
+!
+! USAGE
+!
+! use function_4p_ql15
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 14
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql15, f4p_ql15_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql15
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql15,f4p_ql15_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql15/f4p_ql15
+ ! NAME
+ !
+ ! Function f4p_ql15
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql15(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql15(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql15
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: norma,coupure_4p_ql15
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql15 = 0._ki
+ coupure_4p_ql15 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql15) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql15 (in file f4p_ql15.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql15'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql15) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql15_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql15= a4p_ql15_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql15: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql15: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql15 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql15 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql15
+ !
+ !****f* src/integrals/four_point/function_4p_ql15/f4p_ql15_c
+ ! NAME
+ !
+ ! Function f4p_ql15_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql15_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql15
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql15
+ !
+ !*****
+ function f4p_ql15_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql15_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql15(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql15_c)
+ !
+ end function f4p_ql15_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql15/a4p_ql15_n
+ ! NAME
+ !
+ ! recursive function a4p_ql15_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql15_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql15_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql15_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql15_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,rm2,rm4,lim1,lim2,lim3,cut
+ !real(ki) :: msq
+ complex(ki) :: ds12,ds23,dm2,dm4,dp2,dp3,beta23,x23,fac,y,deno
+ !complex(ki) :: logsmu
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ cut=1.e-8_ki
+ !
+ dm2=m1s-i_*del
+ dm4=m3s-i_*del
+ rm2=sqrt(m1s)
+ rm4=sqrt(m3s)
+ !
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dp2= s2+i_*del
+ dp3= s3+i_*del
+ !
+ lim1=abs(m3s-s3)
+ lim2=abs(m1s-s2)
+ lim3=abs(s23-(rm2-rm4)**2)
+ !
+ y=rm2/rm4*(dm4-dp3)/(dm2-dp2)
+ beta23=Sqrt(1._ki-4*rm2*rm4/(ds23-(rm2-rm4)**2))
+ x23=-(1._ki-beta23)/(1._ki+beta23)
+ deno=rm2*rm4*ds12
+ fac=x23/(1._ki-x23**2)/deno
+ !
+ res_4p_ql15_n(1) = 0._ki
+ res_4p_ql15_n(2) = 0._ki
+ !
+ if ( (lim1 < cut).and.(lim2 > cut) .and. (lim3 > cut) ) then
+ !
+ res_4p_ql15_n(3) = real(-fac*log(x23))
+ res_4p_ql15_n(4) = aimag(-fac*log(x23))
+ res_4p_ql15_n(5) = real( fac*log(x23)*(-log(x23) -log(mu2/dm2) &
+ & -2*log((dm2-dp2)/(-ds12)) ) &
+ & + fac*( -cdilog(1._ki-x23**2) &
+ & + cdilog(1._ki-x23*y) &
+ & - cdilog(1._ki-y/x23) ) )
+ res_4p_ql15_n(6) = aimag( fac*log(x23)*(-log(x23) -log(mu2/dm2) &
+ & -2*log((dm2-dp2)/(-ds12)) ) &
+ & + fac*( -cdilog(1._ki-x23**2) &
+ & + cdilog(1._ki-x23*y) &
+ & - cdilog(1._ki-y/x23) ) )
+ !
+ else if ( (lim2 < cut).and.(lim1>cut) .and. (lim3 > cut) ) then
+ !
+ res_4p_ql15_n(3) = real(-fac*log(x23))
+ res_4p_ql15_n(4) = aimag(-fac*log(x23))
+ res_4p_ql15_n(5) = real( fac*log(x23)*(-log(x23) -log(mu2/dm4) &
+ & -2*log((dm4-dp3)/(-ds12)) ) &
+ & + fac*( -cdilog(1._ki-x23**2) &
+ & + cdilog(1._ki-x23/y) &
+ & - cdilog(1._ki-1._ki/y/x23) ) )
+ res_4p_ql15_n(6) = aimag( fac*log(x23)*(-log(x23) -log(mu2/dm4) &
+ & -2*log((dm4-dp3)/(-ds12)) ) &
+ & + fac*( -cdilog(1._ki-x23**2) &
+ & + cdilog(1._ki-x23/y) &
+ & - cdilog(1._ki-1._ki/y/x23) ) )
+ !
+ else if (lim3 < cut) then
+ !
+ ! call print_error('lim3<cut,lim3=',arg_real=lim3)
+ fac=1._ki/2._ki/deno
+ !
+ res_4p_ql15_n(3) = real(fac)
+ res_4p_ql15_n(4) = aimag(fac)
+ res_4p_ql15_n(5) = real( fac*( log(mu2/rm2/rm4) &
+ & +log((dm2-dp2)/(-ds12)) + log((dm4-dp3)/(-ds12)) &
+ & -2._ki - (1._ki+y)/(1._ki-y)*log(y) ) )
+ res_4p_ql15_n(6) = aimag( fac*( log(mu2/rm2/rm4) &
+ & +log((dm2-dp2)/(-ds12)) + log((dm4-dp3)/(-ds12)) &
+ & -2._ki - (1._ki+y)/(1._ki-y)*log(y) ) )
+ !
+ else ! full expression
+ !
+ res_4p_ql15_n(3) = real(-fac*log(x23))
+ res_4p_ql15_n(4) = aimag(-fac*log(x23))
+ res_4p_ql15_n(5) = real( fac*log(x23)*(-log(x23)/2._ki -log(mu2/rm2/rm4) &
+ & -log((dm2-dp2)/(-ds12)) - log((dm4-dp3)/(-ds12)) ) &
+ & + fac*( cdilog(x23**2) + Pi**2/6._ki +2*log(x23)*log(1._ki-x23**2) &
+ & +log(y)**2/2._ki &
+ & -( cdilog(x23*y) + log(1._ki-x23*y)*(log(x23)+log(y)) ) &
+ & -( cdilog(x23/y) + log(1._ki-x23/y)*(log(x23)-log(y)) ) ) )
+ res_4p_ql15_n(6) = aimag( fac*log(x23)*(-log(x23)/2._ki -log(mu2/rm2/rm4) &
+ & -log((dm2-dp2)/(-ds12)) - log((dm4-dp3)/(-ds12)) ) &
+ & + fac*( cdilog(x23**2) + Pi**2/6._ki + 2*log(x23)*log(1._ki-x23**2) &
+ & +log(y)**2/2._ki &
+ & -( cdilog(x23*y) + log(1._ki-x23*y)*(log(x23)+log(y)) ) &
+ & -( cdilog(x23/y) + log(1._ki-x23/y)*(log(x23)-log(y)) ) ) )
+ !
+ end if ! end test limits
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql15: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql15: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql15_n
+ !
+ !
+end module function_4p_ql15
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql16.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql16.f90
new file mode 100644
index 0000000..226326a
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql16.f90
@@ -0,0 +1,489 @@
+!
+!****h* src/integrals/four_point/function_4p_ql16
+! NAME
+!
+! Module function_4p_ql16
+!
+! USAGE
+!
+! use function_4p_ql16
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 14
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql16, f4p_ql16_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql16
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql16,f4p_ql16_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql16/f4p_ql16
+ ! NAME
+ !
+ ! Function f4p_ql16
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql16(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql16(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql16
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: norma,coupure_4p_ql16
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql16 = 0._ki
+ coupure_4p_ql16 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql16) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql16 (in file f4p_ql16.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql16'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql16) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql16_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql16= a4p_ql16_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql16: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql16: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql16 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql16 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql16
+ !
+ !****f* src/integrals/four_point/function_4p_ql16/f4p_ql16_c
+ ! NAME
+ !
+ ! Function f4p_ql16_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql16_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql16
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql16
+ !
+ !*****
+ function f4p_ql16_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql16_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql16(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql16_c)
+ !
+ end function f4p_ql16_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql16/a4p_ql16_n
+ ! NAME
+ !
+ ! recursive function a4p_ql16_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql16_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql16_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql16_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql16_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,deno,rm2,rm3,rm4,m3mu,lim,cut
+ !real(ki) :: msq
+ complex(ki) :: ds12,ds23,dm2,dm3,dm4,dp2,dp3,beta23,x23,x2,x3,beta2,beta3,logm0,logsmu,fac,y
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ cut=1.e-8_ki
+ !
+ dm2=m1s-i_*del
+ dm3=m2s-i_*del
+ dm4=m3s-i_*del
+ rm2=sqrt(m1s)
+ rm3=sqrt(m2s)
+ rm4=sqrt(m3s)
+ m3mu=sqrt(m2s/mu2)
+ lim=abs(s23-(rm2-rm4)**2)
+ !
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dp2= s2+i_*del
+ dp3= s3+i_*del
+ !
+ y=rm2/rm4*(dm4-dp3)/(dm2-dp2)
+ logsmu=log(mu2/(-ds12))
+ beta23=Sqrt(1._ki-4*rm2*rm4/(ds23-(rm2-rm4)**2))
+ x23=-(1._ki-beta23)/(1._ki+beta23)
+ beta2=Sqrt(1._ki-4*rm2*rm3/(dp2-(rm2-rm3)**2))
+ x2=-(1._ki-beta2)/(1._ki+beta2)
+ beta3=Sqrt(1._ki-4*rm3*rm4/(dp3-(rm3-rm4)**2))
+ x3=-(1._ki-beta3)/(1._ki+beta3)
+ !
+ deno=rm2*rm4*(s12-m2s)
+ fac=x23/(1._ki-x23**2)/deno
+ logm0=Log(m3mu/(dm3-ds12))
+!
+ res_4p_ql16_n(1) = 0._ki
+ res_4p_ql16_n(2) = 0._ki
+ !
+ if (lim > cut ) then
+ res_4p_ql16_n(3) = real(-fac*log(x23))
+ res_4p_ql16_n(4) = aimag(-fac*log(x23))
+!
+ res_4p_ql16_n(5) = real( fac*(2*log(x23)*(log(1._ki-x23**2)-logm0 ) &
+ & + log(x2)**2+log(x3)**2+cdilog(x23**2) + Pi**2/2._ki &
+ & - (log(x23)+log(x2)+log(x3))*log(1._ki-x23*x2*x3) &
+ & - cdilog(x23*x2*x3) &
+ & - (log(x23)+log(1._ki/x2)+log(1._ki/x3))*log(1._ki-x23/x2/x3) &
+ & -cdilog(x23/x2/x3) &
+ & - (log(x23)+log(x2)+log(1._ki/x3))*log(1._ki-x23*x2/x3) &
+ & -cdilog(x23*x2/x3) &
+ & - (log(x23)+log(1._ki/x2)+log(x3))*log(1._ki-x23/x2*x3) &
+ & -cdilog(x23/x2*x3) ) )
+ res_4p_ql16_n(6) = aimag( fac*( 2*log(x23)*(log(1._ki-x23**2)-logm0 ) &
+ & + log(x2)**2+log(x3)**2+cdilog(x23**2) + Pi**2/2._ki &
+ & - (log(x23)+log(x2)+log(x3))*log(1._ki-x23*x2*x3) &
+ & - cdilog(x23*x2*x3) &
+ & - (log(x23)+log(1._ki/x2)+log(1._ki/x3))*log(1._ki-x23/x2/x3) &
+ & -cdilog(x23/x2/x3) &
+ & - (log(x23)+log(x2)+log(1._ki/x3))*log(1._ki-x23*x2/x3) &
+ & -cdilog(x23*x2/x3) &
+ & - (log(x23)+log(1._ki/x2)+log(x3))*log(1._ki-x23/x2*x3) &
+ & -cdilog(x23/x2*x3) ) )
+ !
+ else ! limit x23->1
+ !
+ fac=1._ki/2._ki/deno
+ !
+ res_4p_ql16_n(3) = real(fac)
+ res_4p_ql16_n(4) = aimag(fac)
+ res_4p_ql16_n(5) = real( fac*( 2*logm0 - (1._ki+x2*x3)/(1._ki-x2*x3)*(log(x2)+log(x3)) &
+ & - (x2+x3)/(x3-x2)*(log(x2)-log(x3)) -2._ki ) )
+ res_4p_ql16_n(6) = aimag( fac*( 2*logm0 - (1._ki+x2*x3)/(1._ki-x2*x3)*(log(x2)+log(x3)) &
+ & - (x2+x3)/(x3-x2)*(log(x2)-log(x3)) -2._ki ) )
+ !
+ end if ! end if lim>cut
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql16: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql16: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql16_n
+ !
+ !
+end module function_4p_ql16
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql6.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql6.f90
new file mode 100644
index 0000000..5457a1b
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql6.f90
@@ -0,0 +1,438 @@
+!
+!****h* src/integrals/four_point/function_4p_ql6
+! NAME
+!
+! Module function_4p_ql6
+!
+! USAGE
+!
+! use function_4p_ql6
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! with 1 internal mass and two massive on-shell legs,
+! corresponding to QCDLoop box number 6
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql6, f4p_ql6_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql6
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ !~ use more_integ_info
+ use equal
+ implicit none
+ !
+ private
+ !
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql6,f4p_ql6_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql6/f4p_ql6
+ ! NAME
+ !
+ ! Function f4p_ql6
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql6(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql6(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql6
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: norma,coupure_4p_ql6
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql6 = 0._ki
+ coupure_4p_ql6 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql6) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql6 (in file f4p_ql6.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql6'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql6) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql6_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql6= a4p_ql6_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql6: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql6: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql6 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql6 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql6
+ !
+ !****f* src/integrals/four_point/function_4p_ql6/f4p_ql6_c
+ ! NAME
+ !
+ ! Function f4p_ql6_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql6_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql6
+ !
+ !*****
+ function f4p_ql6_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql6_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql6(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql6_c)
+ !
+ end function f4p_ql6_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql6/a4p_ql6_n
+ ! NAME
+ !
+ ! recursive function a4p_ql6_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql6_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql6_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql6_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql6_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,msq,deno
+ complex(ki) :: ds12,ds23,dm
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ !
+ msq=m3s
+! write(6,*) 'm3s=',m3s
+ deno=-s12*(msq-s23)
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dm=msq-i_*del
+ !
+ res_4p_ql6_n(1) = 2._ki/deno
+ res_4p_ql6_n(2) = 0._ki
+ res_4p_ql6_n(3) = -real(2*log(1._ki-ds23/msq)+log(-ds12/msq)-2*log(mu2/msq))/deno
+ res_4p_ql6_n(4) = -aimag( (2*log(1._ki-ds23/msq)+log(-ds12/msq)-2*log(mu2/msq))/deno )
+ res_4p_ql6_n(5) = real(2*log(1._ki-ds23/msq)*log(-ds12/msq)-Pi**2/2+ &
+ & log(mu2/msq)**2 - log(mu2/msq)*(2*log(1._ki-ds23/msq)+log(-ds12/msq)) )/deno
+ res_4p_ql6_n(6) = aimag( (2*log(1._ki-ds23/msq)*log(-ds12/msq)+ &
+ & log(mu2/msq)**2 - log(mu2/msq)*(2*log(1._ki-ds23/msq)+log(-ds12/msq)) )/deno )
+ !
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql6: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql6: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql6_n
+ !
+ !
+end module function_4p_ql6
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql7.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql7.f90
new file mode 100644
index 0000000..63b702a
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql7.f90
@@ -0,0 +1,444 @@
+!
+!****h* src/integrals/four_point/function_4p_ql7
+! NAME
+!
+! Module function_4p_ql7
+!
+! USAGE
+!
+! use function_4p_ql7
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 7
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql7, f4p_ql7_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql7
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ !~ use more_integ_info
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql7,f4p_ql7_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql7/f4p_ql7
+ ! NAME
+ !
+ ! Function f4p_ql7
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql7(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql7(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql7
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: norma,coupure_4p_ql7
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql7 = 0._ki
+ coupure_4p_ql7 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql7) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql7 (in file f4p_ql7.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql7'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql7) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql7_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql7= a4p_ql7_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql7: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql7: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql7 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql7 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql7
+ !
+ !****f* src/integrals/four_point/function_4p_ql7/f4p_ql7_c
+ ! NAME
+ !
+ ! Function f4p_ql7_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql7_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql7
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql7
+ !
+ !*****
+ function f4p_ql7_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql7_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql7(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql7_c)
+ !
+ end function f4p_ql7_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql7/a4p_ql7_n
+ ! NAME
+ !
+ ! recursive function a4p_ql7_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql7_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql7_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql7_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql7_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,msq,deno
+ complex(ki) :: ds12,ds23,dm,dp4
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ !
+ msq=m3s
+! write(6,*) 'm3s=',m3s
+ deno=-s12*(msq-s23)
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dp4= s4 +i_*del
+ dm=msq-i_*del
+ !
+ res_4p_ql7_n(1) = 3._ki/2._ki/deno
+ res_4p_ql7_n(2) = 0._ki
+ res_4p_ql7_n(3) = -real( (2*log(1._ki-ds23/msq)+log(-ds12/msq)-log(1._ki-dp4/msq) &
+ & -3._ki/2._ki*log(mu2/msq) )/deno )
+ res_4p_ql7_n(4) = -aimag( (2*log(1._ki-ds23/msq)+log(-ds12/msq)-log(1._ki-dp4/msq) &
+ & -3._ki/2._ki*log(mu2/msq))/deno )
+ res_4p_ql7_n(5) = real( 2*log(1._ki-ds23/msq)*log(-ds12/msq) &
+ & - log(1._ki-dp4/msq)**2-5*Pi**2/12 - 2*cDiLog( (ds23-dp4)/(ds23-msq) ) &
+ & + 3._ki/4._ki*log(mu2/msq)**2 &
+ & - log(mu2/msq)*(2*log(1._ki-ds23/msq)+log(-ds12/msq)-log(1._ki-dp4/msq)) )/deno
+ res_4p_ql7_n(6) = aimag( 2*log(1._ki-ds23/msq)*log(-ds12/msq) &
+ & - log(1._ki-dp4/msq)**2 - 2*cdilog( (ds23-dp4)/(ds23-msq) ) &
+ & + 3._ki/4._ki*log(mu2/msq)**2 &
+ & - log(mu2/msq)*(2*log(1._ki-ds23/msq)+log(-ds12/msq)-log(1._ki-dp4/msq)) )/deno
+ !
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql7: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql7: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql7_n
+ !
+ !
+end module function_4p_ql7
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql8.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql8.f90
new file mode 100644
index 0000000..130598c
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql8.f90
@@ -0,0 +1,453 @@
+!
+!****h* src/integrals/four_point/function_4p_ql8
+! NAME
+!
+! Module function_4p_ql8
+!
+! USAGE
+!
+! use function_4p_ql8
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 8
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql8, f4p_ql8_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql8
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ !~ use more_integ_info
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql8,f4p_ql8_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql8/f4p_ql8
+ ! NAME
+ !
+ ! Function f4p_ql8
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql8(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql8(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql8
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: norma,coupure_4p_ql8
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql8 = 0._ki
+ coupure_4p_ql8 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql8) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql8 (in file f4p_ql8.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql8'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql8) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql8_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql8= a4p_ql8_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql8: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql8: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql8 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql8 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql8
+ !
+ !****f* src/integrals/four_point/function_4p_ql8/f4p_ql8_c
+ ! NAME
+ !
+ ! Function f4p_ql8_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql8_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql8
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql8
+ !
+ !*****
+ function f4p_ql8_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql8_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql8(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql8_c)
+ !
+ end function f4p_ql8_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql8/a4p_ql8_n
+ ! NAME
+ !
+ ! recursive function a4p_ql8_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql8_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql8_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql8_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql8_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,msq,deno
+ complex(ki) :: ds12,ds23,dp3,dp4,di3,di4,di34,logm3,logm4,logmu3,logmu4,logsm,logsmu
+ complex(ki) :: eta,etaterm
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ !
+ msq=m3s
+! write(6,*) 'm3s=',m3s
+ deno=-s12*(msq-s23)
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dp3= s3 +i_*del
+ dp4= s4 +i_*del
+ di3 = cdilog(1._ki - (msq-dp3)/(msq-ds23))
+ di4 = cdilog(1._ki - (msq-dp4)/(msq-ds23))
+ di34 = cdilog(1._ki+(msq-dp3)*(msq-dp4)/(ds12*msq))
+ logm3=log((msq-dp3)/msq)
+ logm4=log((msq-dp4)/msq)
+ logmu3=log((msq-dp3)/mu2)
+ logmu4=log((msq-dp4)/mu2)
+ logsmu=log(-ds12/mu2)
+ logsm=log(-ds12/msq)
+ eta=log((msq-dp3)/msq*(msq-dp4)/(-ds12))-log((msq-dp3)/msq)-log((msq-dp4)/(-ds12))
+! write(6,*) 'eta=',eta
+ etaterm=eta*log(1._ki-(msq-dp3)*(msq-dp4)/(-ds12*msq))
+ !
+ res_4p_ql8_n(1) = 1._ki/deno
+ res_4p_ql8_n(2) = 0._ki
+ res_4p_ql8_n(3) = real( -( log(-ds12/mu2)+log((msq-ds23)**2/(msq-dp3)/(msq-dp4)) )/deno )
+! res_4p_ql8_n(4) = aimag( -( log(-ds12/mu2)+log((msq-ds23)**2/(msq-dp3)/(msq-dp4)) )/deno )
+ res_4p_ql8_n(4) = aimag( -( log(-ds12/mu2)+log((msq-ds23)/(msq-dp3))+ &
+ & log((msq-ds23)/(msq-dp4)) )/deno )
+ res_4p_ql8_n(5) = real( (-Pi**2/6 -2*di3-2*di4-di34-etaterm+logsmu**2/2-logsm**2/2 &
+ & + 2*logsmu*log((msq-ds23)/msq) -logm3*logmu3 -logm4*logmu4 )/deno )
+ res_4p_ql8_n(6) = aimag( ( -2*di3-2*di4-di34-etaterm+logsmu**2/2-logsm**2/2 &
+ & + 2*logsmu*log((msq-ds23)/msq) -logm3*logmu3 -logm4*logmu4 )/deno )
+ !
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql8: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql8: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql8_n
+ !
+ !
+end module function_4p_ql8
+!
diff --git a/golem95c-1.2.1/integrals/four_point/function_4p_ql9.f90 b/golem95c-1.2.1/integrals/four_point/function_4p_ql9.f90
new file mode 100644
index 0000000..ceb2075
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/function_4p_ql9.f90
@@ -0,0 +1,449 @@
+!
+!****h* src/integrals/four_point/function_4p_ql9
+! NAME
+!
+! Module function_4p_ql9
+!
+! USAGE
+!
+! use function_4p_ql9
+!
+! DESCRIPTION
+!
+! This module computes the n-dimensional four point function
+! corresponding to QCDLoop box number 9
+! implemented only without Feynman parameters in the numerator!
+!
+! OUTPUT
+!
+! This module exports the functions f4p_ql9, f4p_ql9_c
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/three_point/generic_function_3p.f90)
+! * translate (src/module/translate.f90)
+! * more_integ_info (src/module/more_integ_info.f90)
+!
+!*****
+module function_4p_ql9
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_3p
+ use translate
+ use equal
+ use dilogarithme
+ implicit none
+ !
+ private
+ real(ki) :: s23_glob,s24_glob,s34_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob,par4_glob
+ character (len=1) :: dim_glob
+ !
+ real(ki), dimension(4) :: b
+ real(ki) :: sumb
+ real(ki), dimension(4,4) :: invs,s_mat
+ integer, dimension(4) :: par
+ integer, dimension(4) :: s = (/1,2,3,4/)
+ real(ki) :: lamb
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule3
+ real(ki),dimension(:,:,:), allocatable :: resultat3
+ logical, dimension(:,:), allocatable :: deja_calcule3_np2
+ real(ki),dimension(:,:,:), allocatable :: resultat3_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule33
+ real(ki),dimension(:,:,:,:), allocatable :: resultat33
+ !
+ public :: f4p_ql9,f4p_ql9_c
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/function_4p_ql9/f4p_ql9
+ ! NAME
+ !
+ ! Function f4p_ql9
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = f4p_ql9(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! computes the n-dimensional four point function
+ ! with 1 internal mass and two massive on-shell legs,
+ ! corresponding to QCDLoop box number 6
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character , dim="n" (4-2*eps) - dimensional
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ ! Be careful that, in this function, the arguments par1, par2, par3 and par4
+ ! are mandatory, otherwise use the generic four point function f4p_np2 (f4p_np4).
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real imaginary part of 1/epsilon coefficient, real, imaginary part of the
+ ! finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f4p_ql9(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: f4p_ql9
+ !
+ integer :: nb_par
+ !real(ki) :: plus_grand
+ real(ki) :: norma,coupure_4p_ql9
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3,par4/)
+ !
+ s_mat(1,:) = (/-m1s*2._ki,s2-m1s-m2s,s23-m1s-m3s,s1-m1s-m4s/)
+ s_mat(2,:) = (/s2-m1s-m2s,-m2s*2._ki,s3-m2s-m3s,s12-m2s-m4s/)
+ s_mat(3,:) = (/s23-m1s-m3s,s3-m2s-m3s,-m3s*2._ki,s4-m3s-m4s/)
+ s_mat(4,:) = (/s1-m1s-m4s,s12-m2s-m4s,s4-m3s-m4s,-m4s*2._ki/)
+ ! on redefinit la matrice S de telle facon a ce que ses elements
+ ! soient entre -1 et 1
+ ! plus_grand = maxval(array=abs(s_mat))
+ ! s_mat = s_mat/plus_grand
+ !
+ b(1) = (s_mat(1,3)*s_mat(2,4)-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+2._ki*s_mat(2,3)*s_mat(3,4))&
+ &/(s_mat(1,3)**2*s_mat(2,4))
+ b(2) = (s_mat(1,3)-s_mat(3,4))/(s_mat(1,3)*s_mat(2,4))
+ b(3) = 1._ki/s_mat(1,3)
+ b(4) = (s_mat(1,3)-s_mat(2,3))/(s_mat(1,3)*s_mat(2,4))
+ !
+ sumb = 2._ki*(s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4))/(s_mat(1,3)**2*s_mat(2,4))
+ !
+ !
+ invs(1,1) = 2._ki*s_mat(2,3)/s_mat(2,4)*s_mat(3,4)/s_mat(1,3)**2
+ invs(1,2) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(1,3) = 1._ki/s_mat(1,3)
+ invs(1,4) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(2,1) = -1._ki/s_mat(1,3)/s_mat(2,4)*s_mat(3,4)
+ invs(2,2) = 0._ki
+ invs(2,3) = 0._ki
+ invs(2,4) = 1._ki/s_mat(2,4)
+ invs(3,1) = 1._ki/s_mat(1,3)
+ invs(3,2) = 0._ki
+ invs(3,3) = 0._ki
+ invs(3,4) = 0._ki
+ invs(4,1) = -1._ki/s_mat(1,3)*s_mat(2,3)/s_mat(2,4)
+ invs(4,2) = 1._ki/s_mat(2,4)
+ invs(4,3) = 0._ki
+ invs(4,4) = 0._ki
+ !
+ lamb = s_mat(1,3)**2-s_mat(1,3)*s_mat(2,3)&
+ &-s_mat(1,3)*s_mat(3,4)+s_mat(1,3)*s_mat(2,4)&
+ &+s_mat(2,3)*s_mat(3,4)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ norma = 1._ki/6._ki
+ else if (nb_par == 1) then
+ norma = 1._ki/24._ki
+ else
+ norma = 0._ki
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(5))
+ allocate(resultat(5,2))
+ allocate(deja_calcule3(4,5))
+ allocate(resultat3(4,5,6))
+ allocate(deja_calcule3_np2(4,5))
+ allocate(resultat3_np2(4,5,4))
+ allocate(deja_calcule33(4,5,5))
+ allocate(resultat33(4,5,5,6))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule3 = .false.
+ resultat3 = 0._ki
+ deja_calcule3_np2 = .false.
+ resultat3_np2 = 0._ki
+ deja_calcule33 = .false.
+ resultat33 = 0._ki
+ !
+ f4p_ql9 = 0._ki
+ coupure_4p_ql9 = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p_ql9) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql9 (in file f4p_ql9.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Becareful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_4p_ql9'
+ call catch_exception(0)
+ end if
+ !
+ if (abs(sumb) > coupure_4p_ql9) then
+ !
+ ! analytic computation
+ !
+ if (dim == "n") then
+ !
+ ! a4p_ql9_n is n-dim, not (n+2)-dim !!!
+ !
+ f4p_ql9= a4p_ql9_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql9: box called with wrong dimension')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql9: box called with wrong dimension'
+ call catch_exception(0)
+ !
+ end if
+ !
+ else
+ !
+ !~ call print_error('numerical calculation of f4p_ql9 not implemented')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'numerical calculation of f4p_ql9 not implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule3)
+ deallocate(resultat3)
+ deallocate(deja_calcule3_np2)
+ deallocate(resultat3_np2)
+ deallocate(deja_calcule33)
+ deallocate(resultat33)
+ !
+ end function f4p_ql9
+ !
+ !****f* src/integrals/four_point/function_4p_ql9/f4p_ql9_c
+ ! NAME
+ !
+ ! Function f4p_ql9_c
+ !
+ ! USAGE
+ !
+ ! complex_dim_4 = f4p_ql9_c(dim,s24,s13,s23,s34,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function also computes the function f4p_ql9
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character, dim="n"
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of two complexs (type ki) corresponding to the
+ ! 1/epsilon coefficient and the finite part (as epsilon --> 0)
+ !
+ ! EXAMPLE
+ !
+ ! see function f4p_ql9
+ !
+ !*****
+ function f4p_ql9_c(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ character (len=1), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ complex(ki), dimension(6) :: f4p_ql9_c
+ !
+ real(ki), dimension(6) :: res4
+ !
+ res4 = f4p_ql9(dim,s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ call to_complex(res4,f4p_ql9_c)
+ !
+ end function f4p_ql9_c
+ !
+ !****if* src/integrals/four_point/function_4p_ql9/a4p_ql9_n
+ ! NAME
+ !
+ ! recursive function a4p_ql9_n
+ !
+ ! USAGE
+ !
+ ! real_dim_4 = a4p_ql9_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,par1,par2,par3,par4,mu2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the core for the analytic computation of the (4-2*eps)-dimensional
+ ! four point function corresponding to box 6 of QCDLoop
+ !
+ !
+ ! INPUTS
+ !
+ ! * s12 -- a real (type ki), the S matrix element 2,4 +m1s+m2s
+ ! * s23 -- a real (type ki), the S matrix element 2,3 +m2s+m3s
+ ! * s1 -- a real (type ki), the S matrix element 1,4
+ ! * s2 -- a real (type ki), the S matrix element 2,1
+ ! * s3 -- a real (type ki), the S matrix element 3,2
+ ! * s4 -- a real (type ki), the S matrix element 4,3
+ ! * m1s -- a real (type ki), -1/2*the S matrix element 1,1
+ ! * m2s -- a real (type ki), -1/2*the S matrix element 2,2
+ ! * m3s -- a real (type ki), -1/2*the S matrix element 3,3
+ ! * m4s -- a real (type ki), -1/2*the S matrix element 4,4
+ ! * par1 -- an integer, the label of the fourth Feynman parameter, if none, put 0
+ ! * par2 -- an integer, the label of the third Feynman parameter, if none, put 0
+ ! * par3 -- an integer, the label of the second Feynman parameter, if none, put 0
+ ! * par4 -- an integer, the label of the first Feynman parameter, if none, put 0
+ !
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effects
+ !
+ ! RETURN VALUE
+ !
+ ! this function returns an array of four reals (type ki) corresponding to the
+ ! real and imaginary parts of the 1/eps part and finite part
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a4p_ql9_n(s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,&
+ & par1,par2,par3,par4,mu2) result(res_4p_ql9_n)
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,mu2
+ integer, intent (in) :: par1,par2,par3,par4
+ real(ki), dimension(6) :: res_4p_ql9_n
+ !
+ !integer, dimension(3) :: smj,sm1
+ !integer :: j
+ integer :: nb_par_loc
+ integer, dimension(4) :: par_loc,par_plus
+ !real(ki), dimension(6) :: truc1
+ real(ki) :: del,msq,deno
+ complex(ki) :: ds12,ds23,dp2,dp3,dp4,di2,di3,logp2mu,logms23,logmmu,logsmu,etaterm,eta
+ !
+ par_loc = (/par1,par2,par3,par4/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! only the scalar box (no Feynman parameters in numerator) is implemented
+ !
+ if (nb_par_loc == 0) then
+ !
+ del=10*epsilon(1._ki)
+ !
+ msq=m3s
+! write(6,*) 'm3s=',m3s
+ deno=-s12*(msq-s23)
+ ds12=s12+i_*del
+ ds23=s23+i_*del
+ dp2= s2 +i_*del
+ dp3= s3 +i_*del
+ dp4= s4 +i_*del
+ di2 = cdilog(1._ki - ds12/dp2)
+ di3 = cdilog(1._ki-(msq-dp3)*(msq-ds23)/(-dp2*msq))
+ logp2mu=log(-dp2/mu2)
+ logsmu=log(-ds12/mu2)
+ logms23=log((msq-ds23)/msq)
+ logmmu=log(msq/mu2)
+ eta=log((msq-dp3)/msq*(msq-ds23)/(-dp2))-log((msq-dp3)/msq)-log((msq-ds23)/(-dp2))
+! write(6,*) 'eta=',eta
+ etaterm=eta*log(1._ki-(msq-dp3)*(msq-ds23)/(-dp2*msq))
+ !
+ res_4p_ql9_n(1) = 1._ki/2._ki/deno
+ res_4p_ql9_n(2) = 0._ki
+ res_4p_ql9_n(3) = real( -(log((-ds12)/mu2)-log((-dp2)/mu2)+log((msq-ds23)/msq)+&
+ & log(msq/mu2)/2._ki )/deno )
+ res_4p_ql9_n(4) = aimag( -(log((-ds12)/mu2)-log((-dp2)/mu2)+log((msq-ds23)/msq)+&
+ & log(msq/mu2)/2._ki )/deno )
+ res_4p_ql9_n(5) = real( (di3+etaterm+2*di2+Pi**2/12+(logsmu-logp2mu+logms23+&
+ & logmmu/2._ki)**2)/deno )
+ res_4p_ql9_n(6) = aimag((di3+etaterm+2*di2+ &
+ & (logsmu-logp2mu+logms23+logmmu/2._ki)**2)/deno)
+ !
+ !
+ else
+ !
+ !~ call print_error('In function f4p_ql9: only scalar case available for this box')
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_ql9: only scalar case available for this box'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a4p_ql9_n
+ !
+ !
+end module function_4p_ql9
+!
diff --git a/golem95c-1.2.1/integrals/four_point/generic_function_4p.f90.in b/golem95c-1.2.1/integrals/four_point/generic_function_4p.f90.in
new file mode 100644
index 0000000..8822380
--- /dev/null
+++ b/golem95c-1.2.1/integrals/four_point/generic_function_4p.f90.in
@@ -0,0 +1,3058 @@
+!****h* src/integrals/four_point/generic_function_4p
+!
+!~ changed 13.5.10 to include globally defined scale mu2_scale_par
+!
+!~ 24.6.2010: uses Andre van Hameren's OneLOop for finite D0
+!
+! NAME
+!
+! Module generic_function_4p
+!
+! USAGE
+!
+! use generic_function_4p
+!
+! DESCRIPTION
+!
+! This module contains the generic routines to compute the
+! four point functions in n+2 and n+4 dimensions. It can compute
+! the zero mass, one mass, two mass adjacent, two mass opposite, three mass
+! and four mass four point functions with massless internal lines
+! It can also calculate the IR divergent boxes with massive internal lines, but
+! ONLY in the scalar case.
+! For the latter, the (4-2*eps)-dim expressions are implemented
+!
+!
+! OUTPUT
+!
+! It exports three public routines:
+! * f4p -- a function to compute the four point function in n dimensions
+! (used donly if internal masses are present)
+! * f4p_np2 -- a function to compute the four point function in n+2 dimensions
+! * f4p_np4 -- a function to compute the four point function in n+4 dimensions
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s (src/kinematic/matrice_s.f90) ( only : dim_s, set_ref )
+! * s_matrix_type (src/module/s_matrix_type.f90)
+! * array (src/module/array.f90)
+! * tri_croissant (src/module/tri.f90)
+! * constante (src/module/constante.f90)
+! * function_4p1m (src/integrals/four_point/function_4p1m.f90)
+! * function_4p2m_opp (src/integrals/four_point/function_4p2m_opp.f90)
+! * function_4p2m_adj (src/integrals/four_point/function_4p2m_adj.f90)
+! * function_4p3m (src/integrals/four_point/function_4p3m.f90)
+! * function_4p4m (src/integrals/four_point/function_4p4m.f90)
+! * cache (src/module/cache.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_3p (src/integrals/generic_function_3p.f90)
+! * parametre (src/module/parametre.f90), only : coupure_3p2m,coupure_3p3m,coupure_4p1m,
+! coupure_4p2m_opp,coupure_4p2m_adj,coupure_4p3m,coupure_4p4m
+! * equal (src/module/equal.f90)
+!
+
+!*****
+module generic_function_4p
+ !
+ use precision_golem, only: ki
+ use matrice_s
+ use s_matrix_type
+ use array
+ use tri_croissant
+ use constante
+ use function_4p1m
+ use function_4p2m_opp
+ use function_4p2m_adj
+ use function_4p3m
+ use function_4p4m
+ use function_4p2m_3mi_onshell
+ use function_4p_ql6
+ use function_4p_ql7
+ use function_4p_ql8
+ use function_4p_ql9
+ use function_4p_ql10
+ use function_4p_ql11
+ use function_4p_ql12
+ use function_4p_ql13
+ use function_4p_ql14
+ use function_4p_ql15
+ use function_4p_ql16
+ use form_factor_type
+ use cache
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use generic_function_3p
+ use parametre , only : coupure_4p1m,coupure_4p2m_opp,&
+ coupure_4p2m_adj,coupure_4p3m,coupure_4p4m,&
+ mu2_scale_par,olo,withlt
+ use equal
+
+ !---#[ avh_olo:
+ use avh_olo, only: olo_d0, olo_scale, olo_onshell
+ !---#] avh_olo:
+ implicit none
+ !
+ private
+ !
+ integer, dimension(2) :: set_tot
+ !
+ interface f4p_sca
+ !
+ module procedure f4p_sca_p
+ module procedure f4p_sca_r, f4p_sca_c
+ !
+ end interface
+ !
+ public :: f4p, f4p_np2, f4p_np4 !!! These functions return complex arrays
+ !
+ ! added to include LT option, Jan2011
+@case_with_lt@ interface
+@case_with_lt@ function D0(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4)
+@case_with_lt@ use precision_golem, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt), intent(in) :: p1, p2, p3, p4, p1p2, p2p3
+@case_with_lt@ real(ki_lt), intent(in) :: m1, m2, m3, m4
+@case_with_lt@ complex(ki_lt) :: D0
+@case_with_lt@ end function D0
+@case_with_lt@ end interface
+ !
+@case_with_lt@ interface
+@case_with_lt@ function D0C(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4)
+@case_with_lt@ use precision_golem, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt), intent(in) :: p1, p2, p3, p4, p1p2, p2p3
+@case_with_lt@ complex(ki_lt), intent(in) :: m1, m2, m3, m4
+@case_with_lt@ complex(ki_lt) :: D0C
+@case_with_lt@ end function D0C
+@case_with_lt@ end interface
+ !
+ contains
+ !
+ !****f* src/integrals/four_point/generic_function_4p/f4p_np2
+ ! NAME
+ !
+ ! Function f4p_np2
+ !
+ ! USAGE
+ !
+ ! complex = f4p_np2(s_mat,b_pro,b_pin,parf1,parf2,parf3,parf4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes recursively the generic four point function in n+2 dimensions,
+ ! with or without Feynman parameters in the numerator using the formula of
+ ! JHEP 10 (2005) 015.
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a derived type (s_matrix_poly), giving the S matrix
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ ! * b_pin -- an integer which represents the set of the pinched propagators
+ ! * parf1 -- an integer (optional), the label of the first Feynman parameter
+ ! * parf2 -- an integer (optional), the label of the second Feynman parameter
+ ! * parf3 -- an integer (optional), the label of the third Feynman parameter
+ ! * parf4 -- an integer (optional), the label of the forth Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) number
+ !
+ ! NOTE
+ !
+ ! This function has been changed! It accepts only a s_matrix_poly-type as input
+ ! and returns a complex number instead of a real array!
+ !
+ !*****
+ !
+ recursive function f4p_np2(s_mat_p,b_pro,b_pin,parf1,parf2,parf3,parf4,test_numeric) result(res_4p_np2)
+ !
+ type(s_matrix_poly), intent (in) :: s_mat_p
+ integer, intent (in) :: b_pro,b_pin
+ integer, intent (in), optional :: parf1,parf2,parf3,parf4
+ logical, intent (in), optional :: test_numeric
+ complex(ki) :: res_4p_np2
+ !
+ integer :: par1,par2,par3,par4
+ integer :: parn1,parn2,parn3,parn4
+ integer, dimension(4) :: z_param_ini,z_param_out
+ integer :: taille
+ integer :: nb_par
+ real(ki) :: arg3,arg4,arg5,arg6
+ real(ki) :: m1s,m2s,m3s,m4s,s1,s2,s3,s4
+ complex(ki) :: temp0
+ complex(ki), dimension(3) :: temp1,temp2,temp3,temp4
+ integer :: j,m1,m2,m3,m4
+ integer, dimension(4) :: s
+ integer :: ib,b_pro_mj,pro_dim
+ logical :: not_numeric
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ par4 = 0
+ !
+ if ( present(parf1) ) par1 = parf1
+ if ( present(parf2) ) par2 = parf2
+ if ( present(parf3) ) par3 = parf3
+ if ( present(parf4) ) par4 = parf4
+ !
+ !
+ sortie : if ( (par1 == -1) .or. (par2 == -1) .or. (par3 == -1) &
+ .or. (par4 == -1) ) then
+ !
+ res_4p_np2 = czero
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'something wrong with par1,..,par4'
+ call catch_exception(0)
+ !
+ else sortie
+ !
+ !
+ !
+ ! symetrie: la place de z1,z2,z3,z4 n'a pas d'importance, on les met
+ ! dans l'ordre croissant
+ !
+ z_param_ini = (/par1,par2,par3,par4/)
+ !
+ nb_par = count(mask=z_param_ini/=0)
+ !
+ if (b_pro < 256) then
+ s = bit_sets(b_pro*8:b_pro*8+3)
+ else
+ s = unpackb(b_pro,4)
+ end if
+ !
+ !
+ ! test for switch to numerical evaluation needs to be performed only once
+ !
+ switch_to_numerics: if (present(test_numeric) ) then
+ !
+ not_numeric = test_numeric !this should always be true...
+ !
+ else switch_to_numerics
+ !
+ ! make sure numerical branch is never entered for cases where it is not implemented
+
+ ! NB: This order of the statements
+ ! reduces the number of comparisons required.
+ !
+ ! numerical branch not implemented for complex masses yet:
+ if (iand(s_mat_p%b_cmplx, b_pro) .ne. 0 ) then
+ !
+ not_numeric = .true.
+ !
+ else if (iand(s_mat_p%b_zero, b_pro) .ne. b_pro ) then !case internal masses
+ !
+ not_numeric = .true.
+ !
+ else
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ m4 = s(4)
+ !
+ ! To get the s1..s4, only the real parts of the arguments are needed!
+ !
+ arg3 = s_mat_p%pt_real(m1,m4)
+ arg4 = s_mat_p%pt_real(m1,m2)
+ arg5 = s_mat_p%pt_real(m2,m3)
+ arg6 = s_mat_p%pt_real(m3,m4)
+ !
+ m1s = -s_mat_p%pt_real(m1,m1)/2._ki
+ m2s = -s_mat_p%pt_real(m2,m2)/2._ki
+ m3s = -s_mat_p%pt_real(m3,m3)/2._ki
+ m4s = -s_mat_p%pt_real(m4,m4)/2._ki
+ !
+ !
+ s1=arg3+m1s+m4s
+ s2=arg4+m1s+m2s
+ s3=arg5+m2s+m3s
+ s4=arg6+m3s+m4s
+ !
+ ! case 4 non-light-like legs
+ if ( .not.(equal_real(s1,zero)) .and. &
+ & .not.(equal_real(s2,zero)) .and. &
+ & .not.(equal_real(s3,zero)) .and. &
+ & .not.(equal_real(s4,zero))) then
+ not_numeric = .true.
+ else
+ not_numeric=.not. ( abs(norma_sumb(b_pin)) < coupure(s_mat_p,s) )
+ end if
+ !
+ end if
+ !
+ end if switch_to_numerics
+ !
+ !
+ taille = dim_s - size(s)
+ !
+ select case(taille)
+ !
+ case(0)
+ !
+ set_tot = 0
+ !
+ case(1)
+ set_tot(1) = 0
+
+ if (b_pin < 256) then
+ set_tot(2) = bit_sets(b_pin*8)
+ else
+ set_tot(2:2) = unpackb(b_pin,1)
+ end if
+ !
+ !
+ case(2)
+ if (b_pin < 256) then
+ set_tot(:) = bit_sets(b_pin*8:b_pin*8+1)
+ else
+ set_tot(:) = unpackb(b_pin,2)
+ end if
+ end select
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ cache : if ( computed_f4p_np2(set_tot(1),set_tot(2),&
+ &par2,par3,par4) ) then
+ !
+ res_4p_np2 = results_f4p_np2(set_tot(1),set_tot(2),&
+ &par2,par3,par4)
+ !
+ else cache
+ !
+ numeric : if ( not_numeric ) then
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ if (nb_par == 3) then
+ !
+ temp0 = b(par4,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,parf1=par2,parf2=par3,test_numeric = not_numeric) &
+ + b(par3,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,parf1=par2,parf2=par4,test_numeric = not_numeric) &
+ + b(par2,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,parf1=par3,parf2=par4,test_numeric = not_numeric) &
+ - ( inv_s(par2,par3,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,parf1=par4,test_numeric = not_numeric) &
+ + inv_s(par2,par4,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,parf1=par3,test_numeric = not_numeric) &
+ + inv_s(par3,par4,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,parf1=par2,test_numeric = not_numeric) )/3._ki
+ !
+ temp1(:) = czero
+ temp2(:) = czero
+ temp3(:) = czero
+ temp4(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ first_pinch: do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if ( (j /= par2) .and. (j /= par3) .and. (j /= par4) ) then
+ !
+ temp4 = temp4 - b(j,b_pin)*f3p(s_mat_p,b_pro_mj,par2, &
+ &par3,par4)/2._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par3) ) then
+ !
+ temp1 = temp1 + inv_s(j,par4,b_pin)*f3p(s_mat_p,b_pro_mj,par2,par3)/6._ki
+ !
+ end if
+ !
+ if ( (j /= par2) .and. (j /= par4) ) then
+ !
+ temp2 = temp2 + inv_s(j,par3,b_pin)*f3p(s_mat_p,b_pro_mj,par2,par4)/6._ki
+ !
+ end if
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ temp3 = temp3 + inv_s(j,par2,b_pin)*f3p(s_mat_p,b_pro_mj,par3,par4)/6._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do first_pinch
+ !
+ res_4p_np2 = ( temp0 + temp1(3) + temp2(3) + temp3(3) &
+ & + temp4(3) )/2._ki/sumb(b_pin)
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par == 2) then
+ !
+ temp0 = b(par3,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,parf4=par4,test_numeric = not_numeric) &
+ &+ b(par4,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,parf4=par3,test_numeric = not_numeric) &
+ &- inv_s(par3,par4,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,test_numeric = not_numeric)/2._ki
+ !
+ temp1(:) = czero
+ temp2(:) = czero
+ temp3(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if ( (j /= par3) .and. (j /= par4) ) then
+ !
+ temp3 = temp3 - b(j,b_pin)*f3p(s_mat_p,b_pro_mj,par3,par4)/2._ki
+ !
+ end if
+ !
+ if (j /= par3) then
+ !
+ temp1 = temp1 + inv_s(j,par4,b_pin)*f3p(s_mat_p,b_pro_mj,par3)/4._ki
+ !
+ end if
+ !
+ if (j /= par4) then
+ !
+ temp2 = temp2 + inv_s(j,par3,b_pin)*f3p(s_mat_p,b_pro_mj,par4)/4._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p_np2 = (temp0 + temp1(3) + temp2(3) + temp3(3)) &
+ &*2._ki/3._ki/sumb(b_pin)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par == 1) then
+ !
+ temp0 = b(par4,b_pin)*f4p_np2(s_mat_p,b_pro,b_pin,test_numeric = not_numeric)
+ temp1(:) = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (j /= par4) then
+ !
+ temp2 = temp2 - b(j,b_pin)*f3p(s_mat_p,b_pro_mj,par4)/2._ki
+ !
+ end if
+ !
+ temp1 = temp1 + inv_s(j,par4,b_pin)*f3p(s_mat_p,b_pro_mj)/2._ki
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p_np2 = (temp0 + temp1(3) + temp2(3))/sumb(b_pin)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ else
+ !
+ res_4p_np2 = f4p_np2_sca(s_mat_p,b_pro,b_pin)
+ !
+ end if
+ !
+ else numeric
+ !
+ where (z_param_out /= 0)
+ !
+ z_param_out = locateb(z_param_out,b_pro)
+ !
+ elsewhere
+ !
+ z_param_out = 0
+ !
+ end where
+ !
+ parn1 = z_param_out(1)
+ parn2 = z_param_out(2)
+ parn3 = z_param_out(3)
+ parn4 = z_param_out(4)
+ !
+ res_4p_np2 = f4p_np2_numeric(s_mat_p,b_pro,parn1,parn2,parn3,parn4)
+ !
+ end if numeric
+ !
+ computed_f4p_np2(set_tot(1),set_tot(2),&
+ &par2,par3,par4) = .true.
+ results_f4p_np2(set_tot(1),set_tot(2),&
+ &par2,par3,par4) = res_4p_np2
+ !
+ end if cache
+ !
+ end if sortie
+ !
+ end function f4p_np2
+ !
+ !****f* src/integrals/four_point/generic_function_4p/f4p_np2_sca
+ ! NAME
+ !
+ ! Function f4p_np2_sca
+ !
+ ! USAGE
+ !
+ ! complex = f4p_np2_sca(s_mat_p,b_pro,b_pin)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic four point function in n+2 dimensions,
+ ! without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a type s_matrix_poly object, the S matrix
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) number!
+ !
+ ! NOTE
+ !
+ ! This function now returns a complex number instaed of a real array!
+ !
+ !*****
+ !
+ function f4p_np2_sca(s_mat_p,b_pro,b_pin)
+ !
+ type(s_matrix_poly), intent(in) :: s_mat_p
+ integer, intent (in) :: b_pro,b_pin
+ complex(ki) :: f4p_np2_sca
+ !
+ if (iand(s_mat_p%b_zero,b_pro) .eq. b_pro) then !!! no internal masses
+ !
+ f4p_np2_sca = f4p_np2_sca_massless(s_mat_p%pt_real, b_pro, b_pin)
+ !
+ else
+ !
+ f4p_np2_sca = f4p_np2_sca_massive(s_mat_p, b_pro, b_pin)
+ !
+ end if
+ !
+ end function f4p_np2_sca
+ !
+ function f4p_np2_sca_massless(s_mat_r,b_pro,b_pin)
+ !
+ real(ki), intent (in), dimension(:,:) :: s_mat_r
+ integer, intent (in) :: b_pro,b_pin
+ complex(ki) :: f4p_np2_sca_massless
+ !
+ integer :: par1,par2,par3,par4
+ real(ki), dimension(4) :: temp
+ complex(ki), dimension(2) :: temp_cmplx
+ !
+ integer :: m1,m2,m3,m4
+ real(ki) :: arg1,arg2,arg3,arg4,arg5,arg6
+ logical, dimension(3:6) :: argz
+ integer, dimension(4) :: s
+ integer :: dim_pro
+ !
+ if (b_pro < 256) then
+ dim_pro = bit_count(b_pro)
+ s = bit_sets(b_pro*8:b_pro*8+dim_pro-1)
+ else
+ dim_pro = countb(b_pro)
+ s = unpackb(b_pro,dim_pro)
+ end if
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ m4 = s(4)
+ !
+ arg1 = s_mat_r(m2,m4)
+ arg2 = s_mat_r(m1,m3)
+ arg3 = s_mat_r(m1,m4)
+ arg4 = s_mat_r(m1,m2)
+ arg5 = s_mat_r(m2,m3)
+ arg6 = s_mat_r(m3,m4)
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ par4 = 0
+ !
+ argz(3) = equal_real(arg3,zero)
+ argz(4) = equal_real(arg4,zero)
+ argz(5) = equal_real(arg5,zero)
+ argz(6) = equal_real(arg6,zero)
+ !
+ ! only case with no internal masses:
+ !
+ if ( all(argz) ) then
+ !
+ temp = f4p1m("n+2",arg1,arg2,0._ki,par1,par2,par3,par4)
+ !
+ ! one external mass
+ !
+ else if ( argz(4) .and. argz(5) .and. argz(6) ) then
+ !
+ temp = f4p1m("n+2",arg2,arg1,arg3,par1,par2,par3,par4)
+ !
+ else if ( argz(3) .and. argz(5) .and. argz(6) ) then
+ !
+ temp = f4p1m("n+2",arg1,arg2,arg4,par1,par2,par3,par4)
+ !
+ else if ( argz(3) .and. argz(4) .and. argz(6) ) then
+ !
+ temp = f4p1m("n+2",arg2,arg1,arg5,par1,par2,par3,par4)
+ !
+ else if ( argz(3) .and. argz(4) .and. argz(5) ) then
+ !
+ temp = f4p1m("n+2",arg1,arg2,arg6,par1,par2,par3,par4)
+ !
+ ! two adjacent external masses
+ !
+ else if ( argz(3) .and. argz(6) ) then
+ !
+ temp = f4p2m_adj("n+2",arg2,arg1,arg4,arg5,par1,par2,par3,par4)
+ !
+ else if ( argz(4) .and. argz(5) ) then
+ !
+ temp = f4p2m_adj("n+2",arg2,arg1,arg6,arg3,par1,par2,par3,par4)
+ !
+ else if ( argz(5) .and. argz(6) ) then
+ !
+ temp = f4p2m_adj("n+2",arg1,arg2,arg3,arg4,par1,par2,par3,par4)
+ !
+ else if ( argz(3) .and. argz(4) ) then
+ !
+ temp = f4p2m_adj("n+2",arg1,arg2,arg5,arg6,par1,par2,par3,par4)
+ !
+ ! two opposite external masses
+ !
+ else if ( argz(4) .and. argz(6) ) then
+ !
+ temp = f4p2m_opp("n+2",arg2,arg1,arg5,arg3,par1,par2,par3,par4)
+ !
+ else if ( argz(3) .and. argz(5) ) then
+ !
+ temp = f4p2m_opp("n+2",arg1,arg2,arg4,arg6,par1,par2,par3,par4)
+ !
+ ! three external masses
+ !
+ else if ( argz(3) ) then
+ !
+ temp = f4p3m("n+2",arg1,arg2,arg4,arg5,arg6,par1,par2,par3,par4)
+ !
+ else if ( argz(4) ) then
+ !
+ temp = f4p3m("n+2",arg2,arg1,arg5,arg6,arg3,par1,par2,par3,par4)
+ !
+ else if ( argz(5) ) then
+ !
+ temp = f4p3m("n+2",arg1,arg2,arg6,arg3,arg4,par1,par2,par3,par4)
+ !
+ else if ( argz(6) ) then
+ !
+ temp = f4p3m("n+2",arg2,arg1,arg3,arg4,arg5,par1,par2,par3,par4)
+ !
+ ! four external masses
+ !
+ else
+ !
+ temp = f4p4m("n+2",arg1,arg2,arg3,arg4,arg5,arg6,par1,par2,par3,par4)
+ !
+ end if ! end massless case
+ !
+ temp_cmplx(1) = temp(1) + i_ * temp(2)
+ temp_cmplx(2) = temp(3) + i_ * temp(4)
+ !
+ !
+ f4p_np2_sca_massless = temp_cmplx(2)
+ !
+ !
+ end function f4p_np2_sca_massless
+ !
+ !
+ function f4p_np2_sca_massive(s_mat_p,b_pro,b_pin)
+ !
+ type(s_matrix_poly), intent (in) :: s_mat_p
+ integer, intent (in) :: b_pro,b_pin
+ complex(ki) :: f4p_np2_sca_massive
+ !
+ integer :: j,ib,b_pro_mj
+ complex(ki), dimension(3) :: trisum,temp0
+ complex(ki) :: bsum
+ !
+ ! there is no case with zero internal masses!
+ ! this function is only called if there is at least one internal mass
+ !
+ !
+ ! ********************************************************
+ ! ********** massive case (internal masses): see f4p **************
+ !
+ trisum(:) = czero
+ bsum = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ trisum = trisum + b(j,b_pin)*f3p(s_mat_p,b_pro_mj)
+ bsum = bsum + b(j,b_pin)
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ temp0 = ( f4p(s_mat_p,b_pro) - trisum )/bsum
+ !
+ f4p_np2_sca_massive = temp0(3)
+ !
+ end function f4p_np2_sca_massive
+ !
+ !****f* src/integrals/four_point/generic_function_4p/f4p_np4
+ ! NAME
+ !
+ ! Function f4p_np4
+ !
+ ! USAGE
+ !
+ ! complex_dim2 = f4p_np4(s_mat_p,b_pro,b_pin,parf1,parf2,parf3,parf4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes recursively the generic four point function in n+4 dimensions,
+ ! with or without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a type s_matrix_poly object, the S matrix
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ ! * b_pin -- an integer which represents the set of the pinched propagators
+ ! * parf1 -- an integer (optional), the label of the one Feynman parameter
+ ! * parf2 -- an integer (optional), the label of the second Feynman parameter
+ ! * parf3 -- an integer (optional), the label of the third Feynman parameter
+ ! * parf4 -- an integer (optional), the label of the forth Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) array of rank 1 and shape 2.
+ !
+ ! NOTES
+ !
+ ! This function has been changed! It only accepts a s_matrix_poly type object as input.
+ ! It returns a complex instead of a real array!
+ !
+ !*****
+ !
+ ! this function returns a complex array now!
+ !
+ recursive function f4p_np4(s_mat_p,b_pro,b_pin,parf1,parf2,parf3,parf4,test_numeric) result(res_4p_np4)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in) :: b_pro,b_pin
+ integer, intent (in), optional :: parf1,parf2,parf3,parf4
+ logical, intent (in), optional :: test_numeric
+ complex(ki), dimension(2) :: res_4p_np4
+ !
+ integer :: par1,par2,par3,par4
+ integer :: parn1,parn2,parn3,parn4
+ integer, dimension(4) :: z_param_ini,z_param_out
+ integer :: taille
+ integer :: nb_par
+ real(ki) :: arg1,arg2,arg3,arg4,arg5,arg6
+ real(ki) :: m1s,m2s,m3s,m4s,s1,s2,s3,s4
+ complex(ki) :: temp0
+ complex(ki), dimension(2) :: temp1,temp2,temp3
+ integer :: j,m1,m2,m3,m4
+ integer, dimension(4) :: s
+ integer, dimension(2) :: set
+ integer :: ib,b_pro_mj,dim_pin
+ real(ki) :: norma
+ logical :: not_numeric
+ !
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ par4 = 0
+ !
+ if ( present(parf1) ) par1 = parf1
+ if ( present(parf2) ) par2 = parf2
+ if ( present(parf3) ) par3 = parf3
+ if ( present(parf4) ) par4 = parf4
+ !
+
+ sortie : if ( (par1 == -1) .or. (par2 == -1).or. (par3 == -1) &
+ .or. (par4 == -1) ) then
+ !
+ res_4p_np4(:) = czero
+ !
+ else sortie
+ !
+ ! symetrie: la place de z1,z2,z3,z4 n'a pas d'importance, on les met
+ ! dans l'ordre croissant
+ !
+ z_param_ini = (/par1,par2,par3,par4/)
+ !
+ nb_par = count(mask=z_param_ini/=0)
+ !
+ if (b_pro < 256) then
+ s = bit_sets(b_pro*8:b_pro*8+3)
+ else
+ s = unpackb(b_pro,4)
+ end if
+ !
+ ! test for switch to numerical evaluation needs to be performed only once
+ !
+ switch_to_numerics: if (present(test_numeric) ) then
+ !
+ not_numeric = test_numeric !this should always be true...
+ !
+ else switch_to_numerics
+ !
+ ! make sure numerical branch is never entered for cases where it is not implemented
+
+ ! NB: This order of the statements
+ ! reduces the number of comparisons required.
+ !
+ ! numerical branch not implemented for complex masses yet:
+ if (iand(s_mat_p%b_cmplx, b_pro) .ne. 0 ) then
+ !
+ not_numeric = .true.
+ !
+ else if (iand(s_mat_p%b_zero, b_pro) .ne. b_pro ) then !case internal masses
+ !
+ not_numeric = .true.
+ !
+ else
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ m4 = s(4)
+ !
+ arg1 = s_mat_p%pt_real(m2,m4)
+ arg2 = s_mat_p%pt_real(m1,m3)
+ arg3 = s_mat_p%pt_real(m1,m4)
+ arg4 = s_mat_p%pt_real(m1,m2)
+ arg5 = s_mat_p%pt_real(m2,m3)
+ arg6 = s_mat_p%pt_real(m3,m4)
+ !
+ m1s = -s_mat_p%pt_real(m1,m1)/2._ki
+ m2s = -s_mat_p%pt_real(m2,m2)/2._ki
+ m3s = -s_mat_p%pt_real(m3,m3)/2._ki
+ m4s = -s_mat_p%pt_real(m4,m4)/2._ki
+ !
+ ! end if
+ !
+ s1=arg3+m1s+m4s
+ s2=arg4+m1s+m2s
+ s3=arg5+m2s+m3s
+ s4=arg6+m3s+m4s
+ !
+ ! else
+ ! case 4 non-light-like legs
+ if ( .not.(equal_real(s1,zero)) .and. &
+ & .not.(equal_real(s2,zero)) .and. &
+ & .not.(equal_real(s3,zero)) .and. &
+ & .not.(equal_real(s4,zero))) then
+ not_numeric = .true.
+ else
+ not_numeric=.not. ( abs(norma_sumb(b_pin)) < coupure(s_mat_p,s) )
+ end if
+ !
+ end if
+ !
+ end if switch_to_numerics
+ !
+ if (nb_par == 0) then
+ !
+ norma = 1._ki/6._ki
+ !
+ else if (nb_par == 1) then
+ !
+ norma = 1._ki/24._ki
+ !
+ else
+ !
+ norma = 0._ki
+ !
+ end if
+ !
+ taille = dim_s - size(s)
+ !
+ select case(taille)
+ !
+ case(0)
+ !
+ set_tot = 0
+ !
+ case(1)
+ !
+ if (b_pin < 256) then
+ set(1:1) = bit_sets(b_pin*8:b_pin*8)
+ else
+ set(1:1) = unpackb(b_pin,1)
+ end if
+ set_tot(1) = 0
+ set_tot(2) = set(1)
+ !
+ case(2)
+ !
+ if (b_pin < 256) then
+ set = bit_sets(b_pin*8:b_pin*8+1)
+ else
+ set = unpackb(b_pin,2)
+ end if
+ !
+ set_tot(1:2) = set(1:2)
+ !
+ end select
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ cache : if ( computed_f4p_np4(set_tot(1),set_tot(2),par4) ) then
+ !
+ res_4p_np4 = results_f4p_np4(set_tot(1),set_tot(2),par4,:)
+ !
+ else cache
+ !
+ ! before: numeric : if ( not_numeric .and. &
+ ! & (abs(norma_sumb(b_pin)) >= coupure(s_mat_p,s) )) then
+ numeric : if ( not_numeric ) then
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ if (nb_par == 1) then
+ !
+ temp0 = f4p_np2(s_mat_p,b_pro,b_pin, parf4 = par4, test_numeric = not_numeric)/3._ki
+ temp1 = b(par4,b_pin)*f4p_np4(s_mat_p,b_pro,b_pin, test_numeric = not_numeric)
+ temp2(:) = czero
+ temp3(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ temp2 = temp2 + inv_s(j,par4,b_pin)*f3p_np2(s_mat_p,b_pro_mj)/6._ki
+ !
+ if (j /= par4) then
+ !
+ temp3 = temp3 - b(j,b_pin)*f3p_np2(s_mat_p,b_pro_mj,par4)/2._ki
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p_np4(1) = ( temp1(1)+temp2(1)+temp3(1) )/(2._ki*sumb(b_pin))
+ res_4p_np4(2) = ( temp1(2)+temp1(1)/6._ki+temp2(2)+temp2(1)/2._ki &
+ +temp3(2)+temp3(1)/2._ki+temp0 )/(2._ki*sumb(b_pin))
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ else if (nb_par == 0) then
+ !
+ temp0 = f4p_np2(s_mat_p,b_pro,b_pin,test_numeric = not_numeric)
+ !
+ temp1(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ temp1 = temp1 + b(j,b_pin)*f3p_np2(s_mat_p,b_pro_mj)
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_4p_np4(1) = ( -temp1(1) )/(3._ki*sumb(b_pin))
+ res_4p_np4(2) = (temp0 - temp1(2) - 2._ki/3._ki*temp1(1) )/(3._ki*sumb(b_pin) )
+ !
+ ! cas avec plus de un parametre de feynman au numerateur
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_np4:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of four-point integrals in n+4 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb((/par1,par2,par3,par4/)),4/)
+ call catch_exception(0)
+ !
+ end if
+ !
+ else numeric
+ !
+ where (z_param_out /= 0)
+ !
+ z_param_out = locateb(z_param_out,b_pro)
+ !
+ elsewhere
+ !
+ z_param_out = 0
+ !
+ end where
+ !
+ parn1 = z_param_out(1)
+ parn2 = z_param_out(2)
+ parn3 = z_param_out(3)
+ parn4 = z_param_out(4)
+ !
+ res_4p_np4 = f4p_np4_numeric(s_mat_p,b_pro,parn1,parn2,parn3,parn4)
+ !
+ end if numeric
+ !
+ computed_f4p_np4(set_tot(1),set_tot(2),par4) = .true.
+ results_f4p_np4(set_tot(1),set_tot(2),par4,:) = res_4p_np4
+ !
+ end if cache
+ !
+ end if sortie
+ !
+ end function f4p_np4
+ !
+ !
+ !****f* src/integrals/four_point/generic_function_4p/f4p_np2_numeric
+ ! NAME
+ !
+ ! Function f4p_np2_numeric
+ !
+ ! USAGE
+ !
+ ! complex = f4p_np2_numeric(s_mat_p,b_pro,parf1,parf2,parf3,parf4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes numerically the generic four point function in n+2 dimensions,
+ ! with or without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a derived type s_matrix_poly, the S matrix
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ ! * par1 -- an integer, the label of the one Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the third Feynman parameter
+ ! * par4 -- an integer, the label of the forth Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex number!
+ !
+ ! NOTES
+ !
+ ! This function has been changed! It only accepts a s_matrix_poly type object!
+ ! It returns a complex number!
+ !
+ !*****
+ !
+ ! returns a complex number now!
+ !
+ function f4p_np2_numeric(s_mat_p,b_pro,parf1,parf2,parf3,parf4)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in) :: b_pro
+ integer, intent (in) :: parf1,parf2,parf3,parf4
+ complex(ki) :: f4p_np2_numeric
+ !
+ integer :: par1,par2,par3,par4
+ integer, dimension(4) :: z_param_ini,z_param_out
+ real(ki), dimension(4) :: temp
+ integer :: m1,m2,m3,m4
+ real(ki) :: arg1,arg2,arg3,arg4,arg5,arg6
+ integer, dimension(4) :: s
+ integer :: dim_pro
+ logical, dimension(3:6) :: argz
+ !
+ sortie : if ( (parf1 == -1) .or. (parf2 == -1).or. (parf3 == -1) &
+ .or. (parf4 == -1) ) then
+ !
+ f4p_np2_numeric = czero
+ !
+ else sortie
+ !
+ ! symetrie: la place de z1,z2,z3,z4 n'a pas d'importance, on les met
+ ! dans l'ordre croissant
+ !
+ z_param_ini(1) = parf1
+ z_param_ini(2) = parf2
+ z_param_ini(3) = parf3
+ z_param_ini(4) = parf4
+ !
+ if (b_pro < 256) then
+ dim_pro = bit_count(b_pro)
+ s = bit_sets(b_pro*8:b_pro*8+dim_pro)
+ else
+ dim_pro = countb(b_pro)
+ s = unpackb(b_pro,dim_pro)
+ end if
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ m4 = s(4)
+ !
+ ! arg1 = s, arg2 = t et les autres arguments sont les masses externes
+ !
+ ! only massless case is considered here, relevant piece of s_matrix is necessarily real
+ !
+ arg1 = s_mat_p%pt_real(m2,m4)
+ arg2 = s_mat_p%pt_real(m1,m3)
+ arg3 = s_mat_p%pt_real(m1,m4)
+ arg4 = s_mat_p%pt_real(m1,m2)
+ arg5 = s_mat_p%pt_real(m2,m3)
+ arg6 = s_mat_p%pt_real(m3,m4)
+ !
+ argz(3) = equal_real(arg3,zero)
+ argz(4) = equal_real(arg4,zero)
+ argz(5) = equal_real(arg5,zero)
+ argz(6) = equal_real(arg6,zero)
+ !
+ ! no external mass
+ !
+ if ( (argz(3)) .and. (argz(4)) .and. (argz(5)) &
+ .and. (argz(6)) ) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+2",arg1,arg2,0._ki,par1,par2,par3,par4)
+ !
+ ! one external mass
+ !
+ else if ( ( (argz(4)) .and. (argz(5)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,3,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+2",arg2,arg1,arg3,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(5)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,2,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+2",arg1,arg2,arg4,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(4)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,1,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+2",arg2,arg1,arg5,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(4)) .and. (argz(5)) ) ) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+2",arg1,arg2,arg6,par1,par2,par3,par4)
+ !
+ ! two adjacent external masses
+ !
+ else if ( ( (argz(3)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,1,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_adj("n+2",arg2,arg1,arg4,arg5,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(4)) .and. (argz(5)) ) ) then
+ !
+ call shift_param(z_param_ini,3,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_adj("n+2",arg2,arg1,arg6,arg3,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(5)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,2,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_adj("n+2",arg1,arg2,arg3,arg4,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(4)) ) ) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_adj("n+2",arg1,arg2,arg5,arg6,par1,par2,par3,par4)
+ !
+ ! two opposite external masses
+ !
+ else if ( ( (argz(4)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,3,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_opp("n+2",arg2,arg1,arg5,arg3,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(5)) ) ) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ temp = f4p2m_opp("n+2",arg1,arg2,arg4,arg6,par1,par2,par3,par4)
+ !
+ ! three external masses
+ !
+ else if (argz(3)) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p3m("n+2",arg1,arg2,arg4,arg5,arg6,par1,par2,par3,par4)
+ !
+ else if (argz(4)) then
+ !
+ call shift_param(z_param_ini,3,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p3m("n+2",arg2,arg1,arg5,arg6,arg3,par1,par2,par3,par4)
+ !
+ else if (argz(5)) then
+ !
+ call shift_param(z_param_ini,2,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p3m("n+2",arg1,arg2,arg6,arg3,arg4,par1,par2,par3,par4)
+ !
+ else if (argz(6)) then
+ !
+ call shift_param(z_param_ini,1,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p3m("n+2",arg2,arg1,arg3,arg4,arg5,par1,par2,par3,par4)
+ !
+ ! four external masses
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_np2_numeric:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'four external mass four point integral not yet implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ f4p_np2_numeric = temp(3) + i_ * temp(4)
+ !
+ end if sortie
+ !
+ end function f4p_np2_numeric
+ !
+ !****f* src/integrals/four_point/generic_function_4p/f4p_np4_numeric
+ ! NAME
+ !
+ ! Function f4p_np4_numeric
+ !
+ ! USAGE
+ !
+ ! complex_dim2 = f4p_np4_numeric(s_mat_p,b_pro,parf1,parf2,parf3,parf4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes numerically the generic four point function in n+4 dimensions,
+ ! with or without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a derived type s_matrix_poly, the S matrix
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ ! * parf1 -- an integer (optional), the label of the one Feynman parameter
+ ! * parf2 -- an integer (optional), the label of the second Feynman parameter
+ ! * parf3 -- an integer (optional), the label of the third Feynman parameter
+ ! * parf4 -- an integer (optional), the label of the forth Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) array of rank 1 and shape 2.
+ !
+ ! NOTES
+ !
+ ! This function has been changed! It only accepts a s_matrix_poly type object!
+ ! It returns a complex array!
+ !
+ !
+ !
+ !*****
+ !
+ function f4p_np4_numeric(s_mat_p,b_pro,parf1,parf2,parf3,parf4)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: parf1,parf2,parf3,parf4
+ complex(ki), dimension(2) :: f4p_np4_numeric
+ !
+ real(ki), dimension(4) :: temp
+ integer :: par1,par2,par3,par4
+ integer, dimension(4) :: z_param_ini,z_param_out
+ integer :: m1,m2,m3,m4
+ real(ki) :: arg1,arg2,arg3,arg4,arg5,arg6
+ integer, dimension(4) :: s
+ integer :: pro_dim
+ logical, dimension(3:6) :: argz
+ !
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ par4 = 0
+ !
+ if ( present(parf1) ) par1 = parf1
+ if ( present(parf2) ) par2 = parf2
+ if ( present(parf3) ) par3 = parf3
+ if ( present(parf4) ) par4 = parf4
+ !
+ sortie : if ( (par1 == -1) .or. (par2 == -1).or. (par3 == -1) &
+ .or. (par4 == -1) ) then
+ !
+ f4p_np4_numeric(:) = czero
+ !
+ else sortie
+ !
+ ! symetrie: la place de z1,z2,z3,z4 n'a pas d'importance, on les met
+ ! dans l'ordre croissant
+ !
+ z_param_ini(1) = par1
+ z_param_ini(2) = par2
+ z_param_ini(3) = par3
+ z_param_ini(4) = par4
+ !
+ if (b_pro < 256) then
+ pro_dim = bit_count(b_pro)
+ s = bit_sets(b_pro*8:b_pro*8+pro_dim)
+ else
+ pro_dim = countb(b_pro)
+ s = unpackb(b_pro,pro_dim)
+ end if
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ m4 = s(4)
+ !
+ ! arg1 = s, arg2 = t et les autres arguments sont les masses externes
+ !
+ ! only massless case is considered here, relevant piece of s_matrix is necessarily real
+ !
+ arg1 = s_mat_p%pt_real(m2,m4)
+ arg2 = s_mat_p%pt_real(m1,m3)
+ arg3 = s_mat_p%pt_real(m1,m4)
+ arg4 = s_mat_p%pt_real(m1,m2)
+ arg5 = s_mat_p%pt_real(m2,m3)
+ arg6 = s_mat_p%pt_real(m3,m4)
+ !
+ argz(3) = equal_real(arg3,zero)
+ argz(4) = equal_real(arg4,zero)
+ argz(5) = equal_real(arg5,zero)
+ argz(6) = equal_real(arg6,zero)
+ !
+ ! no external mass
+ !
+ if ( (argz(3)) .and. (argz(4)) .and. (argz(5)) .and. (argz(6)) ) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+4",arg1,arg2,0._ki,par1,par2,par3,par4)
+ !
+ ! one external mass
+ !
+ else if ( ( (argz(4)) .and. (argz(5)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,3,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+4",arg2,arg1,arg3,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(5)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,2,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+4",arg1,arg2,arg4,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(4)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,1,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+4",arg2,arg1,arg5,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(4)) .and. (argz(5)) ) ) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p1m("n+4",arg1,arg2,arg6,par1,par2,par3,par4)
+ !
+ ! two adjacent external masses
+ !
+ else if ( ( (argz(3)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,1,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_adj("n+4",arg2,arg1,arg4,arg5,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(4)) .and. (argz(5)) ) ) then
+ !
+ call shift_param(z_param_ini,3,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_adj("n+4",arg2,arg1,arg6,arg3,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(5)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,2,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_adj("n+4",arg1,arg2,arg3,arg4,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(4)) ) ) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_adj("n+4",arg1,arg2,arg5,arg6,par1,par2,par3,par4)
+ !
+ ! two opposite external masses
+ !
+ else if ( ( (argz(4)) .and. (argz(6)) ) ) then
+ !
+ call shift_param(z_param_ini,3,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_opp("n+4",arg2,arg1,arg5,arg3,par1,par2,par3,par4)
+ !
+ else if ( ( (argz(3)) .and. (argz(5)) ) ) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p2m_opp("n+4",arg1,arg2,arg4,arg6,par1,par2,par3,par4)
+ !
+ ! three external masses
+ !
+ else if (argz(3)) then
+ !
+ call tri_int4(z_param_ini,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p3m("n+4",arg1,arg2,arg4,arg5,arg6,par1,par2,par3,par4)
+ !
+ else if (argz(4)) then
+ !
+ call shift_param(z_param_ini,3,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p3m("n+4",arg2,arg1,arg5,arg6,arg3,par1,par2,par3,par4)
+ !
+ else if (argz(5)) then
+ !
+ call shift_param(z_param_ini,2,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p3m("n+4",arg1,arg2,arg6,arg3,arg4,par1,par2,par3,par4)
+ !
+ else if (argz(6)) then
+ !
+ call shift_param(z_param_ini,1,4,z_param_out)
+ !
+ par1 = z_param_out(1)
+ par2 = z_param_out(2)
+ par3 = z_param_out(3)
+ par4 = z_param_out(4)
+ !
+ temp = f4p3m("n+4",arg2,arg1,arg3,arg4,arg5,par1,par2,par3,par4)
+ !
+ ! four external masses
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f4p_np4_numeric:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'four external mass four point integral not yet implemented'
+ call catch_exception(0)
+ !
+ end if
+ !
+ f4p_np4_numeric(1) = temp(1) + i_ * temp(2)
+ f4p_np4_numeric(2) = temp(3) + i_ * temp(4)
+ !
+ end if sortie
+ !
+ end function f4p_np4_numeric
+ !
+ !****if* src/integrals/four_point/generic_function_4p/coupure
+ ! NAME
+ !
+ ! Function coupure
+ !
+ ! USAGE
+ !
+ ! real = coupure(s_mat_p,s)
+ !
+ ! DESCRIPTION
+ !
+ ! Depending on the set s and the S matrix (s_mat), this function returns
+ ! the value of the cut to switch from analytic to numeric
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a derived type s_matrix_poly object. The S matrix.
+ ! * s -- an integer array of rank 1 and shape 4, the set of the four unpinched
+ ! propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function coupure(s_mat_p,s)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in), dimension(4) :: s
+ real(ki) :: coupure
+ !
+ integer :: m1,m2,m3,m4
+ real(ki) :: arg3,arg4,arg5,arg6
+ real(ki), dimension(4) :: table_arg
+ integer :: count_mass
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ m4 = s(4)
+ !
+ ! arg1 = s, arg2 = t et les autres arguments sont les masses externes
+ !
+ ! function coupure only defined for massless matrices so far. if masses are involved, the args do not
+ ! reflect the invariant masses of the external legs (or s and t)
+ !
+ !
+ arg3 = s_mat_p%pt_real(m1,m4)
+ arg4 = s_mat_p%pt_real(m1,m2)
+ arg5 = s_mat_p%pt_real(m2,m3)
+ arg6 = s_mat_p%pt_real(m3,m4)
+ !
+ !
+ table_arg = (/arg3,arg4,arg5,arg6/)
+ count_mass = count(mask=table_arg/=zero)
+ !
+ select case(count_mass)
+ !
+ case(0,1)
+ !
+ coupure = coupure_4p1m
+ !
+ case(2)
+ !
+ if ( (equal_real(arg3*arg5,0._ki)) .and. (equal_real(arg4*arg6,0._ki)) ) then
+ !
+ coupure = coupure_4p2m_adj
+ !
+ else
+ !
+ coupure = coupure_4p2m_opp
+ !
+ end if
+ !
+ case(3)
+ !
+ coupure = coupure_4p3m
+ !
+ case(4)
+ !
+ coupure = coupure_4p4m
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function coupure:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the case required for four point integral not yet &
+ &implemented'
+ call catch_exception(0)
+ !
+ end select
+ !
+ end function coupure
+ !
+ ! *********************************************************************
+ ! added for massive case
+ ! ***********************************************************************
+ !****f* src/integrals/four_point/generic_function_4p/f4p
+ ! NAME
+ !
+ ! Function f4p
+ !
+ ! USAGE
+ !
+ ! cmplx_dim3 = f4p(s_mat,b_pro,b_pin,parf1,parf2,parf3,parf4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic four point function in n dimensions
+ ! only scalar case is implemented!!!
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a derived type s_matrix_poly, the S matrix
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ ! * b_pin -- an integer which represents the set of the pinched propagators
+ ! * parf1 -- an integer (optional), the label of the one Feynman parameter
+ ! * parf2 -- an integer (optional), the label of the second Feynman parameter
+ ! * parf3 -- an integer (optional), the label of the third Feynman parameter
+ ! * parf4 -- an integer (optional), the label of the forth Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) array of rank 1 and shape 3
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f4p(s_mat_p,b_pro,b_pin,parf1,parf2,parf3,parf4)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: b_pin, parf1,parf2,parf3,parf4
+ complex(ki), dimension(3) :: f4p
+ real(ki), dimension(6) :: f4p_real
+ !
+ f4p_real = f4p_ra(s_mat_p,b_pro,b_pin=b_pin,parf1=parf1,parf2=parf2,parf3=parf3,parf4=parf4)
+ !
+ f4p(1) = f4p_real(1) + i_ * f4p_real(2)
+ f4p(2) = f4p_real(3) + i_ * f4p_real(4)
+ f4p(3) = f4p_real(5) + i_ * f4p_real(6)
+ !
+ end function f4p
+ !
+ function f4p_ra(s_mat_p,b_pro,b_pin,parf1,parf2,parf3,parf4) result(res_4p)
+ !
+ type(s_matrix_poly), intent (in) :: s_mat_p
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: b_pin, parf1,parf2,parf3,parf4
+ real(ki), dimension(6) :: res_4p
+ !
+ integer :: par1,par2,par3,par4
+ !
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ par4 = 0
+ !
+ if ( present(parf1) ) par1 = parf1
+ if ( present(parf2) ) par2 = parf2
+ if ( present(parf3) ) par3 = parf3
+ if ( present(parf4) ) par4 = parf4
+ !
+ sortie : if ( (par1 == -1) .or. (par2 == -1) .or. (par3 == -1) &
+ .or. (par4 == -1) ) then
+ !
+ res_4p(:) = 0._ki
+ !
+ else if ( (par1+par2+par3+par4) /= 0 ) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In f4p_ra: called with non-zero Feynman parameters!'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The 4-dim box is only implemented for the scalar case!'
+ !
+ call catch_exception(0)
+ !
+ else sortie
+ !
+ res_4p = f4p_sca(s_mat_p,b_pro)
+ !
+ end if sortie
+ !
+ !
+ end function f4p_ra
+ !
+ !
+ !****f* src/integrals/four_point/generic_function_4p/f4p_sca
+ ! NAME
+ !
+ ! Function f4p_sca
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f4p_sca(s_mat_p,b_pro)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic four point function in n dimensions,
+ ! without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a s_matrix_poly type, the S matrix
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 6
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f4p_sca_p(s_mat_p,b_pro)
+ !
+ type(s_matrix_poly), intent(in) :: s_mat_p
+ integer, intent (in) :: b_pro
+ !
+ real(ki), dimension(6) :: f4p_sca_p
+ !
+ if (iand(s_mat_p%b_cmplx, b_pro) .eq. 0 ) then
+ !
+ f4p_sca_p = f4p_sca_r(s_mat_p%pt_real, b_pro)
+ !
+ else
+ !
+ f4p_sca_p = f4p_sca_c(s_mat_p%pt_cmplx, b_pro)
+ !
+ end if
+ !
+ end function f4p_sca_p
+ !
+ function f4p_sca_r(s_mat_r,b_pro)
+ !
+ real(ki), intent (in), dimension(:,:) :: s_mat_r
+ integer, intent (in) :: b_pro
+ real(ki), dimension(6) :: f4p_sca_r,temp
+ integer :: par1,par2,par3,par4
+ integer :: m1,m2,m3,m4
+ real(ki) :: arg1,arg2,arg3,arg4,arg5,arg6
+ real(ki) :: m1s,m2s,m3s,m4s,s12,s23,s1,s2,s3,s4
+ complex(ki_avh) :: D0res
+ complex(ki_avh), dimension(0:2) :: D0olo
+ integer, dimension(4) :: s
+ integer :: pro_dim
+ logical, dimension(4) :: msz, ssz
+ logical, dimension(4,4) :: meqs
+ !
+ ! mu2_scale_par is defined globally:
+ ! default mu2_scale_par=1 is set in paramtere.f90,
+ ! unless defined otherwise by user in his main program
+ !
+ if (b_pro < 256) then
+ pro_dim = bit_count(b_pro)
+ s = bit_sets(b_pro*8:b_pro*8+pro_dim-1)
+ else
+ pro_dim = countb(b_pro)
+ s = unpackb(b_pro,pro_dim)
+ end if
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ m4 = s(4)
+ !
+ !
+ arg1 = s_mat_r(m2,m4)
+ arg2 = s_mat_r(m1,m3)
+ arg3 = s_mat_r(m1,m4)
+ arg4 = s_mat_r(m1,m2)
+ arg5 = s_mat_r(m2,m3)
+ arg6 = s_mat_r(m3,m4)
+ !
+ m1s = -s_mat_r(m1,m1)/2._ki
+ m2s = -s_mat_r(m2,m2)/2._ki
+ m3s = -s_mat_r(m3,m3)/2._ki
+ m4s = -s_mat_r(m4,m4)/2._ki
+ !
+ msz(1) = equal_real(m1s,zero)
+ msz(2) = equal_real(m2s,zero)
+ msz(3) = equal_real(m3s,zero)
+ msz(4) = equal_real(m4s,zero)
+ !
+ s1=arg3+m1s+m4s
+ s2=arg4+m1s+m2s
+ s3=arg5+m2s+m3s
+ s4=arg6+m3s+m4s
+ !
+ call cut_s(s1,m1s,m4s)
+ call cut_s(s2,m1s,m2s)
+ call cut_s(s3,m2s,m3s)
+ call cut_s(s4,m3s,m4s)
+ !
+ ssz(1) = equal_real(s1,zero)
+ ssz(2) = equal_real(s2,zero)
+ ssz(3) = equal_real(s3,zero)
+ ssz(4) = equal_real(s4,zero)
+ !
+ meqs(1,1) = equal_real(m1s,s1)
+ meqs(1,2) = equal_real(m1s,s2)
+ meqs(1,3) = equal_real(m1s,s3)
+ meqs(1,4) = equal_real(m1s,s4)
+ meqs(2,1) = equal_real(m2s,s1)
+ meqs(2,2) = equal_real(m2s,s2)
+ meqs(2,3) = equal_real(m2s,s3)
+ meqs(2,4) = equal_real(m2s,s4)
+ meqs(3,1) = equal_real(m3s,s1)
+ meqs(3,2) = equal_real(m3s,s2)
+ meqs(3,3) = equal_real(m3s,s3)
+ meqs(3,4) = equal_real(m3s,s4)
+ meqs(4,1) = equal_real(m4s,s1)
+ meqs(4,2) = equal_real(m4s,s2)
+ meqs(4,3) = equal_real(m4s,s3)
+ meqs(4,4) = equal_real(m4s,s4)
+ !
+ !
+ s12 = arg1+m4s+m2s
+ s23 = arg2+m1s+m3s
+ !
+ call cut_s(s12,m4s,m2s)
+ call cut_s(s23,m1s,m3s)
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ par4 = 0
+ !
+ temp(:) = 0._ki
+ !
+ ! case no internal masses:
+ !
+ if ( (msz(1)) .and. (msz(2)) .and. (msz(3)) &
+ .and. (msz(4)) ) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'use dim=n+2 for boxes with no internal masses !'
+ call catch_exception(0)
+ !
+ else ! at least one internal mass nonzero
+ !
+ ! ********************************************************
+ ! ********** massive case (internal masses) **************
+ !
+ ! case two massive on-shell legs, three internal masses, all masses equal
+ if ( .not.(msz(1)) .and..not.(msz(2)) .and.(msz(3)) &
+ & .and..not.(msz(4)) .and. (equal_real(m1s,m2s)) .and. (equal_real(m2s,m4s)) &
+ & .and.(meqs(2,3)) .and.(meqs(4,4)) ) then
+ !
+ temp = f4p2m_3mi_onshell("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massless internal line
+ !
+ else if ( .not.(msz(2)) .and..not.(msz(3)) .and.(msz(4)) &
+ & .and..not.(msz(1)) .and. (equal_real(m2s,m3s)) .and. (equal_real(m3s,m1s)) &
+ & .and.(meqs(3,4)) .and.(meqs(1,1)) ) then
+ !
+ temp = f4p2m_3mi_onshell("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ !
+ else if ( .not.(msz(3)) .and..not.(msz(4)) .and.(msz(1)) &
+ & .and..not.(msz(2)) .and. (equal_real(m3s,m4s)) .and. (equal_real(m4s,m2s)) &
+ & .and.(meqs(4,1)) .and.(meqs(2,2)) ) then
+ !
+ temp = f4p2m_3mi_onshell("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(4)) .and..not.(msz(1)) .and.(msz(2)) &
+ & .and..not.(msz(3)) .and. (equal_real(m4s,m1s)) .and. (equal_real(m1s,m3s)) &
+ & .and.(meqs(1,2)) .and.(meqs(3,3)) ) then
+ !
+ temp = f4p2m_3mi_onshell("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 6 *****************
+ ! QCDL m4 is golem m3
+ !
+ else if ( (msz(1)) .and.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and. (ssz(2)) &
+ & .and.(equal_real(s3,s4)) .and.(meqs(3,4)) ) then
+ !
+ temp = f4p_ql6("n",s1,s2,m3s,m3s,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massive internal line
+ !
+ else if ( (msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and. (ssz(3)) &
+ & .and.(equal_real(s4,s1)) .and.(meqs(4,1)) ) then
+ !
+ temp = f4p_ql6("n",s2,s3,m4s,m4s,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and. (ssz(4)) &
+ & .and.(equal_real(s1,s2)) .and.(meqs(1,2)) ) then
+ !
+ temp = f4p_ql6("n",s3,s4,m1s,m1s,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and. (ssz(1)) &
+ & .and.(equal_real(s2,s3)) .and.(meqs(2,3)) ) then
+ !
+ temp = f4p_ql6("n",s4,s1,m2s,m2s,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 7 *****************
+ ! QCDL m_i is golem m_{i-1}
+ !
+ !
+ else if ( (msz(1)) .and.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and. (ssz(2)) &
+ & .and. (meqs(3,3)) ) then
+ !
+ temp = f4p_ql7("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massive internal line
+ !
+ else if ( (msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and. (ssz(3)) &
+ & .and. (meqs(4,4)) ) then
+ !
+ temp = f4p_ql7("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and. (ssz(4)) &
+ & .and. (meqs(1,1)) ) then
+ !
+ temp = f4p_ql7("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and. (ssz(1)) &
+ & .and.(meqs(2,2)) ) then
+ !
+ temp = f4p_ql7("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 7b *****************
+ !~ p4^2=m3^2 instead of p3^2=m3^2 (in golem labelling) is also possible!
+ else if ( (msz(1)) .and.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and. (ssz(2)) &
+ & .and. (meqs(3,4)) ) then
+ !
+ temp = f4p_ql7("n",s1,s2,s4,s3,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massive internal line
+ !
+ else if ( (msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and. (ssz(3)) &
+ & .and. (meqs(4,1)) ) then
+ !
+ temp = f4p_ql7("n",s2,s3,s1,s4,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and. (ssz(4)) &
+ & .and. (meqs(1,2)) ) then
+ !
+ temp = f4p_ql7("n",s3,s4,s2,s1,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and. (ssz(1)) &
+ & .and.(meqs(2,3)) ) then
+ !
+ temp = f4p_ql7("n",s4,s1,s3,s2,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 8 *****************
+ !
+ ! limits s3,s4->0 are harmless, so do not require s3,s4 to be nonzero
+ !
+ else if ( (msz(1)) .and.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and. (ssz(2)) ) then
+ !
+ temp = f4p_ql8("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massive internal line
+ !
+ else if ( (msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and. (ssz(3)) ) then
+ !
+ temp = f4p_ql8("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and. (ssz(4)) ) then
+ !
+ temp = f4p_ql8("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and. (ssz(1)) ) then
+ !
+ temp = f4p_ql8("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 9 *****************
+ !
+ else if ( (msz(1)) .and.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and..not.(ssz(2)) &
+ & .and.(meqs(3,4)) ) then
+ !
+ temp = f4p_ql9("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massive internal line
+ !
+ else if ( (msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and..not.(ssz(3)) &
+ & .and.(meqs(4,1)) ) then
+ !
+ temp = f4p_ql9("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and..not.(ssz(4)) &
+ & .and.(meqs(1,2)) ) then
+ !
+ temp = f4p_ql9("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and..not.(ssz(1)) &
+ & .and.(meqs(2,3)) ) then
+ !
+ temp = f4p_ql9("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 9b *****************
+ !~ m2^2 nonzero instead of m3^2 (in golem labelling) is also possible!
+ !
+ else if ( (msz(1)) .and..not.(msz(2)) .and.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and..not.(ssz(4)) .and.(meqs(2,2)) ) then
+ !
+ temp = f4p_ql9("n",s1,s4,s3,s2,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massive internal line (permu1)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and..not.(ssz(1)) .and.(meqs(3,3)) ) then
+ !
+ temp = f4p_ql9("n",s2,s1,s4,s3,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massive internal line (permu2)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and..not.(ssz(2)) .and.(meqs(4,4)) ) then
+ !
+ temp = f4p_ql9("n",s3,s2,s1,s4,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massive internal line (permu3)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and..not.(ssz(3)) .and.(meqs(1,1)) ) then
+ !
+ temp = f4p_ql9("n",s4,s3,s2,s1,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 10 *****************
+ !
+ ! note that limits s3,s4->0 are harmless, so do not require s3,s4 to be nonzero
+ !
+ else if ( (msz(1)) .and.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and..not.(ssz(2)) ) then
+ !
+ if (ssz(4).and.meqs(3,2).and.meqs(3,3)) then
+ ! use function where limit is implemented analytically
+ temp = f4p_ql10a("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else
+ !
+ temp = f4p_ql10("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ endif ! end test for limit box 10a
+ !
+ ! permute the massive internal line
+ !
+ else if ( (msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and..not.(ssz(3)) ) then
+ !
+ if (ssz(1).and.meqs(4,3).and.meqs(4,4)) then
+ ! use function where limit is implemented analytically
+ temp = f4p_ql10a("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else
+ !
+ temp = f4p_ql10("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ endif ! end test for limit box 10a
+ !
+ else if ( (msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and..not.(ssz(4)) ) then
+ !
+ if (ssz(2).and.meqs(1,4).and.meqs(1,1)) then
+ ! use function where limit is implemented analytically
+ temp = f4p_ql10a("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else
+ !
+ temp = f4p_ql10("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ endif ! end test for limit box 10a
+ !
+ else if ( (msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and..not.(ssz(1)) ) then
+ !
+ if (ssz(3).and.meqs(2,1).and.meqs(2,2)) then
+ ! use function where limit is implemented analytically
+ temp = f4p_ql10a("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ else
+ !
+ temp = f4p_ql10("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ endif ! end test for limit box 10a
+ !
+ ! *********** case QCDLoop box 10b *****************
+ !~ m2^2 nonzero instead of m3^2 (in golem labelling) is also possible!
+ !
+ else if ( (msz(1)) .and..not.(msz(2)) .and.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and..not.(ssz(4)) ) then
+ !
+ if (ssz(2).and.meqs(2,3).and.meqs(2,4)) then
+ ! use function where limit is implemented analytically
+ temp = f4p_ql10a("n",s1,s4,s3,s2,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ else
+ !
+ temp = f4p_ql10("n",s1,s4,s3,s2,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ endif ! end test for limit box 10a
+ !
+ ! permute the massive internal line (permu1)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and..not.(ssz(1)) ) then
+ !
+ if (ssz(3).and.meqs(3,4).and.meqs(3,1)) then
+ ! use function where limit is implemented analytically
+ temp = f4p_ql10a("n",s2,s1,s4,s3,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else
+ !
+ temp = f4p_ql10("n",s2,s1,s4,s3,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ endif ! end test for limit box 10a
+ !
+ ! permute the massive internal line (permu2)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and..not.(ssz(2)) ) then
+ !
+ if (ssz(4).and.meqs(4,1).and.meqs(4,2)) then
+ ! use function where limit is implemented analytically
+ temp = f4p_ql10a("n",s3,s2,s1,s4,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else
+ !
+ temp = f4p_ql10("n",s3,s2,s1,s4,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ endif ! end test for limit box 10a
+ !
+ ! permute the massive internal line (permu3)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and..not.(ssz(3)) ) then
+ !
+ if (ssz(1).and.meqs(1,2).and.meqs(1,3)) then
+ ! use function where limit is implemented analytically
+ temp = f4p_ql10a("n",s4,s3,s2,s1,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else
+ !
+ temp = f4p_ql10("n",s4,s3,s2,s1,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ endif ! end test for limit box 10a
+ !
+ ! *********** case QCDLoop box 11 *****************
+ !
+ else if ( (msz(1)) .and..not.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and.(meqs(2,2)) &
+ & .and.(meqs(3,4)) ) then
+ !
+ temp = f4p_ql11("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and.(meqs(3,3)) &
+ & .and.(meqs(4,1)) ) then
+ !
+ temp = f4p_ql11("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and.(meqs(4,4)) &
+ & .and.(meqs(1,2)) ) then
+ !
+ temp = f4p_ql11("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and.(meqs(1,1)) &
+ & .and.(meqs(2,3)) ) then
+ !
+ temp = f4p_ql11("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 12 *****************
+ !
+ ! limit p3^2 -> 0 is finite, taken care of in function_4p_ql12.f90
+ ! limit p4^2 -> 0 is harmless, so do not restrict s4 to nonzero value
+ !
+ else if ( (msz(1)) .and..not.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and.(meqs(2,2)) ) then
+ !
+ temp = f4p_ql12("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and.(meqs(3,3)) ) then
+ !
+ temp = f4p_ql12("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and.(meqs(4,4)) ) then
+ !
+ temp = f4p_ql12("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and.(meqs(1,1)) ) then
+ !
+ temp = f4p_ql12("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 12b *****************
+ !~ TAKE INTO ACCOUNT MIRROR SYMMETRY, corrected 16.8.2011
+ !~ mass ordering corrected 13.9.2011
+ !
+ else if ( (msz(1)) .and..not.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and.(meqs(3,4)) ) then
+ !
+ temp = f4p_ql12("n",s1,s4,s3,s2,s23,s12,m1s,m3s,m2s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and.(meqs(4,1)) ) then
+ !
+ temp = f4p_ql12("n",s2,s1,s4,s3,s12,s23,m2s,m4s,m3s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and.(meqs(1,2)) ) then
+ !
+ temp = f4p_ql12("n",s3,s2,s1,s4,s23,s12,m3s,m1s,m4s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and.(meqs(2,3)) ) then
+ !
+ temp = f4p_ql12("n",s4,s3,s2,s1,s12,s23,m4s,m2s,m1s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 13 *****************
+ !
+ ! limit p3^2 -> 0 is finite, taken care of in function_4p_ql13.f90
+ ! limits p4^2,p2^2 -> 0 are harmless, so do not restrict s4,s2 to nonzero value
+ !
+ else if ( (msz(1)) .and..not.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) ) then
+ !
+ temp = f4p_ql13("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) ) then
+ !
+ temp = f4p_ql13("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) ) then
+ !
+ temp = f4p_ql13("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) ) then
+ !
+ temp = f4p_ql13("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 14 *****************
+ !
+ else if ( .not.(msz(1)) .and.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (meqs(1,1)) .and.(meqs(1,2)) &
+ & .and.(meqs(3,3)) .and.(meqs(3,4)) ) then
+ !
+ temp = f4p_ql14("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (meqs(2,2)) .and.(meqs(2,3)) &
+ & .and.(meqs(4,4)) .and.(meqs(4,1)) ) then
+ !
+ temp = f4p_ql14("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (meqs(3,3)) .and.(meqs(3,4)) &
+ & .and.(meqs(1,1)) .and.(meqs(1,2)) ) then
+ !
+ temp = f4p_ql14("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (meqs(4,4)) .and.(meqs(4,1)) &
+ & .and.(meqs(2,2)) .and.(meqs(2,3)) ) then
+ !
+ temp = f4p_ql14("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 15 *****************
+ ! limit s2,s3->0 is finite, so do not impose condition on s2,s3
+ !
+ else if ( .not.(msz(1)) .and.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (meqs(1,1)) &
+ & .and.(meqs(3,4)) ) then
+ !
+ temp = f4p_ql15("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (meqs(2,2)) &
+ & .and.(meqs(4,1)) ) then
+ !
+ temp = f4p_ql15("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (meqs(3,3)) &
+ & .and.(meqs(1,2)) ) then
+ !
+ temp = f4p_ql15("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (meqs(4,4)) &
+ & .and.(meqs(2,3)) ) then
+ !
+ temp = f4p_ql15("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 16 *****************
+ !
+ ! note that limits s2->0 and s3->0 are nonsingular, so do not require s2,s3 not=0
+ !
+ else if ( .not.(msz(1)) .and..not.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (meqs(1,1)) &
+ & .and.(meqs(3,4)) ) then
+ !
+ temp = f4p_ql16("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(2)) .and..not.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (meqs(2,2)) &
+ & .and.(meqs(4,1)) ) then
+ !
+ temp = f4p_ql16("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(3)) .and..not.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (meqs(3,3)) &
+ & .and.(meqs(1,2)) ) then
+ !
+ temp = f4p_ql16("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(4)) .and..not.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (meqs(4,4)) &
+ & .and.(meqs(2,3)) ) then
+ !
+ temp = f4p_ql16("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ else
+ !
+ ! changed to include LT option Jan2011
+ ! use avh_olo or LT
+@case_with_lt@ if (withlt) then
+ !
+@case_with_lt@ D0res = D0(real(s1,ki_lt),real(s2,ki_lt),real(s3,ki_lt),real(s4,ki_lt),&
+@case_with_lt@ & @case_with_lt@real(s12,ki_lt),real(s23,ki_lt),real(m4s,ki_lt),real(m1s,ki_lt),&
+@case_with_lt@ & real(m2s,ki_lt),real(m3s,ki_lt))
+ !
+@case_with_lt@ else ! use avholo
+ !
+ if (.not. olo) then
+! call avh_olo_onshell(100._ki*epsilon(1._ki))
+ call olo_onshell(real(1.e-10_ki, ki_avh))
+ call olo_scale(real(sqrt(mu2_scale_par), ki_avh))
+ olo=.true.
+ end if
+ !
+ call olo_d0(D0olo,real(s1,ki_avh),real(s2,ki_avh),real(s3,ki_avh),real(s4,ki_avh),&
+ & real(s12,ki_avh),real(s23,ki_avh),real(m4s,ki_avh),real(m1s,ki_avh),&
+ & real(m2s,ki_avh),real(m3s,ki_avh))
+ D0res = D0olo(0)
+ !
+@case_with_lt@ end if ! end if with lt
+ !
+ temp(5)= real(D0res)
+ temp(6)= aimag(D0res)
+ !
+ end if ! end distuinguish different cases of internal masses
+ !
+ end if ! end test if internal masses are present
+ !
+ f4p_sca_r = temp
+ !
+ !
+ end function f4p_sca_r
+ !
+ !
+ function f4p_sca_c(s_mat_c,b_pro)
+ !
+ complex(ki), intent (in), dimension(:,:) :: s_mat_c
+ integer, intent (in) :: b_pro
+ real(ki), dimension(6) :: f4p_sca_c,temp
+ integer :: par1,par2,par3,par4
+ integer :: m1,m2,m3,m4
+ complex(ki) :: arg1,arg2,arg3,arg4,arg5,arg6
+ complex(ki) :: m1s, m2s, m3s, m4s
+ real(ki) :: s12,s23,s1,s2,s3,s4
+ complex(ki_avh) :: D0res
+ complex(ki_avh), dimension(0:2) :: D0olo
+ complex(ki_avh) :: cp1,cp2,cp3,cp4,cp12,cp23,cm1,cm2,cm3,cm4
+ integer, dimension(4) :: s
+ integer :: pro_dim
+ integer :: nb_cm
+ logical, dimension(4) :: msz, ssz, msc
+ logical, dimension(4,4) :: meqs
+ logical :: avh_olo_div
+ !
+ ! mu2_scale_par is defined globally:
+ ! default mu2_scale_par=1 is set in paramtere.f90,
+ ! unless defined otherwise by user in his main program
+ !
+ if (b_pro < 256) then
+ pro_dim = bit_count(b_pro)
+ s = bit_sets(b_pro*8:b_pro*8+pro_dim-1)
+ else
+ pro_dim = countb(b_pro)
+ s = unpackb(b_pro,pro_dim)
+ end if
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ m4 = s(4)
+ !
+ !
+ arg1 = s_mat_c(m2,m4)
+ arg2 = s_mat_c(m1,m3)
+ arg3 = s_mat_c(m1,m4)
+ arg4 = s_mat_c(m1,m2)
+ arg5 = s_mat_c(m2,m3)
+ arg6 = s_mat_c(m3,m4)
+ !
+ m1s = -s_mat_c(m1,m1)/2._ki
+ m2s = -s_mat_c(m2,m2)/2._ki
+ m3s = -s_mat_c(m3,m3)/2._ki
+ m4s = -s_mat_c(m4,m4)/2._ki
+ !
+ msc(1) = (.not. equal_real(aimag(m1s),zero) )
+ msc(2) = (.not. equal_real(aimag(m2s),zero) )
+ msc(3) = (.not. equal_real(aimag(m3s),zero) )
+ msc(4) = (.not. equal_real(aimag(m4s),zero) )
+ !
+ nb_cm = count(mask=msc .eqv. .true.)
+ !
+ where (msc)
+ !
+ msz = .false.
+ !
+ elsewhere
+ !
+ msz = equal_real(real( (/ m1s,m2s,m3s,m4s /) , ki), zero)
+ !
+ end where
+ !
+ s1 = real(arg3+m1s+m4s,ki)
+ s2 = real(arg4+m1s+m2s,ki)
+ s3 = real(arg5+m2s+m3s,ki)
+ s4 = real(arg6+m3s+m4s,ki)
+ !
+ call cut_s(s1,m1s,m4s)
+ call cut_s(s2,m1s,m2s)
+ call cut_s(s3,m2s,m3s)
+ call cut_s(s4,m3s,m4s)
+ !
+ ssz(1) = equal_real(s1,zero)
+ ssz(2) = equal_real(s2,zero)
+ ssz(3) = equal_real(s3,zero)
+ ssz(4) = equal_real(s4,zero)
+ !
+ !
+ s12 = arg1+m4s+m2s
+ s23 = arg2+m1s+m3s
+ !
+ call cut_s(s12,m4s,m2s)
+ call cut_s(s23,m1s,m3s)
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ par4 = 0
+ !
+ temp(:) = 0._ki
+ !
+ meqs(:,:) = .false.
+ !
+ avh_olo_div = .false.
+ !
+ number_complex_masses: select case (nb_cm)
+ !
+ case (0)
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In f4p_sca_c call with zero complex masses!'
+ call catch_exception(0)
+ !
+ case (1) ! cases with one complex mass! only the following cases need to be considered!
+ !
+ if ( msc(1) ) then
+ !
+ meqs(2,3) = equal_real(real(m2s,ki),s3)
+ meqs(4,4) = equal_real(real(m4s,ki),s4)
+ !
+ else if ( msc(2) ) then
+ !
+ meqs(1,1) = equal_real(real(m1s,ki),s1)
+ meqs(3,4) = equal_real(real(m3s,ki),s4)
+ !
+ else if (msc(3) ) then
+ !
+ meqs(2,2) = equal_real(real(m2s,ki),s2)
+ meqs(4,1) = equal_real(real(m4s,ki),s1)
+ !
+ else if ( msc(4) ) then
+ !
+ meqs(1,2) = equal_real(real(m1s,ki),s2)
+ meqs(3,3) = equal_real(real(m3s,ki),s3)
+ !
+ end if
+ !
+ ! ************************************************
+ ! The following Integrals are not implemented
+ ! for complex masses yet. A call to avh_olo is
+ ! made instead!
+ !
+ ! *********** case QCDLoop box 8 *****************
+ !
+ ! limits s3,s4->0 are harmless, so do not require s3,s4 to be nonzero
+ !
+ if ( (msz(1)) .and. (msz(2)) .and. .not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and. (ssz(2)) ) then
+ !
+ avh_olo_div = .true.
+ !temp = f4p_ql8("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ ! permute the massive internal line
+ !
+ else if ( (msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and. (ssz(3)) ) then
+ !
+ avh_olo_div = .true.
+ !temp = f4p_ql8("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and. (ssz(4)) ) then
+ !
+ avh_olo_div = .true.
+ !temp = f4p_ql8("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and. (ssz(1)) ) then
+ !
+ avh_olo_div = .true.
+ !temp = f4p_ql8("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ !
+ ! *********** case QCDLoop box 10 *****************
+ !
+ ! note that limits s3,s4->0 are harmless, so do not require s3,s4 to be nonzero
+ !
+ else if ( (msz(1)) .and.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and..not.(ssz(2)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! !
+ ! temp = f4p_ql10("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ ! !
+ !
+ ! permute the massive internal line
+ !
+ else if ( (msz(2)) .and.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and..not.(ssz(3)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! !
+ ! temp = f4p_ql10("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ ! !
+ !
+ else if ( (msz(3)) .and.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and..not.(ssz(4)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! !
+ ! temp = f4p_ql10("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ ! !
+ !
+ else if ( (msz(4)) .and.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and..not.(ssz(1)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! !
+ ! temp = f4p_ql10("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ ! !
+ !
+ ! *********** case QCDLoop box 10b *****************
+ !~ m2^2 nonzero instead of m3^2 (in golem labelling) is also possible!
+ !
+ else if ( (msz(1)) .and..not.(msz(2)) .and.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and..not.(ssz(4)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! !
+ ! temp = f4p_ql10("n",s1,s4,s3,s2,s23,s12,m1s,m3s,m2s,m4s,0,0,0,0,mu2_scale_par)
+ ! !
+ !
+ ! permute the massive internal line (permu1)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and..not.(ssz(1)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! !
+ ! temp = f4p_ql10("n",s2,s1,s4,s3,s12,s23,m2s,m4s,m3s,m1s,0,0,0,0,mu2_scale_par)
+ ! !
+ !
+ ! permute the massive internal line (permu2)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and..not.(ssz(2)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! !
+ ! temp = f4p_ql10("n",s3,s2,s1,s4,s23,s12,m3s,m1s,m4s,m2s,0,0,0,0,mu2_scale_par)
+ ! !
+ !
+ ! permute the massive internal line (permu3)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and..not.(ssz(3)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! !
+ ! temp = f4p_ql10("n",s4,s3,s2,s1,s12,s23,m4s,m2s,m1s,m3s,0,0,0,0,mu2_scale_par)
+ ! !
+ !
+ !
+ ! *********** case QCDLoop box 12 *****************
+ !
+ ! limit p3^2 -> 0 is finite, taken care of in function_4p_ql12.f90
+ ! limit p4^2 -> 0 is harmless, so do not restrict s4 to nonzero value
+ !
+ else if ( (msz(1)) .and..not.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) .and.(meqs(2,2)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql12("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) .and.(meqs(3,3)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql12("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) .and.(meqs(4,4)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql12("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) .and.(meqs(1,1)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql12("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ ! *********** case QCDLoop box 13 *****************
+ !
+ ! limit p3^2 -> 0 is finite, taken care of in function_4p_ql13.f90
+ ! limits p4^2,p2^2 -> 0 are harmless, so do not restrict s4,s2 to nonzero value
+ !
+ else if ( (msz(1)) .and..not.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql13("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql13("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql13("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql13("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ !
+ ! *********** case QCDLoop box 16 *****************
+ !
+ ! note that limits s2->0 and s3->0 are nonsingular, so do not require s2,s3 not=0
+ !
+ else if ( .not.(msz(1)) .and..not.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (meqs(1,1)) &
+ & .and.(meqs(3,4)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql16("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(2)) .and..not.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (meqs(2,2)) &
+ & .and.(meqs(4,1)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql16("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(3)) .and..not.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (meqs(3,3)) &
+ & .and.(meqs(1,2)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql16("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( .not.(msz(4)) .and..not.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (meqs(4,4)) &
+ & .and.(meqs(2,3)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql16("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ end if
+ !
+ case (2) ! only one divergent box integral in this case!
+ ! ! no meqs required!
+ !
+ ! *********** case QCDLoop box 13 *****************
+ !
+ ! limit p3^2 -> 0 is finite, taken care of in function_4p_ql13.f90
+ ! limits p4^2,p2^2 -> 0 are harmless, so do not restrict s4,s2 to nonzero value
+ !
+ if ( (msz(1)) .and..not.(msz(2)) .and..not.(msz(3)) &
+ & .and.(msz(4)) .and. (ssz(1)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql13("n",s1,s2,s3,s4,s12,s23,m1s,m2s,m3s,m4s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(2)) .and..not.(msz(3)) .and..not.(msz(4)) &
+ & .and.(msz(1)) .and. (ssz(2)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql13("n",s2,s3,s4,s1,s23,s12,m2s,m3s,m4s,m1s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(3)) .and..not.(msz(4)) .and..not.(msz(1)) &
+ & .and.(msz(2)) .and. (ssz(3)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql13("n",s3,s4,s1,s2,s12,s23,m3s,m4s,m1s,m2s,0,0,0,0,mu2_scale_par)
+ !
+ else if ( (msz(4)) .and..not.(msz(1)) .and..not.(msz(2)) &
+ & .and.(msz(3)) .and. (ssz(4)) ) then
+ !
+ avh_olo_div = .true.
+ !
+ ! temp = f4p_ql13("n",s4,s1,s2,s3,s23,s12,m4s,m1s,m2s,m3s,0,0,0,0,mu2_scale_par)
+ !
+ end if
+ !
+ case default
+ !
+ avh_olo_div = .false.
+ !
+ end select number_complex_masses
+ !
+ ! changed to include LT option Jan2011
+ ! use avh_olo or LT in finite case
+@case_with_lt@ if (withlt.and..not.avh_olo_div) then
+ !
+@case_with_lt@ D0res = D0C(real(s1,ki_lt),real(s2,ki_lt),real(s3,ki_lt),real(s4,ki_lt),&
+@case_with_lt@ & real(s12,ki_lt),real(s23,ki_lt),m4s,m1s,m2s,m3s)
+ !
+@case_with_lt@ temp(5)= real(D0res,ki)
+@case_with_lt@ temp(6)= aimag(D0res)
+ !
+@case_with_lt@ else
+ ! use avh_olo
+ !
+ if (.not. olo) then
+! call avh_olo_onshell(100._ki*epsilon(1._ki))
+ call avh_olo_onshell(1.e-10_ki)
+ call avh_olo_mu_set(sqrt(mu2_scale_par))
+ olo=.true.
+ end if
+ !
+ cp1 = cmplx(s1,0._ki_avh,ki_avh)
+ cp2 = cmplx(s2,0._ki_avh,ki_avh)
+ cp3 = cmplx(s3,0._ki_avh,ki_avh)
+ cp4 = cmplx(s4,0._ki_avh,ki_avh)
+ cp12 = cmplx(s12,0._ki_avh,ki_avh)
+ cp23 = cmplx(s23,0._ki_avh,ki_avh)
+ !
+ cm1 = cmplx(m1s,kind=ki_avh)
+ cm2 = cmplx(m2s,kind=ki_avh)
+ cm3 = cmplx(m3s,kind=ki_avh)
+ cm4 = cmplx(m4s,kind=ki_avh)
+ !
+ call olo_d0(D0olo,cp1,cp2,cp3,cp4,cp12,cp23,cm4,cm1,cm2,cm3)
+ !
+ !
+ if (avh_olo_div) then
+ !
+ temp(1) = real(D0olo(2),ki)
+ temp(2) = aimag(D0olo(2) )
+ temp(3) = real(D0olo(1),ki)
+ temp(4) = aimag(D0olo(1) )
+ temp(5) = real(D0olo(0),ki)
+ temp(6) = aimag(D0olo(0) )
+ !
+ else
+ !
+ D0res = D0olo(0)
+ !
+ temp(5)= real(D0res,ki)
+ temp(6)= aimag(D0res)
+ !
+ !
+ !
+ end if ! ends if (avh_olo_div)
+@case_with_lt@ end if ! When using LT, this ends if (withlt.and..not.avh_olo_div)
+
+ !
+ f4p_sca_c = real(temp,ki)
+ !
+ end function f4p_sca_c
+ !
+ !~********************************************************************
+ !
+ !
+end module generic_function_4p
+
diff --git a/golem95c-1.2.1/integrals/one_point/Makefile.am b/golem95c-1.2.1/integrals/one_point/Makefile.am
new file mode 100644
index 0000000..756b69c
--- /dev/null
+++ b/golem95c-1.2.1/integrals/one_point/Makefile.am
@@ -0,0 +1,14 @@
+noinst_LTLIBRARIES=libgolem95_integrals_one_point.la
+
+libgolem95_integrals_one_point_la_SOURCES= generic_function_1p.f90
+libgolem95_integrals_one_point_la_FCFLAGS=\
+ -I$(builddir)/../../module \
+ -I$(builddir)/../../kinematic \
+ -I$(builddir)/../../numerical \
+ -I$(builddir)/../../../avh_olo-2.2.1
+
+
+nodist_pkginclude_HEADERS= generic_function_1p.mod
+CLEANFILES=*.mod
+
+include Makefile.dep
diff --git a/golem95c-1.2.1/integrals/one_point/Makefile.dep b/golem95c-1.2.1/integrals/one_point/Makefile.dep
new file mode 100644
index 0000000..5746dc2
--- /dev/null
+++ b/golem95c-1.2.1/integrals/one_point/Makefile.dep
@@ -0,0 +1 @@
+# Module dependencies
diff --git a/golem95c-1.2.1/integrals/one_point/Makefile.in b/golem95c-1.2.1/integrals/one_point/Makefile.in
new file mode 100644
index 0000000..a5f0826
--- /dev/null
+++ b/golem95c-1.2.1/integrals/one_point/Makefile.in
@@ -0,0 +1,555 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.dep \
+ $(srcdir)/Makefile.in
+subdir = golem95c-1.2.1/integrals/one_point
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+LTLIBRARIES = $(noinst_LTLIBRARIES)
+libgolem95_integrals_one_point_la_LIBADD =
+am_libgolem95_integrals_one_point_la_OBJECTS = \
+ libgolem95_integrals_one_point_la-generic_function_1p.lo
+libgolem95_integrals_one_point_la_OBJECTS = \
+ $(am_libgolem95_integrals_one_point_la_OBJECTS)
+libgolem95_integrals_one_point_la_LINK = $(LIBTOOL) --tag=FC \
+ $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(FCLD) \
+ $(libgolem95_integrals_one_point_la_FCFLAGS) $(FCFLAGS) \
+ $(AM_LDFLAGS) $(LDFLAGS) -o $@
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem95_integrals_one_point_la_SOURCES)
+DIST_SOURCES = $(libgolem95_integrals_one_point_la_SOURCES)
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgincludedir)"
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+noinst_LTLIBRARIES = libgolem95_integrals_one_point.la
+libgolem95_integrals_one_point_la_SOURCES = generic_function_1p.f90
+libgolem95_integrals_one_point_la_FCFLAGS = \
+ -I$(builddir)/../../module \
+ -I$(builddir)/../../kinematic \
+ -I$(builddir)/../../numerical \
+ -I$(builddir)/../../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS = generic_function_1p.mod
+CLEANFILES = *.mod
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/one_point/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/one_point/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+
+clean-noinstLTLIBRARIES:
+ -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+ @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem95_integrals_one_point.la: $(libgolem95_integrals_one_point_la_OBJECTS) $(libgolem95_integrals_one_point_la_DEPENDENCIES)
+ $(libgolem95_integrals_one_point_la_LINK) $(libgolem95_integrals_one_point_la_OBJECTS) $(libgolem95_integrals_one_point_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+libgolem95_integrals_one_point_la-generic_function_1p.lo: generic_function_1p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_one_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_one_point_la-generic_function_1p.lo $(FCFLAGS_f90) `test -f 'generic_function_1p.f90' || echo '$(srcdir)/'`generic_function_1p.f90
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libtool clean-noinstLTLIBRARIES ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/integrals/one_point/generic_function_1p.f90 b/golem95c-1.2.1/integrals/one_point/generic_function_1p.f90
new file mode 100644
index 0000000..5c877dd
--- /dev/null
+++ b/golem95c-1.2.1/integrals/one_point/generic_function_1p.f90
@@ -0,0 +1,234 @@
+!****h* src/integrals/two_point/generic_function_1p
+! NAME
+!
+! Module generic_function_1p
+!
+! USAGE
+!
+! use generic_function_1p
+!
+! DESCRIPTION
+!
+! This module contains the generic routines to compute
+! one point functions in n dimensions
+!
+! OUTPUT
+!
+! It exports one public routine:
+! * f1p -- a function to compute the one point function in n dimensions
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * array (src/module/array.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * parametre (src/module/parametre.f90)
+! * s_matrix_type (src/module/s_matrix_type.f90)
+! * equal (src/module/equal.f90)
+!
+!*****
+module generic_function_1p
+ !
+ use precision_golem
+ use array
+ use logarithme
+ use constante, only:czero, zero
+ use sortie_erreur
+ use parametre
+ use s_matrix_type
+ use equal
+ !
+ implicit none
+ !
+ private
+ !
+ interface f1p
+ !
+ module procedure f1p_r, f1p_c
+ module procedure f1p_p
+ !
+ end interface
+
+ public :: f1p
+ !
+contains
+ !
+ !****f* src/integrals/one_point/generic_function_1p/f1p
+ ! NAME
+ !
+ ! Function f1p
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f1p(s_mat_p,b_pro,parf1)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic two point function in n dimensions,
+ ! with or without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat_(r/c/p) -- a real/complex (type ki)/type(s_matrix_poly) array of rank 2, the S matrix
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ ! * parf1 -- an integer (optional), the label of the one Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ function f1p_p(s_mat_p,b_pro,parf1)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent(in) :: b_pro
+ integer, intent(in), optional :: parf1
+ complex(ki), dimension(2) :: f1p_p
+ !
+ if (iand(s_mat_p%b_cmplx, b_pro) .eq. 0 ) then
+ !
+ f1p_p = f1p_r(s_mat_p%pt_real, b_pro, parf1=parf1)
+ !
+ else
+ !
+ f1p_p = f1p_c(s_mat_p%pt_cmplx, b_pro, parf1=parf1)
+ !
+ end if
+ !
+ end function f1p_p
+ !
+ function f1p_r(s_mat_r,b_pro,parf1)
+ !
+ real(ki), intent (in), dimension(:,:) :: s_mat_r
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: parf1
+ complex(ki), dimension(2) :: f1p_r
+ !
+ integer :: par1
+ real(ki) :: mass1
+ integer :: m1
+ integer, dimension(1) :: s
+ !
+ if (present(parf1)) then
+ par1 = parf1
+ else
+ par1 = 0
+ end if
+ !
+ if (par1 /= 0) par1 = locateb(par1, b_pro)
+ !
+ if (par1 == -1) then
+ !
+ f1p_r(:) = czero
+ !
+ else
+ !
+ s = unpackb(b_pro,countb(b_pro))
+ !
+ m1 = s(1)
+ !
+ mass1 = -s_mat_r(m1,m1)/2._ki
+ !
+ if ( equal_real(mass1,zero) ) then
+ !
+ f1p_r(:) = czero
+ !
+ else
+ !
+ if (par1 == 0) then
+ !
+ f1p_r(1) = cmplx(mass1,0._ki,ki)
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f1p_r(2) = mass1*(1._ki - z_log(mass1/mu2_scale_par,-1._ki) )
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f1p_r(2) = cmplx(mass1,0._ki,ki)
+ !
+ end if
+ !
+ else if (par1 /= 0) then
+ !
+ f1p_r(:) = czero
+ !
+ end if
+ !
+ end if
+ !
+ end if
+ !
+ end function f1p_r
+ !
+ function f1p_c(s_mat_c,b_pro,parf1)
+ !
+ complex(ki), intent (in), dimension(:,:) :: s_mat_c
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: parf1
+ complex(ki), dimension(2) :: f1p_c
+ !
+ integer :: par1
+ complex(ki) :: mass1
+ integer :: m1
+ integer, dimension(1) :: s
+ !
+ if (present(parf1)) then
+ par1 = parf1
+ else
+ par1 = 0
+ end if
+ !
+ if (par1 /= 0) par1 = locateb(par1, b_pro)
+ !
+ if (par1 == -1) then
+ !
+ f1p_c(:) = czero
+ !
+ else
+ !
+ s = unpackb(b_pro,countb(b_pro))
+ !
+ m1 = s(1)
+ !
+ mass1 = -s_mat_c(m1,m1)/2._ki
+ !
+ ! This function is only called with non_vanishing mass1
+ !
+ if (par1 == 0) then
+ !
+ f1p_c(1) = mass1
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f1p_c(2) = mass1*(1._ki - z_log(mass1/mu2_scale_par,-1._ki) )
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f1p_c(2) = mass1
+ !
+ end if
+ !
+ else if (par1 /= 0) then
+ !
+ f1p_c(:) = czero
+ !
+ end if
+ !
+ end if
+ !
+ end function f1p_c
+ !
+end module generic_function_1p
diff --git a/golem95c-1.2.1/integrals/three_point/Makefile.am b/golem95c-1.2.1/integrals/three_point/Makefile.am
new file mode 100644
index 0000000..5729774
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/Makefile.am
@@ -0,0 +1,24 @@
+noinst_LTLIBRARIES=libgolem95_integrals_three_point.la
+
+libgolem95_integrals_three_point_la_SOURCES= \
+ mod_gn.f90 mod_h0.f90 mod_he.f90 mod_hf.f90 \
+ function_3p0m_1mi.f90 function_3p1m_1mi.f90 function_3p1m_2mi.f90 \
+ function_3p1m.f90 function_3p2m_1mi.f90 function_3p2m.f90 \
+ function_3p3m.f90 function_3p_finite.f90 \
+ generic_function_3p.f90
+libgolem95_integrals_three_point_la_FCFLAGS=\
+ -I$(builddir)/../../module \
+ -I$(builddir)/../../kinematic \
+ -I$(builddir)/../../numerical \
+ -I$(builddir)/../one_point \
+ -I$(builddir)/../two_point \
+ -I$(builddir)/../../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS= function_3p3m.mod generic_function_3p.mod \
+ function_3p1m_2mi.mod func_h0.mod func_he.mod \
+ function_3p2m_1mi.mod func_hf.mod function_3p_finite.mod \
+ func_gn.mod function_3p0m_1mi.mod function_3p1m_1mi.mod \
+ function_3p2m.mod function_3p1m.mod
+CLEANFILES=*.mod
+
+include Makefile.dep
diff --git a/golem95c-1.2.1/integrals/three_point/Makefile.dep b/golem95c-1.2.1/integrals/three_point/Makefile.dep
new file mode 100644
index 0000000..ffe9a73
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/Makefile.dep
@@ -0,0 +1,25 @@
+# Module dependencies
+function_3p1m.o: mod_h0.o
+function_3p1m.lo: mod_h0.lo
+function_3p1m.obj: mod_h0.obj
+function_3p1m_1mi.o: mod_he.o
+function_3p1m_1mi.lo: mod_he.lo
+function_3p1m_1mi.obj: mod_he.obj
+function_3p1m_2mi.o: mod_gn.o
+function_3p1m_2mi.lo: mod_gn.lo
+function_3p1m_2mi.obj: mod_gn.obj
+function_3p2m.o: mod_h0.o mod_he.o mod_hf.o
+function_3p2m.lo: mod_h0.lo mod_he.lo mod_hf.lo
+function_3p2m.obj: mod_h0.obj mod_he.obj mod_hf.obj
+function_3p2m_1mi.o: mod_he.o mod_hf.o
+function_3p2m_1mi.lo: mod_he.lo mod_hf.lo
+function_3p2m_1mi.obj: mod_he.obj mod_hf.obj
+generic_function_3p.o: function_3p0m_1mi.o function_3p1m.o function_3p1m_1mi.o \
+ function_3p1m_2mi.o function_3p2m.o function_3p2m_1mi.o \
+ function_3p3m.o function_3p_finite.o
+generic_function_3p.lo: function_3p0m_1mi.lo function_3p1m.lo \
+ function_3p1m_1mi.lo function_3p1m_2mi.lo function_3p2m.lo \
+ function_3p2m_1mi.lo function_3p3m.lo function_3p_finite.lo
+generic_function_3p.obj: function_3p0m_1mi.obj function_3p1m.obj \
+ function_3p1m_1mi.obj function_3p1m_2mi.obj function_3p2m.obj \
+ function_3p2m_1mi.obj function_3p3m.obj function_3p_finite.obj
diff --git a/golem95c-1.2.1/integrals/three_point/Makefile.in b/golem95c-1.2.1/integrals/three_point/Makefile.in
new file mode 100644
index 0000000..582dce7
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/Makefile.in
@@ -0,0 +1,640 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.dep \
+ $(srcdir)/Makefile.in
+subdir = golem95c-1.2.1/integrals/three_point
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+LTLIBRARIES = $(noinst_LTLIBRARIES)
+libgolem95_integrals_three_point_la_LIBADD =
+am_libgolem95_integrals_three_point_la_OBJECTS = \
+ libgolem95_integrals_three_point_la-mod_gn.lo \
+ libgolem95_integrals_three_point_la-mod_h0.lo \
+ libgolem95_integrals_three_point_la-mod_he.lo \
+ libgolem95_integrals_three_point_la-mod_hf.lo \
+ libgolem95_integrals_three_point_la-function_3p0m_1mi.lo \
+ libgolem95_integrals_three_point_la-function_3p1m_1mi.lo \
+ libgolem95_integrals_three_point_la-function_3p1m_2mi.lo \
+ libgolem95_integrals_three_point_la-function_3p1m.lo \
+ libgolem95_integrals_three_point_la-function_3p2m_1mi.lo \
+ libgolem95_integrals_three_point_la-function_3p2m.lo \
+ libgolem95_integrals_three_point_la-function_3p3m.lo \
+ libgolem95_integrals_three_point_la-function_3p_finite.lo \
+ libgolem95_integrals_three_point_la-generic_function_3p.lo
+libgolem95_integrals_three_point_la_OBJECTS = \
+ $(am_libgolem95_integrals_three_point_la_OBJECTS)
+libgolem95_integrals_three_point_la_LINK = $(LIBTOOL) --tag=FC \
+ $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(FCLD) \
+ $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) \
+ $(AM_LDFLAGS) $(LDFLAGS) -o $@
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem95_integrals_three_point_la_SOURCES)
+DIST_SOURCES = $(libgolem95_integrals_three_point_la_SOURCES)
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgincludedir)"
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+noinst_LTLIBRARIES = libgolem95_integrals_three_point.la
+libgolem95_integrals_three_point_la_SOURCES = \
+ mod_gn.f90 mod_h0.f90 mod_he.f90 mod_hf.f90 \
+ function_3p0m_1mi.f90 function_3p1m_1mi.f90 function_3p1m_2mi.f90 \
+ function_3p1m.f90 function_3p2m_1mi.f90 function_3p2m.f90 \
+ function_3p3m.f90 function_3p_finite.f90 \
+ generic_function_3p.f90
+
+libgolem95_integrals_three_point_la_FCFLAGS = \
+ -I$(builddir)/../../module \
+ -I$(builddir)/../../kinematic \
+ -I$(builddir)/../../numerical \
+ -I$(builddir)/../one_point \
+ -I$(builddir)/../two_point \
+ -I$(builddir)/../../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS = function_3p3m.mod generic_function_3p.mod \
+ function_3p1m_2mi.mod func_h0.mod func_he.mod \
+ function_3p2m_1mi.mod func_hf.mod function_3p_finite.mod \
+ func_gn.mod function_3p0m_1mi.mod function_3p1m_1mi.mod \
+ function_3p2m.mod function_3p1m.mod
+
+CLEANFILES = *.mod
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/three_point/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/three_point/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+
+clean-noinstLTLIBRARIES:
+ -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+ @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem95_integrals_three_point.la: $(libgolem95_integrals_three_point_la_OBJECTS) $(libgolem95_integrals_three_point_la_DEPENDENCIES)
+ $(libgolem95_integrals_three_point_la_LINK) $(libgolem95_integrals_three_point_la_OBJECTS) $(libgolem95_integrals_three_point_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+libgolem95_integrals_three_point_la-mod_gn.lo: mod_gn.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-mod_gn.lo $(FCFLAGS_f90) `test -f 'mod_gn.f90' || echo '$(srcdir)/'`mod_gn.f90
+
+libgolem95_integrals_three_point_la-mod_h0.lo: mod_h0.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-mod_h0.lo $(FCFLAGS_f90) `test -f 'mod_h0.f90' || echo '$(srcdir)/'`mod_h0.f90
+
+libgolem95_integrals_three_point_la-mod_he.lo: mod_he.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-mod_he.lo $(FCFLAGS_f90) `test -f 'mod_he.f90' || echo '$(srcdir)/'`mod_he.f90
+
+libgolem95_integrals_three_point_la-mod_hf.lo: mod_hf.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-mod_hf.lo $(FCFLAGS_f90) `test -f 'mod_hf.f90' || echo '$(srcdir)/'`mod_hf.f90
+
+libgolem95_integrals_three_point_la-function_3p0m_1mi.lo: function_3p0m_1mi.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-function_3p0m_1mi.lo $(FCFLAGS_f90) `test -f 'function_3p0m_1mi.f90' || echo '$(srcdir)/'`function_3p0m_1mi.f90
+
+libgolem95_integrals_three_point_la-function_3p1m_1mi.lo: function_3p1m_1mi.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-function_3p1m_1mi.lo $(FCFLAGS_f90) `test -f 'function_3p1m_1mi.f90' || echo '$(srcdir)/'`function_3p1m_1mi.f90
+
+libgolem95_integrals_three_point_la-function_3p1m_2mi.lo: function_3p1m_2mi.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-function_3p1m_2mi.lo $(FCFLAGS_f90) `test -f 'function_3p1m_2mi.f90' || echo '$(srcdir)/'`function_3p1m_2mi.f90
+
+libgolem95_integrals_three_point_la-function_3p1m.lo: function_3p1m.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-function_3p1m.lo $(FCFLAGS_f90) `test -f 'function_3p1m.f90' || echo '$(srcdir)/'`function_3p1m.f90
+
+libgolem95_integrals_three_point_la-function_3p2m_1mi.lo: function_3p2m_1mi.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-function_3p2m_1mi.lo $(FCFLAGS_f90) `test -f 'function_3p2m_1mi.f90' || echo '$(srcdir)/'`function_3p2m_1mi.f90
+
+libgolem95_integrals_three_point_la-function_3p2m.lo: function_3p2m.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-function_3p2m.lo $(FCFLAGS_f90) `test -f 'function_3p2m.f90' || echo '$(srcdir)/'`function_3p2m.f90
+
+libgolem95_integrals_three_point_la-function_3p3m.lo: function_3p3m.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-function_3p3m.lo $(FCFLAGS_f90) `test -f 'function_3p3m.f90' || echo '$(srcdir)/'`function_3p3m.f90
+
+libgolem95_integrals_three_point_la-function_3p_finite.lo: function_3p_finite.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-function_3p_finite.lo $(FCFLAGS_f90) `test -f 'function_3p_finite.f90' || echo '$(srcdir)/'`function_3p_finite.f90
+
+libgolem95_integrals_three_point_la-generic_function_3p.lo: generic_function_3p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_three_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_three_point_la-generic_function_3p.lo $(FCFLAGS_f90) `test -f 'generic_function_3p.f90' || echo '$(srcdir)/'`generic_function_3p.f90
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libtool clean-noinstLTLIBRARIES ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+function_3p1m.o: mod_h0.o
+function_3p1m.lo: mod_h0.lo
+function_3p1m.obj: mod_h0.obj
+function_3p1m_1mi.o: mod_he.o
+function_3p1m_1mi.lo: mod_he.lo
+function_3p1m_1mi.obj: mod_he.obj
+function_3p1m_2mi.o: mod_gn.o
+function_3p1m_2mi.lo: mod_gn.lo
+function_3p1m_2mi.obj: mod_gn.obj
+function_3p2m.o: mod_h0.o mod_he.o mod_hf.o
+function_3p2m.lo: mod_h0.lo mod_he.lo mod_hf.lo
+function_3p2m.obj: mod_h0.obj mod_he.obj mod_hf.obj
+function_3p2m_1mi.o: mod_he.o mod_hf.o
+function_3p2m_1mi.lo: mod_he.lo mod_hf.lo
+function_3p2m_1mi.obj: mod_he.obj mod_hf.obj
+generic_function_3p.o: function_3p0m_1mi.o function_3p1m.o function_3p1m_1mi.o \
+ function_3p1m_2mi.o function_3p2m.o function_3p2m_1mi.o \
+ function_3p3m.o function_3p_finite.o
+generic_function_3p.lo: function_3p0m_1mi.lo function_3p1m.lo \
+ function_3p1m_1mi.lo function_3p1m_2mi.lo function_3p2m.lo \
+ function_3p2m_1mi.lo function_3p3m.lo function_3p_finite.lo
+generic_function_3p.obj: function_3p0m_1mi.obj function_3p1m.obj \
+ function_3p1m_1mi.obj function_3p1m_2mi.obj function_3p2m.obj \
+ function_3p2m_1mi.obj function_3p3m.obj function_3p_finite.obj
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/integrals/three_point/function_3p0m_1mi.f90 b/golem95c-1.2.1/integrals/three_point/function_3p0m_1mi.f90
new file mode 100644
index 0000000..f0432ac
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/function_3p0m_1mi.f90
@@ -0,0 +1,622 @@
+!
+!****h* src/integral/three_point/function_3p0m_1mi
+! NAME
+!
+! Module function_3p0m_1mi
+!
+! USAGE
+!
+! use function_3p0m_1mi
+!
+! DESCRIPTION
+!
+! This module is used to compute the zero off-shell external leg one internal mass three point function
+! with/without Feynman parameters in n, n+2 dimensions
+!
+! OUTPUT
+!
+! This module exports two functions:
+! * f3p0m_1mi -- a function for the computation of the zero off-shell external leg one internal mass three
+! point function with/without Feynman parameters in n dimensions
+! * f3p0m_1mi_np2 -- a function for the computation of the zero off-shell external leg one internal mass three
+! point function with/without Feynman parameters in n+2 dimensions
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * logarithme (src/module/z_log.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90) only : tab_erreur_par,catch_exception
+! * parametre (src/module/parametre.f90) only : rat_or_tot_par,mu2_scale_par
+! * array (src/module/array.f90) only : packb
+!
+!*****
+module function_3p0m_1mi
+ !
+ use precision_golem
+ use logarithme
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only : rat_or_tot_par,mu2_scale_par
+ use array, only : packb
+ implicit none
+ !
+ private
+ !
+ public :: f3p0m_1mi, f3p0m_1mi_np2
+ !
+ contains
+ !
+ !
+ !****f* src/integral/three_point/function_3p0m_1mi/f3p0m_1mi
+ ! NAME
+ !
+ ! Function f3p0m_1mi
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f3p0m_1mi(m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the zero off-shell external leg one internal mass three point function in n dimensions
+ ! with up to three Feynman parameters in the numerator.
+ ! It returns an array of 6 reals corresponding to the real/imaginary
+ ! part of the coefficient of the 1/epsilon^2 term, real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * m3_sq -- real (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 6 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon^2 term,
+ ! real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f3p0m_1mi(m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(6) :: f3p0m_1mi
+ !
+ complex(ki) :: c_temp_d2,c_temp_d2_rat
+ complex(ki) :: c_temp_d1,c_temp_d1_rat
+ complex(ki) :: c_temp,c_temp_rat
+ real(ki) :: lmu2
+ !
+ f3p0m_1mi = 0._ki
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/2._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/2._ki/m3_sq
+ !
+ c_temp=(1._ki+1._ki/2._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=1._ki/m3_sq
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ if (par3 == 1) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/2._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/2._ki/m3_sq
+ !
+ c_temp=1._ki/2._ki*z_log(m3_sq,-1._ki)/m3_sq
+ !
+ c_temp_rat=0._ki
+ !
+ else if (par3 == 2) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/2._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/2._ki/m3_sq
+ !
+ c_temp=1._ki/2._ki*z_log(m3_sq,-1._ki)/m3_sq
+ !
+ c_temp_rat=0._ki
+ !
+ else if (par3 == 3) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=-1._ki/2._ki/m3_sq
+ !
+ c_temp_d1_rat=-1._ki/2._ki/m3_sq
+ !
+ c_temp=(1._ki-1._ki/2._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=1._ki/m3_sq
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p0m_1mi:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Unimplemented combination of parameters.'
+ tab_erreur_par(3)%chaine = 'par1 = %d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ else if ( (par1==0) ) then
+ !
+ if ( (par2 == 1) .and. (par3 == 1) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/2._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/2._ki/m3_sq
+ !
+ c_temp=(-1._ki/2._ki+1._ki/2._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=-1._ki/2._ki/m3_sq
+ !
+ else if ( (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/2._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/2._ki/m3_sq
+ !
+ c_temp=(-1._ki/2._ki+1._ki/2._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=-1._ki/2._ki/m3_sq
+ !
+ else if ( (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=-1._ki/2._ki/m3_sq
+ !
+ c_temp_rat=-1._ki/2._ki/m3_sq
+ !
+ else if ( (par2 == 1) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/4._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/4._ki/m3_sq
+ !
+ c_temp=(-1._ki/4._ki+1._ki/4._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=-1._ki/4._ki/m3_sq
+ !
+ else if ( (par2 == 1) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=-1._ki/4._ki/m3_sq
+ !
+ c_temp_d1_rat=-1._ki/4._ki/m3_sq
+ !
+ c_temp=(3._ki/4._ki-1._ki/4._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=3._ki/4._ki/m3_sq
+ !
+ else if ( (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=-1._ki/4._ki/m3_sq
+ !
+ c_temp_d1_rat=-1._ki/4._ki/m3_sq
+ !
+ c_temp=(3._ki/4._ki-1._ki/4._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=3._ki/4._ki/m3_sq
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p0m_1mi:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Unimplemented combination of parameters.'
+ tab_erreur_par(3)%chaine = 'par1 = %d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ else
+ !
+ if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 1) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/2._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/2._ki/m3_sq
+ !
+ c_temp=(-5._ki/6._ki+1._ki/2._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=-5._ki/6._ki/m3_sq
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/2._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/2._ki/m3_sq
+ !
+ c_temp=(-5._ki/6._ki+1._ki/2._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=-5._ki/6._ki/m3_sq
+ !
+ else if ( (par1 == 3) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=-1._ki/6._ki/m3_sq
+ !
+ c_temp_rat=-1._ki/6._ki/m3_sq
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/6._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/6._ki/m3_sq
+ !
+ c_temp=(-5._ki/18._ki+1._ki/6._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=-5._ki/18._ki/m3_sq
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/6._ki/m3_sq
+ !
+ c_temp_d1_rat=1._ki/6._ki/m3_sq
+ !
+ c_temp=(-5._ki/18._ki+1._ki/6._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=-5._ki/18._ki/m3_sq
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=-1._ki/6._ki/m3_sq
+ !
+ c_temp_d1_rat=-1._ki/6._ki/m3_sq
+ !
+ c_temp=(11._ki/18._ki-1._ki/6._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=11._ki/18._ki/m3_sq
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=-1._ki/6._ki/m3_sq
+ !
+ c_temp_d1_rat=-1._ki/6._ki/m3_sq
+ !
+ c_temp=(11._ki/18._ki-1._ki/6._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=11._ki/18._ki/m3_sq
+ !
+ else if ( (par1 == 1) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=-1._ki/6._ki/m3_sq
+ !
+ c_temp_rat=-1._ki/6._ki/m3_sq
+ !
+ else if ( (par1 == 2) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=-1._ki/6._ki/m3_sq
+ !
+ c_temp_rat=-1._ki/6._ki/m3_sq
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=-1._ki/12._ki/m3_sq
+ !
+ c_temp_d1_rat=-1._ki/12._ki/m3_sq
+ !
+ c_temp=(11._ki/36._ki-1._ki/12._ki*z_log(m3_sq,-1._ki))/m3_sq
+ !
+ c_temp_rat=11._ki/36._ki/m3_sq
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p0m_1mi:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Unimplemented combination of parameters.'
+ tab_erreur_par(3)%chaine = 'par1 = %d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ !
+ end if
+ !
+ end if
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ f3p0m_1mi(1:2) = (/real(c_temp_d2,ki),aimag(c_temp_d2)/)
+ f3p0m_1mi(3:4) = (/real(c_temp_d1,ki),aimag(c_temp_d1)/)
+ f3p0m_1mi(5:6) = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ f3p0m_1mi(1:2) = (/real(c_temp_d2_rat,ki),aimag(c_temp_d2_rat)/)
+ f3p0m_1mi(3:4) = (/real(c_temp_d1_rat,ki),aimag(c_temp_d1_rat)/)
+ f3p0m_1mi(5:6) = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ ! On change \epsilon_{ir} en -\epsilon_{uv}
+ !
+ f3p0m_1mi(3:4) = -f3p0m_1mi(3:4)
+ !
+ ! on ajoute la dependence en mu^2
+ !
+ lmu2 = log(mu2_scale_par)
+ f3p0m_1mi(5:6) = f3p0m_1mi(5:6) + f3p0m_1mi(3:4)*lmu2 + f3p0m_1mi(1:2)*lmu2**2/2._ki
+ f3p0m_1mi(3:4) = f3p0m_1mi(3:4) + f3p0m_1mi(1:2)*lmu2
+ !
+ end function f3p0m_1mi
+ !
+ !
+ !****f* src/integral/three_point/function_3p0m_1mi/f3p0m_1mi_np2
+ ! NAME
+ !
+ ! Function f3p0m_1mi_np2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f3p0m_1mi_np2(m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the zero off-shell external leg one internal mass three point function in n+2 dimensions.
+ ! with up to one Feynman parameter in the numerator.
+ ! It retuns an array of 4 reals corresponding to the real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * m3_sq -- real (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter = 0
+ ! * par2 -- an integer, the label of the second Feynman parameter = 0
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 4 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term. If par1 and/or par2
+ ! are different from zero, an error is returned.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f3p0m_1mi_np2(m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p0m_1mi_np2
+ !
+ complex(ki) :: c_temp,c_temp_rat
+ real(ki) :: lmu2
+ !
+ f3p0m_1mi_np2 = 0._ki
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ f3p0m_1mi_np2(1) = -1._ki/2._ki
+ f3p0m_1mi_np2(2) = 0._ki
+ !
+ c_temp=-3._ki/2._ki+1._ki/2._ki*z_log(m3_sq,-1._ki)
+ !
+ c_temp_rat=-3._ki/2._ki
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ f3p0m_1mi_np2(3:4) = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ f3p0m_1mi_np2(3:4) = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f3p0m_1mi_np2(1) = -1._ki/6._ki
+ f3p0m_1mi_np2(2) = 0._ki
+ !
+ if (par3 == 1) then !changed: 11.08.10
+ !
+ c_temp=-11._ki/18._ki+1._ki/6._ki*z_log(m3_sq,-1._ki)
+ !
+ c_temp_rat=-11._ki/18._ki
+ !
+ else if (par3 == 2) then !changed: 11.08.10
+ !
+ c_temp=-11._ki/18._ki+1._ki/6._ki*z_log(m3_sq,-1._ki)
+ !
+ c_temp_rat=-11._ki/18._ki
+ !
+ else if (par3 == 3) then
+ !
+ c_temp=-5._ki/18._ki+1._ki/6._ki*z_log(m3_sq,-1._ki)
+ !
+ c_temp_rat=-5._ki/18._ki
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p0m_1mi_np2:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Unimplemented combination of parameters.'
+ tab_erreur_par(3)%chaine = 'par1 = %d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ !
+ end if
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ f3p0m_1mi_np2(3:4) = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ f3p0m_1mi_np2(3:4) = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p0m_1mi_np2:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of 3-point integrals in 6 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb((/par1,par2,par3/)),4/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ ! on ajoute la dependence en mu^2
+ !
+ lmu2 = log(mu2_scale_par)
+ f3p0m_1mi_np2(3:4) = f3p0m_1mi_np2(3:4) + f3p0m_1mi_np2(1:2)*lmu2
+ !
+ end function f3p0m_1mi_np2
+ !
+end module function_3p0m_1mi
diff --git a/golem95c-1.2.1/integrals/three_point/function_3p1m.f90 b/golem95c-1.2.1/integrals/three_point/function_3p1m.f90
new file mode 100644
index 0000000..8819978
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/function_3p1m.f90
@@ -0,0 +1,319 @@
+!
+!****h* src/integral/three_point/function_3p1m
+! NAME
+!
+! Module function_3p1m
+!
+! USAGE
+!
+! use function_3p1m
+!
+! DESCRIPTION
+!
+! This module is used to compute the one off-shell external leg three point function
+! with no internal mass with/without Feynman parameters in n, n+2 dimensions
+!
+! OUTPUT
+!
+! This module exports two functions:
+! * f3p1m -- a function for the computation of the one off-shell external three
+! point function with/without Feynman parameters in n dimensions
+! * f3p1m_np2 -- a function for the computation of the one off-shell external three
+! point function with/without Feynman parameters in n+2 dimensions
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * logarithme (src/module/z_log.f90)
+! * func_h0 (src/integrals/three_point/mod_h0.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+!
+!*****
+module function_3p1m
+ !
+ use precision_golem
+ use logarithme
+ use func_h0
+ use sortie_erreur
+ implicit none
+ !
+ private
+ !
+ public :: f3p1m, f3p1m_np2
+ !
+ contains
+ !
+ !****f* src/integral/three_point/function_3p1m/f3p1m
+ ! NAME
+ !
+ ! Function f3p1m
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f3p1m(s13,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the one off-shell external three point function in n dimensions
+ ! with up to three Feynman parameters in the numerator.
+ ! It retuns an array of 6 reals corresponding to the real/imaginary
+ ! part of the coefficient of the 1/epsilon^2 term, real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s13 -- real (type ki), the value of the S matrix element corresponding to the external off-shell leg
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 6 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon^2 term,
+ ! real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ ! one mass three point function without Feynman parameters
+ ! f3p1m(s13,0,0,0)
+ ! with one Feynman parameter at the numerator z_1
+ ! f3p1m(s13,0,0,1)
+ ! with three Feynman parameters at the numerator z_2^2 z_3
+ ! f3p1m(s13,2,2,3)
+ !
+ !*****
+ function f3p1m(s13,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s13
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(6) :: f3p1m
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ f3p1m(1:2) = h0d(s13)
+ f3p1m(3:4) = h0e(s13)
+ f3p1m(5:6) = h0f(s13)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ if ( (par3 == 1) .or. (par3 == 3) ) then
+ !
+ f3p1m(1:2) = 0._ki
+ f3p1m(3:4) = h0d(s13)
+ f3p1m(5:6) = h0e(s13)-2._ki*h0d(s13)
+ !
+ else if (par3 == 2) then
+ !
+ f3p1m(1:2) = h0d(s13)
+ f3p1m(3:4) = h0e(s13)-2._ki*h0d(s13)
+ f3p1m(5:6) = h0f(s13)-2._ki*h0e(s13)+4._ki*h0d(s13)
+ !
+ end if
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ else if ( par1 == 0 ) then
+ !
+ if ( ((par2 == 1) .and. (par3 == 1)) .or. &
+ ((par2 == 3) .and. (par3 == 3)) &
+ ) then
+ !
+ f3p1m(1:2) = 0._ki
+ f3p1m(3:4) = h0d(s13)/2._ki
+ f3p1m(5:6) = h0e(s13)/2._ki-h0d(s13)
+ !
+ else if ( (par2 == 2) .and. (par3 == 2) ) then
+ !
+ f3p1m(1:2) = h0d(s13)
+ f3p1m(3:4) = h0e(s13)-3._ki*h0d(s13)
+ f3p1m(5:6) = h0f(s13)-3._ki*h0e(s13)+7._ki*h0d(s13)
+ !
+ else if ( ((par2 == 1) .and. (par3 == 2)) .or. &
+ ((par2 == 2) .and. (par3 == 3)) &
+ ) then
+ !
+ f3p1m(1:2) = 0._ki
+ f3p1m(3:4) = h0d(s13)/2._ki
+ f3p1m(5:6) = h0e(s13)/2._ki-3._ki/2._ki*h0d(s13)
+ !
+ else if ( (par2 == 1) .and. (par3 == 3) ) then
+ !
+ f3p1m(1:2) = 0._ki
+ f3p1m(3:4) = 0._ki
+ f3p1m(5:6) = h0d(s13)/2._ki
+ !
+ end if
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ else
+ !
+ if ( ((par1 == 1) .and. (par2 == 1) .and. (par3 == 1)) .or. &
+ ((par1 == 3) .and. (par2 == 3) .and. (par3 == 3)) &
+ ) then
+ !
+ f3p1m(1:2) = 0._ki
+ f3p1m(3:4) = h0d(s13)/3._ki
+ f3p1m(5:6) = h0e(s13)/3._ki-13._ki/18._ki*h0d(s13)
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ f3p1m(1:2) = h0d(s13)
+ f3p1m(3:4) = h0e(s13)-11._ki/3._ki*h0d(s13)
+ f3p1m(5:6) = h0f(s13)-11._ki/3._ki*h0e(s13)+85._ki/9._ki*h0d(s13)
+ !
+ else if ( ((par1 == 1) .and. (par2 == 1) .and. (par3 == 2)) .or. &
+ ((par1 == 2) .and. (par2 == 3) .and. (par3 == 3)) &
+ ) then
+ !
+ f3p1m(1:2) = 0._ki
+ f3p1m(3:4) = h0d(s13)/6._ki
+ f3p1m(5:6) = h0e(s13)/6._ki-4._ki/9._ki*h0d(s13)
+ !
+ else if ( ((par1 == 1) .and. (par2 == 2) .and. (par3 == 2)) .or. &
+ ((par1 == 2) .and. (par2 == 2) .and. (par3 == 3)) &
+ ) then
+ !
+ f3p1m(1:2) = 0._ki
+ f3p1m(3:4) = h0d(s13)/3._ki
+ f3p1m(5:6) = h0e(s13)/3._ki-11._ki/9._ki*h0d(s13)
+ !
+ else if ( ((par1 == 1) .and. (par2 == 1) .and. (par3 == 3)) .or. &
+ ((par1 == 1) .and. (par2 == 3) .and. (par3 == 3)) &
+ ) then
+ !
+ f3p1m(1:2) = 0._ki
+ f3p1m(3:4) = 0._ki
+ f3p1m(5:6) = h0d(s13)/6._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ f3p1m(1:2) = 0._ki
+ f3p1m(3:4) = 0._ki
+ f3p1m(5:6) = h0d(s13)/6._ki
+ !
+ end if
+ !
+ end if
+ !
+ ! On change \epsilon_{ir} en -\epsilon_{uv}
+ !
+ f3p1m(3:4) = -f3p1m(3:4)
+ !
+ end function f3p1m
+ !
+ !****f* src/integral/three_point/function_3p1m/f3p1m_np2
+ ! NAME
+ !
+ ! Function f3p1m_np2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f3p1m_np2(s13,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the one off-shell external three point function in n+2 dimensions.
+ ! with up to one Feynman parameter in the numerator.
+ ! It retuns an array of 4 reals corresponding to the real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s13 -- real (type ki), the value of the S matrix element corresponding to the external off-shell leg
+ ! * par1 -- an integer, the label of the third Feynman parameter = 0
+ ! * par2 -- an integer, the label of the second Feynman parameter = 0
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 4 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term. If par1 and/or par2
+ ! are different from zero, an error is returned.
+ !
+ ! EXAMPLE
+ !
+ ! one mass three point function without Feynman parameters
+ ! f3p1m_np2(s13,0,0,0)
+ ! with one Feynman parameter at the numerator z_1
+ ! f3p1m_np2(s13,0,0,1)
+ !
+ !*****
+ function f3p1m_np2(s13,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s13
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p1m_np2
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ f3p1m_np2(1) = -1._ki/2._ki
+ f3p1m_np2(2) = 0._ki
+ f3p1m_np2(3:4) = 1._ki/2._ki*h0e(s13)*s13
+ f3p1m_np2(3) = f3p1m_np2(3) - 3._ki/2._ki
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f3p1m_np2(1) = -1._ki/6._ki
+ f3p1m_np2(2) = 0._ki
+ !
+ if ( (par3 == 1) .or. (par3 == 3) ) then
+ !
+ f3p1m_np2(3:4) = 1._ki/6._ki*h0e(s13)*s13
+ f3p1m_np2(3) = f3p1m_np2(3) - 4._ki/9._ki
+ !
+ else if (par3 == 2) then
+ !
+ f3p1m_np2(3:4) = 1._ki/6._ki*h0e(s13)*s13
+ f3p1m_np2(3) = f3p1m_np2(3) - 11._ki/18._ki
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'error in function f3p1m_np2'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of two mass six dimensional 3-point function &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'Feynman param 1: %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(4)%a_imprimer = .true.
+ tab_erreur_par(4)%chaine = 'Feynman param 2: %d1'
+ tab_erreur_par(4)%arg_int = par2
+ tab_erreur_par(5)%a_imprimer = .true.
+ tab_erreur_par(5)%chaine = 'Feynman param 3: %d1'
+ tab_erreur_par(5)%arg_int = par3
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function f3p1m_np2
+ !
+end module function_3p1m
diff --git a/golem95c-1.2.1/integrals/three_point/function_3p1m_1mi.f90 b/golem95c-1.2.1/integrals/three_point/function_3p1m_1mi.f90
new file mode 100644
index 0000000..9c31865
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/function_3p1m_1mi.f90
@@ -0,0 +1,653 @@
+!
+!****h* src/integral/three_point/function_3p1m_1mi
+! NAME
+!
+! Module function_3p1m_1mi
+!
+! USAGE
+!
+! use function_3p1m_1mi
+!
+! DESCRIPTION
+!
+! This module is used to compute the one off-shell external leg one internal mass three point function
+! with/without Feynman parameters in n, n+2 dimensions
+!
+! OUTPUT
+!
+! This module exports two functions:
+! * f3p1m_1mi -- a function for the computation of the one off-shell external leg one internal mass three
+! point function with/without Feynman parameters in n dimensions
+! * f3p1m_1mi_np2 -- a function for the computation of the one off-shell external leg one internal mass three
+! point function with/without Feynman parameters in n+2 dimensions
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * logarithme (src/module/z_log.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * func_he (src/integrals/three_point/mod_he.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90) only : tab_erreur_par,catch_exception
+! * constante (src/module/constante.f90) only : un,pi6
+! * parametre (src/module/parametre.f90) only : rat_or_tot_par,mu2_scale_par
+! * array (src/module/array.f90) only : packb
+!
+!*****
+module function_3p1m_1mi
+ !
+ use precision_golem
+ use logarithme
+ use dilogarithme
+ use func_he
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use constante, only : un,pi6
+ use parametre, only : rat_or_tot_par,mu2_scale_par
+ use array, only : packb
+ implicit none
+ !
+ private
+ !
+ public :: f3p1m_1mi, f3p1m_1mi_np2
+ !
+ contains
+ !
+ !
+ !****f* src/integral/three_point/function_3p1m_1mi/f3p1m_1mi
+ ! NAME
+ !
+ ! Function f3p1m_1mi
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f3p1m_1mi(s13,m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the one off-shell external leg one internal mass three point function in n dimensions
+ ! with up to three Feynman parameters in the numerator.
+ ! It retuns an array of 6 reals corresponding to the real/imaginary
+ ! part of the coefficient of the 1/epsilon^2 term, real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s13 -- real (type ki), the value of the S matrix element corresponding to the external off-shell leg
+ ! * m3_sq -- real (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 6 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon^2 term,
+ ! real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f3p1m_1mi(s13,m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(6) :: f3p1m_1mi
+ !
+ complex(ki) :: c_temp_d2,c_temp_d2_rat
+ complex(ki) :: c_temp_d1,c_temp_d1_rat
+ complex(ki) :: c_temp,c_temp_rat
+ real(ki) :: lmu2
+ !
+ f3p1m_1mi = 0._ki
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ c_temp_d2=1._ki/2._ki/s13
+ !
+ c_temp_d2_rat=1._ki/2._ki/s13
+ !
+ c_temp_d1=z_log(-s13,-1._ki)/s13-1._ki/2._ki*z_log(m3_sq,-1._ki)/&
+ &s13
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=-zdilog((m3_sq+s13)/s13,-1._ki)/s13+1._ki/2._ki*z_log2(-s1&
+ &3,-1._ki)/s13-1._ki/4._ki*z_log2(m3_sq,-1._ki)/s13
+ !
+ c_temp_rat=0._ki
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ if (par3 == 1) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/s13
+ !
+ c_temp_d1_rat=1._ki/s13
+ !
+ c_temp=(he_c(1,s13,-m3_sq)*s13-2._ki+z_log(m3_sq,-1._ki)+2._ki*he&
+ &_c(1,s13,-m3_sq)*m3_sq)/s13
+ !
+ c_temp_rat=-2._ki/s13
+ !
+ else if (par3 == 2) then
+ !
+ c_temp_d2=1._ki/2._ki/s13
+ !
+ c_temp_d2_rat=1._ki/2._ki/s13
+ !
+ c_temp_d1=z_log(-s13,-1._ki)/s13-1._ki/s13-1._ki/2._ki*z_log(m3_s&
+ &q,-1._ki)/s13
+ !
+ c_temp_d1_rat=-1._ki/s13
+ !
+ c_temp=-1._ki/4._ki*(4._ki*zdilog((m3_sq+s13)/s13,-1._ki)-2._ki*z&
+ &_log2(-s13,-1._ki)+8._ki*z_log(-s13,-1._ki)+z_log2(m3_sq,-1._ki&
+ &)-8._ki-4._ki*z_log(m3_sq,-1._ki))/s13
+ !
+ c_temp_rat=2._ki/s13
+ !
+ else if (par3 == 3) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=he_c(1,s13,-m3_sq)
+ !
+ c_temp_rat=0._ki
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p1m_1mi:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Unimplemented combination of parameters.'
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ else if ( (par1==0) ) then
+ !
+ if ( (par2 == 1) .and. (par3 == 1) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/2._ki/s13
+ !
+ c_temp_d1_rat=1._ki/2._ki/s13
+ !
+ c_temp=1._ki/2._ki*(he_c(2,s13,-m3_sq)*s13**2-s13+2._ki*he_c(2,s1&
+ &3,-m3_sq)*m3_sq*s13-3._ki*m3_sq+2._ki*he_c(2,s13,-m3_sq)*m3_sq*&
+ &*2+z_log(m3_sq,-1._ki)*m3_sq)/s13/m3_sq
+ !
+ c_temp_rat=-1._ki/2._ki*(2._ki*s13+m3_sq)/(s13+m3_sq)/s13
+ !
+ else if ( (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=1._ki/2._ki/s13
+ !
+ c_temp_d2_rat=1._ki/2._ki/s13
+ !
+ c_temp_d1=z_log(-s13,-1._ki)/s13-3._ki/2._ki/s13-1._ki/2._ki*z_lo&
+ &g(m3_sq,-1._ki)/s13
+ !
+ c_temp_d1_rat=-3._ki/2._ki/s13
+ !
+ c_temp=-1._ki/4._ki*(4._ki*zdilog((s13+m3_sq)/s13,-1._ki)-2._ki*z&
+ &_log2(-s13,-1._ki)+12._ki*z_log(-s13,-1._ki)-6._ki*z_log(m3_sq,&
+ &-1._ki)-14._ki+z_log2(m3_sq,-1._ki))/s13
+ !
+ c_temp_rat=7._ki/2._ki/s13
+ !
+ else if ( (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=1._ki/2._ki*(he_c(2,s13,-m3_sq)*s13-1._ki)/m3_sq
+ !
+ c_temp_rat=-1._ki/2._ki/(s13+m3_sq)
+ !
+ else if ( (par2 == 1) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/2._ki/s13
+ !
+ c_temp_d1_rat=1._ki/2._ki/s13
+ !
+ c_temp=1._ki/2._ki*(he_c(1,s13,-m3_sq)*s13-3._ki+z_log(m3_sq,-1._&
+ &ki)+2._ki*he_c(1,s13,-m3_sq)*m3_sq)/s13
+ !
+ c_temp_rat=-3._ki/2._ki/s13
+ !
+ else if ( (par2 == 1) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=1._ki/2._ki*he_c(2,s13,-m3_sq)
+ !
+ c_temp_rat=1._ki/2._ki/(s13+m3_sq)
+ !
+ else if ( (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=1._ki/2._ki*he_c(1,s13,-m3_sq)
+ !
+ c_temp_rat=0._ki
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p1m_1mi:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Unimplemented combination of parameters.'
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ else
+ !
+ if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 1) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/3._ki/s13
+ !
+ c_temp_d1_rat=1._ki/3._ki/s13
+ !
+ c_temp=1._ki/18._ki*(6._ki*he_c(3,s13,-m3_sq)*s13**3-3._ki*s13**2&
+ &+18._ki*he_c(3,s13,-m3_sq)*m3_sq*s13**2+18._ki*he_c(3,s13,-m3_s&
+ &q)*m3_sq**2*s13-12._ki*m3_sq*s13+12._ki*he_c(3,s13,-m3_sq)*m3_s&
+ &q**3+6._ki*z_log(m3_sq,-1._ki)*m3_sq**2-22._ki*m3_sq**2)/s13/m3&
+ &_sq**2
+ !
+ c_temp_rat=-1._ki/18._ki/m3_sq*(6._ki*s13**2+25._ki*m3_sq*s13+16.&
+ &_ki*m3_sq**2)/(s13+m3_sq)/s13
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=1._ki/2._ki/s13
+ !
+ c_temp_d2_rat=1._ki/2._ki/s13
+ !
+ c_temp_d1=z_log(-s13,-1._ki)/s13-11._ki/6._ki/s13-1._ki/2._ki*z_l&
+ &og(m3_sq,-1._ki)/s13
+ !
+ c_temp_d1_rat=-11._ki/6._ki/s13
+ !
+ c_temp=1._ki/36._ki*(-36._ki*zdilog((s13+m3_sq)/s13,-1._ki)+18._k&
+ &i*z_log2(-s13,-1._ki)-132._ki*z_log(-s13,-1._ki)+66._ki*z_log(m&
+ &3_sq,-1._ki)+170._ki-9._ki*z_log2(m3_sq,-1._ki))/s13
+ !
+ c_temp_rat=85._ki/18._ki/s13
+ !
+ else if ( (par1 == 3) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=1._ki/6._ki*(2._ki*he_c(3,s13,-m3_sq)*s13**2-s13-m3_sq)/m3&
+ &_sq**2
+ !
+ c_temp_rat=-1._ki/6._ki/m3_sq*(2._ki*s13+m3_sq)/(s13+m3_sq)
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/6._ki/s13
+ !
+ c_temp_d1_rat=1._ki/6._ki/s13
+ !
+ c_temp=1._ki/18._ki*(3._ki*he_c(2,s13,-m3_sq)*s13**2-3._ki*s13+6.&
+ &_ki*he_c(2,s13,-m3_sq)*m3_sq*s13-11._ki*m3_sq+6._ki*he_c(2,s13,&
+ &-m3_sq)*m3_sq**2+3._ki*z_log(m3_sq,-1._ki)*m3_sq)/m3_sq/s13
+ !
+ c_temp_rat=-1._ki/18._ki*(8._ki*s13+5._ki*m3_sq)/s13/(s13+m3_sq)
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=1._ki/3._ki/s13
+ !
+ c_temp_d1_rat=1._ki/3._ki/s13
+ !
+ c_temp=1._ki/9._ki*(3._ki*he_c(1,s13,-m3_sq)*s13-11._ki+3._ki*z_l&
+ &og(m3_sq,-1._ki)+6._ki*he_c(1,s13,-m3_sq)*m3_sq)/s13
+ !
+ c_temp_rat=-11._ki/9._ki/s13
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=1._ki/3._ki*he_c(3,s13,-m3_sq)
+ !
+ c_temp_rat=1._ki/6._ki/(s13+m3_sq)
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=1._ki/3._ki*he_c(1,s13,-m3_sq)
+ !
+ c_temp_rat=0._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=1._ki/6._ki*(2._ki*he_c(3,s13,-m3_sq)*s13-1)/m3_sq
+ !
+ c_temp_rat=-1._ki/6._ki/(s13+m3_sq)
+ !
+ else if ( (par1 == 2) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=1._ki/6._ki*(he_c(2,s13,-m3_sq)*s13-1)/m3_sq
+ !
+ c_temp_rat=-1._ki/6._ki/(s13+m3_sq)
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp_d2=0._ki
+ !
+ c_temp_d2_rat=0._ki
+ !
+ c_temp_d1=0._ki
+ !
+ c_temp_d1_rat=0._ki
+ !
+ c_temp=1._ki/6._ki*he_c(2,s13,-m3_sq)
+ !
+ c_temp_rat=1._ki/6._ki/(s13+m3_sq)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p1m_1mi:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Unimplemented combination of parameters.'
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ end if
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ f3p1m_1mi(1:2) = (/real(c_temp_d2,ki),aimag(c_temp_d2)/)
+ f3p1m_1mi(3:4) = (/real(c_temp_d1,ki),aimag(c_temp_d1)/)
+ f3p1m_1mi(5:6) = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ f3p1m_1mi(1:2) = (/real(c_temp_d2_rat,ki),aimag(c_temp_d2_rat)/)
+ f3p1m_1mi(3:4) = (/real(c_temp_d1_rat,ki),aimag(c_temp_d1_rat)/)
+ f3p1m_1mi(5:6) = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ ! On change \epsilon_{ir} en -\epsilon_{uv}
+ !
+ f3p1m_1mi(3:4) = -f3p1m_1mi(3:4)
+ !
+ ! On factorise r_{\gamma}
+ !
+ f3p1m_1mi(5:6) = f3p1m_1mi(5:6)+pi6*f3p1m_1mi(1:2)
+ !
+ ! on ajoute la dependence en mu^2
+ !
+ lmu2 = log(mu2_scale_par)
+ f3p1m_1mi(5:6) = f3p1m_1mi(5:6) + f3p1m_1mi(3:4)*lmu2 + f3p1m_1mi(1:2)*lmu2**2/2._ki
+ f3p1m_1mi(3:4) = f3p1m_1mi(3:4) + f3p1m_1mi(1:2)*lmu2
+ !
+ end function f3p1m_1mi
+ !
+ !
+ !****f* src/integral/three_point/function_3p1m_1mi/f3p1m_1mi_np2
+ ! NAME
+ !
+ ! Function f3p1m_1mi_np2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f3p1m_1mi_np2(s13,m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the one off-shell external leg one internal mass three point function in n+2 dimensions.
+ ! with up to one Feynman parameter in the numerator.
+ ! It retuns an array of 4 reals corresponding to the real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s13 -- real (type ki), the value of the S matrix element corresponding to the external off-shell leg
+ ! * m3_sq -- real (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter = 0
+ ! * par2 -- an integer, the label of the second Feynman parameter = 0
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 4 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term. If par1 and/or par2
+ ! are different from zero, an error is returned.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f3p1m_1mi_np2(s13,m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p1m_1mi_np2
+ !
+ complex(ki) :: c_temp,c_temp_rat
+ real(ki) :: lmu2
+ !
+ f3p1m_1mi_np2 = 0._ki
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ f3p1m_1mi_np2(1) = -1._ki/2._ki
+ f3p1m_1mi_np2(2) = 0._ki
+ !
+ c_temp=1._ki/2._ki*z_log(m3_sq,-1._ki)-3._ki/2._ki+1._ki/2._ki*he&
+ &_c(1,s13,-m3_sq)*s13
+ !
+ c_temp_rat=-3._ki/2._ki
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ f3p1m_1mi_np2(3:4) = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ f3p1m_1mi_np2(3:4) = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f3p1m_1mi_np2(1) = -1._ki/6._ki
+ f3p1m_1mi_np2(2) = 0._ki
+ !
+ if (par3 == 1) then
+ !
+ c_temp=1._ki/6._ki*z_log(m3_sq,-1._ki)-1._ki/18._ki*(3._ki*s13**2&
+ &*he_c(2,s13,-m3_sq)-6._ki*he_c(1,s13,-m3_sq)*s13*m3_sq-3._ki*s1&
+ &3+11._ki*m3_sq)/m3_sq
+ !
+ c_temp_rat=-1._ki/18._ki*(8._ki*s13+11._ki*m3_sq)/(s13+m3_sq)
+ !
+ else if (par3 == 2) then
+ !
+ c_temp=1._ki/6._ki*z_log(m3_sq,-1._ki)-11._ki/18._ki+1._ki/6._ki*&
+ &he_c(1,s13,-m3_sq)*s13
+ !
+ c_temp_rat=-11._ki/18._ki
+ !
+ else if (par3 == 3) then
+ !
+ c_temp=1._ki/6._ki*z_log(m3_sq,-1._ki)+1._ki/18._ki*(3._ki*s13**2&
+ &*he_c(2,s13,-m3_sq)-3._ki*s13-5._ki*m3_sq)/m3_sq
+ !
+ c_temp_rat=-1._ki/18._ki*(8._ki*s13+5._ki*m3_sq)/(s13+m3_sq)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p1m_1mi_np2:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Unimplemented combination of parameters.'
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ f3p1m_1mi_np2(3:4) = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ f3p1m_1mi_np2(3:4) = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p1m_1mi_np2:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of 3-point integrals in 6 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb((/par1,par2,par3/)),4/)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ ! on ajoute la dependence en mu^2
+ !
+ lmu2 = log(mu2_scale_par)
+ f3p1m_1mi_np2(3:4) = f3p1m_1mi_np2(3:4) + f3p1m_1mi_np2(1:2)*lmu2
+ !
+ end function f3p1m_1mi_np2
+ !
+end module function_3p1m_1mi
diff --git a/golem95c-1.2.1/integrals/three_point/function_3p1m_2mi.f90 b/golem95c-1.2.1/integrals/three_point/function_3p1m_2mi.f90
new file mode 100644
index 0000000..21852f7
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/function_3p1m_2mi.f90
@@ -0,0 +1,365 @@
+!
+!****h* src/integral/three_point/function_3p1m_2mi
+! NAME
+!
+! Module function_3p1m_2mi
+!
+! USAGE
+!
+! use function_3p1m_2mi
+!
+! DESCRIPTION
+!
+! This module is used to compute the one off-shell external leg two internal mass three point function
+! with/without Feynman parameters in n, n+2 dimensions
+!
+! OUTPUT
+!
+! This module exports two functions:
+! * f3p1m_2mi -- a function for the computation of the one off-shell external leg two internal mass three
+! point function with/without Feynman parameters in n dimensions
+! * f3p1m_2mi_np2 -- a function for the computation of the one off-shell external leg two internal mass three
+! point function with/without Feynman parameters in n+2 dimensions
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * func_gn (src/integrals/three_point/mod_gn.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90) only : tab_erreur_par,catch_exception,origine_info_par,num_grand_b_info_par,denom_grand_b_info_par
+! * constante (src/module/constante.f90) only : un,i_,pi6
+! * parametre (src/module/parametre.f90) only : rat_or_tot_par,mu2_scale_par
+! * array (src/module/array.f90) only : packb
+!
+!*****
+module function_3p1m_2mi
+ !
+ use precision_golem
+ use func_gn
+ use sortie_erreur, only : tab_erreur_par,catch_exception,origine_info_par,num_grand_b_info_par,denom_grand_b_info_par
+ use constante, only : un,i_,pi6
+ use parametre, only : rat_or_tot_par,mu2_scale_par
+ use array, only : packb
+ implicit none
+ !
+ private
+ !
+ public :: f3p1m_2mi, f3p1m_2mi_np2
+ !
+ contains
+ !
+ !
+ !****f* src/integral/three_point/function_3p1m_2mi/f3p1m_2mi
+ ! NAME
+ !
+ ! Function f3p1m_2mi
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f3p1m_2mi(s13,m1_sq,m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the one off-shell external leg two internal mass three point function in n dimensions
+ ! with up to three Feynman parameters in the numerator.
+ ! It retuns an array of 6 reals corresponding to the real/imaginary
+ ! part of the coefficient of the 1/epsilon^2 term, real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s13 -- real (type ki), the value of the S matrix element corresponding to the external off-shell leg
+ ! * m1_sq -- real (type ki), the value of the first internal mass squared
+ ! * m3_sq -- real (type ki), the value of the second internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 6 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon^2 term,
+ ! real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f3p1m_2mi(s13,m1_sq,m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s13,m1_sq,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(6) :: f3p1m_2mi
+ !
+ real(ki) :: a,b,c
+ real(ki) :: lmu2
+ real(ki) :: true_thresh,false_thresh
+ logical :: dist
+ !
+ f3p1m_2mi = 0._ki
+ !
+ a = s13+m1_sq+m3_sq
+ b = ( m1_sq-m3_sq-(s13+m1_sq+m3_sq) )
+ c = m3_sq
+ ! one tests if we are closer from the real threshold or from the false threshold
+ true_thresh = (sqrt(m1_sq)+sqrt(m3_sq))**2
+ false_thresh = (sqrt(m1_sq)-sqrt(m3_sq))**2
+ dist = abs(a-true_thresh) <= abs(a-false_thresh)
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ f3p1m_2mi(3:4) = -0.5_ki*ge(1,a,b,c,dist)
+ f3p1m_2mi(5:6) = -0.5_ki*gf(1,a,b,c,dist)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ if (par3 == 1) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(2,a,b,c,dist)
+ !
+ else if (par3 == 2) then
+ !
+ f3p1m_2mi(3:4) = -0.5_ki*ge(1,a,b,c,dist)
+ f3p1m_2mi(5:6) = -0.5_ki*gf(1,a,b,c,dist)+ge(1,a,b,c,dist)
+ !
+ else if (par3 == 3) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(2,a,-b-2*a,a+b+c,dist)
+ !
+ end if
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ else if ( (par1==0) ) then
+ !
+ if ( (par2 == 1) .and. (par3 == 1) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(3,a,b,c,dist)/2._ki
+ !
+ else if ( (par2 == 2) .and. (par3 == 2) ) then
+ !
+ f3p1m_2mi(3:4) = -0.5_ki*ge(1,a,b,c,dist)
+ f3p1m_2mi(5:6) = -0.5_ki*gf(1,a,b,c,dist)+3._ki/2._ki*ge(1,a,b,c,dist)
+ !
+ else if ( (par2 == 3) .and. (par3 == 3) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(3,a,-b-2*a,a+b+c,dist)/2._ki
+ !
+ else if ( (par2 == 1) .and. (par3 == 2) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(2,a,b,c,dist)/2._ki
+ !
+ else if ( (par2 == 1) .and. (par3 == 3) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -(ge(2,a,b,c,dist)-ge(3,a,b,c,dist))/2._ki
+ !
+ else if ( (par2 == 2) .and. (par3 == 3) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(2,a,-b-2*a,a+b+c,dist)/2._ki
+ !
+ end if
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ else
+ !
+ if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 1) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(4,a,b,c,dist)/3._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ f3p1m_2mi(3:4) = -0.5_ki*ge(1,a,b,c,dist)
+ f3p1m_2mi(5:6) = -0.5_ki*gf(1,a,b,c,dist)+11._ki/6._ki*ge(1,a,b,c,dist)
+ !
+ else if ( (par1 == 3) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(4,a,-b-2*a,a+b+c,dist)/3._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 2) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(3,a,b,c,dist)/6._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(2,a,b,c,dist)/3._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 3) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -(ge(3,a,b,c,dist)-ge(4,a,b,c,dist))/3._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(2,a,-b-2*a,a+b+c,dist)/3._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -(ge(3,a,-b-2*a,a+b+c,dist)-ge(4,a,-b-2*a,a+b+c,dist))/3._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -ge(3,a,-b-2*a,a+b+c,dist)/6._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ f3p1m_2mi(3:4) = 0._ki
+ f3p1m_2mi(5:6) = -(ge(2,a,b,c,dist)-ge(3,a,b,c,dist))/6._ki
+ !
+ end if
+ !
+ end if
+ !
+ ! On change \epsilon_{ir} en -\epsilon_{uv}
+ !
+ f3p1m_2mi(3:4) = -f3p1m_2mi(3:4)
+ !
+ ! On factorise r_{\gamma}
+ !
+ f3p1m_2mi(5:6) = f3p1m_2mi(5:6)+pi6*f3p1m_2mi(1:2)
+ !
+ ! on ajoute la dependence en mu^2
+ !
+ lmu2 = log(mu2_scale_par)
+ f3p1m_2mi(5:6) = f3p1m_2mi(5:6) + f3p1m_2mi(3:4)*lmu2 + f3p1m_2mi(1:2)*lmu2**2/2._ki
+ f3p1m_2mi(3:4) = f3p1m_2mi(3:4) + f3p1m_2mi(1:2)*lmu2
+ !
+ end function f3p1m_2mi
+ !
+ !****f* src/integral/three_point/function_3p1m_2mi/f3p1m_2mi_np2
+ ! NAME
+ !
+ ! Function f3p1m_2mi_np2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f3p1m_2mi_np2(s13,m1_sq,m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the one off-shell external leg two internal mass three point function in n+2 dimensions.
+ ! with up to one Feynman parameter in the numerator.
+ ! It retuns an array of 4 reals corresponding to the real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s13 -- real (type ki), the value of the S matrix element corresponding to the external off-shell leg
+ ! * m1_sq -- real (type ki), the value of the first internal mass squared
+ ! * m3_sq -- real (type ki), the value of the second internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter = 0
+ ! * par2 -- an integer, the label of the second Feynman parameter = 0
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 4 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term. If par1 and/or par2
+ ! are different from zero, an error is returned.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function f3p1m_2mi_np2(s13,m1_sq,m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s13,m1_sq,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p1m_2mi_np2
+ !
+ real(ki) :: a,b,c
+ real(ki) :: lmu2
+ !
+ f3p1m_2mi_np2 = 0._ki
+ !
+ a = s13+m1_sq+m3_sq
+ b = ( m1_sq-m3_sq-(s13+m1_sq+m3_sq) )
+ c = m3_sq
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ f3p1m_2mi_np2(1) = -1._ki/2._ki
+ f3p1m_2mi_np2(2) = 0._ki
+ f3p1m_2mi_np2(3:4) = gl(1,a,b,c)/2._ki
+ f3p1m_2mi_np2(3) = f3p1m_2mi_np2(3)-2._ki/4._ki
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f3p1m_2mi_np2(1) = -1._ki/6._ki
+ f3p1m_2mi_np2(2) = 0._ki
+ !
+ if (par3 == 1) then
+ !
+ f3p1m_2mi_np2(3:4) = gl(2,a,b,c)/3._ki
+ f3p1m_2mi_np2(3) = f3p1m_2mi_np2(3)-1._ki/9._ki
+ !
+ else if (par3 == 2) then
+ !
+ f3p1m_2mi_np2(3:4) = gl(1,a,b,c)/6._ki
+ f3p1m_2mi_np2(3) = f3p1m_2mi_np2(3)-5._ki/18._ki
+ !
+ else if (par3 == 3) then
+ !
+ f3p1m_2mi_np2(3:4) = gl(2,a,-b-2*a,a+b+c)/3._ki
+ f3p1m_2mi_np2(3) = f3p1m_2mi_np2(3)-1._ki/9._ki
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p1m_2mi_np2:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of 3-point integrals in 6 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb((/par1,par2,par3/)),4/)
+ call catch_exception(0)
+ !
+ end if
+ !
+ ! on ajoute la dependence en mu^2
+ !
+ lmu2 = log(mu2_scale_par)
+ f3p1m_2mi_np2(3:4) = f3p1m_2mi_np2(3:4) + f3p1m_2mi_np2(1:2)*lmu2
+ !
+ end function f3p1m_2mi_np2
+ !
+end module function_3p1m_2mi
diff --git a/golem95c-1.2.1/integrals/three_point/function_3p2m.f90 b/golem95c-1.2.1/integrals/three_point/function_3p2m.f90
new file mode 100644
index 0000000..79ce28b
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/function_3p2m.f90
@@ -0,0 +1,335 @@
+!
+!****h* src/integral/three_point/function_3p2m
+! NAME
+!
+! Module function_3p2m
+!
+! USAGE
+!
+! use function_3p2m
+!
+! DESCRIPTION
+!
+! This module is used to compute the two off-shell external leg three point function
+! with no internal mass with/without Feynman parameters in n, n+2 dimensions
+!
+! OUTPUT
+!
+! This module exports two functions:
+! * f3p2m -- a function for the computation of the two off-shell external leg three
+! point function with/without Feynman parameters in n dimensions
+! * f3p2m_np2 -- a function for the computation of the two off-shell external leg three
+! point function with/without Feynman parameters in n+2 dimensions
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * logarithme (src/module/z_log.f90)
+! * func_h0 (src/integrals/three_point/mod_h0.f90)
+! * func_he (src/integrals/three_point/mod_he.f90)
+! * func_hf (src/integrals/three_point/mod_hf.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+!
+!*****
+module function_3p2m
+ !
+ use precision_golem
+ use logarithme
+ use func_h0
+ use func_he
+ use func_hf
+ use sortie_erreur
+ implicit none
+ !
+ private
+ !
+ public :: f3p2m, f3p2m_np2
+ !
+ contains
+ !
+ !
+ !****f* src/integral/three_point/function_3p2m/f3p2m
+ ! NAME
+ !
+ ! Function f3p2m
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f3p2m(s13,s23,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the two off-shell external leg three point function in n dimensions
+ ! with up to three Feynman parameters in the numerator.
+ ! It retuns an array of 6 reals corresponding to the real/imaginary
+ ! part of the coefficient of the 1/epsilon^2 term, real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s13 -- real (type ki), the value of the S matrix element corresponding to the first external off-shell leg
+ ! * s23 -- real (type ki), the value of the S matrix element corresponding to the second external off-shell leg
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 6 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon^2 term,
+ ! real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ ! two mass three point function without Feynman parameters
+ ! f3p2m(s13,s23,0,0,0)
+ ! with one Feynman parameter at the numerator z_1
+ ! f3p2m(s13,s23,0,0,1)
+ ! with three Feynman parameters at the numerator z_2^2 z_3
+ ! f3p2m(s13,s23,2,2,3)
+ !
+ !*****
+ function f3p2m(s23,s13,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s23,s13
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(6) :: f3p2m
+ !
+ f3p2m = 0._ki
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ f3p2m(3:4) = he(1,s13,s23)
+ f3p2m(5:6) = hf(1,s13,s23)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ if (par3 == 1) then
+ !
+ f3p2m(3:4) = he(2,s13,s23)
+ f3p2m(5:6) = hf(2,s13,s23)-f3p2m(3:4)
+ !
+ else if (par3 == 2) then
+ !
+ f3p2m(3:4) = he(2,s23,s13)
+ f3p2m(5:6) = hf(2,s23,s13)-f3p2m(3:4)
+ !
+ else if (par3 == 3) then
+ !
+ f3p2m(5:6) = he(1,s13,s23)
+ !
+ end if
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ else if ( (par1==0) ) then
+ !
+ if ( (par2 == 1) .and. (par3 == 1) ) then
+ !
+ f3p2m(3:4) = he(3,s13,s23)
+ f3p2m(5:6) = hf(3,s13,s23)-3._ki/2._ki*f3p2m(3:4)
+ !
+ else if ( (par2 == 2) .and. (par3 == 2) ) then
+ !
+ f3p2m(3:4) = he(3,s23,s13)
+ f3p2m(5:6) = hf(3,s23,s13)-3._ki/2._ki*f3p2m(3:4)
+ !
+ else if ( (par2 == 3) .and. (par3 == 3) ) then
+ !
+ f3p2m(5:6) = he(1,s13,s23)/2._ki
+ !
+ else if ( (par2 == 1) .and. (par3 == 2) ) then
+ !
+ f3p2m(3:4) = he(2,s13,s23)-he(3,s13,s23)
+ f3p2m(5:6) = hf(2,s13,s23)-hf(3,s13,s23)-3._ki/2._ki*f3p2m(3:4)
+ !
+ else if ( (par2 == 1) .and. (par3 == 3) ) then
+ !
+ f3p2m(5:6) = he(2,s13,s23)/2._ki
+ !
+ else if ( (par2 == 2) .and. (par3 == 3) ) then
+ !
+ f3p2m(5:6) = he(2,s23,s13)/2._ki
+ !
+ end if
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ else
+ !
+ if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 1) ) then
+ !
+ f3p2m(3:4) = he(4,s13,s23)
+ f3p2m(5:6) = hf(4,s13,s23)-11._ki/6._ki*f3p2m(3:4)
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ f3p2m(3:4) = he(4,s23,s13)
+ f3p2m(5:6) = hf(4,s23,s13)-11._ki/6._ki*f3p2m(3:4)
+ !
+ else if ( (par1 == 3) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ f3p2m(5:6) = he(1,s13,s23)/3._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 2) ) then
+ !
+ f3p2m(3:4) = he(3,s13,s23)-he(4,s13,s23)
+ f3p2m(5:6) = hf(3,s13,s23)-hf(4,s13,s23)-11._ki/6._ki*f3p2m(3:4)
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ f3p2m(3:4) = he(3,s23,s13)-he(4,s23,s13)
+ f3p2m(5:6) = hf(3,s23,s13)-hf(4,s23,s13)-11._ki/6._ki*f3p2m(3:4)
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 3) ) then
+ !
+ f3p2m(5:6) = he(3,s13,s23)/3._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ f3p2m(5:6) = he(3,s23,s13)/3._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ f3p2m(5:6) = he(2,s13,s23)/6._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ f3p2m(5:6) = he(2,s23,s13)/6._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ f3p2m(5:6) = he(2,s13,s23)/3._ki-he(3,s13,s23)/3._ki
+ !
+ end if
+ !
+ end if
+ !
+ ! On change \epsilon_{ir} en -\epsilon_{uv}
+ !
+ f3p2m(3:4) = -f3p2m(3:4)
+ !
+ end function f3p2m
+ !
+ !
+ !****f* src/integral/three_point/function_3p2m/f3p2m_np2
+ ! NAME
+ !
+ ! Function f3p2m_np2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f3p2m_np2(s13,s23,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the two off-shell external leg three point function in n+2 dimensions.
+ ! with up to one Feynman parameter in the numerator.
+ ! It retuns an array of 4 reals corresponding to the real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s13 -- real (type ki), the value of the S matrix element corresponding to the first external off-shell leg
+ ! * s23 -- real (type ki), the value of the S matrix element corresponding to the second external off-shell leg
+ ! * par1 -- an integer, the label of the third Feynman parameter = 0
+ ! * par2 -- an integer, the label of the second Feynman parameter = 0
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 4 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term. If par1 and/or par2
+ ! are different from zero, an error is returned.
+ !
+ ! EXAMPLE
+ !
+ ! two mass three point function without Feynman parameters
+ ! f3p2m_np2(s13,s23,0,0,0)
+ ! with one Feynman parameter at the numerator z_1
+ ! f3p2m_np2(s13,s23,0,0,1)
+ !
+ !*****
+ function f3p2m_np2(s23,s13,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s23,s13
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p2m_np2
+ !
+ f3p2m_np2 = 0._ki
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ f3p2m_np2(1) = -1._ki/2._ki
+ f3p2m_np2(2) = 0._ki
+ f3p2m_np2(3:4) = (s13*h0e(s13)+s23*he(1,s13,s23))/2._ki
+ f3p2m_np2(3) = f3p2m_np2(3)-3._ki/2._ki
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f3p2m_np2(1) = -1._ki/6._ki
+ f3p2m_np2(2) = 0._ki
+ !
+ if (par3 == 1) then
+ !
+ f3p2m_np2(3:4) = (s13*h0e(s13)+s23*he(2,s13,s23))/6._ki
+ !
+ else if (par3 == 2) then
+ !
+ f3p2m_np2(3:4) = (s23*h0e(s23)+s13*he(2,s23,s13))/6._ki
+ !
+ else if (par3 == 3) then
+ !
+ f3p2m_np2(3:4) = (s13*h0e(s13)+s23*he(1,s13,s23))/6._ki
+ !
+ end if
+ !
+ f3p2m_np2(3) = f3p2m_np2(3)-8._ki/18._ki
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'error in function f3p2m_np2'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of two mass six dimensional 3-point function &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'Feynman param 1: %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(4)%a_imprimer = .true.
+ tab_erreur_par(4)%chaine = 'Feynman param 2: %d1'
+ tab_erreur_par(4)%arg_int = par2
+ tab_erreur_par(5)%a_imprimer = .true.
+ tab_erreur_par(5)%chaine = 'Feynman param 3: %d1'
+ tab_erreur_par(5)%arg_int = par3
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function f3p2m_np2
+ !
+end module function_3p2m
diff --git a/golem95c-1.2.1/integrals/three_point/function_3p2m_1mi.f90 b/golem95c-1.2.1/integrals/three_point/function_3p2m_1mi.f90
new file mode 100644
index 0000000..1604b82
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/function_3p2m_1mi.f90
@@ -0,0 +1,2871 @@
+!
+!****h* src/integral/three_point/function_3p2m_1mi
+! NAME
+!
+! Module function_3p2m_1mi
+!
+! USAGE
+!
+! use function_3p2m_1mi
+!
+! DESCRIPTION
+!
+! This module is used to compute the two off-shell external leg one internal mass three point function
+! with/without Feynman parameters in n, n+2 dimensions
+!
+! OUTPUT
+!
+! This module exports two functions:
+! * f3p2m_1mi -- a function for the computation of the two off-shell external leg one internal mass three
+! point function with/without Feynman parameters in n dimensions
+! * f3p2m_1mi_np2 -- a function for the computation of the two off-shell external leg one internal mass three
+! point function with/without Feynman parameters in n+2 dimensions
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * logarithme (src/module/z_log.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * func_he (src/integrals/three_point/mod_he.f90)
+! * func_hf (src/integrals/three_point/mod_hf.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90) only : tab_erreur_par,catch_exception,origine_info_par,num_grand_b_info_par,denom_grand_b_info_par
+! * constante (src/module/constante.f90) only : i_,un
+! * parametre (src/module/parametre.f90) only : coupure_3p2m_1mi,rat_or_tot_par,tolerance,alpha_par,beta_par,lambda_par,mu2_scale_par
+! * array (src/module/array.f90) only : packb
+! * numerical_evaluation (src/numerical/mod_numeric.f90) only : generic_eval_numer
+!
+!*****
+module function_3p2m_1mi
+ !
+ use precision_golem
+ use logarithme
+ use dilogarithme
+ use func_he
+ use func_hf
+ use sortie_erreur, only : tab_erreur_par,catch_exception,origine_info_par,num_grand_b_info_par,denom_grand_b_info_par
+ use constante, only : i_, un, czero
+ use parametre, only : coupure_3p2m_1mi,rat_or_tot_par,tolerance,alpha_par,beta_par,lambda_par,mu2_scale_par
+ use array, only : packb
+ use numerical_evaluation, only : generic_eval_numer
+ implicit none
+ !
+ private
+ complex(ki) :: s13_glob,m3_sq_glob,s23_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob
+ character (len=3) :: dim_glob
+ integer, dimension(3) :: par
+ !
+ interface f3p2m_1mi
+ module procedure f3p2m_1mi_r
+ module procedure f3p2m_1mi_c
+ end interface
+ !
+ interface f3p2m_1mi_np2
+ module procedure f3p2m_1mi_np2_r
+ module procedure f3p2m_1mi_np2_c
+ end interface
+ !
+!
+ public :: f3p2m_1mi, f3p2m_1mi_np2
+ !
+ contains
+ !
+ !****f* src/integral/three_point/function_3p2m_1mi/f3p2m_1mi
+ ! NAME
+ !
+ ! Function f3p2m_1mi
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f3p2m_1mi(s23,s13,m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the two off-shell external leg one internal mass three point function in n dimensions
+ ! with up to three Feynman parameters in the numerator.
+ ! It retuns an array of 6 reals corresponding to the real/imaginary
+ ! part of the coefficient of the 1/epsilon^2 term, real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s23 -- real/complex (type ki), the value of the S matrix element corresponding to the first external off-shell leg
+ ! * s13 -- real/complex (type ki), the value of the S matrix element corresponding to the second external off-shell leg
+ ! * m3_sq -- real/complex (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 6 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon^2 term,
+ ! real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ !
+ function f3p2m_1mi_r(s23,s13,m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(6) :: f3p2m_1mi_r
+ !
+ real(ki) :: lamb
+ real(ki) :: plus_grand
+ complex(ki) :: resto,abserro
+ real(ki) :: as23,as13,am3_sq
+ !
+ !
+ ! on redefinit la matrice S de telle facon a ce que ces elements
+ ! soient entre -1 et 1
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ plus_grand = max(abs(s13),abs(s23),abs(m3_sq))
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ plus_grand = 1._ki
+ !
+ end if
+ !
+ as13 = s13/plus_grand
+ as23 = s23/plus_grand
+ am3_sq = m3_sq/plus_grand
+ !
+ lamb = as13-as23
+ !
+ f3p2m_1mi_r(:) = 0._ki
+ !
+ ! the correction for plus_grand are taken into account in he and hf
+ !
+ f3p2m_1mi_r = a3p2m_1mi_div_r(s23,s13,m3_sq,par1,par2,par3)
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_3p2m_1mi) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p2m_1mi (in file function_3p2m_1mi.f90):&
+ &the flag rat to compute the rational part is on &
+ &and the program reaches a region of phase space in &
+ &which det(G) = 0 . Be careful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_3p2m_1mi'
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ if (abs(lamb) > coupure_3p2m_1mi) then
+ !
+ ! analytic computation
+ !
+ f3p2m_1mi_r(5:6) = f3p2m_1mi_r(5:6) + a3p2m_1mi_r(as23,as13,am3_sq,par1,par2,par3)&
+ &/plus_grand
+ !
+ else
+ !
+ ! numerical computation
+ !
+ dim_glob = "ndi"
+ par1_glob = par1
+ par2_glob = par2
+ par3_glob = par3
+ !
+ s23_glob = cmplx(as23,0._ki,ki)
+ s13_glob = cmplx(as13,0._ki,ki)
+ m3_sq_glob = cmplx(am3_sq,0._ki,ki)
+ !
+ resto = 0._ki
+ abserro = 0._ki
+ !
+ ! on pose z = x - i*eps*y (avec x et y > 0)
+ ! z*s23+(1-z)*s23 = s23+x*(s23-s23)-i*eps*y*(s23-s23)
+ ! on veut la partie imaginaire du meme signe que i*lambda
+ ! => eps*(s23-s23) < 0
+ !
+ ! faire attention que suivant le signe de eps_glob, on tourne dans le
+ ! sens des aiguilles d'une montre ou inversement
+ ! eps_glob = 1, on ferme le contour vers le bas --> -2 i Pi residu
+ ! eps_glob = -1, on ferme le contour vers le haut --> +2 i Pi residu
+ !
+ eps_glob = sign(1._ki,as23-as13)
+ !
+ origine_info_par = "f3p2m_1mi, dimension "
+ num_grand_b_info_par = lamb
+ denom_grand_b_info_par = 1._ki
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,resto,abserro)
+ !
+ resto = resto/plus_grand
+ !
+ f3p2m_1mi_r(5) = f3p2m_1mi_r(5) + real(resto,ki)
+ f3p2m_1mi_r(6) = f3p2m_1mi_r(6) + aimag(resto)
+ !
+ end if
+ !
+ ! la dependance en mu2 se fait a travers les fonctions he,hf
+ ! inutile de l'ajouter
+ !
+ end function f3p2m_1mi_r
+ !
+ function f3p2m_1mi_c(s23,s13,m3_sq,par1,par2,par3)
+ !
+ complex(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(6) :: f3p2m_1mi_c
+ !
+ complex(ki) :: lamb
+ real(ki) :: plus_grand
+ complex(ki) :: as23,as13,am3_sq
+ complex(ki) :: resto,abserro
+ !
+ !
+ ! We divide by the maximal real or imaginary value to get the real and
+ ! imaginary entries between -1 and 1
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ plus_grand = max ( maxval ( abs( real( (/ s13, s23, m3_sq /), ki ) ) ), &
+ & maxval ( abs( aimag( (/ s13, s23, m3_sq /) ) ) ) )
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ plus_grand = 1._ki
+ !
+ end if
+ !
+ as13 = s13/plus_grand
+ as23 = s23/plus_grand
+ am3_sq = m3_sq/plus_grand
+ !
+ lamb = as13-as23
+ !
+ f3p2m_1mi_c(:) = 0._ki
+ !
+ ! the correction for plus_grand are taken into account in he and hf
+ !
+ f3p2m_1mi_c = a3p2m_1mi_div_c(s23,s13,m3_sq,par1,par2,par3)
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_3p2m_1mi) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = &
+ &'In function f3p2m_1mi (in file function_3p2m_1mi.f90):&
+ &the flag rat to compute the rational part is on &
+ &and the program reaches a region of phase space in &
+ &which det(G) = 0 . Be careful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_3p2m_1mi'
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ if (abs(lamb) > coupure_3p2m_1mi) then
+ !
+ ! analytic computation
+ !
+ f3p2m_1mi_c(5:6) = f3p2m_1mi_c(5:6) + a3p2m_1mi_c(as23,as13,am3_sq,par1,par2,par3)&
+ &/plus_grand
+ !
+ else
+ !
+ ! numerical computation
+ !
+ dim_glob = "ndi"
+ par1_glob = par1
+ par2_glob = par2
+ par3_glob = par3
+ !
+ s23_glob = as23
+ s13_glob = as13
+ m3_sq_glob = am3_sq
+ !
+ resto = 0._ki
+ abserro = 0._ki
+ !
+ ! on pose z = x - i*eps*y (avec x et y > 0)
+ ! z*s13+(1-z)*s23 = s23+x*(s13-s23)-i*eps*y*(s13-s23)
+ ! now s13 and s23 are complex BUT HAVE THE SAME IMAGINARY PART
+ ! i.e. s13-s23 is real.
+ ! We want the the argument of the log never cross the cut, that is to say that the
+ ! sign(Im(arg_log)) is constant along the contour
+ ! => eps = -sign(Im(s23))*sign(s13-s23)
+ ! Note that with this prescription we avoid the pole when z*s13+(1-z)*s23=0
+ !
+ ! faire attention que suivant le signe de eps_glob, on tourne dans le
+ ! sens des aiguilles d'une montre ou inversement
+ ! eps_glob = 1, on ferme le contour vers le bas --> -2 i Pi residu
+ ! eps_glob = -1, on ferme le contour vers le haut --> +2 i Pi residu
+ !
+ eps_glob = -sign(1._ki,aimag(s23_glob))*sign(1._ki,real(s13_glob-s23_glob,ki))
+ !
+ origine_info_par = "f3p2m_1mi_c, dimension "
+ num_grand_b_info_par = lamb
+ denom_grand_b_info_par = 1._ki
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,resto,abserro)
+ !
+ resto = resto/plus_grand
+ !
+ f3p2m_1mi_c(5) = f3p2m_1mi_c(5) + real(resto,ki)
+ f3p2m_1mi_c(6) = f3p2m_1mi_c(6) + aimag(resto)
+ !
+ end if
+ !
+ ! la dependance en mu2 se fait a travers les fonctions he,hf
+ ! inutile de l'ajouter
+ !
+ !
+ end function f3p2m_1mi_c
+ !
+ !****f* src/integral/three_point/function_3p2m_1mi/f3p2m_1mi_np2
+ ! NAME
+ !
+ ! Function f3p2m_1mi_np2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f3p2m_1mi_np2(s23,s13,m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the two off-shell external leg one internal mass three point function in n+2 dimensions
+ ! with up to three Feynman parameters in the numerator.
+ ! It retuns an array of 4 reals corresponding to the real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s23 -- real/complex (type ki), the value of the S matrix element corresponding to the first external off-shell leg
+ ! * s13 -- real/complex (type ki), the value of the S matrix element corresponding to the second external off-shell leg
+ ! * m3_sq -- real/complex (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 4 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term. If par1 and/or par2
+ ! are different from zero, an error is returned.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ !
+ function f3p2m_1mi_np2_r(s23,s13,m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p2m_1mi_np2_r
+ !
+ integer :: nb_par
+ real(ki) :: lamb
+ real(ki) :: plus_grand
+ real(ki) :: norma
+ complex(ki) :: resto,abserro
+ real(ki) :: as23,as13,am3_sq
+ real(ki) :: lmu2
+ !
+ par = (/par1,par2,par3/)
+ !
+ !
+ ! on redefinit la matrice S de telle facon a ce que ces elements
+ ! soient entre -1 et 1
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ plus_grand = max(abs(s13),abs(s23),abs(m3_sq))
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ plus_grand = 1._ki
+ !
+ end if
+ !
+ as13 = s13/plus_grand
+ as23 = s23/plus_grand
+ am3_sq = m3_sq/plus_grand
+ !
+ lamb = as13-as23
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ !
+ norma = -1._ki/2._ki
+ !
+ else if (nb_par == 1) then
+ !
+ norma = -1._ki/6._ki
+ !
+ else
+ !
+ norma = 0._ki
+ !
+ end if
+ !
+ !
+ f3p2m_1mi_np2_r(:) = 0._ki
+ !
+ f3p2m_1mi_np2_r(1:2) = (/ norma, 0._ki /)
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_3p2m_1mi) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p2m_1mi (in file function_3p2m_1mi.f90):&
+ &the flag rat to compute the rational part is on &
+ &and the program reaches a region of phase space in &
+ &which det(G) = 0 . Be careful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_3p2m_1mi'
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ if (abs(lamb) > coupure_3p2m_1mi) then
+ !
+ ! analytic computation
+ !
+ f3p2m_1mi_np2_r(3:4) = a3p2m_1mi_np2_r(as23,as13,am3_sq,par1,par2,par3)
+ f3p2m_1mi_np2_r(3) = f3p2m_1mi_np2_r(3)-log(plus_grand)*norma
+ !
+ else
+ !
+ ! numerical computation
+ !
+ dim_glob = "n+2"
+ par1_glob = par1
+ par2_glob = par2
+ par3_glob = par3
+ !
+ s23_glob = cmplx(as23,0._ki,ki)
+ s13_glob = cmplx(as13,0._ki,ki)
+ m3_sq_glob = cmplx(am3_sq,0._ki,ki)
+ !
+ resto = 0._ki
+ abserro = 0._ki
+ !
+ ! on pose z = x - i*eps*y (avec x et y > 0)
+ ! z*s23+(1-z)*s23 = s23+x*(s23-s23)-i*eps*y*(s23-s23)
+ ! on veut la partie imaginaire du meme signe que i*lambda
+ ! => eps*(s23-s23) < 0
+ !
+ ! faire attention que suivant le signe de eps_glob, on tourne dans le
+ ! sens des aiguilles d'une montre ou inversement
+ ! eps_glob = 1, on ferme le contour vers le bas --> -2 i Pi residu
+ ! eps_glob = -1, on ferme le contour vers le haut --> +2 i Pi residu
+ !
+ eps_glob = sign(1._ki,as23-as13)
+ !
+ origine_info_par = "f3p2m_1mi_np2, dimension "
+ num_grand_b_info_par = lamb
+ denom_grand_b_info_par = 1._ki
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,resto,abserro)
+ !
+ resto = resto-log(plus_grand)*norma
+ !
+ f3p2m_1mi_np2_r(3) = real(resto,ki)
+ f3p2m_1mi_np2_r(4) = aimag(resto)
+ !
+ end if
+ !
+ ! on ajoute la dependence en mu^2
+ !
+ lmu2 = log(mu2_scale_par)
+ f3p2m_1mi_np2_r(3:4) = f3p2m_1mi_np2_r(3:4) + f3p2m_1mi_np2_r(1:2)*lmu2
+ !
+ end function f3p2m_1mi_np2_r
+ !
+ !
+ function f3p2m_1mi_np2_c(s23,s13,m3_sq,par1,par2,par3)
+ !
+ complex(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p2m_1mi_np2_c
+ !
+ integer :: nb_par
+ complex(ki) :: lamb
+ complex(ki) :: resto, abserro
+ real(ki) :: plus_grand
+ real(ki) :: norma
+ complex(ki) :: as23,as13,am3_sq
+ real(ki) :: lmu2
+ !
+ par = (/par1,par2,par3/)
+ !
+ !
+ ! We divide by the maximal real or imaginary value to get the real and
+ ! imaginary entries between -1 and 1
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ plus_grand = max ( maxval ( abs( real( (/ s13, s23, m3_sq /), ki ) ) ), &
+ & maxval ( abs( aimag( (/ s13, s23, m3_sq /) ) ) ) )
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ plus_grand = 1._ki
+ !
+ end if
+ !
+ as13 = s13/plus_grand
+ as23 = s23/plus_grand
+ am3_sq = m3_sq/plus_grand
+ !
+ lamb = as13-as23
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ !
+ norma = -1._ki/2._ki
+ !
+ else if (nb_par == 1) then
+ !
+ norma = -1._ki/6._ki
+ !
+ else
+ !
+ norma = 0._ki
+ !
+ end if
+ !
+ !
+ f3p2m_1mi_np2_c(:) = 0._ki
+ !
+ f3p2m_1mi_np2_c(1:2) = (/ norma, 0._ki /)
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_3p2m_1mi) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p2m_1mi (in file function_3p2m_1mi.f90):&
+ &the flag rat to compute the rational part is on &
+ &and the program reaches a region of phase space in &
+ &which det(G) = 0 . Be careful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_3p2m_1mi'
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ if (abs(lamb) > coupure_3p2m_1mi) then
+ !
+ ! analytic computation
+ !
+ f3p2m_1mi_np2_c(3:4) = a3p2m_1mi_np2_c(as23,as13,am3_sq,par1,par2,par3)
+ f3p2m_1mi_np2_c(3) = f3p2m_1mi_np2_c(3)-log(plus_grand)*norma
+ !
+ else
+ !
+ ! numerical computation
+ !
+ dim_glob = "n+2"
+ par1_glob = par1
+ par2_glob = par2
+ par3_glob = par3
+ !
+ s23_glob = as23
+ s13_glob = as13
+ m3_sq_glob = am3_sq
+ !
+ resto = 0._ki
+ abserro = 0._ki
+ !
+ ! on pose z = x - i*eps*y (avec x et y > 0)
+ ! z*s13+(1-z)*s23 = s23+x*(s13-s23)-i*eps*y*(s13-s23)
+ ! now s13 and s23 are complex BUT HAVE THE SAME IMAGINARY PART
+ ! i.e. s13-s23 is real.
+ ! We want the the argument of the log never cross the cut, that is to say that the
+ ! sign(Im(arg_log)) is constant along the contour
+ ! => eps = -sign(Im(s23))*sign(s13-s23)
+ ! Note that with this prescription we avoid the pole when z*s13+(1-z)*s23=0
+ !
+ ! faire attention que suivant le signe de eps_glob, on tourne dans le
+ ! sens des aiguilles d'une montre ou inversement
+ ! eps_glob = 1, on ferme le contour vers le bas --> -2 i Pi residu
+ ! eps_glob = -1, on ferme le contour vers le haut --> +2 i Pi residu
+ !
+ eps_glob = -sign(1._ki,aimag(s23_glob))*sign(1._ki,real(s13_glob-s23_glob,ki))
+ !
+ origine_info_par = "f3p2m_1mi_np2_c, dimension "
+ num_grand_b_info_par = lamb
+ denom_grand_b_info_par = 1._ki
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,resto,abserro)
+ !
+ resto = resto-log(plus_grand)*norma
+ !
+ f3p2m_1mi_np2_c(3) = real(resto,ki)
+ f3p2m_1mi_np2_c(4) = aimag(resto)
+ !
+ end if
+ !
+ ! on ajoute la dependence en mu^2
+ !
+ lmu2 = log(mu2_scale_par)
+ f3p2m_1mi_np2_c(3:4) = f3p2m_1mi_np2_c(3:4) + f3p2m_1mi_np2_c(1:2)*lmu2
+ !
+ end function f3p2m_1mi_np2_c
+
+ !****if* src/integral/three_point/function_3p2m_1mi/a3p2m_1mi_div
+ ! NAME
+ !
+ ! Function a3p2m_1mi_div
+ !
+ ! USAGE
+ !
+ ! real_dim6 = a3p2m_1mi_div(s23,s13,m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the divergent part of the two off-shell external leg three point function in n dimensions
+ ! with up to three Feynman parameters in the numerator.
+ ! It retuns an array of 6 reals corresponding to the real/imaginary
+ ! part of the coefficient of the 1/epsilon^2 term, real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s23 -- real/complex (type ki), the value of the S matrix element corresponding to the first external off-shell leg
+ ! * s13 -- real/complex (type ki), the value of the S matrix element corresponding to the second external off-shell leg
+ ! * m3_sq -- real/complex (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 6 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon^2 term,
+ ! real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ !
+ function a3p2m_1mi_div_r(s23,s13,m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(6) :: a3p2m_1mi_div_r
+ !
+ a3p2m_1mi_div_r(:) = 0._ki
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=he(1,s13,s23)
+ !
+ a3p2m_1mi_div_r(5:6)=hf(1,s13,s23)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ if (par3 == 1) then
+ !
+ a3p2m_1mi_div_r(3:4)=he(2,s13,s23)
+ !
+ a3p2m_1mi_div_r(5:6)=hf(2,s13,s23)
+ !
+ else if (par3 == 2) then
+ !
+ a3p2m_1mi_div_r(3:4)=he(1,s13,s23)-he(2,s13,s23)
+ !
+ a3p2m_1mi_div_r(5:6)=hf(1,s13,s23)-hf(2,s13,s23)
+ !
+ else if (par3 == 3) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ end if
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ else if ( (par1==0) ) then
+ !
+ if ( (par2 == 1) .and. (par3 == 1) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=he(3,s13,s23)
+ !
+ a3p2m_1mi_div_r(5:6)=hf(3,s13,s23)
+ !
+ else if ( (par2 == 2) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=he(1,s13,s23)-2._ki*he(2,s13,s23)+he(3,s13,s23&
+ &)
+ !
+ a3p2m_1mi_div_r(5:6)=hf(1,s13,s23)-2._ki*hf(2,s13,s23)+hf(3,s13,s23&
+ &)
+ !
+ else if ( (par2 == 3) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ else if ( (par2 == 1) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=he(2,s13,s23)-he(3,s13,s23)
+ !
+ a3p2m_1mi_div_r(5:6)=hf(2,s13,s23)-hf(3,s13,s23)
+ !
+ else if ( (par2 == 1) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ else if ( (par2 == 2) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ end if
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ else
+ !
+ if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 1) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=he(4,s13,s23)
+ !
+ a3p2m_1mi_div_r(5:6)=hf(4,s13,s23)
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=he(1,s13,s23)-3._ki*he(2,s13,s23)-he(4,s13,s23&
+ &)+3._ki*he(3,s13,s23)
+ !
+ a3p2m_1mi_div_r(5:6)=hf(1,s13,s23)-3._ki*hf(2,s13,s23)-hf(4,s13,s23&
+ &)+3._ki*hf(3,s13,s23)
+ !
+ else if ( (par1 == 3) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=-he(4,s13,s23)+he(3,s13,s23)
+ !
+ a3p2m_1mi_div_r(5:6)=-hf(4,s13,s23)+hf(3,s13,s23)
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=he(2,s13,s23)+he(4,s13,s23)-2._ki*he(3,s13,s23&
+ &)
+ !
+ a3p2m_1mi_div_r(5:6)=hf(2,s13,s23)+hf(4,s13,s23)-2._ki*hf(3,s13,s23&
+ &)
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_r(3:4)=0._ki
+ !
+ a3p2m_1mi_div_r(5:6)=0._ki
+ !
+ end if
+ !
+ end if
+ !
+ ! On change \epsilon_{ir} en -\epsilon_{uv}
+ !
+ a3p2m_1mi_div_r(3:4) = -a3p2m_1mi_div_r(3:4)
+ !
+ end function a3p2m_1mi_div_r
+ !
+ !
+ function a3p2m_1mi_div_c(s23,s13,m3_sq,par1,par2,par3)
+ !
+ complex(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(6) :: a3p2m_1mi_div_c
+ !
+ a3p2m_1mi_div_c(:) = 0._ki
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=he(1,s13,s23)
+ !
+ a3p2m_1mi_div_c(5:6)=hf(1,s13,s23)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ if (par3 == 1) then
+ !
+ a3p2m_1mi_div_c(3:4)=he(2,s13,s23)
+ !
+ a3p2m_1mi_div_c(5:6)=hf(2,s13,s23)
+ !
+ else if (par3 == 2) then
+ !
+ a3p2m_1mi_div_c(3:4)=he(1,s13,s23)-he(2,s13,s23)
+ !
+ a3p2m_1mi_div_c(5:6)=hf(1,s13,s23)-hf(2,s13,s23)
+ !
+ else if (par3 == 3) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ end if
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ else if ( (par1==0) ) then
+ !
+ if ( (par2 == 1) .and. (par3 == 1) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=he(3,s13,s23)
+ !
+ a3p2m_1mi_div_c(5:6)=hf(3,s13,s23)
+ !
+ else if ( (par2 == 2) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=he(1,s13,s23)-2._ki*he(2,s13,s23)+he(3,s13,s23&
+ &)
+ !
+ a3p2m_1mi_div_c(5:6)=hf(1,s13,s23)-2._ki*hf(2,s13,s23)+hf(3,s13,s23&
+ &)
+ !
+ else if ( (par2 == 3) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ else if ( (par2 == 1) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=he(2,s13,s23)-he(3,s13,s23)
+ !
+ a3p2m_1mi_div_c(5:6)=hf(2,s13,s23)-hf(3,s13,s23)
+ !
+ else if ( (par2 == 1) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ else if ( (par2 == 2) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ end if
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ else
+ !
+ if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 1) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=he(4,s13,s23)
+ !
+ a3p2m_1mi_div_c(5:6)=hf(4,s13,s23)
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=he(1,s13,s23)-3._ki*he(2,s13,s23)-he(4,s13,s23&
+ &)+3._ki*he(3,s13,s23)
+ !
+ a3p2m_1mi_div_c(5:6)=hf(1,s13,s23)-3._ki*hf(2,s13,s23)-hf(4,s13,s23&
+ &)+3._ki*hf(3,s13,s23)
+ !
+ else if ( (par1 == 3) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=-he(4,s13,s23)+he(3,s13,s23)
+ !
+ a3p2m_1mi_div_c(5:6)=-hf(4,s13,s23)+hf(3,s13,s23)
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=he(2,s13,s23)+he(4,s13,s23)-2._ki*he(3,s13,s23&
+ &)
+ !
+ a3p2m_1mi_div_c(5:6)=hf(2,s13,s23)+hf(4,s13,s23)-2._ki*hf(3,s13,s23&
+ &)
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ a3p2m_1mi_div_c(3:4)=0._ki
+ !
+ a3p2m_1mi_div_c(5:6)=0._ki
+ !
+ end if
+ !
+ end if
+ !
+ ! On change \epsilon_{ir} en -\epsilon_{uv}
+ !
+ a3p2m_1mi_div_c(3:4) = -a3p2m_1mi_div_c(3:4)
+ !
+ end function a3p2m_1mi_div_c
+ !
+ !****if* src/integral/three_point/function_3p2m_1mi/a3p2m_1mi
+ ! NAME
+ !
+ ! Function a3p2m_1mi
+ !
+ ! USAGE
+ !
+ ! real_dim2 = a3p2m_1mi(s23,s13,m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the non divergent part two off-shell external leg three point function in n dimensions
+ ! with up to three Feynman parameters in the numerator.
+ ! It retuns an array of 2 reals corresponding to the real/imaginary
+ ! part of the constant term.
+ !
+ ! INPUTS
+ !
+ ! * s23 -- real/complex (type ki), the value of the S matrix element corresponding to the first external off-shell leg
+ ! * s13 -- real/complex (type ki), the value of the S matrix element corresponding to the second external off-shell leg
+ ! * m3_sq -- real/complex (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 2 corresponding to
+ ! the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function a3p2m_1mi_r(s23,s13,m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(2) :: a3p2m_1mi_r
+ !
+ complex(ki) :: c_temp,c_temp_rat
+ real(ki) :: sc13,sc23
+ !
+ a3p2m_1mi_r(:) = 0._ki
+ !
+ sc13=sign(un,s13+m3_sq)
+ !
+ sc23=sign(un,s23+m3_sq)
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ c_temp=-1._ki/(s13-s23)*zdilog((s13+m3_sq)/s13,-1._ki)+zdilog((s2&
+ &3+m3_sq)/s23,-1._ki)/(s13-s23)
+ !
+ c_temp_rat=czero
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ if (par3 == 1) then
+ !
+ c_temp=s23/(s13-s23)**2*zdilog((s13+m3_sq)/s13,-1._ki)-s23/(s13-s&
+ &23)**2*zdilog((s23+m3_sq)/s23,-1._ki)-m3_sq*z_log(m3_sq,-1._ki)&
+ &/(s13-s23)**2-s23/(s13-s23)**2*z_log(-s23,-1._ki)+(s23+m3_sq)/(&
+ &s13-s23)**2*z_log(-s13,-1._ki)-1._ki/(s13-s23)+1._ki/s13*q(1,1.&
+ &_ki+m3_sq/s13,-sc13)*(s23+m3_sq)*m3_sq/(s13-s23)**2
+ !
+ c_temp_rat=-1._ki/(s13-s23)
+ !
+ else if (par3 == 2) then
+ !
+ c_temp=-s13/(s13-s23)**2*zdilog((s13+m3_sq)/s13,-1._ki)+s13/(s13-&
+ &s23)**2*zdilog((s23+m3_sq)/s23,-1._ki)+m3_sq*z_log(m3_sq,-1._ki&
+ &)/(s13-s23)**2+s13/(s13-s23)**2*z_log(-s23,-1._ki)-(s13+m3_sq)/&
+ &(s13-s23)**2*z_log(-s13,-1._ki)+1._ki/s23*q(1,1._ki+m3_sq/s23,-&
+ &sc23)*m3_sq/(s13-s23)-m3_sq*(s13+m3_sq)/s13/(s13-s23)**2*q(1,1.&
+ &_ki+m3_sq/s13,-sc13)+1._ki/(s13-s23)
+ !
+ c_temp_rat=1._ki/(s13-s23)
+ !
+ else if (par3 == 3) then
+ !
+ c_temp=-1._ki/(s13-s23)*z_log(-s23,-1._ki)+1._ki/s13*q(1,1._ki+m3&
+ &_sq/s13,-sc13)*m3_sq/(s13-s23)-1._ki/s23*q(1,1._ki+m3_sq/s23,-s&
+ &c23)*m3_sq/(s13-s23)+1._ki/(s13-s23)*z_log(-s13,-1._ki)
+ !
+ c_temp_rat=0._ki
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a3p2m_1mi_r:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Unimplemented combination of Feynman parameters"
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ else if ( (par1==0) ) then
+ !
+ if ( (par2 == 1) .and. (par3 == 1) ) then
+ !
+ c_temp=-s23**2/(s13-s23)**3*zdilog((s13+m3_sq)/s13,-1._ki)+s23**2&
+ &/(s13-s23)**3*zdilog((s23+m3_sq)/s23,-1._ki)+1._ki/2._ki*m3_sq*&
+ &(-m3_sq+2._ki*s23)/(s13-s23)**3*z_log(m3_sq,-1._ki)-1._ki/2._ki&
+ &*(s23+m3_sq)*(3._ki*s23-m3_sq)/(s13-s23)**3*z_log(-s13,-1._ki)+&
+ &3._ki/2._ki*s23**2/(s13-s23)**3*z_log(-s23,-1._ki)-1._ki/2._ki/&
+ &s13**2*m3_sq**2/(s13-s23)**3*(s23+m3_sq)**2*q(2,1._ki+m3_sq/s13&
+ &,-sc13)-m3_sq*(s23+m3_sq)*(-m3_sq+s23)/s13/(s13-s23)**3*q(1,1._&
+ &ki+m3_sq/s13,-sc13)-1._ki/4._ki*(3._ki*s13**3-12._ki*s13**2*s23&
+ &-2._ki*m3_sq*s13**2+9._ki*s13*s23**2+4._ki*m3_sq*s13*s23+2._ki*&
+ &s13*m3_sq**2-2._ki*m3_sq*s23**2-4._ki*s23*m3_sq**2-2._ki*m3_sq*&
+ &*3)/s13/(s13-s23)**3
+ !
+ c_temp_rat=-1._ki/4._ki*(3._ki*s13**2+m3_sq*s13-9._ki*s23*s13-7._&
+ &ki*m3_sq*s23)/(s13+m3_sq)/(s13-s23)**2
+ !
+ else if ( (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp=-s13**2/(s13-s23)**3*zdilog((s13+m3_sq)/s13,-1._ki)+s13**2&
+ &/(s13-s23)**3*zdilog((s23+m3_sq)/s23,-1._ki)+1._ki/2._ki*m3_sq*&
+ &(4._ki*s13-2._ki*s23-m3_sq)/(s13-s23)**3*z_log(m3_sq,-1._ki)-1.&
+ &_ki/2._ki*(s13+m3_sq)*(3._ki*s13-m3_sq)/(s13-s23)**3*z_log(-s13&
+ &,-1._ki)+1._ki/2._ki*(2._ki*s23*m3_sq+3._ki*s13**2-2._ki*m3_sq*&
+ &s13)/(s13-s23)**3*z_log(-s23,-1._ki)-1._ki/2._ki*m3_sq**2*(s13+&
+ &m3_sq)**2/s13**2/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)+m3_sq*&
+ &(s13-s23-m3_sq)/s23/(s13-s23)**2*q(1,1._ki+m3_sq/s23,-sc23)+1._&
+ &ki/2._ki/s23**2/(s13-s23)*m3_sq**2*q(2,1._ki+m3_sq/s23,-sc23)-m&
+ &3_sq*(s13-m3_sq)*(s13+m3_sq)/s13/(s13-s23)**3*q(1,1._ki+m3_sq/s&
+ &13,-sc13)+1._ki/4._ki/s13/s23*(3._ki*s13*s23**3-2._ki*m3_sq*s13&
+ &*s23**2-12._ki*s13**2*s23**2+9._ki*s13**3*s23+4._ki*m3_sq*s13**&
+ &2*s23+2._ki*m3_sq**3*s23+2._ki*m3_sq**2*s13*s23-2._ki*s13**3*m3&
+ &_sq)/(s13-s23)**3
+ !
+ c_temp_rat=1._ki/4._ki*(7._ki*m3_sq*s13+9._ki*s23*s13-m3_sq*s23-3&
+ &._ki*s23**2)/(s13-s23)**2/(s23+m3_sq)
+ !
+ else if ( (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/2._ki/(s13-s23)*z_log(-s13,-1._ki)-1._ki/2._ki/(s13-&
+ &s23)*z_log(-s23,-1._ki)-1._ki/2._ki/s13**2*m3_sq**2/(s13-s23)*q&
+ &(2,1._ki+m3_sq/s13,-sc13)-1._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)*&
+ &m3_sq/(s13-s23)+1._ki/2._ki/s23**2/(s13-s23)*m3_sq**2*q(2,1._ki&
+ &+m3_sq/s23,-sc23)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m3_sq/(s&
+ &13-s23)-1._ki/2._ki*m3_sq/s13/s23
+ !
+ c_temp_rat=-1._ki/2._ki*m3_sq/(s13+m3_sq)/(s23+m3_sq)
+ !
+ else if ( (par2 == 1) .and. (par3 == 2) ) then
+ !
+ c_temp=s23*s13/(s13-s23)**3*zdilog((s13+m3_sq)/s13,-1._ki)-s23*s1&
+ &3/(s13-s23)**3*zdilog((s23+m3_sq)/s23,-1._ki)-1._ki/2._ki*m3_sq&
+ &*(-m3_sq+2._ki*s13)/(s13-s23)**3*z_log(m3_sq,-1._ki)+1._ki/2._k&
+ &i*(s23*m3_sq-m3_sq**2+m3_sq*s13+3._ki*s23*s13)/(s13-s23)**3*z_l&
+ &og(-s13,-1._ki)-1._ki/2._ki*(s23*m3_sq-m3_sq*s13+3._ki*s23*s13)&
+ &/(s13-s23)**3*z_log(-s23,-1._ki)+1._ki/2._ki*(s23+m3_sq)*m3_sq*&
+ &*2*(s13+m3_sq)/s13**2/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)+1&
+ &._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)**2*m3_sq**2&
+ &+m3_sq*(-m3_sq**2+s23*s13)/s13/(s13-s23)**3*q(1,1._ki+m3_sq/s13&
+ &,-sc13)-1._ki/4._ki*(3._ki*s13**3-3._ki*s13*s23**2+2._ki*s23*m3&
+ &_sq**2+2._ki*m3_sq**3)/s13/(s13-s23)**3
+ !
+ c_temp_rat=-3._ki/4._ki*(s13+s23)/(s13-s23)**2
+ !
+ else if ( (par2 == 1) .and. (par3 == 3) ) then
+ !
+ c_temp=-1._ki/2._ki*(-m3_sq+s23)/(s13-s23)**2*z_log(-s13,-1._ki)+&
+ &1._ki/2._ki*(-m3_sq+s23)/(s13-s23)**2*z_log(-s23,-1._ki)-1._ki/&
+ &2._ki/s13**2*(s23+m3_sq)/(s13-s23)**2*m3_sq**2*q(2,1._ki+m3_sq/&
+ &s13,-sc13)-1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)&
+ &**2*m3_sq**2+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)/(s13-s23)**2*&
+ &m3_sq**2+1._ki/2._ki/s13*(s13**2-s23*s13-m3_sq*s13+s23*m3_sq+m3&
+ &_sq**2)/(s13-s23)**2
+ !
+ c_temp_rat=1._ki/2._ki*s13/(s13-s23)/(s13+m3_sq)
+ !
+ else if ( (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/2._ki*(s13-m3_sq)/(s13-s23)**2*z_log(-s13,-1._ki)-1.&
+ &_ki/2._ki*(s13-m3_sq)/(s13-s23)**2*z_log(-s23,-1._ki)+1._ki/2._&
+ &ki*m3_sq**2*(s13+m3_sq)/s13**2/(s13-s23)**2*q(2,1._ki+m3_sq/s13&
+ &,-sc13)+1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)**2&
+ &*m3_sq**2-1._ki/2._ki/s23**2/(s13-s23)*m3_sq**2*q(2,1._ki+m3_sq&
+ &/s23,-sc23)-1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)/(s13-s23)**2*m&
+ &3_sq**2-1._ki/2._ki/s13/s23*(-s13*s23**2+s13**2*s23+s23*m3_sq**&
+ &2+m3_sq*s13*s23-m3_sq*s13**2)/(s13-s23)**2
+ !
+ c_temp_rat=-1._ki/2._ki*s23/(s13-s23)/(s23+m3_sq)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a3p2m_1mi_r:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Unimplemented combination of Feynman parameters"
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ else
+ !
+ if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 1) ) then
+ !
+ c_temp=s23**3/(s13-s23)**4*zdilog((s13+m3_sq)/s13,-1._ki)-s23**3/&
+ &(s13-s23)**4*zdilog((s23+m3_sq)/s23,-1._ki)-1._ki/6._ki*m3_sq*(&
+ &-3._ki*s23*m3_sq+2._ki*m3_sq**2+6._ki*s23**2)/(s13-s23)**4*z_lo&
+ &g(m3_sq,-1._ki)+1._ki/6._ki*(s23+m3_sq)*(2._ki*m3_sq**2-5._ki*s&
+ &23*m3_sq+11._ki*s23**2)/(s13-s23)**4*z_log(-s13,-1._ki)-11._ki/&
+ &6._ki*s23**3/(s13-s23)**4*z_log(-s23,-1._ki)+m3_sq*(s23+m3_sq)*&
+ &(m3_sq**2+s23**2-s23*m3_sq)/s13/(s13-s23)**4*q(1,1._ki+m3_sq/s1&
+ &3,-sc13)+1._ki/3._ki/s13**3*(s23+m3_sq)**3/(s13-s23)**4*m3_sq**&
+ &3*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/2._ki*m3_sq**2*(s23+m3_sq)**&
+ &2*(-2._ki*m3_sq+s23)/s13**2/(s13-s23)**4*q(2,1._ki+m3_sq/s13,-s&
+ &c13)-1._ki/36._ki*(22._ki*s13**5-6._ki*m3_sq*s13**4-99._ki*s23*&
+ &s13**4-6._ki*m3_sq**2*s13**3+198._ki*s23**2*s13**3+36._ki*s23*m&
+ &3_sq*s13**3-54._ki*m3_sq*s23**2*s13**2-121._ki*s23**3*s13**2+18&
+ &._ki*m3_sq**3*s13**2+18._ki*m3_sq**2*s23**2*s13+24._ki*s23**3*m&
+ &3_sq*s13-36._ki*s23*m3_sq**3*s13-30._ki*m3_sq**4*s13+6._ki*s23*&
+ &*3*m3_sq**2+18._ki*s23*m3_sq**4+6._ki*m3_sq**5+18._ki*m3_sq**3*&
+ &s23**2)/s13**2/(s13-s23)**4
+ !
+ c_temp_rat=-1._ki/36._ki*(22._ki*s13**4+38._ki*m3_sq*s13**3-77._k&
+ &i*s23*s13**3-124._ki*s23*m3_sq*s13**2+121._ki*s23**2*s13**2+4._&
+ &ki*m3_sq**2*s13**2-23._ki*s23*m3_sq**2*s13+218._ki*s23**2*s13*m&
+ &3_sq+85._ki*s23**2*m3_sq**2)/(s13-s23)**3/(s13+m3_sq)**2
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp=-s13**3/(s13-s23)**4*zdilog((s13+m3_sq)/s13,-1._ki)+s13**3&
+ &/(s13-s23)**4*zdilog((s23+m3_sq)/s23,-1._ki)+1._ki/6._ki*m3_sq*&
+ &(2._ki*m3_sq**2+6._ki*s23*m3_sq+6._ki*s23**2+18._ki*s13**2-18._&
+ &ki*s23*s13-9._ki*m3_sq*s13)/(s13-s23)**4*z_log(m3_sq,-1._ki)-1.&
+ &_ki/6._ki*(s13+m3_sq)*(2._ki*m3_sq**2-5._ki*m3_sq*s13+11._ki*s1&
+ &3**2)/(s13-s23)**4*z_log(-s13,-1._ki)+1._ki/6._ki*(18._ki*s23*m&
+ &3_sq*s13+11._ki*s13**3-12._ki*m3_sq*s13**2+6._ki*m3_sq**2*s13-6&
+ &._ki*m3_sq**2*s23-6._ki*s23**2*m3_sq)/(s13-s23)**4*z_log(-s23,-&
+ &1._ki)+1._ki/3._ki/s23**3*m3_sq**3/(s13-s23)*q(3,1._ki+m3_sq/s2&
+ &3,-sc23)-m3_sq*(s13+m3_sq)*(s13**2-m3_sq*s13+m3_sq**2)/s13/(s13&
+ &-s23)**4*q(1,1._ki+m3_sq/s13,-sc13)-1._ki/3._ki*m3_sq**3*(s13+m&
+ &3_sq)**3/s13**3/(s13-s23)**4*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/2&
+ &._ki*m3_sq*(2._ki*m3_sq**2+2._ki*s13**2-4._ki*s23*s13+2._ki*s23&
+ &**2-3._ki*m3_sq*s13+3._ki*s23*m3_sq)/s23/(s13-s23)**3*q(1,1._ki&
+ &+m3_sq/s23,-sc23)-1._ki/2._ki*m3_sq**2*(s13-2._ki*m3_sq)*(s13+m&
+ &3_sq)**2/s13**2/(s13-s23)**4*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/2&
+ &._ki*m3_sq**2*(-m3_sq+s13-s23)/s23**2/(s13-s23)**2*q(2,1._ki+m3&
+ &_sq/s23,-sc23)+1._ki/36._ki/s13**2/s23**2*(-6._ki*m3_sq**2*s13*&
+ &*5+121._ki*s23**2*s13**5-24._ki*s23*m3_sq*s13**5+54._ki*s23**2*&
+ &s13**4*m3_sq+36._ki*s23*m3_sq**2*s13**4-198._ki*s23**3*s13**4-3&
+ &6._ki*s23**3*m3_sq*s13**3+99._ki*s23**4*s13**3-36._ki*s23**2*m3&
+ &_sq**2*s13**3+24._ki*s23**3*m3_sq**2*s13**2+6._ki*s23**4*m3_sq*&
+ &s13**2-22._ki*s23**5*s13**2-12._ki*s23**2*m3_sq**4*s13+6._ki*s2&
+ &3**2*m3_sq**5)/(s13-s23)**4
+ !
+ c_temp_rat=1._ki/36._ki*(218._ki*s23*m3_sq*s13**2+121._ki*s23**2*&
+ &s13**2+85._ki*m3_sq**2*s13**2-124._ki*s23**2*s13*m3_sq-23._ki*s&
+ &23*m3_sq**2*s13-77._ki*s23**3*s13+38._ki*s23**3*m3_sq+4._ki*s23&
+ &**2*m3_sq**2+22._ki*s23**4)/(s23+m3_sq)**2/(s13-s23)**3
+ !
+ else if ( (par1 == 3) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/3._ki/(s13-s23)*z_log(-s13,-1._ki)-1._ki/3._ki/(s13-&
+ &s23)*z_log(-s23,-1._ki)-1._ki/3._ki/s23**3*m3_sq**3/(s13-s23)*q&
+ &(3,1._ki+m3_sq/s23,-sc23)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*&
+ &m3_sq/(s13-s23)+1._ki/3._ki/s13**3/(s13-s23)*m3_sq**3*q(3,1._ki&
+ &+m3_sq/s13,-sc13)-1._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)*m3_sq/(s&
+ &13-s23)-1._ki/s13**2/(s13-s23)*m3_sq**2*q(2,1._ki+m3_sq/s13,-sc&
+ &13)+1._ki/s23**2/(s13-s23)*m3_sq**2*q(2,1._ki+m3_sq/s23,-sc23)-&
+ &1._ki/6._ki*(5._ki*s23*s13-s23*m3_sq-m3_sq*s13)/s23**2*m3_sq/s1&
+ &3**2
+ !
+ c_temp_rat=-1._ki/6._ki*(5._ki*s23*s13+3._ki*m3_sq*s13+m3_sq**2+3&
+ &._ki*s23*m3_sq)*m3_sq/(s13+m3_sq)**2/(s23+m3_sq)**2
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 2) ) then
+ !
+ c_temp=-s23**2*s13/(s13-s23)**4*zdilog((s13+m3_sq)/s13,-1._ki)+s2&
+ &3**2*s13/(s13-s23)**4*zdilog((s23+m3_sq)/s23,-1._ki)+1._ki/6._k&
+ &i*m3_sq*(2._ki*m3_sq**2+6._ki*s23*s13-3._ki*m3_sq*s13)/(s13-s23&
+ &)**4*z_log(m3_sq,-1._ki)-1._ki/6._ki*(2._ki*m3_sq**3+2._ki*s23*&
+ &*2*m3_sq-2._ki*m3_sq**2*s23+4._ki*s23*m3_sq*s13-m3_sq**2*s13+11&
+ &._ki*s23**2*s13)/(s13-s23)**4*z_log(-s13,-1._ki)+1._ki/6._ki*(2&
+ &._ki*s23**2*m3_sq-2._ki*m3_sq**2*s23-2._ki*s23*m3_sq*s13+2._ki*&
+ &m3_sq**2*s13+11._ki*s23**2*s13)/(s13-s23)**4*z_log(-s23,-1._ki)&
+ &-m3_sq*(m3_sq**3+s23**2*s13)/s13/(s13-s23)**4*q(1,1._ki+m3_sq/s&
+ &13,-sc13)-1._ki/3._ki*m3_sq**3*(s23+m3_sq)**2*(s13+m3_sq)/s13**&
+ &3/(s13-s23)**4*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/3._ki/s23*q(1,1&
+ &._ki+m3_sq/s23,-sc23)*m3_sq**3/(s13-s23)**3-1._ki/2._ki*m3_sq**&
+ &2*(s23+m3_sq)*(-2._ki*m3_sq**2-m3_sq*s13+s23*s13)/s13**2/(s13-s&
+ &23)**4*q(2,1._ki+m3_sq/s13,-sc13)-1._ki/36._ki*(11._ki*s13**5-6&
+ &6._ki*s23*s13**4-6._ki*m3_sq*s13**4+12._ki*s23*m3_sq*s13**3+33.&
+ &_ki*s23**2*s13**3+6._ki*m3_sq**2*s13**3-6._ki*m3_sq*s23**2*s13*&
+ &*2+22._ki*s23**3*s13**2-12._ki*s23*m3_sq**2*s13**2-6._ki*m3_sq*&
+ &*3*s13**2-12._ki*m3_sq**2*s23**2*s13+24._ki*m3_sq**4*s13+12._ki&
+ &*s23*m3_sq**3*s13-6._ki*m3_sq**3*s23**2-6._ki*m3_sq**5-12._ki*s&
+ &23*m3_sq**4)/s13**2/(s13-s23)**4
+ !
+ c_temp_rat=-1._ki/36._ki*(11._ki*s13**3-55._ki*s23*s13**2+5._ki*m&
+ &3_sq*s13**2-49._ki*s23*m3_sq*s13-22._ki*s23**2*s13-22._ki*s23**&
+ &2*m3_sq)/(s13-s23)**3/(s13+m3_sq)
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp=s23*s13**2/(s13-s23)**4*zdilog((s13+m3_sq)/s13,-1._ki)-s23&
+ &*s13**2/(s13-s23)**4*zdilog((s23+m3_sq)/s23,-1._ki)-1._ki/6._ki&
+ &*m3_sq*(2._ki*m3_sq**2+6._ki*s13**2+3._ki*s23*m3_sq-6._ki*m3_sq&
+ &*s13)/(s13-s23)**4*z_log(m3_sq,-1._ki)+1._ki/6._ki*(4._ki*s23*m&
+ &3_sq*s13+11._ki*s23*s13**2+2._ki*m3_sq**3+2._ki*m3_sq*s13**2-2.&
+ &_ki*m3_sq**2*s13-m3_sq**2*s23)/(s13-s23)**4*z_log(-s13,-1._ki)-&
+ &1._ki/6._ki*(4._ki*s23*m3_sq*s13+11._ki*s23*s13**2-4._ki*m3_sq*&
+ &s13**2+4._ki*m3_sq**2*s13-4._ki*m3_sq**2*s23)/(s13-s23)**4*z_lo&
+ &g(-s23,-1._ki)+m3_sq*(s23*s13**2+m3_sq**3)/s13/(s13-s23)**4*q(1&
+ &,1._ki+m3_sq/s13,-sc13)+1._ki/3._ki*(s23+m3_sq)*m3_sq**3*(s13+m&
+ &3_sq)**2/s13**3/(s13-s23)**4*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/6&
+ &._ki*m3_sq**2*(3._ki*s13-3._ki*s23-4._ki*m3_sq)/s23/(s13-s23)**&
+ &3*q(1,1._ki+m3_sq/s23,-sc23)+1._ki/2._ki*m3_sq**2*(s13+m3_sq)*(&
+ &s23*s13-2._ki*m3_sq**2-s23*m3_sq)/s13**2/(s13-s23)**4*q(2,1._ki&
+ &+m3_sq/s13,-sc13)+1._ki/6._ki/s23**2*m3_sq**3/(s13-s23)**2*q(2,&
+ &1._ki+m3_sq/s23,-sc23)-1._ki/36._ki/s13**2/s23*(11._ki*s23**4*s&
+ &13**2-66._ki*s23**3*s13**3-6._ki*s23**3*s13**2*m3_sq+33._ki*s23&
+ &**2*s13**4+6._ki*s23**2*m3_sq**4+12._ki*s23**2*s13**3*m3_sq+24.&
+ &_ki*s23**2*s13**2*m3_sq**2+22._ki*s13**5*s23-6._ki*s23*m3_sq*s1&
+ &3**4-18._ki*s23*m3_sq**4*s13+6._ki*s23*m3_sq**5-12._ki*s23*m3_s&
+ &q**2*s13**3+6._ki*m3_sq**2*s13**4)/(s13-s23)**4
+ !
+ c_temp_rat=-1._ki/36._ki*(22._ki*s23*s13**2+22._ki*m3_sq*s13**2+4&
+ &9._ki*s23*m3_sq*s13+55._ki*s23**2*s13-5._ki*s23**2*m3_sq-11._ki&
+ &*s23**3)/(s13-s23)**3/(s23+m3_sq)
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/3._ki*(m3_sq**2+s23**2-s23*m3_sq)/(s13-s23)**3*z_log&
+ &(-s13,-1._ki)-1._ki/3._ki*(m3_sq**2+s23**2-s23*m3_sq)/(s13-s23)&
+ &**3*z_log(-s23,-1._ki)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m3_&
+ &sq**3/(s13-s23)**3+1._ki/3._ki/s13**3*(s23+m3_sq)**2*m3_sq**3/(&
+ &s13-s23)**3*q(3,1._ki+m3_sq/s13,-sc13)-1._ki/3._ki/s23*q(1,1._k&
+ &i+m3_sq/s23,-sc23)*m3_sq**3/(s13-s23)**3-1._ki/s13**2*(s23+m3_s&
+ &q)*m3_sq**3/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/6._ki&
+ &/s13**2*(s13**4+m3_sq*s13**3-4._ki*s23*s13**3+3._ki*s23**2*s13*&
+ &*2-3._ki*m3_sq**2*s13**2-s23**2*s13*m3_sq+4._ki*s23*m3_sq**2*s1&
+ &3+5._ki*m3_sq**3*s13-m3_sq**4-2._ki*s23*m3_sq**3-s23**2*m3_sq**&
+ &2)/(s13-s23)**3
+ !
+ c_temp_rat=1._ki/6._ki*s13*(s13**2+3._ki*m3_sq*s13-3._ki*s23*s13-&
+ &5._ki*s23*m3_sq)/(s13-s23)**2/(s13+m3_sq)**2
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/3._ki*(s13**2-m3_sq*s13+m3_sq**2)/(s13-s23)**3*z_log&
+ &(-s13,-1._ki)-1._ki/3._ki*(s13**2-m3_sq*s13+m3_sq**2)/(s13-s23)&
+ &**3*z_log(-s23,-1._ki)-1._ki/3._ki/s23**3*m3_sq**3/(s13-s23)*q(&
+ &3,1._ki+m3_sq/s23,-sc23)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m&
+ &3_sq**3/(s13-s23)**3+1._ki/3._ki*m3_sq**3*(s13+m3_sq)**2/s13**3&
+ &/(s13-s23)**3*q(3,1._ki+m3_sq/s13,-sc13)-1._ki/3._ki/s23*q(1,1.&
+ &_ki+m3_sq/s23,-sc23)*m3_sq**3/(s13-s23)**3-m3_sq**3*(s13+m3_sq)&
+ &/s13**2/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/3._ki/s23&
+ &**2*m3_sq**3/(s13-s23)**2*q(2,1._ki+m3_sq/s23,-sc23)-1._ki/6._k&
+ &i/s13**2/s23**2*(-s23*m3_sq*s13**4-m3_sq**2*s13**4+3._ki*s23**2&
+ &*s13**4-4._ki*s23**3*s13**3+4._ki*s23*m3_sq**2*s13**3+s23**3*s1&
+ &3**2*m3_sq+s23**4*s13**2-3._ki*s23**2*s13**2*m3_sq**2-3._ki*m3_&
+ &sq**3*s23**2*s13+s23**2*m3_sq**4)/(s13-s23)**3
+ !
+ c_temp_rat=-1._ki/6._ki*s23*(3._ki*s23*s13+5._ki*m3_sq*s13-s23**2&
+ &-3._ki*s23*m3_sq)/(s13-s23)**2/(s23+m3_sq)**2
+ !
+ else if ( (par1 == 1) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp=-1._ki/6._ki*(-2._ki*m3_sq+s23)/(s13-s23)**2*z_log(-s13,-1&
+ &._ki)+1._ki/6._ki*(-2._ki*m3_sq+s23)/(s13-s23)**2*z_log(-s23,-1&
+ &._ki)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)/(s13-s23)**2*m3_sq**&
+ &2+1._ki/3._ki/s13**3*(s23+m3_sq)/(s13-s23)**2*m3_sq**3*q(3,1._k&
+ &i+m3_sq/s13,-sc13)-1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(&
+ &s13-s23)**2*m3_sq**2-1._ki/2._ki*m3_sq**2*(s23+2._ki*m3_sq)/s13&
+ &**2/(s13-s23)**2*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/6._ki/s23**2*&
+ &m3_sq**3/(s13-s23)**2*q(2,1._ki+m3_sq/s23,-sc23)+1._ki/6._ki/s1&
+ &3**2/s23*(-s23**2*m3_sq**2-s23**2*s13**2+2._ki*s23**2*s13*m3_sq&
+ &+s23*s13**3+5._ki*s23*m3_sq**2*s13-s23*m3_sq**3-2._ki*s23*m3_sq&
+ &*s13**2-m3_sq**2*s13**2)/(s13-s23)**2
+ !
+ c_temp_rat=1._ki/6._ki*(s23*s13**2+m3_sq*s13**2-m3_sq**2*s13+m3_s&
+ &q**2*s23)/(s13-s23)/(s13+m3_sq)**2/(s23+m3_sq)
+ !
+ else if ( (par1 == 2) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/6._ki*(s13-2._ki*m3_sq)/(s13-s23)**2*z_log(-s13,-1._&
+ &ki)-1._ki/6._ki*(s13-2._ki*m3_sq)/(s13-s23)**2*z_log(-s23,-1._k&
+ &i)+1._ki/3._ki/s23**3*m3_sq**3/(s13-s23)*q(3,1._ki+m3_sq/s23,-s&
+ &c23)-1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)/(s13-s23)**2*m3_sq**2&
+ &-1._ki/3._ki*m3_sq**3*(s13+m3_sq)/s13**3/(s13-s23)**2*q(3,1._ki&
+ &+m3_sq/s13,-sc13)+1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s&
+ &13-s23)**2*m3_sq**2+1._ki/2._ki*m3_sq**2*(s13+2._ki*m3_sq)/s13*&
+ &*2/(s13-s23)**2*q(2,1._ki+m3_sq/s13,-sc13)-1._ki/6._ki*m3_sq**2&
+ &*(m3_sq+3._ki*s13-3._ki*s23)/s23**2/(s13-s23)**2*q(2,1._ki+m3_s&
+ &q/s23,-sc23)-1._ki/6._ki/s13**2/s23**2*(-s23**3*s13**2+s23**2*s&
+ &13**3+4._ki*m3_sq**2*s23**2*s13-m3_sq**3*s23**2+2._ki*m3_sq*s23&
+ &**2*s13**2-2._ki*s23*m3_sq*s13**3-2._ki*s23*m3_sq**2*s13**2+m3_&
+ &sq**2*s13**3)/(s13-s23)**2
+ !
+ c_temp_rat=-1._ki/6._ki*(s23**2*s13+m3_sq**2*s13-m3_sq**2*s23+s23&
+ &**2*m3_sq)/(s23+m3_sq)**2/(s13-s23)/(s13+m3_sq)
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp=-1._ki/6._ki*(2._ki*s23*s13-m3_sq*s13-s23*m3_sq+2._ki*m3_s&
+ &q**2)/(s13-s23)**3*z_log(-s13,-1._ki)+1._ki/6._ki*(2._ki*s23*s1&
+ &3-m3_sq*s13-s23*m3_sq+2._ki*m3_sq**2)/(s13-s23)**3*z_log(-s23,-&
+ &1._ki)-1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m3_sq**3/(s13-s23)*&
+ &*3-1._ki/3._ki*(s13+m3_sq)*m3_sq**3*(s23+m3_sq)/s13**3/(s13-s23&
+ &)**3*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/3._ki/s23*q(1,1._ki+m3_sq&
+ &/s23,-sc23)*m3_sq**3/(s13-s23)**3+1._ki/2._ki*m3_sq**3*(s13+s23&
+ &+2._ki*m3_sq)/s13**2/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)-1.&
+ &_ki/6._ki/s23**2*m3_sq**3/(s13-s23)**2*q(2,1._ki+m3_sq/s23,-sc2&
+ &3)+1._ki/6._ki/s23/s13**2*(-s23**3*s13**2-m3_sq**2*s23**2*s13+2&
+ &._ki*m3_sq*s23**2*s13**2+m3_sq**3*s23**2-4._ki*s23*m3_sq**3*s13&
+ &-2._ki*s23*m3_sq*s13**3+s23*s13**4+s23*m3_sq**4+m3_sq**2*s13**3&
+ &)/(s13-s23)**3
+ !
+ c_temp_rat=1._ki/6._ki*(s23*s13**2+m3_sq*s13**2+s23**2*s13+s23**2&
+ &*m3_sq)/(s13-s23)**2/(s13+m3_sq)/(s23+m3_sq)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a3p2m_1mi_r:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Unimplemented combination of Feynman parameters"
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ end if
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ a3p2m_1mi_r=(/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ a3p2m_1mi_r=(/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ end function a3p2m_1mi_r
+ !
+ function a3p2m_1mi_c(s23,s13,m3_sq,par1,par2,par3)
+ !
+ complex(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(2) :: a3p2m_1mi_c
+ !
+ complex(ki) :: c_temp,c_temp_rat
+ real(ki) :: sc13,sc23
+ !
+ a3p2m_1mi_c(:) = 0._ki
+ !
+ sc13=sign(un,real(s13+m3_sq,ki))
+ !
+ sc23=sign(un,real(s23+m3_sq,ki))
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ c_temp=-1._ki/(s13-s23)*zdilog((s13+m3_sq)/s13,-1._ki)+zdilog((s2&
+ &3+m3_sq)/s23,-1._ki)/(s13-s23)
+ !
+ c_temp_rat = czero
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ if (par3 == 1) then
+ !
+ c_temp=s23/(s13-s23)**2*zdilog((s13+m3_sq)/s13,-1._ki)-s23/(s13-s&
+ &23)**2*zdilog((s23+m3_sq)/s23,-1._ki)-m3_sq*z_log(m3_sq,-1._ki)&
+ &/(s13-s23)**2-s23/(s13-s23)**2*z_log(-s23,-1._ki)+(s23+m3_sq)/(&
+ &s13-s23)**2*z_log(-s13,-1._ki)-1._ki/(s13-s23)+1._ki/s13*q(1,1.&
+ &_ki+m3_sq/s13,-sc13)*(s23+m3_sq)*m3_sq/(s13-s23)**2
+ !
+ c_temp_rat=-1._ki/(s13-s23)
+ !
+ else if (par3 == 2) then
+ !
+ c_temp=-s13/(s13-s23)**2*zdilog((s13+m3_sq)/s13,-1._ki)+s13/(s13-&
+ &s23)**2*zdilog((s23+m3_sq)/s23,-1._ki)+m3_sq*z_log(m3_sq,-1._ki&
+ &)/(s13-s23)**2+s13/(s13-s23)**2*z_log(-s23,-1._ki)-(s13+m3_sq)/&
+ &(s13-s23)**2*z_log(-s13,-1._ki)+1._ki/s23*q(1,1._ki+m3_sq/s23,-&
+ &sc23)*m3_sq/(s13-s23)-m3_sq*(s13+m3_sq)/s13/(s13-s23)**2*q(1,1.&
+ &_ki+m3_sq/s13,-sc13)+1._ki/(s13-s23)
+ !
+ c_temp_rat=1._ki/(s13-s23)
+ !
+ else if (par3 == 3) then
+ !
+ c_temp=-1._ki/(s13-s23)*z_log(-s23,-1._ki)+1._ki/s13*q(1,1._ki+m3&
+ &_sq/s13,-sc13)*m3_sq/(s13-s23)-1._ki/s23*q(1,1._ki+m3_sq/s23,-s&
+ &c23)*m3_sq/(s13-s23)+1._ki/(s13-s23)*z_log(-s13,-1._ki)
+ !
+ c_temp_rat=0._ki
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function a3p2m_1mi_c:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "unimplemented combination of feynman parameters"
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ else if ( (par1==0) ) then
+ !
+ if ( (par2 == 1) .and. (par3 == 1) ) then
+ !
+ c_temp=-s23**2/(s13-s23)**3*zdilog((s13+m3_sq)/s13,-1._ki)+s23**2&
+ &/(s13-s23)**3*zdilog((s23+m3_sq)/s23,-1._ki)+1._ki/2._ki*m3_sq*&
+ &(-m3_sq+2._ki*s23)/(s13-s23)**3*z_log(m3_sq,-1._ki)-1._ki/2._ki&
+ &*(s23+m3_sq)*(3._ki*s23-m3_sq)/(s13-s23)**3*z_log(-s13,-1._ki)+&
+ &3._ki/2._ki*s23**2/(s13-s23)**3*z_log(-s23,-1._ki)-1._ki/2._ki/&
+ &s13**2*m3_sq**2/(s13-s23)**3*(s23+m3_sq)**2*q(2,1._ki+m3_sq/s13&
+ &,-sc13)-m3_sq*(s23+m3_sq)*(-m3_sq+s23)/s13/(s13-s23)**3*q(1,1._&
+ &ki+m3_sq/s13,-sc13)-1._ki/4._ki*(3._ki*s13**3-12._ki*s13**2*s23&
+ &-2._ki*m3_sq*s13**2+9._ki*s13*s23**2+4._ki*m3_sq*s13*s23+2._ki*&
+ &s13*m3_sq**2-2._ki*m3_sq*s23**2-4._ki*s23*m3_sq**2-2._ki*m3_sq*&
+ &*3)/s13/(s13-s23)**3
+ !
+ c_temp_rat=-1._ki/4._ki*(3._ki*s13**2+m3_sq*s13-9._ki*s23*s13-7._&
+ &ki*m3_sq*s23)/(s13+m3_sq)/(s13-s23)**2
+ !
+ else if ( (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp=-s13**2/(s13-s23)**3*zdilog((s13+m3_sq)/s13,-1._ki)+s13**2&
+ &/(s13-s23)**3*zdilog((s23+m3_sq)/s23,-1._ki)+1._ki/2._ki*m3_sq*&
+ &(4._ki*s13-2._ki*s23-m3_sq)/(s13-s23)**3*z_log(m3_sq,-1._ki)-1.&
+ &_ki/2._ki*(s13+m3_sq)*(3._ki*s13-m3_sq)/(s13-s23)**3*z_log(-s13&
+ &,-1._ki)+1._ki/2._ki*(2._ki*s23*m3_sq+3._ki*s13**2-2._ki*m3_sq*&
+ &s13)/(s13-s23)**3*z_log(-s23,-1._ki)-1._ki/2._ki*m3_sq**2*(s13+&
+ &m3_sq)**2/s13**2/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)+m3_sq*&
+ &(s13-s23-m3_sq)/s23/(s13-s23)**2*q(1,1._ki+m3_sq/s23,-sc23)+1._&
+ &ki/2._ki/s23**2/(s13-s23)*m3_sq**2*q(2,1._ki+m3_sq/s23,-sc23)-m&
+ &3_sq*(s13-m3_sq)*(s13+m3_sq)/s13/(s13-s23)**3*q(1,1._ki+m3_sq/s&
+ &13,-sc13)+1._ki/4._ki/s13/s23*(3._ki*s13*s23**3-2._ki*m3_sq*s13&
+ &*s23**2-12._ki*s13**2*s23**2+9._ki*s13**3*s23+4._ki*m3_sq*s13**&
+ &2*s23+2._ki*m3_sq**3*s23+2._ki*m3_sq**2*s13*s23-2._ki*s13**3*m3&
+ &_sq)/(s13-s23)**3
+ !
+ c_temp_rat=1._ki/4._ki*(7._ki*m3_sq*s13+9._ki*s23*s13-m3_sq*s23-3&
+ &._ki*s23**2)/(s13-s23)**2/(s23+m3_sq)
+ !
+ else if ( (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/2._ki/(s13-s23)*z_log(-s13,-1._ki)-1._ki/2._ki/(s13-&
+ &s23)*z_log(-s23,-1._ki)-1._ki/2._ki/s13**2*m3_sq**2/(s13-s23)*q&
+ &(2,1._ki+m3_sq/s13,-sc13)-1._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)*&
+ &m3_sq/(s13-s23)+1._ki/2._ki/s23**2/(s13-s23)*m3_sq**2*q(2,1._ki&
+ &+m3_sq/s23,-sc23)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m3_sq/(s&
+ &13-s23)-1._ki/2._ki*m3_sq/s13/s23
+ !
+ c_temp_rat=-1._ki/2._ki*m3_sq/(s13+m3_sq)/(s23+m3_sq)
+ !
+ else if ( (par2 == 1) .and. (par3 == 2) ) then
+ !
+ c_temp=s23*s13/(s13-s23)**3*zdilog((s13+m3_sq)/s13,-1._ki)-s23*s1&
+ &3/(s13-s23)**3*zdilog((s23+m3_sq)/s23,-1._ki)-1._ki/2._ki*m3_sq&
+ &*(-m3_sq+2._ki*s13)/(s13-s23)**3*z_log(m3_sq,-1._ki)+1._ki/2._k&
+ &i*(s23*m3_sq-m3_sq**2+m3_sq*s13+3._ki*s23*s13)/(s13-s23)**3*z_l&
+ &og(-s13,-1._ki)-1._ki/2._ki*(s23*m3_sq-m3_sq*s13+3._ki*s23*s13)&
+ &/(s13-s23)**3*z_log(-s23,-1._ki)+1._ki/2._ki*(s23+m3_sq)*m3_sq*&
+ &*2*(s13+m3_sq)/s13**2/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)+1&
+ &._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)**2*m3_sq**2&
+ &+m3_sq*(-m3_sq**2+s23*s13)/s13/(s13-s23)**3*q(1,1._ki+m3_sq/s13&
+ &,-sc13)-1._ki/4._ki*(3._ki*s13**3-3._ki*s13*s23**2+2._ki*s23*m3&
+ &_sq**2+2._ki*m3_sq**3)/s13/(s13-s23)**3
+ !
+ c_temp_rat=-3._ki/4._ki*(s13+s23)/(s13-s23)**2
+ !
+ else if ( (par2 == 1) .and. (par3 == 3) ) then
+ !
+ c_temp=-1._ki/2._ki*(-m3_sq+s23)/(s13-s23)**2*z_log(-s13,-1._ki)+&
+ &1._ki/2._ki*(-m3_sq+s23)/(s13-s23)**2*z_log(-s23,-1._ki)-1._ki/&
+ &2._ki/s13**2*(s23+m3_sq)/(s13-s23)**2*m3_sq**2*q(2,1._ki+m3_sq/&
+ &s13,-sc13)-1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)&
+ &**2*m3_sq**2+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)/(s13-s23)**2*&
+ &m3_sq**2+1._ki/2._ki/s13*(s13**2-s23*s13-m3_sq*s13+s23*m3_sq+m3&
+ &_sq**2)/(s13-s23)**2
+ !
+ c_temp_rat=1._ki/2._ki*s13/(s13-s23)/(s13+m3_sq)
+ !
+ else if ( (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/2._ki*(s13-m3_sq)/(s13-s23)**2*z_log(-s13,-1._ki)-1.&
+ &_ki/2._ki*(s13-m3_sq)/(s13-s23)**2*z_log(-s23,-1._ki)+1._ki/2._&
+ &ki*m3_sq**2*(s13+m3_sq)/s13**2/(s13-s23)**2*q(2,1._ki+m3_sq/s13&
+ &,-sc13)+1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)**2&
+ &*m3_sq**2-1._ki/2._ki/s23**2/(s13-s23)*m3_sq**2*q(2,1._ki+m3_sq&
+ &/s23,-sc23)-1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)/(s13-s23)**2*m&
+ &3_sq**2-1._ki/2._ki/s13/s23*(-s13*s23**2+s13**2*s23+s23*m3_sq**&
+ &2+m3_sq*s13*s23-m3_sq*s13**2)/(s13-s23)**2
+ !
+ c_temp_rat=-1._ki/2._ki*s23/(s13-s23)/(s23+m3_sq)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function a3p2m_1mi_c:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "unimplemented combination of feynman parameters"
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ else
+ !
+ if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 1) ) then
+ !
+ c_temp=s23**3/(s13-s23)**4*zdilog((s13+m3_sq)/s13,-1._ki)-s23**3/&
+ &(s13-s23)**4*zdilog((s23+m3_sq)/s23,-1._ki)-1._ki/6._ki*m3_sq*(&
+ &-3._ki*s23*m3_sq+2._ki*m3_sq**2+6._ki*s23**2)/(s13-s23)**4*z_lo&
+ &g(m3_sq,-1._ki)+1._ki/6._ki*(s23+m3_sq)*(2._ki*m3_sq**2-5._ki*s&
+ &23*m3_sq+11._ki*s23**2)/(s13-s23)**4*z_log(-s13,-1._ki)-11._ki/&
+ &6._ki*s23**3/(s13-s23)**4*z_log(-s23,-1._ki)+m3_sq*(s23+m3_sq)*&
+ &(m3_sq**2+s23**2-s23*m3_sq)/s13/(s13-s23)**4*q(1,1._ki+m3_sq/s1&
+ &3,-sc13)+1._ki/3._ki/s13**3*(s23+m3_sq)**3/(s13-s23)**4*m3_sq**&
+ &3*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/2._ki*m3_sq**2*(s23+m3_sq)**&
+ &2*(-2._ki*m3_sq+s23)/s13**2/(s13-s23)**4*q(2,1._ki+m3_sq/s13,-s&
+ &c13)-1._ki/36._ki*(22._ki*s13**5-6._ki*m3_sq*s13**4-99._ki*s23*&
+ &s13**4-6._ki*m3_sq**2*s13**3+198._ki*s23**2*s13**3+36._ki*s23*m&
+ &3_sq*s13**3-54._ki*m3_sq*s23**2*s13**2-121._ki*s23**3*s13**2+18&
+ &._ki*m3_sq**3*s13**2+18._ki*m3_sq**2*s23**2*s13+24._ki*s23**3*m&
+ &3_sq*s13-36._ki*s23*m3_sq**3*s13-30._ki*m3_sq**4*s13+6._ki*s23*&
+ &*3*m3_sq**2+18._ki*s23*m3_sq**4+6._ki*m3_sq**5+18._ki*m3_sq**3*&
+ &s23**2)/s13**2/(s13-s23)**4
+ !
+ c_temp_rat=-1._ki/36._ki*(22._ki*s13**4+38._ki*m3_sq*s13**3-77._k&
+ &i*s23*s13**3-124._ki*s23*m3_sq*s13**2+121._ki*s23**2*s13**2+4._&
+ &ki*m3_sq**2*s13**2-23._ki*s23*m3_sq**2*s13+218._ki*s23**2*s13*m&
+ &3_sq+85._ki*s23**2*m3_sq**2)/(s13-s23)**3/(s13+m3_sq)**2
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp=-s13**3/(s13-s23)**4*zdilog((s13+m3_sq)/s13,-1._ki)+s13**3&
+ &/(s13-s23)**4*zdilog((s23+m3_sq)/s23,-1._ki)+1._ki/6._ki*m3_sq*&
+ &(2._ki*m3_sq**2+6._ki*s23*m3_sq+6._ki*s23**2+18._ki*s13**2-18._&
+ &ki*s23*s13-9._ki*m3_sq*s13)/(s13-s23)**4*z_log(m3_sq,-1._ki)-1.&
+ &_ki/6._ki*(s13+m3_sq)*(2._ki*m3_sq**2-5._ki*m3_sq*s13+11._ki*s1&
+ &3**2)/(s13-s23)**4*z_log(-s13,-1._ki)+1._ki/6._ki*(18._ki*s23*m&
+ &3_sq*s13+11._ki*s13**3-12._ki*m3_sq*s13**2+6._ki*m3_sq**2*s13-6&
+ &._ki*m3_sq**2*s23-6._ki*s23**2*m3_sq)/(s13-s23)**4*z_log(-s23,-&
+ &1._ki)+1._ki/3._ki/s23**3*m3_sq**3/(s13-s23)*q(3,1._ki+m3_sq/s2&
+ &3,-sc23)-m3_sq*(s13+m3_sq)*(s13**2-m3_sq*s13+m3_sq**2)/s13/(s13&
+ &-s23)**4*q(1,1._ki+m3_sq/s13,-sc13)-1._ki/3._ki*m3_sq**3*(s13+m&
+ &3_sq)**3/s13**3/(s13-s23)**4*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/2&
+ &._ki*m3_sq*(2._ki*m3_sq**2+2._ki*s13**2-4._ki*s23*s13+2._ki*s23&
+ &**2-3._ki*m3_sq*s13+3._ki*s23*m3_sq)/s23/(s13-s23)**3*q(1,1._ki&
+ &+m3_sq/s23,-sc23)-1._ki/2._ki*m3_sq**2*(s13-2._ki*m3_sq)*(s13+m&
+ &3_sq)**2/s13**2/(s13-s23)**4*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/2&
+ &._ki*m3_sq**2*(-m3_sq+s13-s23)/s23**2/(s13-s23)**2*q(2,1._ki+m3&
+ &_sq/s23,-sc23)+1._ki/36._ki/s13**2/s23**2*(-6._ki*m3_sq**2*s13*&
+ &*5+121._ki*s23**2*s13**5-24._ki*s23*m3_sq*s13**5+54._ki*s23**2*&
+ &s13**4*m3_sq+36._ki*s23*m3_sq**2*s13**4-198._ki*s23**3*s13**4-3&
+ &6._ki*s23**3*m3_sq*s13**3+99._ki*s23**4*s13**3-36._ki*s23**2*m3&
+ &_sq**2*s13**3+24._ki*s23**3*m3_sq**2*s13**2+6._ki*s23**4*m3_sq*&
+ &s13**2-22._ki*s23**5*s13**2-12._ki*s23**2*m3_sq**4*s13+6._ki*s2&
+ &3**2*m3_sq**5)/(s13-s23)**4
+ !
+ c_temp_rat=1._ki/36._ki*(218._ki*s23*m3_sq*s13**2+121._ki*s23**2*&
+ &s13**2+85._ki*m3_sq**2*s13**2-124._ki*s23**2*s13*m3_sq-23._ki*s&
+ &23*m3_sq**2*s13-77._ki*s23**3*s13+38._ki*s23**3*m3_sq+4._ki*s23&
+ &**2*m3_sq**2+22._ki*s23**4)/(s23+m3_sq)**2/(s13-s23)**3
+ !
+ else if ( (par1 == 3) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/3._ki/(s13-s23)*z_log(-s13,-1._ki)-1._ki/3._ki/(s13-&
+ &s23)*z_log(-s23,-1._ki)-1._ki/3._ki/s23**3*m3_sq**3/(s13-s23)*q&
+ &(3,1._ki+m3_sq/s23,-sc23)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*&
+ &m3_sq/(s13-s23)+1._ki/3._ki/s13**3/(s13-s23)*m3_sq**3*q(3,1._ki&
+ &+m3_sq/s13,-sc13)-1._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)*m3_sq/(s&
+ &13-s23)-1._ki/s13**2/(s13-s23)*m3_sq**2*q(2,1._ki+m3_sq/s13,-sc&
+ &13)+1._ki/s23**2/(s13-s23)*m3_sq**2*q(2,1._ki+m3_sq/s23,-sc23)-&
+ &1._ki/6._ki*(5._ki*s23*s13-s23*m3_sq-m3_sq*s13)/s23**2*m3_sq/s1&
+ &3**2
+ !
+ c_temp_rat=-1._ki/6._ki*(5._ki*s23*s13+3._ki*m3_sq*s13+m3_sq**2+3&
+ &._ki*s23*m3_sq)*m3_sq/(s13+m3_sq)**2/(s23+m3_sq)**2
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 2) ) then
+ !
+ c_temp=-s23**2*s13/(s13-s23)**4*zdilog((s13+m3_sq)/s13,-1._ki)+s2&
+ &3**2*s13/(s13-s23)**4*zdilog((s23+m3_sq)/s23,-1._ki)+1._ki/6._k&
+ &i*m3_sq*(2._ki*m3_sq**2+6._ki*s23*s13-3._ki*m3_sq*s13)/(s13-s23&
+ &)**4*z_log(m3_sq,-1._ki)-1._ki/6._ki*(2._ki*m3_sq**3+2._ki*s23*&
+ &*2*m3_sq-2._ki*m3_sq**2*s23+4._ki*s23*m3_sq*s13-m3_sq**2*s13+11&
+ &._ki*s23**2*s13)/(s13-s23)**4*z_log(-s13,-1._ki)+1._ki/6._ki*(2&
+ &._ki*s23**2*m3_sq-2._ki*m3_sq**2*s23-2._ki*s23*m3_sq*s13+2._ki*&
+ &m3_sq**2*s13+11._ki*s23**2*s13)/(s13-s23)**4*z_log(-s23,-1._ki)&
+ &-m3_sq*(m3_sq**3+s23**2*s13)/s13/(s13-s23)**4*q(1,1._ki+m3_sq/s&
+ &13,-sc13)-1._ki/3._ki*m3_sq**3*(s23+m3_sq)**2*(s13+m3_sq)/s13**&
+ &3/(s13-s23)**4*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/3._ki/s23*q(1,1&
+ &._ki+m3_sq/s23,-sc23)*m3_sq**3/(s13-s23)**3-1._ki/2._ki*m3_sq**&
+ &2*(s23+m3_sq)*(-2._ki*m3_sq**2-m3_sq*s13+s23*s13)/s13**2/(s13-s&
+ &23)**4*q(2,1._ki+m3_sq/s13,-sc13)-1._ki/36._ki*(11._ki*s13**5-6&
+ &6._ki*s23*s13**4-6._ki*m3_sq*s13**4+12._ki*s23*m3_sq*s13**3+33.&
+ &_ki*s23**2*s13**3+6._ki*m3_sq**2*s13**3-6._ki*m3_sq*s23**2*s13*&
+ &*2+22._ki*s23**3*s13**2-12._ki*s23*m3_sq**2*s13**2-6._ki*m3_sq*&
+ &*3*s13**2-12._ki*m3_sq**2*s23**2*s13+24._ki*m3_sq**4*s13+12._ki&
+ &*s23*m3_sq**3*s13-6._ki*m3_sq**3*s23**2-6._ki*m3_sq**5-12._ki*s&
+ &23*m3_sq**4)/s13**2/(s13-s23)**4
+ !
+ c_temp_rat=-1._ki/36._ki*(11._ki*s13**3-55._ki*s23*s13**2+5._ki*m&
+ &3_sq*s13**2-49._ki*s23*m3_sq*s13-22._ki*s23**2*s13-22._ki*s23**&
+ &2*m3_sq)/(s13-s23)**3/(s13+m3_sq)
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 2) ) then
+ !
+ c_temp=s23*s13**2/(s13-s23)**4*zdilog((s13+m3_sq)/s13,-1._ki)-s23&
+ &*s13**2/(s13-s23)**4*zdilog((s23+m3_sq)/s23,-1._ki)-1._ki/6._ki&
+ &*m3_sq*(2._ki*m3_sq**2+6._ki*s13**2+3._ki*s23*m3_sq-6._ki*m3_sq&
+ &*s13)/(s13-s23)**4*z_log(m3_sq,-1._ki)+1._ki/6._ki*(4._ki*s23*m&
+ &3_sq*s13+11._ki*s23*s13**2+2._ki*m3_sq**3+2._ki*m3_sq*s13**2-2.&
+ &_ki*m3_sq**2*s13-m3_sq**2*s23)/(s13-s23)**4*z_log(-s13,-1._ki)-&
+ &1._ki/6._ki*(4._ki*s23*m3_sq*s13+11._ki*s23*s13**2-4._ki*m3_sq*&
+ &s13**2+4._ki*m3_sq**2*s13-4._ki*m3_sq**2*s23)/(s13-s23)**4*z_lo&
+ &g(-s23,-1._ki)+m3_sq*(s23*s13**2+m3_sq**3)/s13/(s13-s23)**4*q(1&
+ &,1._ki+m3_sq/s13,-sc13)+1._ki/3._ki*(s23+m3_sq)*m3_sq**3*(s13+m&
+ &3_sq)**2/s13**3/(s13-s23)**4*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/6&
+ &._ki*m3_sq**2*(3._ki*s13-3._ki*s23-4._ki*m3_sq)/s23/(s13-s23)**&
+ &3*q(1,1._ki+m3_sq/s23,-sc23)+1._ki/2._ki*m3_sq**2*(s13+m3_sq)*(&
+ &s23*s13-2._ki*m3_sq**2-s23*m3_sq)/s13**2/(s13-s23)**4*q(2,1._ki&
+ &+m3_sq/s13,-sc13)+1._ki/6._ki/s23**2*m3_sq**3/(s13-s23)**2*q(2,&
+ &1._ki+m3_sq/s23,-sc23)-1._ki/36._ki/s13**2/s23*(11._ki*s23**4*s&
+ &13**2-66._ki*s23**3*s13**3-6._ki*s23**3*s13**2*m3_sq+33._ki*s23&
+ &**2*s13**4+6._ki*s23**2*m3_sq**4+12._ki*s23**2*s13**3*m3_sq+24.&
+ &_ki*s23**2*s13**2*m3_sq**2+22._ki*s13**5*s23-6._ki*s23*m3_sq*s1&
+ &3**4-18._ki*s23*m3_sq**4*s13+6._ki*s23*m3_sq**5-12._ki*s23*m3_s&
+ &q**2*s13**3+6._ki*m3_sq**2*s13**4)/(s13-s23)**4
+ !
+ c_temp_rat=-1._ki/36._ki*(22._ki*s23*s13**2+22._ki*m3_sq*s13**2+4&
+ &9._ki*s23*m3_sq*s13+55._ki*s23**2*s13-5._ki*s23**2*m3_sq-11._ki&
+ &*s23**3)/(s13-s23)**3/(s23+m3_sq)
+ !
+ else if ( (par1 == 1) .and. (par2 == 1) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/3._ki*(m3_sq**2+s23**2-s23*m3_sq)/(s13-s23)**3*z_log&
+ &(-s13,-1._ki)-1._ki/3._ki*(m3_sq**2+s23**2-s23*m3_sq)/(s13-s23)&
+ &**3*z_log(-s23,-1._ki)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m3_&
+ &sq**3/(s13-s23)**3+1._ki/3._ki/s13**3*(s23+m3_sq)**2*m3_sq**3/(&
+ &s13-s23)**3*q(3,1._ki+m3_sq/s13,-sc13)-1._ki/3._ki/s23*q(1,1._k&
+ &i+m3_sq/s23,-sc23)*m3_sq**3/(s13-s23)**3-1._ki/s13**2*(s23+m3_s&
+ &q)*m3_sq**3/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/6._ki&
+ &/s13**2*(s13**4+m3_sq*s13**3-4._ki*s23*s13**3+3._ki*s23**2*s13*&
+ &*2-3._ki*m3_sq**2*s13**2-s23**2*s13*m3_sq+4._ki*s23*m3_sq**2*s1&
+ &3+5._ki*m3_sq**3*s13-m3_sq**4-2._ki*s23*m3_sq**3-s23**2*m3_sq**&
+ &2)/(s13-s23)**3
+ !
+ c_temp_rat=1._ki/6._ki*s13*(s13**2+3._ki*m3_sq*s13-3._ki*s23*s13-&
+ &5._ki*s23*m3_sq)/(s13-s23)**2/(s13+m3_sq)**2
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/3._ki*(s13**2-m3_sq*s13+m3_sq**2)/(s13-s23)**3*z_log&
+ &(-s13,-1._ki)-1._ki/3._ki*(s13**2-m3_sq*s13+m3_sq**2)/(s13-s23)&
+ &**3*z_log(-s23,-1._ki)-1._ki/3._ki/s23**3*m3_sq**3/(s13-s23)*q(&
+ &3,1._ki+m3_sq/s23,-sc23)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m&
+ &3_sq**3/(s13-s23)**3+1._ki/3._ki*m3_sq**3*(s13+m3_sq)**2/s13**3&
+ &/(s13-s23)**3*q(3,1._ki+m3_sq/s13,-sc13)-1._ki/3._ki/s23*q(1,1.&
+ &_ki+m3_sq/s23,-sc23)*m3_sq**3/(s13-s23)**3-m3_sq**3*(s13+m3_sq)&
+ &/s13**2/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/3._ki/s23&
+ &**2*m3_sq**3/(s13-s23)**2*q(2,1._ki+m3_sq/s23,-sc23)-1._ki/6._k&
+ &i/s13**2/s23**2*(-s23*m3_sq*s13**4-m3_sq**2*s13**4+3._ki*s23**2&
+ &*s13**4-4._ki*s23**3*s13**3+4._ki*s23*m3_sq**2*s13**3+s23**3*s1&
+ &3**2*m3_sq+s23**4*s13**2-3._ki*s23**2*s13**2*m3_sq**2-3._ki*m3_&
+ &sq**3*s23**2*s13+s23**2*m3_sq**4)/(s13-s23)**3
+ !
+ c_temp_rat=-1._ki/6._ki*s23*(3._ki*s23*s13+5._ki*m3_sq*s13-s23**2&
+ &-3._ki*s23*m3_sq)/(s13-s23)**2/(s23+m3_sq)**2
+ !
+ else if ( (par1 == 1) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp=-1._ki/6._ki*(-2._ki*m3_sq+s23)/(s13-s23)**2*z_log(-s13,-1&
+ &._ki)+1._ki/6._ki*(-2._ki*m3_sq+s23)/(s13-s23)**2*z_log(-s23,-1&
+ &._ki)+1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)/(s13-s23)**2*m3_sq**&
+ &2+1._ki/3._ki/s13**3*(s23+m3_sq)/(s13-s23)**2*m3_sq**3*q(3,1._k&
+ &i+m3_sq/s13,-sc13)-1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(&
+ &s13-s23)**2*m3_sq**2-1._ki/2._ki*m3_sq**2*(s23+2._ki*m3_sq)/s13&
+ &**2/(s13-s23)**2*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/6._ki/s23**2*&
+ &m3_sq**3/(s13-s23)**2*q(2,1._ki+m3_sq/s23,-sc23)+1._ki/6._ki/s1&
+ &3**2/s23*(-s23**2*m3_sq**2-s23**2*s13**2+2._ki*s23**2*s13*m3_sq&
+ &+s23*s13**3+5._ki*s23*m3_sq**2*s13-s23*m3_sq**3-2._ki*s23*m3_sq&
+ &*s13**2-m3_sq**2*s13**2)/(s13-s23)**2
+ !
+ c_temp_rat=1._ki/6._ki*(s23*s13**2+m3_sq*s13**2-m3_sq**2*s13+m3_s&
+ &q**2*s23)/(s13-s23)/(s13+m3_sq)**2/(s23+m3_sq)
+ !
+ else if ( (par1 == 2) .and. (par2 == 3) .and. (par3 == 3) ) then
+ !
+ c_temp=1._ki/6._ki*(s13-2._ki*m3_sq)/(s13-s23)**2*z_log(-s13,-1._&
+ &ki)-1._ki/6._ki*(s13-2._ki*m3_sq)/(s13-s23)**2*z_log(-s23,-1._k&
+ &i)+1._ki/3._ki/s23**3*m3_sq**3/(s13-s23)*q(3,1._ki+m3_sq/s23,-s&
+ &c23)-1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)/(s13-s23)**2*m3_sq**2&
+ &-1._ki/3._ki*m3_sq**3*(s13+m3_sq)/s13**3/(s13-s23)**2*q(3,1._ki&
+ &+m3_sq/s13,-sc13)+1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s&
+ &13-s23)**2*m3_sq**2+1._ki/2._ki*m3_sq**2*(s13+2._ki*m3_sq)/s13*&
+ &*2/(s13-s23)**2*q(2,1._ki+m3_sq/s13,-sc13)-1._ki/6._ki*m3_sq**2&
+ &*(m3_sq+3._ki*s13-3._ki*s23)/s23**2/(s13-s23)**2*q(2,1._ki+m3_s&
+ &q/s23,-sc23)-1._ki/6._ki/s13**2/s23**2*(-s23**3*s13**2+s23**2*s&
+ &13**3+4._ki*m3_sq**2*s23**2*s13-m3_sq**3*s23**2+2._ki*m3_sq*s23&
+ &**2*s13**2-2._ki*s23*m3_sq*s13**3-2._ki*s23*m3_sq**2*s13**2+m3_&
+ &sq**2*s13**3)/(s13-s23)**2
+ !
+ c_temp_rat=-1._ki/6._ki*(s23**2*s13+m3_sq**2*s13-m3_sq**2*s23+s23&
+ &**2*m3_sq)/(s23+m3_sq)**2/(s13-s23)/(s13+m3_sq)
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) .and. (par3 == 3) ) then
+ !
+ c_temp=-1._ki/6._ki*(2._ki*s23*s13-m3_sq*s13-s23*m3_sq+2._ki*m3_s&
+ &q**2)/(s13-s23)**3*z_log(-s13,-1._ki)+1._ki/6._ki*(2._ki*s23*s1&
+ &3-m3_sq*s13-s23*m3_sq+2._ki*m3_sq**2)/(s13-s23)**3*z_log(-s23,-&
+ &1._ki)-1._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m3_sq**3/(s13-s23)*&
+ &*3-1._ki/3._ki*(s13+m3_sq)*m3_sq**3*(s23+m3_sq)/s13**3/(s13-s23&
+ &)**3*q(3,1._ki+m3_sq/s13,-sc13)+1._ki/3._ki/s23*q(1,1._ki+m3_sq&
+ &/s23,-sc23)*m3_sq**3/(s13-s23)**3+1._ki/2._ki*m3_sq**3*(s13+s23&
+ &+2._ki*m3_sq)/s13**2/(s13-s23)**3*q(2,1._ki+m3_sq/s13,-sc13)-1.&
+ &_ki/6._ki/s23**2*m3_sq**3/(s13-s23)**2*q(2,1._ki+m3_sq/s23,-sc2&
+ &3)+1._ki/6._ki/s23/s13**2*(-s23**3*s13**2-m3_sq**2*s23**2*s13+2&
+ &._ki*m3_sq*s23**2*s13**2+m3_sq**3*s23**2-4._ki*s23*m3_sq**3*s13&
+ &-2._ki*s23*m3_sq*s13**3+s23*s13**4+s23*m3_sq**4+m3_sq**2*s13**3&
+ &)/(s13-s23)**3
+ !
+ c_temp_rat=1._ki/6._ki*(s23*s13**2+m3_sq*s13**2+s23**2*s13+s23**2&
+ &*m3_sq)/(s13-s23)**2/(s13+m3_sq)/(s23+m3_sq)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function a3p2m_1mi_c:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "unimplemented combination of feynman parameters"
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ end if
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ a3p2m_1mi_c=(/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ a3p2m_1mi_c=(/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ end function a3p2m_1mi_c
+ !
+ !
+ !****if* src/integral/three_point/function_3p2m_1mi/a3p2m_1mi_np2
+ ! NAME
+ !
+ ! Function a3p2m_1mi_np2
+ !
+ ! USAGE
+ !
+ ! real_dim2 = a3p2m_1mi_np2(s23,s13,m3_sq,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the non divergent two off-shell external leg three point function in n+2 dimensions.
+ ! with up to one Feynman parameter in the numerator.
+ ! It retuns an array of 2 reals corresponding to the real/imaginary part of the
+ ! constant term.
+ !
+ ! INPUTS
+ !
+ ! * s23 -- real/complex (type ki), the value of the S matrix element corresponding to the first external off-shell leg
+ ! * s13 -- real/complex (type ki), the value of the S matrix element corresponding to the second external off-shell leg
+ ! * m3_sq -- real/complex (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter = 0
+ ! * par2 -- an integer, the label of the second Feynman parameter = 0
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 2 corresponding to
+ ! the real/imaginary part of the coefficient of the constant term. If par1 and/or par2
+ ! are different from zero, an error is returned.
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ function a3p2m_1mi_np2_r(s23,s13,m3_sq,par1,par2,par3)
+ !
+ real(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(2) :: a3p2m_1mi_np2_r
+ !
+ complex(ki) :: c_temp,c_temp_rat
+ real(ki) :: sc13,sc23
+ !
+ a3p2m_1mi_np2_r(:) = 0._ki
+ !
+ sc13=sign(un,s13+m3_sq)
+ !
+ sc23=sign(un,s23+m3_sq)
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ c_temp=1._ki/2._ki*(-s13+m3_sq)/(-s13+s23)*z_log(-s13,-1._ki)+1._&
+ &ki/2._ki*(-m3_sq+s23)/(-s13+s23)*z_log(-s23,-1._ki)+1._ki/2._ki&
+ &*m3_sq**2/s13/(-s13+s23)*q(1,1._ki+m3_sq/s13,-sc13)-3._ki/2._ki&
+ &-1._ki/2._ki*m3_sq**2/s23/(-s13+s23)*q(1,1._ki+m3_sq/s23,-sc23)
+ !
+ c_temp_rat=-3._ki/2._ki
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ a3p2m_1mi_np2_r = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ a3p2m_1mi_np2_r = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ !
+ if (par3 == 1) then
+ !
+ c_temp=-1._ki/6._ki*(-m3_sq*s23+m3_sq**2+2._ki*s13*s23-s13**2)/(s&
+ &13-s23)**2*z_log(-s13,-1._ki)+1._ki/6._ki*(-m3_sq*s23+m3_sq**2+&
+ &s23**2)/(s13-s23)**2*z_log(-s23,-1._ki)-1._ki/3._ki/s13*q(1,1._&
+ &ki+m3_sq/s13,-sc13)/(s13-s23)**2*m3_sq**3+1._ki/6._ki/s13**2*(s&
+ &23+m3_sq)/(s13-s23)**2*m3_sq**3*q(2,1._ki+m3_sq/s13,-sc13)+1._k&
+ &i/6._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)**2*m3_sq**3-1.&
+ &_ki/18._ki*(3._ki*m3_sq**3+3._ki*s23*m3_sq**2-3._ki*s13*m3_sq**&
+ &2-3._ki*s23*s13*m3_sq+3._ki*m3_sq*s13**2-19._ki*s23*s13**2+11._&
+ &ki*s23**2*s13+8._ki*s13**3)/s13/(s13-s23)**2
+ !
+ c_temp_rat=-1._ki/18._ki*(8._ki*s13**2-11._ki*s13*s23+11._ki*s13*&
+ &m3_sq-11._ki*m3_sq*s23)/(s13+m3_sq)/(s13-s23)
+ !
+ else if (par3 == 2) then
+ !
+ c_temp=1._ki/6._ki*(-s13*m3_sq+m3_sq**2+s13**2)/(s13-s23)**2*z_lo&
+ &g(-s13,-1._ki)-1._ki/6._ki*(2._ki*s13*s23-s23**2+m3_sq**2-s13*m&
+ &3_sq)/(s13-s23)**2*z_log(-s23,-1._ki)+1._ki/3._ki/s13*q(1,1._ki&
+ &+m3_sq/s13,-sc13)/(s13-s23)**2*m3_sq**3-1._ki/6._ki*(s13+m3_sq)&
+ &*m3_sq**3/s13**2/(s13-s23)**2*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/&
+ &6._ki/s23**2/(s13-s23)*m3_sq**3*q(2,1._ki+m3_sq/s23,-sc23)-1._k&
+ &i/6._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)**2*m3_sq**3+1.&
+ &_ki/18._ki/s23/s13*(3._ki*m3_sq**3*s23+3._ki*s23*s13*m3_sq**2-3&
+ &._ki*m3_sq**2*s13**2+3._ki*m3_sq*s23*s13**2-3._ki*s23**2*s13*m3&
+ &_sq-8._ki*s23**3*s13-11._ki*s13**3*s23+19._ki*s23**2*s13**2)/(s&
+ &13-s23)**2
+ !
+ c_temp_rat=-1._ki/18._ki*(11._ki*s13*m3_sq-11._ki*m3_sq*s23-8._ki&
+ &*s23**2+11._ki*s13*s23)/(s13-s23)/(s23+m3_sq)
+ !
+ else if (par3 == 3) then
+ !
+ c_temp=-1._ki/6._ki*(-s13+2._ki*m3_sq)/(s13-s23)*z_log(-s13,-1._k&
+ &i)+1._ki/6._ki*(2._ki*m3_sq-s23)/(s13-s23)*z_log(-s23,-1._ki)-1&
+ &._ki/2._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m3_sq**2/(s13-s23)+1.&
+ &_ki/6._ki/s13**2/(s13-s23)*m3_sq**3*q(2,1._ki+m3_sq/s13,-sc13)-&
+ &1._ki/6._ki/s23**2/(s13-s23)*m3_sq**3*q(2,1._ki+m3_sq/s23,-sc23&
+ &)+1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)*m3_sq**2/(s13-s23)&
+ &+1._ki/18._ki*(3._ki*m3_sq**2-8._ki*s13*s23)/s13/s23
+ !
+ c_temp_rat=-1._ki/18._ki*(8._ki*s13*m3_sq+8._ki*s13*s23+5._ki*m3_&
+ &sq**2+8._ki*m3_sq*s23)/(s23+m3_sq)/(s13+m3_sq)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function a3p2m_1mi_np2_r:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "unimplemented combination of feynman parameters"
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ a3p2m_1mi_np2_r = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ a3p2m_1mi_np2_r = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a3p3m_np2:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &'no need of 3-point integrals in 6 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = &
+ &'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb(par),3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ end function a3p2m_1mi_np2_r
+ !
+ function a3p2m_1mi_np2_c(s23,s13,m3_sq,par1,par2,par3)
+ !
+ complex(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(2) :: a3p2m_1mi_np2_c
+ !
+ complex(ki) :: c_temp,c_temp_rat
+ real(ki) :: sc13,sc23
+ !
+ a3p2m_1mi_np2_c(:) = 0._ki
+ !
+ sc13=sign(un,real(s13+m3_sq,ki))
+ !
+ sc23=sign(un,real(s23+m3_sq,ki))
+ !
+ ! cas sans parametre de feynman au numerateur
+ if ( (par1 == 0) .and. (par2 == 0) .and. (par3 == 0) ) then
+ !
+ c_temp=1._ki/2._ki*(-s13+m3_sq)/(-s13+s23)*z_log(-s13,-1._ki)+1._&
+ &ki/2._ki*(-m3_sq+s23)/(-s13+s23)*z_log(-s23,-1._ki)+1._ki/2._ki&
+ &*m3_sq**2/s13/(-s13+s23)*q(1,1._ki+m3_sq/s13,-sc13)-3._ki/2._ki&
+ &-1._ki/2._ki*m3_sq**2/s23/(-s13+s23)*q(1,1._ki+m3_sq/s23,-sc23)
+ !
+ c_temp_rat=-3._ki/2._ki
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ a3p2m_1mi_np2_c = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ a3p2m_1mi_np2_c = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function a3p2m_1mi_np2_c:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "unimplemented combination of feynman parameters"
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ ! cas avec un parametre de feynman au numerateur
+ else if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ !
+ if (par3 == 1) then
+ !
+ c_temp=-1._ki/6._ki*(-m3_sq*s23+m3_sq**2+2._ki*s13*s23-s13**2)/(s&
+ &13-s23)**2*z_log(-s13,-1._ki)+1._ki/6._ki*(-m3_sq*s23+m3_sq**2+&
+ &s23**2)/(s13-s23)**2*z_log(-s23,-1._ki)-1._ki/3._ki/s13*q(1,1._&
+ &ki+m3_sq/s13,-sc13)/(s13-s23)**2*m3_sq**3+1._ki/6._ki/s13**2*(s&
+ &23+m3_sq)/(s13-s23)**2*m3_sq**3*q(2,1._ki+m3_sq/s13,-sc13)+1._k&
+ &i/6._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)**2*m3_sq**3-1.&
+ &_ki/18._ki*(3._ki*m3_sq**3+3._ki*s23*m3_sq**2-3._ki*s13*m3_sq**&
+ &2-3._ki*s23*s13*m3_sq+3._ki*m3_sq*s13**2-19._ki*s23*s13**2+11._&
+ &ki*s23**2*s13+8._ki*s13**3)/s13/(s13-s23)**2
+ !
+ c_temp_rat=-1._ki/18._ki*(8._ki*s13**2-11._ki*s13*s23+11._ki*s13*&
+ &m3_sq-11._ki*m3_sq*s23)/(s13+m3_sq)/(s13-s23)
+ !
+ else if (par3 == 2) then
+ !
+ c_temp=1._ki/6._ki*(-s13*m3_sq+m3_sq**2+s13**2)/(s13-s23)**2*z_lo&
+ &g(-s13,-1._ki)-1._ki/6._ki*(2._ki*s13*s23-s23**2+m3_sq**2-s13*m&
+ &3_sq)/(s13-s23)**2*z_log(-s23,-1._ki)+1._ki/3._ki/s13*q(1,1._ki&
+ &+m3_sq/s13,-sc13)/(s13-s23)**2*m3_sq**3-1._ki/6._ki*(s13+m3_sq)&
+ &*m3_sq**3/s13**2/(s13-s23)**2*q(2,1._ki+m3_sq/s13,-sc13)+1._ki/&
+ &6._ki/s23**2/(s13-s23)*m3_sq**3*q(2,1._ki+m3_sq/s23,-sc23)-1._k&
+ &i/6._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)/(s13-s23)**2*m3_sq**3+1.&
+ &_ki/18._ki/s23/s13*(3._ki*m3_sq**3*s23+3._ki*s23*s13*m3_sq**2-3&
+ &._ki*m3_sq**2*s13**2+3._ki*m3_sq*s23*s13**2-3._ki*s23**2*s13*m3&
+ &_sq-8._ki*s23**3*s13-11._ki*s13**3*s23+19._ki*s23**2*s13**2)/(s&
+ &13-s23)**2
+ !
+ c_temp_rat=-1._ki/18._ki*(11._ki*s13*m3_sq-11._ki*m3_sq*s23-8._ki&
+ &*s23**2+11._ki*s13*s23)/(s13-s23)/(s23+m3_sq)
+ !
+ else if (par3 == 3) then
+ !
+ c_temp=-1._ki/6._ki*(-s13+2._ki*m3_sq)/(s13-s23)*z_log(-s13,-1._k&
+ &i)+1._ki/6._ki*(2._ki*m3_sq-s23)/(s13-s23)*z_log(-s23,-1._ki)-1&
+ &._ki/2._ki/s13*q(1,1._ki+m3_sq/s13,-sc13)*m3_sq**2/(s13-s23)+1.&
+ &_ki/6._ki/s13**2/(s13-s23)*m3_sq**3*q(2,1._ki+m3_sq/s13,-sc13)-&
+ &1._ki/6._ki/s23**2/(s13-s23)*m3_sq**3*q(2,1._ki+m3_sq/s23,-sc23&
+ &)+1._ki/2._ki/s23*q(1,1._ki+m3_sq/s23,-sc23)*m3_sq**2/(s13-s23)&
+ &+1._ki/18._ki*(3._ki*m3_sq**2-8._ki*s13*s23)/s13/s23
+ !
+ c_temp_rat=-1._ki/18._ki*(8._ki*s13*m3_sq+8._ki*s13*s23+5._ki*m3_&
+ &sq**2+8._ki*m3_sq*s23)/(s23+m3_sq)/(s13+m3_sq)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function a3p2m_1mi_np2_c:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "unimplemented combination of feynman parameters"
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'par1=%d0, par2,par3 = %d1'
+ tab_erreur_par(3)%arg_int = par1
+ tab_erreur_par(3)%arg_int_tab = (/par2,par3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ if ( (rat_or_tot_par%tot_selected) ) then
+ !
+ a3p2m_1mi_np2_c = (/real(c_temp,ki),aimag(c_temp)/)
+ !
+ else !if ( (rat_or_tot_par%rat_selected) ) then
+ !
+ a3p2m_1mi_np2_c = (/real(c_temp_rat,ki),aimag(c_temp_rat)/)
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a3p3m_np2:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ &'no need of 3-point integrals in 6 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = &
+ &'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb(par),3/)
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ end function a3p2m_1mi_np2_c
+ !
+ !
+ !****if* src/integral/three_point/function_3p2m_1mi/eval_numer_gi
+ ! NAME
+ !
+ ! Function eval_numer_gi
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_gi(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the integrand that will be computed numerically
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integral variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, use the values of the local (for this module) variables
+ ! eps_glob,s23_glob,s13_glob,s23_glob,par1_glob,par2_glob,par3_glob,dim_glob
+ ! and also the global variables alpha_par,beta_par and lambda_par given
+ ! by the module parametre (src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) which is the value of the
+ ! integrand at the value u
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_gi(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_gi
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ z = x - eps_glob*i_*y
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ !
+ eval_numer_gi = fg(z,s23_glob,s13_glob,m3_sq_glob,&
+ & par1_glob,par2_glob,par3_glob,&
+ & dim_glob)
+ eval_numer_gi = eval_numer_gi*jacob
+ !
+ end function eval_numer_gi
+ !
+ !****if* src/integral/three_point/function_3p2m_1mi/fg
+ ! NAME
+ !
+ ! Function fg
+ !
+ ! USAGE
+ !
+ ! complex = fg(z,s23,s13,m3_sq,par1,par2,par3,dim)
+ !
+ ! DESCRIPTION
+ !
+ ! This function gives the structure of the integrand for the different cases
+ !
+ ! INPUTS
+ !
+ ! * z -- a complex (type ki), the integral variable
+ ! * s23 -- complex (type ki), the value of the S matrix element corresponding to the first external off-shell leg
+ ! * s13 -- complex (type ki), the value of the S matrix element corresponding to the second external off-shell leg
+ ! * m3_sq -- complex (type ki), the value of the internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! * dim -- a character (length 3), to compute in n or n+2 dimensions,
+ ! the values are "ndi", "n+2"
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function fg(z,s23,s13,m3_sq,par1,par2,par3,dim)
+ !
+ complex(ki), intent (in) :: z
+ complex(ki), intent (in) :: s23,s13,m3_sq
+ integer, intent (in) :: par1,par2,par3
+ character (len=3) :: dim
+ complex(ki) :: fg
+ !
+ integer, dimension(3) :: par
+ integer :: nb_par
+ complex(ki) :: d1_var,d2_var
+ !
+ par = (/par1,par2,par3/)
+ nb_par = count(mask=par/=0)
+ !
+ d1_var=-z*(s13-s23)-s23
+ !
+ d2_var=-z*(s13-s23)-s23-m3_sq
+ !
+ if (dim == "ndi") then
+ !
+ if (nb_par == 0) then
+ !
+ fg=log(d1_var)*m3_sq/d1_var/d2_var-log(m3_sq)*m3_sq/d1_var/d2_var
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ fg=m3_sq/d1_var*z/d2_var-log(d1_var)*m3_sq**2/d1_var*z/d2_var**2+&
+ &log(m3_sq)*m3_sq**2/d1_var*z/d2_var**2+z/d1_var
+ !
+ case(2)
+ !
+ fg=m3_sq/d1_var/d2_var-log(d1_var)*m3_sq**2/d1_var/d2_var**2+log(&
+ &m3_sq)*m3_sq**2/d1_var/d2_var**2-m3_sq/d1_var*z/d2_var+log(d1_v&
+ &ar)*m3_sq**2/d1_var*z/d2_var**2-log(m3_sq)*m3_sq**2/d1_var*z/d2&
+ &_var**2-z/d1_var+1._ki/d1_var
+ !
+ case(3)
+ !
+ fg=-1._ki/d2_var+m3_sq*log(d1_var)/d2_var**2-m3_sq*log(m3_sq)/d2_&
+ &var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 1, 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 2) then
+ !
+ select case(par2)
+ !
+ case(1)
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ fg=1._ki/2._ki*m3_sq/d1_var*z**2/d2_var-m3_sq**2/d1_var*z**2/d2_v&
+ &ar**2+log(d1_var)*m3_sq**3/d1_var*z**2/d2_var**3-log(m3_sq)*m3_&
+ &sq**3/d1_var*z**2/d2_var**3+3._ki/2._ki*z**2/d1_var
+ !
+ case(2)
+ !
+ fg=log(d1_var)*m3_sq**3/d1_var*z/d2_var**3-log(m3_sq)*m3_sq**3/d1&
+ &_var*z/d2_var**3-log(d1_var)*m3_sq**3/d1_var*z**2/d2_var**3+log&
+ &(m3_sq)*m3_sq**3/d1_var*z**2/d2_var**3+1._ki/2._ki*m3_sq/d1_var&
+ &*z/d2_var-m3_sq**2/d1_var*z/d2_var**2-1._ki/2._ki*m3_sq/d1_var*&
+ &z**2/d2_var+m3_sq**2/d1_var*z**2/d2_var**2+3._ki/2._ki*z/d1_var&
+ &-3._ki/2._ki*z**2/d1_var
+ !
+ case(3)
+ !
+ fg=-1._ki/2._ki*z/d2_var+m3_sq*z/d2_var**2-m3_sq**2*log(d1_var)*z&
+ &/d2_var**3+m3_sq**2*log(m3_sq)*z/d2_var**3
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 1, 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ fg=1._ki/2._ki*m3_sq/d1_var/d2_var-log(m3_sq)*m3_sq**3/d1_var/d2_&
+ &var**3-m3_sq/d1_var*z/d2_var+2._ki*m3_sq**2/d1_var*z/d2_var**2+&
+ &1._ki/2._ki*m3_sq/d1_var*z**2/d2_var-m3_sq**2/d1_var*z**2/d2_va&
+ &r**2+log(d1_var)*m3_sq**3/d1_var/d2_var**3-m3_sq**2/d1_var/d2_v&
+ &ar**2-2._ki*log(d1_var)*m3_sq**3/d1_var*z/d2_var**3+2._ki*log(m&
+ &3_sq)*m3_sq**3/d1_var*z/d2_var**3+log(d1_var)*m3_sq**3/d1_var*z&
+ &**2/d2_var**3-log(m3_sq)*m3_sq**3/d1_var*z**2/d2_var**3-3._ki*z&
+ &/d1_var+3._ki/2._ki*z**2/d1_var+3._ki/2._ki/d1_var
+ !
+ case(3)
+ !
+ fg=-1._ki/2._ki/d2_var+m3_sq/d2_var**2-m3_sq**2*log(d1_var)/d2_va&
+ &r**3+m3_sq**2*log(m3_sq)/d2_var**3+1._ki/2._ki*z/d2_var-m3_sq*z&
+ &/d2_var**2+m3_sq**2*log(d1_var)*z/d2_var**3-m3_sq**2*log(m3_sq)&
+ &*z/d2_var**3
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ fg=-1._ki/2._ki/d2_var+m3_sq*log(d1_var)/d2_var**2-m3_sq*log(m3_s&
+ &q)/d2_var**2-m3_sq/d2_var**2+m3_sq**2*log(d1_var)/d2_var**3-m3_&
+ &sq**2*log(m3_sq)/d2_var**3
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par2 should be 1, 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 3) then
+ !
+ select case(par1)
+ !
+ case(1)
+ !
+ select case(par2)
+ !
+ case(1)
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ fg=1._ki/3._ki*m3_sq/d1_var*z**3/d2_var-1._ki/2._ki*m3_sq**2/d1_v&
+ &ar*z**3/d2_var**2+m3_sq**3/d1_var*z**3/d2_var**3-log(d1_var)*m3&
+ &_sq**4/d1_var*z**3/d2_var**4+log(m3_sq)*m3_sq**4/d1_var*z**3/d2&
+ &_var**4+11._ki/6._ki*z**3/d1_var
+ !
+ case(2)
+ !
+ fg=1._ki/3._ki*m3_sq/d1_var*z**2/d2_var-1._ki/2._ki*m3_sq**2/d1_v&
+ &ar*z**2/d2_var**2+m3_sq**3/d1_var*z**2/d2_var**3-1._ki/3._ki*m3&
+ &_sq/d1_var*z**3/d2_var+1._ki/2._ki*m3_sq**2/d1_var*z**3/d2_var*&
+ &*2-m3_sq**3/d1_var*z**3/d2_var**3-log(d1_var)*m3_sq**4/d1_var*z&
+ &**2/d2_var**4+log(m3_sq)*m3_sq**4/d1_var*z**2/d2_var**4+log(d1_&
+ &var)*m3_sq**4/d1_var*z**3/d2_var**4-log(m3_sq)*m3_sq**4/d1_var*&
+ &z**3/d2_var**4+11._ki/6._ki*z**2/d1_var-11._ki/6._ki*z**3/d1_va&
+ &r
+ !
+ case(3)
+ !
+ fg=-1._ki/3._ki*z**2/d2_var+1._ki/2._ki*m3_sq*z**2/d2_var**2-m3_s&
+ &q**2*z**2/d2_var**3+m3_sq**3*log(d1_var)*z**2/d2_var**4-m3_sq**&
+ &3*log(m3_sq)*z**2/d2_var**4
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 1, 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ fg=1._ki/3._ki*m3_sq/d1_var*z/d2_var-1._ki/2._ki*m3_sq**2/d1_var*&
+ &z/d2_var**2+m3_sq**3/d1_var*z/d2_var**3-2._ki/3._ki*m3_sq/d1_va&
+ &r*z**2/d2_var+m3_sq**2/d1_var*z**2/d2_var**2-2._ki*m3_sq**3/d1_&
+ &var*z**2/d2_var**3+1._ki/3._ki*m3_sq/d1_var*z**3/d2_var-1._ki/2&
+ &._ki*m3_sq**2/d1_var*z**3/d2_var**2+m3_sq**3/d1_var*z**3/d2_var&
+ &**3-log(d1_var)*m3_sq**4/d1_var*z/d2_var**4+log(m3_sq)*m3_sq**4&
+ &/d1_var*z/d2_var**4+2._ki*log(d1_var)*m3_sq**4/d1_var*z**2/d2_v&
+ &ar**4-2._ki*log(m3_sq)*m3_sq**4/d1_var*z**2/d2_var**4-log(d1_va&
+ &r)*m3_sq**4/d1_var*z**3/d2_var**4+log(m3_sq)*m3_sq**4/d1_var*z*&
+ &*3/d2_var**4+11._ki/6._ki*z/d1_var-11._ki/3._ki*z**2/d1_var+11.&
+ &_ki/6._ki*z**3/d1_var
+ !
+ case(3)
+ !
+ fg=-1._ki/3._ki*z/d2_var+1._ki/2._ki*m3_sq*z/d2_var**2-m3_sq**2*z&
+ &/d2_var**3+m3_sq**3*log(d1_var)*z/d2_var**4-m3_sq**3*log(m3_sq)&
+ &*z/d2_var**4+1._ki/3._ki*z**2/d2_var-1._ki/2._ki*m3_sq*z**2/d2_&
+ &var**2+m3_sq**2*z**2/d2_var**3-m3_sq**3*log(d1_var)*z**2/d2_var&
+ &**4+m3_sq**3*log(m3_sq)*z**2/d2_var**4
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ fg=-1._ki/6._ki*z/d2_var+1._ki/2._ki*m3_sq*z/d2_var**2-m3_sq**2*l&
+ &og(d1_var)*z/d2_var**3+m3_sq**2*log(m3_sq)*z/d2_var**3+m3_sq**2&
+ &*z/d2_var**3-m3_sq**3*log(d1_var)*z/d2_var**4+m3_sq**3*log(m3_s&
+ &q)*z/d2_var**4
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par2 should be 1, 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par2)
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ fg=-3._ki*log(d1_var)*m3_sq**4/d1_var*z**2/d2_var**4+3._ki*log(m3&
+ &_sq)*m3_sq**4/d1_var*z**2/d2_var**4+3._ki*log(d1_var)*m3_sq**4/&
+ &d1_var*z/d2_var**4-3._ki*log(m3_sq)*m3_sq**4/d1_var*z/d2_var**4&
+ &+m3_sq/d1_var*z**2/d2_var-1._ki/3._ki*m3_sq/d1_var*z**3/d2_var-&
+ &m3_sq/d1_var*z/d2_var-3._ki/2._ki*m3_sq**2/d1_var*z**2/d2_var**&
+ &2+1._ki/2._ki*m3_sq**2/d1_var*z**3/d2_var**2-m3_sq**3/d1_var*z*&
+ &*3/d2_var**3+log(d1_var)*m3_sq**4/d1_var*z**3/d2_var**4-log(m3_&
+ &sq)*m3_sq**4/d1_var*z**3/d2_var**4+3._ki*m3_sq**3/d1_var*z**2/d&
+ &2_var**3-3._ki*m3_sq**3/d1_var*z/d2_var**3+1._ki/3._ki*m3_sq/d1&
+ &_var/d2_var-1._ki/2._ki*m3_sq**2/d1_var/d2_var**2+m3_sq**3/d1_v&
+ &ar/d2_var**3+3._ki/2._ki*m3_sq**2/d1_var*z/d2_var**2-log(d1_var&
+ &)*m3_sq**4/d1_var/d2_var**4+log(m3_sq)*m3_sq**4/d1_var/d2_var**&
+ &4-11._ki/2._ki*z/d1_var+11._ki/2._ki*z**2/d1_var-11._ki/6._ki*z&
+ &**3/d1_var+11._ki/6._ki/d1_var
+ !
+ case(3)
+ !
+ fg=-1._ki/3._ki/d2_var+1._ki/2._ki*m3_sq/d2_var**2-m3_sq**2/d2_va&
+ &r**3+m3_sq**3*log(d1_var)/d2_var**4-m3_sq**3*log(m3_sq)/d2_var*&
+ &*4+2._ki/3._ki*z/d2_var-m3_sq*z/d2_var**2+2._ki*m3_sq**2*z/d2_v&
+ &ar**3-2._ki*m3_sq**3*log(d1_var)*z/d2_var**4+2._ki*m3_sq**3*log&
+ &(m3_sq)*z/d2_var**4-1._ki/3._ki*z**2/d2_var+1._ki/2._ki*m3_sq*z&
+ &**2/d2_var**2-m3_sq**2*z**2/d2_var**3+m3_sq**3*log(d1_var)*z**2&
+ &/d2_var**4-m3_sq**3*log(m3_sq)*z**2/d2_var**4
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ fg=-1._ki/6._ki/d2_var+1._ki/2._ki*m3_sq/d2_var**2-m3_sq**2*log(d&
+ &1_var)/d2_var**3+m3_sq**2*log(m3_sq)/d2_var**3+m3_sq**2/d2_var*&
+ &*3-m3_sq**3*log(d1_var)/d2_var**4+m3_sq**3*log(m3_sq)/d2_var**4&
+ &+1._ki/6._ki*z/d2_var-1._ki/2._ki*m3_sq*z/d2_var**2+m3_sq**2*lo&
+ &g(d1_var)*z/d2_var**3-m3_sq**2*log(m3_sq)*z/d2_var**3-m3_sq**2*&
+ &z/d2_var**3+m3_sq**3*log(d1_var)*z/d2_var**4-m3_sq**3*log(m3_sq&
+ &)*z/d2_var**4
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par2 should be 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par2)
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ fg=-1._ki/3._ki/d2_var+m3_sq*log(d1_var)/d2_var**2-m3_sq*log(m3_s&
+ &q)/d2_var**2-3._ki/2._ki*m3_sq/d2_var**2+2._ki*m3_sq**2*log(d1_&
+ &var)/d2_var**3-2._ki*m3_sq**2*log(m3_sq)/d2_var**3-m3_sq**2/d2_&
+ &var**3+m3_sq**3*log(d1_var)/d2_var**4-m3_sq**3*log(m3_sq)/d2_va&
+ &r**4
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par2 should be 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par1 should be 1, 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Unexpected value for nb_par = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else if (dim == "n+2") then
+ !
+ if (nb_par == 0) then
+ !
+ fg=1._ki/2._ki*m3_sq**2*log(m3_sq)/d2_var**2-1._ki/2._ki*(m3_sq-d&
+ &2_var)*(m3_sq+d2_var)/d2_var**2*log(d1_var)+1._ki/2._ki*(m3_sq-&
+ &2._ki*d2_var)/d2_var
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ fg=-1._ki/3._ki*m3_sq**3*log(m3_sq)*z/d2_var**3+1._ki/3._ki*log(d&
+ &1_var)/d2_var**3*(m3_sq+d2_var)*(m3_sq**2-m3_sq*d2_var+d2_var**&
+ &2)*z-1._ki/18._ki/d2_var**2*(-3._ki*m3_sq*d2_var+6._ki*m3_sq**2&
+ &+13._ki*d2_var**2)*z
+ !
+ case(2)
+ !
+ fg=-1._ki/3._ki*m3_sq**3*log(m3_sq)/d2_var**3*(1._ki-z)+1._ki/3._&
+ &ki*log(d1_var)/d2_var**3*(m3_sq+d2_var)*(m3_sq**2-m3_sq*d2_var+&
+ &d2_var**2)*(1._ki-z)-1._ki/18._ki/d2_var**2*(-3._ki*m3_sq*d2_va&
+ &r+6._ki*m3_sq**2+13._ki*d2_var**2)*(1._ki-z)
+ !
+ case(3)
+ !
+ fg=1._ki/6._ki*m3_sq**2*(3._ki*d2_var+2._ki*m3_sq)/d2_var**3*log(&
+ &m3_sq)-1._ki/6._ki*(2._ki*m3_sq-d2_var)*(m3_sq+d2_var)**2/d2_va&
+ &r**3*log(d1_var)+1._ki/18._ki*(6._ki*m3_sq*d2_var-5._ki*d2_var*&
+ &*2+6._ki*m3_sq**2)/d2_var**2
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "par3 should be 1, 2 or 3 but is %d0"
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "Unexpected value for nb_par = %d0"
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in function fg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & "dim is %c0"
+ tab_erreur_par(2)%arg_char = dim
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ end function fg
+ !
+end module function_3p2m_1mi
diff --git a/golem95c-1.2.1/integrals/three_point/function_3p3m.f90 b/golem95c-1.2.1/integrals/three_point/function_3p3m.f90
new file mode 100644
index 0000000..531240b
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/function_3p3m.f90
@@ -0,0 +1,1614 @@
+!
+!****h* src/integral/three_point/function_3p3m
+! NAME
+!
+! Module function_3p3m
+!
+! USAGE
+!
+! use function_3p3m
+!
+! DESCRIPTION
+!
+! This module is used to compute the three off-shell external leg three point function
+! with no internal leg with/without Feynman parameters in n, n+2 dimensions
+!
+! OUTPUT
+!
+! This module exports three functions:
+! * f3p3m -- a function for the computation of the three mass three
+! point function with/without Feynman parameters in n, n+2 dimensions
+! * f3p3m_c -- a function which computes the same thing as f3p3m, only
+! the format of the return values is different
+! * i3_3mass -- a function for the computation of the scalar three mass three
+! point function in n dimensions
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_2p (src/integrals/two_point/generic_function_2p.f90)
+! * multiply_div (src/module/multiply_div.f90)
+! * s_matrix_type (src/module/s_matrix_type.f90)
+!
+!*****
+module function_3p3m
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use sortie_erreur
+ use generic_function_2p
+ use multiply_div
+ use s_matrix_type
+ use matrice_s, only : prepare_s_matrix_local
+ implicit none
+ !
+ private
+ !
+ real(ki) :: s12_glob,s23_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob
+ character (len=3) :: dim_glob
+ !
+ real(ki), dimension(3) :: b
+ real(ki) :: sumb
+ real(ki), dimension(3,3) :: invs,s_mat_loc
+ integer, dimension(3) :: par
+ integer, dimension(3) :: s = (/1,2,3/)
+ type (s_matrix_poly) :: s_mat_p_loc
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:,:), allocatable :: deja_calcule2
+ real(ki),dimension(:,:,:), allocatable :: resultat2
+ logical, dimension(:), allocatable :: deja_calcule_np2
+ real(ki),dimension(:,:), allocatable :: resultat_np2
+ logical, dimension(:,:,:), allocatable :: deja_calcule22
+ real(ki),dimension(:,:,:,:), allocatable :: resultat22
+ !
+ public :: f3p3m,i3_3mass,f3p3m_c
+ !
+ contains
+ !
+ !****f* src/integral/three_point/function_3p3m/f3p3m
+ ! NAME
+ !
+ ! Function f3p3m
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f3p3m(dim,m1,m2,m3,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the three off-shell external leg three point function in n
+ ! and n+2 dimension. It uses the formula of ref.
+ ! It switches to numerical evaluation if the Gram determinant is smaller than
+ ! coupure_3p3m (in src/module/parametre.f90)
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (length 3), to compute in n or n+2 dimensions,
+ ! the values are "ndi", "n+2"
+ ! * m1 -- a real (type ki), the first mass squared
+ ! * m2 -- a real (type ki), the second mass squared
+ ! * m3 -- a real (type ki), the third mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 4 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term. If par1 and/or par2
+ ! are different from zero for dim="n+2", an error is returned.
+ !
+ ! EXAMPLE
+ !
+ ! three mass three point function without Feynman parameters in n dimensions
+ ! f3p3m("ndi",m1,m2,m3,0,0,0)
+ ! with one Feynman parameter at the numerator z_1 in n dimensions
+ ! f3p3m("ndi",m1,m2,m3,0,0,1)
+ ! with three Feynman parameters at the numerator z_2^2 z_3 in n dimensions
+ ! f3p3m("ndi",m1,m2,m3,2,2,3)
+ ! three mass three point function without Feynman parameters in n+2 dimensions
+ ! f3p3m("n+2",m1,m2,m3,0,0,0)
+ ! with one Feynman parameter at the numerator z_1 in n+2 dimensions
+ ! f3p3m("n+2",m1,m2,m3,0,0,1)
+ !
+ !*****
+ function f3p3m(dim,m1,m2,m3,par1,par2,par3)
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p3m
+ !
+ integer :: nb_par
+ real(ki) :: lamb
+ real(ki) :: plus_grand
+ real(ki) :: norma
+ complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3/)
+ !
+ s_mat_loc(1,:) = (/0._ki,m2,m1/)
+ s_mat_loc(2,:) = (/m2,0._ki,m3/)
+ s_mat_loc(3,:) = (/m1,m3,0._ki/)
+ !
+ ! on redefinit la matrice S de telle facon a ce que ces elements
+ ! soient entre -1 et 1
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ plus_grand = maxval(array=abs(s_mat_loc))
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ plus_grand = 1._ki
+ !
+ end if
+ !
+ s_mat_loc = s_mat_loc/plus_grand
+ !
+ s_mat_p_loc = assign_s_matrix(s_mat_loc)
+ call prepare_s_matrix_local(s_mat_p_loc,s)
+ !
+ b(1) = (s_mat_loc(1,3)+s_mat_loc(1,2)-s_mat_loc(2,3))/(2._ki*s_mat_loc(1,3)*s_mat_loc(1,2))
+ b(2) = (s_mat_loc(1,2)+s_mat_loc(2,3)-s_mat_loc(1,3))/(2._ki*s_mat_loc(1,2)*s_mat_loc(2,3))
+ b(3) = (s_mat_loc(1,3)+s_mat_loc(2,3)-s_mat_loc(1,2))/(2._ki*s_mat_loc(1,3)*s_mat_loc(2,3))
+ !
+ sumb = (2._ki*s_mat_loc(1,3)*s_mat_loc(2,3)+2._ki*s_mat_loc(1,2)*s_mat_loc(2,3)&
+ &+2._ki*s_mat_loc(1,3)*s_mat_loc(1,2)-s_mat_loc(1,3)*s_mat_loc(1,3)-s_mat_loc(1,2)*s_mat_loc(1,2)&
+ &-s_mat_loc(2,3)*s_mat_loc(2,3))/(2._ki*s_mat_loc(1,3)*s_mat_loc(1,2)*s_mat_loc(2,3))
+ !
+ invs(1,1) = -s_mat_loc(2,3)/s_mat_loc(1,2)/s_mat_loc(1,3)/2._ki
+ invs(1,2) = 1._ki/s_mat_loc(1,2)/2._ki
+ invs(1,3) = 1._ki/s_mat_loc(1,3)/2._ki
+ invs(2,1) = 1._ki/s_mat_loc(1,2)/2._ki
+ invs(2,2) = -s_mat_loc(1,3)/s_mat_loc(1,2)/s_mat_loc(2,3)/2._ki
+ invs(2,3) = 1._ki/s_mat_loc(2,3)/2._ki
+ invs(3,1) = 1._ki/s_mat_loc(1,3)/2._ki
+ invs(3,2) = 1._ki/s_mat_loc(2,3)/2._ki
+ invs(3,3) = -s_mat_loc(1,2)/s_mat_loc(1,3)/s_mat_loc(2,3)/2._ki
+ !
+ lamb = 2._ki*s_mat_loc(1,3)*s_mat_loc(2,3)+2._ki*s_mat_loc(1,2)*s_mat_loc(2,3)&
+ +2._ki*s_mat_loc(1,3)*s_mat_loc(1,2)-s_mat_loc(1,3)*s_mat_loc(1,3)-s_mat_loc(1,2)*s_mat_loc(1,2)&
+ -s_mat_loc(2,3)*s_mat_loc(2,3)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ !
+ norma = -1._ki/2._ki
+ !
+ else if (nb_par == 1) then
+ !
+ norma = -1._ki/6._ki
+ !
+ else
+ !
+ norma = 0._ki
+ !
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(4))
+ allocate(resultat(4,2))
+ allocate(deja_calcule2(3,4))
+ allocate(resultat2(3,4,4))
+ allocate(deja_calcule_np2(4))
+ allocate(resultat_np2(4,4))
+ allocate(deja_calcule22(3,4,4))
+ allocate(resultat22(3,4,4,4))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule2 = .false.
+ resultat2 = 0._ki
+ deja_calcule_np2 = .false.
+ resultat_np2 = 0._ki
+ deja_calcule22 = .false.
+ resultat22 = 0._ki
+ !
+ f3p3m = 0._ki
+ !
+ if ( (rat_or_tot_par%rat_selected) .and. (abs(lamb) <= coupure_4p1m) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p3m (in file function_3p3m.f90): &
+ &the flag rat to compute the rational part is on &
+ &and the program reachs a region of phase space in &
+ &which det(G) = 0 Be careful that the rational part &
+ &is not well behaved in this region&
+ &Nevertheless if the user wants to go on, he has to &
+ &reduce the value of the parameter coupure_3p3m'
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ if (abs(sumb) > coupure_3p3m) then
+ !
+ ! analytic computation
+ !
+ if (dim == "ndi") then
+ !
+ f3p3m(3:4)= a3p3m(s_mat_loc(1,3),s_mat_loc(1,2),s_mat_loc(2,3),par1,par2,par3)&
+ &/plus_grand
+ !
+ else if (dim == "n+2") then
+ !
+ f3p3m = a3p3m_np2(s_mat_loc(1,3),s_mat_loc(1,2),s_mat_loc(2,3),par1,par2,par3)
+ f3p3m(3) = f3p3m(3)-log(plus_grand)*norma
+ ! mu2_scale_par is already contained in the bubbles,
+ ! but scaling of s_mat_loc still needs to be undone
+ !
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p3m (function_3p3m.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'dim = %c0'
+ tab_erreur_par(2)%arg_char = dim
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else
+ !
+ ! numerical computation
+ !
+ dim_glob = dim
+ par1_glob = par1
+ par2_glob = par2
+ par3_glob = par3
+ !
+ s13_glob = s_mat_loc(1,3)
+ s12_glob = s_mat_loc(1,2)
+ s23_glob = s_mat_loc(2,3)
+ !
+ resto = 0._ki
+ abserro = 0._ki
+ !
+ ! on pose z = x - i*eps*y (avec x et y > 0)
+ ! z*s13+(1-z)*s23 = s23+x*(s13-s23)-i*eps*y*(s13-s23)
+ ! on veut la partie imaginaire du meme signe que i*lambda
+ ! => eps*(s13-s23) < 0
+ !
+ ! faire attention que suivant le signe de eps_glob, on tourne dans le
+ ! sens des aiguilles d'une montre ou inversement
+ ! eps_glob = 1, on ferme le contour vers le bas --> -2 i Pi residu
+ ! eps_glob = -1, on ferme le contour vers le haut --> +2 i Pi residu
+ !
+ eps_glob = sign(1._ki,s23_glob-s13_glob)
+ !
+ origine_info_par = "f3p3m, dimension "//dim
+ num_grand_b_info_par = lamb
+ denom_grand_b_info_par = (2._ki*s_mat_loc(1,3)*s_mat_loc(1,2)*s_mat_loc(2,3))
+ !
+ call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,resto,abserro)
+ !
+ if (dim == "ndi") then
+ !
+ resto = resto/plus_grand
+ !
+ else if (dim == "n+2") then
+ !
+ f3p3m(1) = norma
+ f3p3m(2) = 0._ki
+ resto = resto-log(plus_grand/mu2_scale_par)*norma
+ !
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function f3p3m (function_3p3m.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'dim = %c0'
+ tab_erreur_par(2)%arg_char = dim
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ f3p3m(3) = real(resto,ki)
+ f3p3m(4) = aimag(resto)
+ !
+ end if
+ !
+ ! on libere la memoire
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule2)
+ deallocate(resultat2)
+ deallocate(deja_calcule_np2)
+ deallocate(resultat_np2)
+ deallocate(deja_calcule22)
+ deallocate(resultat22)
+ !
+ end function f3p3m
+ !
+ !****f* src/integral/three_point/function_3p3m/f3p3m_c
+ ! NAME
+ !
+ ! Function f3p3m_c
+ !
+ ! USAGE
+ !
+ ! complex_dim3 = f3p3m_c(dim,m1,m2,m3,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! It computes the same thing that the function f3p3m, but the returned
+ ! value is a complex (type ki) array of rank 1 and shape 2
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (length 3), to compute in n or n+2 dimensions,
+ ! the values are "ndi", "n+2"
+ ! * m1 -- a real (type ki), the first mass squared
+ ! * m2 -- a real (type ki), the second mass squared
+ ! * m3 -- a real (type ki), the third mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An complex (type ki) array of rank 1 and shape 2 corresponding to
+ ! the (real part,imaginary part) of the coefficient of the 1/epsilon term
+ ! and the (real part,imaginary part) of the constant term. If par1 and/or par2
+ ! are different from zero for dim="n+2", an error is returned.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f3p3m_c(dim,m1,m2,m3,par1,par2,par3)
+ !
+ use translate
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ complex(ki), dimension(2) :: f3p3m_c
+ !
+ real(ki), dimension(4) :: res4
+ !
+ res4 = f3p3m(dim,m1,m2,m3,par1,par2,par3)
+ call to_complex(res4,f3p3m_c)
+ !
+ end function f3p3m_c
+ !
+ !****if* src/integral/three_point/function_3p3m/a3p3m
+ ! NAME
+ !
+ ! Function a3p3m
+ !
+ ! USAGE
+ !
+ ! real_dim2 = a3p3m(m1,m2,m3,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This recursive function implements the formula of ref 1
+ !
+ ! INPUTS
+ !
+ ! * m1 -- a real (type ki), the first mass squared
+ ! * m2 -- a real (type ki), the second mass squared
+ ! * m3 -- a real (type ki), the third mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! This function modify the value of the local (for the module) variables:
+ ! * deja_calcule, deja_calcule2, deja_calcule_np2 and deja_calcule22
+ ! * resultat, resultat2, resultat_np2 and resultat22
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a3p3m(m1,m2,m3,par1,par2,par3) result(res_3p3m)
+ !
+ real(ki), intent (in) :: m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(2) :: res_3p3m
+ !
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(3) :: par_loc,par_plus
+ real(ki), dimension(4) :: truc1
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(4) :: temp1,temp2,temp3
+ real(ki), dimension(4) :: temp10,temp11,temp12
+ complex(ki) :: ctemp
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ ctemp = i3_3mass(m1,m2,m3)
+ res_3p3m(1) = real(ctemp,ki)
+ res_3p3m(2) = aimag(ctemp)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a3p3m(m1,m2,m3,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (deja_calcule2(j,1)) then
+ !
+ truc1 = resultat2(j,1,:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj) !returns real array!
+ resultat2(j,1,:) = truc1
+ deja_calcule2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b(j)*truc1
+ temp2 = temp2 + invs(j,par3)*truc1
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3p3m(1) = b(par3)*(temp0(1) - temp1(3))/sumb + temp2(3)
+ res_3p3m(2) = b(par3)*(temp0(2) - temp1(4))/sumb + temp2(4)
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ if (deja_calcule_np2(par_plus(3))) then
+ !
+ temp11 = resultat_np2(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a3p3m_np2(m1,m2,m3,0,0,par3)
+ resultat_np2(par_plus(3),:) = temp11
+ deja_calcule_np2(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp10 = resultat_np2(1,:)
+ temp3 = invs(par2,par3)*temp10
+ temp1 = b(par2)*temp11
+ temp1 = mult_div(-2._ki/3._ki,temp1)*3._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule2(j,par_plus(3))) then
+ !
+ truc1 = resultat2(j,par_plus(3),:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj,par3) !returns real array!
+ resultat2(j,par_plus(3),:) = truc1
+ deja_calcule2(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + invs(j,par2)*truc1
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3p3m(1) = -temp3(3) + temp1(3) + temp2(3)
+ res_3p3m(2) = -temp3(4) + temp1(4) + temp2(4)
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ temp12 = a3p3m_np2(m1,m2,m3,0,par2,par3)
+ temp10 = resultat_np2(par_plus(3),:)
+ temp11 = resultat_np2(par_plus(2),:)
+ temp3 = invs(par1,par2)*temp10 &
+ + invs(par1,par3)*temp11
+ temp1 = b(par1)*temp12
+ temp1 = mult_div(-1._ki/2._ki,temp1)*4._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if ( (j /= par3) .and. (j /= par2) ) then
+ !
+ truc1 = resultat22(j,par_plus(2),par_plus(3),:)
+ temp2 = temp2 + invs(j,par1)*truc1
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3p3m(1) = -temp3(3) + temp1(3) + temp2(3)
+ res_3p3m(2) = -temp3(4) + temp1(4) + temp2(4)
+ !
+ end if
+ !
+ end function a3p3m
+ !
+ !****if* src/integral/three_point/function_3p3m/a3p3m_np2
+ ! NAME
+ !
+ ! Function a3p3m_np2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = a3p3m_np2(m1,m2,m3,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This recursive function implements the formula of ref 1
+ !
+ ! INPUTS
+ !
+ ! * m1 -- a real (type ki), the first mass squared
+ ! * m2 -- a real (type ki), the second mass squared
+ ! * m3 -- a real (type ki), the third mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! This function modify the value of the local (for the module) variables:
+ ! * deja_calcule, deja_calcule2, deja_calcule_np2 and deja_calcule22
+ ! * resultat, resultat2, resultat_np2 and resultat22
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 4
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a3p3m_np2(m1,m2,m3,par1,par2,par3) result(res_3p3m_np2)
+ !
+ real(ki), intent (in) :: m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: res_3p3m_np2
+ !
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(3) :: par_loc,par_plus
+ real(ki), dimension(4) :: truc1,truc2
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(4) :: temp1,temp2,temp3
+ real(ki), dimension(4) :: temp10,temp11
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a3p3m(m1,m2,m3,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp1 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (deja_calcule2(j,1)) then
+ !
+ truc1 = resultat2(j,1,:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj) !returns real array!
+ resultat2(j,1,:) = truc1
+ deja_calcule2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b(j)*truc1
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3p3m_np2(1) = (- temp1(1))/sumb
+ res_3p3m_np2(2) = (- temp1(2))/sumb
+ res_3p3m_np2(3) = (temp0(1) - temp1(3))/sumb
+ res_3p3m_np2(4) = (temp0(2) - temp1(4))/sumb
+ res_3p3m_np2 = mult_div(1._ki,res_3p3m_np2)/2._ki
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule_np2(1)) then
+ !
+ temp10 = resultat_np2(1,:)
+ !
+ else
+ !
+ temp10 = a3p3m_np2(m1,m2,m3,0,0,0)
+ resultat_np2(1,:) = temp10
+ deja_calcule_np2(1) = .true.
+ !
+ end if
+ !
+ temp3 = b(par3)*temp10
+ temp1 = 0._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (deja_calcule2(j,1)) then
+ !
+ truc1 = resultat2(j,1,:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj) !returns real array!
+ resultat2(j,1,:) = truc1
+ deja_calcule2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs(j,par3)*truc1
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule2(j,par_plus(3))) then
+ !
+ truc2 = resultat2(j,par_plus(3),:)
+ !
+ else
+ !
+ truc2 = f2p_ra(s_mat_p_loc,b_pro_mj,par3) !returns real array!
+ resultat2(j,par_plus(3),:) = truc2
+ deja_calcule2(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + b(j)*truc2
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ temp1 = mult_div(2._ki/3._ki,temp1)/3._ki
+ temp2 = mult_div(2._ki/3._ki,temp2)/3._ki
+ res_3p3m_np2(1) = (temp3(1) + temp1(1) - temp2(1))/sumb
+ res_3p3m_np2(2) = (temp3(2) + temp1(2) - temp2(2))/sumb
+ res_3p3m_np2(3) = (temp3(3) + temp1(3) - temp2(3))/sumb
+ res_3p3m_np2(4) = (temp3(4) + temp1(4) - temp2(4))/sumb
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ temp0 = a3p3m(m1,m2,m3,0,par2,par3)
+ !
+ if (deja_calcule_np2(par_plus(2))) then
+ !
+ temp10 = resultat_np2(par_plus(2),:)
+ !
+ else
+ !
+ temp10 = a3p3m_np2(m1,m2,m3,0,0,par2)
+ resultat_np2(par_plus(2),:) = temp10
+ deja_calcule_np2(par_plus(2)) = .true.
+ !
+ end if
+ !
+ if (deja_calcule_np2(par_plus(3))) then
+ !
+ temp11 = resultat_np2(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a3p3m_np2(m1,m2,m3,0,0,par3)
+ resultat_np2(par_plus(3),:) = temp11
+ deja_calcule_np2(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp3 = b(par3)*temp10 + b(par2)*temp11
+ temp1 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if ( (j /= par2) .and. (j /= par3) ) then
+ !
+ if (deja_calcule22(j,par_plus(2),par_plus(3))) then
+ !
+ truc1 = resultat22(j,par_plus(2),par_plus(3),:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj,par2,par3) !returns real array!
+ resultat22(j,par_plus(2),par_plus(3),:) = truc1
+ deja_calcule22(j,par_plus(2),par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b(j)*truc1
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3p3m_np2(1) = (temp3(1) - temp1(1))/sumb
+ res_3p3m_np2(2) = (temp3(2) - temp1(2))/sumb
+ res_3p3m_np2(3) = (temp0(1) + temp3(3) - temp1(3))/sumb
+ res_3p3m_np2(4) = (temp0(2) + temp3(4) - temp1(4))/sumb
+ res_3p3m_np2 = mult_div(1._ki/2._ki,res_3p3m_np2)/4._ki
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function a3p3m_np2:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'no need of 3-point integrals in 6 dimension &
+ &with more than one Feynman parameter in the numerator'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'The value of Feynman parameters in argument: %d1'
+ tab_erreur_par(3)%arg_int_tab = (/packb(par),4/)
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a3p3m_np2
+ !
+ !****f* src/integral/three_point/function_3p3m/i3_3mass
+ ! NAME
+ !
+ ! Function i3_3mass
+ !
+ ! USAGE
+ !
+ ! complex = i3_3mass(m1,m2,m3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the scalar three off-shell external leg three point function
+ ! in n dimension
+ !
+ ! INPUTS
+ !
+ ! * m1 -- a real (type ki), the first mass squared
+ ! * m2 -- a real (type ki), the second mass squared
+ ! * m3 -- a real (type ki), the third mass squared
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of rat_or_tot_par
+ ! (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function i3_3mass(m1,m2,m3)
+ !
+ real(ki), intent(in) :: m1,m2,m3
+ complex(ki) :: i3_3mass
+ !
+ complex(ki) :: cx1,cx2
+ real(ki) :: delta,sig,nsig
+ real(ki) :: x1,x2
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ delta = m1**2+m2**2+m3**2-2._ki*m1*m2-2._ki*m1*m3-2._ki*m2*m3
+ sig = sign(1._ki,m1)
+ !
+ if (delta >= 0._ki) then
+ !
+ x1 = (m1+m3-m2+sqrt(delta))/(2._ki*m1)
+ x2 = (m1+m3-m2-sqrt(delta))/(2._ki*m1)
+ !
+ ! pour avoir une fonction symetrique en fonction des trois arguments
+ ! il faut multiplier la partie imaginaire par sig
+ !
+ nsig = sig*sign(1._ki,m2-m3)
+ sig = sig*sig
+ !
+ i3_3mass = 1._ki/sqrt(delta)*( 2._ki*zdilog(1._ki-1._ki/x1,-sig) &
+ + 2._ki*zdilog(1._ki-1._ki/(1._ki-x2),-sig) + pi**2/3._ki &
+ + 1._ki/2._ki*( &
+ z_log2((1._ki-x1)/x1,sig) + z_log2((1._ki-x2)/x2,-sig) &
+ - z_log2(x2/(1._ki-x1),nsig) + z_log2(x1/(1._ki-x2),-nsig) ) )
+ !
+ else !if (delta < 0._ki) then
+ !
+ cx1 = (m1+m3-m2+(-sig*i_)*sqrt(-delta))/(2._ki*m1)
+ cx2 = (m1+m3-m2-(-sig*i_)*sqrt(-delta))/(2._ki*m1)
+ i3_3mass = (sig*i_)/sqrt(-delta)*( 2._ki*cdilog(1._ki-1._ki/cx1) &
+ + 2._ki*cdilog(1._ki-1._ki/(1._ki-cx2)) + pi**2/3._ki &
+ + 1._ki/2._ki*( &
+ (log((1._ki-cx1)/cx1))**2 + (log((1._ki-cx2)/cx2))**2 &
+ - (log(cx2/(1._ki-cx1)))**2 + (log(cx1/(1._ki-cx2)))**2 ) )
+ !
+ end if
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ i3_3mass = 0._ki
+ !
+ end if
+ !
+ end function i3_3mass
+ !
+ !****if* src/integral/three_point/function_3p3m/eval_numer_gi
+ ! NAME
+ !
+ ! Function eval_numer_gi
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_gi(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This function is the integrand that will be computed numerically
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integral variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, use the values of the local (for this module) variables
+ ! eps_glob,s13_glob,s12_glob,s23_glob,par1_glob,par2_glob,par3_glob,dim_glob
+ ! and also the global variables alpha_par,beta_par and lambda_par given
+ ! by the module parametre (src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) which is the value of the
+ ! integrand at the value u
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_gi(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_gi
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ z = x - eps_glob*i_*y
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ !
+ eval_numer_gi = fg(z,s13_glob,s12_glob,s23_glob,&
+ & par1_glob,par2_glob,par3_glob,&
+ & dim_glob)
+ eval_numer_gi = eval_numer_gi*jacob
+ !
+ end function eval_numer_gi
+ !
+ !****if* src/integral/three_point/function_3p3m/fg
+ ! NAME
+ !
+ ! Function fg
+ !
+ ! USAGE
+ !
+ ! complex = fg(z,s13,s12,s23,par1,par2,par3,dim)
+ !
+ ! DESCRIPTION
+ !
+ ! This function gives the structure of the integrand for the different cases
+ !
+ ! INPUTS
+ !
+ ! * z -- a complex (type ki), the integral variable
+ ! * s13 -- a real (type ki), the first mass squared
+ ! * s12 -- a real (type ki), the second mass squared
+ ! * s23 -- a real (type ki), the third mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! * dim -- a character (length 3), to compute in n or n+2 dimensions,
+ ! the values are "ndi", "n+2"
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function fg(z,s13,s12,s23,par1,par2,par3,dim)
+ !
+ complex(ki), intent (in) :: z
+ real(ki), intent (in) :: s13,s12,s23
+ integer, intent (in) :: par1,par2,par3
+ character (len=3) :: dim
+ complex(ki) :: fg
+ !
+ integer, dimension(3) :: par
+ integer :: nb_par
+ complex(ki) :: c_var,d_var,h_var
+ !
+ par = (/par1,par2,par3/)
+ nb_par = count(mask=par/=0)
+ !
+ c_var=z*s13+(1._ki-z)*s23
+ !
+ d_var=z*(1._ki-z)*s12-z*s13-(1._ki-z)*s23
+ !
+ h_var=z*(1._ki-z)*s12
+ !
+ if (dim == "ndi") then
+ if (nb_par == 0) then
+ !
+ fg=(log(z)+log(1._ki-z)+z_log(s12,1._ki)-log(c_var))/d_var
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ fg=-z*(-d_var+c_var*log(z)+c_var*log(1._ki-z)+c_var*z_log(s12,1._ki&
+ &)-c_var*log(c_var))/d_var**2
+ !
+ case(2)
+ !
+ fg=(-d_var+c_var*log(z)+c_var*log(1._ki-z)+c_var*z_log(s12,1._ki)-c&
+ &_var*log(c_var))*(-1._ki+z)/d_var**2
+ !
+ case(3)
+ !
+ fg=(-log(c_var)*d_var-c_var*log(c_var)+d_var*log(z)+d_var*log(1._k&
+ &i-z)+d_var*z_log(s12,1._ki)+c_var*log(z)+c_var*log(1._ki-z)+c_var&
+ &*z_log(s12,1._ki)-d_var)/d_var**2
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 1, 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 2) then
+ !
+ select case(par2)
+ !
+ case(1)
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ fg=1._ki/2._ki*z**2*(d_var**2-2._ki*c_var*d_var+2._ki*c_var**2*log(z)&
+ &+2._ki*c_var**2*log(1._ki-z)+2._ki*c_var**2*z_log(s12,1._ki)-2._ki*c&
+ &_var**2*log(c_var))/d_var**3
+ !
+ case(2)
+ !
+ fg=-1._ki/2._ki*z*(d_var**2-2._ki*c_var*d_var+2._ki*c_var**2*log(z)+2&
+ &._ki*c_var**2*log(1._ki-z)+2._ki*c_var**2*z_log(s12,1._ki)-2._ki*c_v&
+ &ar**2*log(c_var))*(-1._ki+z)/d_var**3
+ !
+ case(3)
+ !
+ fg=-1._ki/2._ki*z*(-2._ki*c_var*log(c_var)*d_var-2._ki*c_var**2*log(c&
+ &_var)+2._ki*c_var*d_var*log(z)+2._ki*c_var*d_var*log(1._ki-z)+2._ki&
+ &*c_var*d_var*z_log(s12,1._ki)+2._ki*c_var**2*log(z)+2._ki*c_var**2&
+ &*log(1._ki-z)+2._ki*c_var**2*z_log(s12,1._ki)-d_var**2-2._ki*c_var*&
+ &d_var)/d_var**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 1, 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ fg=1._ki/2._ki*(-1._ki+z)**2*(d_var**2-2._ki*c_var*d_var+2._ki*c_var**&
+ &2*log(z)+2._ki*c_var**2*log(1._ki-z)+2._ki*c_var**2*z_log(s12,1._ki&
+ &)-2._ki*c_var**2*log(c_var))/d_var**3
+ !
+ case(3)
+ !
+ fg=1._ki/2._ki*(-2._ki*c_var*log(c_var)*d_var-2._ki*c_var**2*log(c_va&
+ &r)+2._ki*c_var*d_var*log(z)+2._ki*c_var*d_var*log(1._ki-z)+2._ki*c_&
+ &var*d_var*z_log(s12,1._ki)+2._ki*c_var**2*log(z)+2._ki*c_var**2*lo&
+ &g(1._ki-z)+2._ki*c_var**2*z_log(s12,1._ki)-d_var**2-2._ki*c_var*d_v&
+ &ar)*(-1._ki+z)/d_var**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ fg=1._ki/2._ki*(-2._ki*log(c_var)*d_var**2-4._ki*c_var*log(c_var)*d_v&
+ &ar-2._ki*c_var**2*log(c_var)+2._ki*d_var**2*log(z)+2._ki*d_var**2*&
+ &log(1._ki-z)+2._ki*d_var**2*z_log(s12,1._ki)+4._ki*c_var*d_var*log(&
+ &z)+4._ki*c_var*d_var*log(1._ki-z)+4._ki*c_var*d_var*z_log(s12,1._ki&
+ &)+2._ki*c_var**2*log(z)+2._ki*c_var**2*log(1._ki-z)+2._ki*c_var**2*&
+ &z_log(s12,1._ki)-3._ki*d_var**2-2._ki*c_var*d_var)/d_var**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par2 should be 1, 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else if (nb_par == 3) then
+ !
+ select case(par1)
+ !
+ case(1)
+ !
+ select case(par2)
+ !
+ case(1)
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ fg=-1._ki/6._ki*z**3*(-2._ki*d_var**3+3._ki*c_var*d_var**2-6._ki*c_var&
+ &**2*d_var+6._ki*c_var**3*log(z)+6._ki*c_var**3*log(1._ki-z)+6._ki*c&
+ &_var**3*z_log(s12,1._ki)-6._ki*c_var**3*log(c_var))/d_var**4
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*z**2*(-2._ki*d_var**3+3._ki*c_var*d_var**2-6._ki*c_var*&
+ &*2*d_var+6._ki*c_var**3*log(z)+6._ki*c_var**3*log(1._ki-z)+6._ki*c_&
+ &var**3*z_log(s12,1._ki)-6._ki*c_var**3*log(c_var))*(-1._ki+z)/d_va&
+ &r**4
+ !
+ case(3)
+ !
+ fg=1._ki/6._ki*z**2*(-6._ki*c_var**2*log(c_var)*d_var-6._ki*c_var**3*&
+ &log(c_var)+6._ki*c_var**2*d_var*log(z)+6._ki*c_var**2*d_var*log(1&
+ &._ki-z)+6._ki*c_var**2*d_var*z_log(s12,1._ki)+6._ki*c_var**3*log(z)&
+ &+6._ki*c_var**3*log(1._ki-z)+6._ki*c_var**3*z_log(s12,1._ki)+d_var*&
+ &*3-3._ki*c_var*d_var**2-6._ki*c_var**2*d_var)/d_var**4
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 1, 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ fg=-1._ki/6._ki*z*(-1._ki+z)**2*(-2._ki*d_var**3+3._ki*c_var*d_var**2-&
+ &6._ki*c_var**2*d_var+6._ki*c_var**3*log(z)+6._ki*c_var**3*log(1._ki&
+ &-z)+6._ki*c_var**3*z_log(s12,1._ki)-6._ki*c_var**3*log(c_var))/d_v&
+ &ar**4
+ !
+ case(3)
+ !
+ fg=-1._ki/6._ki*z*(-6._ki*c_var**2*log(c_var)*d_var-6._ki*c_var**3*lo&
+ &g(c_var)+6._ki*c_var**2*d_var*log(z)+6._ki*c_var**2*d_var*log(1._k&
+ &i-z)+6._ki*c_var**2*d_var*z_log(s12,1._ki)+6._ki*c_var**3*log(z)+6&
+ &._ki*c_var**3*log(1._ki-z)+6._ki*c_var**3*z_log(s12,1._ki)+d_var**3&
+ &-3._ki*c_var*d_var**2-6._ki*c_var**2*d_var)*(-1._ki+z)/d_var**4
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ fg=-1._ki/6._ki*z*(-6._ki*c_var*log(c_var)*d_var**2-12._ki*c_var**2*l&
+ &og(c_var)*d_var-6._ki*c_var**3*log(c_var)+6._ki*c_var*d_var**2*lo&
+ &g(z)+6._ki*c_var*d_var**2*log(1._ki-z)+6._ki*c_var*d_var**2*z_log(&
+ &s12,1._ki)+12._ki*c_var**2*d_var*log(z)+12._ki*c_var**2*d_var*log(&
+ &1._ki-z)+12._ki*c_var**2*d_var*z_log(s12,1._ki)+6._ki*c_var**3*log(&
+ &z)+6._ki*c_var**3*log(1._ki-z)+6._ki*c_var**3*z_log(s12,1._ki)-2._ki&
+ &*d_var**3-9._ki*c_var*d_var**2-6._ki*c_var**2*d_var)/d_var**4
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par2 should be 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ select case(par2)
+ !
+ case(2)
+ !
+ select case(par3)
+ !
+ case(2)
+ !
+ fg=1._ki/6._ki*(-1._ki+z)**3*(-2._ki*d_var**3+3._ki*c_var*d_var**2-6._k&
+ &i*c_var**2*d_var+6._ki*c_var**3*log(z)+6._ki*c_var**3*log(1._ki-z)&
+ &+6._ki*c_var**3*z_log(s12,1._ki)-6._ki*c_var**3*log(c_var))/d_var*&
+ &*4
+ !
+ case(3)
+ !
+ fg=1._ki/6._ki*(-1._ki+z)**2*(-6._ki*c_var**2*log(c_var)*d_var-6._ki*c&
+ &_var**3*log(c_var)+6._ki*c_var**2*d_var*log(z)+6._ki*c_var**2*d_v&
+ &ar*log(1._ki-z)+6._ki*c_var**2*d_var*z_log(s12,1._ki)+6._ki*c_var**&
+ &3*log(z)+6._ki*c_var**3*log(1._ki-z)+6._ki*c_var**3*z_log(s12,1._ki&
+ &)+d_var**3-3._ki*c_var*d_var**2-6._ki*c_var**2*d_var)/d_var**4
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ fg=1._ki/6._ki*(-6._ki*c_var*log(c_var)*d_var**2-12._ki*c_var**2*log(&
+ &c_var)*d_var-6._ki*c_var**3*log(c_var)+6._ki*c_var*d_var**2*log(z&
+ &)+6._ki*c_var*d_var**2*log(1._ki-z)+6._ki*c_var*d_var**2*z_log(s12&
+ &,1._ki)+12._ki*c_var**2*d_var*log(z)+12._ki*c_var**2*d_var*log(1._k&
+ &i-z)+12._ki*c_var**2*d_var*z_log(s12,1._ki)+6._ki*c_var**3*log(z)+&
+ &6._ki*c_var**3*log(1._ki-z)+6._ki*c_var**3*z_log(s12,1._ki)-2._ki*d_&
+ &var**3-9._ki*c_var*d_var**2-6._ki*c_var**2*d_var)*(-1._ki+z)/d_var&
+ &**4
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par2 should be 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ select case(par2)
+ !
+ case(3)
+ !
+ select case(par3)
+ !
+ case(3)
+ !
+ fg=1._ki/6._ki*(-6._ki*log(c_var)*d_var**3-18._ki*c_var*log(c_var)*d_&
+ &var**2-18._ki*c_var**2*log(c_var)*d_var-6._ki*c_var**3*log(c_var)&
+ &+6._ki*d_var**3*log(z)+6._ki*d_var**3*log(1._ki-z)+6._ki*d_var**3*z&
+ &_log(s12,1._ki)+18._ki*c_var*d_var**2*log(z)+18._ki*c_var*d_var**2&
+ &*log(1._ki-z)+18._ki*c_var*d_var**2*z_log(s12,1._ki)+18._ki*c_var**&
+ &2*d_var*log(z)+18._ki*c_var**2*d_var*log(1._ki-z)+18._ki*c_var**2*&
+ &d_var*z_log(s12,1._ki)+6._ki*c_var**3*log(z)+6._ki*c_var**3*log(1.&
+ &_ki-z)+6._ki*c_var**3*z_log(s12,1._ki)-11._ki*d_var**3-15._ki*c_var*&
+ &d_var**2-6._ki*c_var**2*d_var)/d_var**4
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par2 should be 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par2
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par1 should be 1, 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'Unexpected value for nb_par = %d0'
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else if (dim == "n+2") then
+ !
+ if (nb_par == 0) then
+ !
+ fg=1._ki/2._ki*(c_var**2*log(-c_var)+d_var**2*log(z)+d_var**2*log(1&
+ &._ki-z)+d_var**2*z_log(-s12,-1._ki)-c_var**2*log(z)-c_var**2*log(&
+ &1._ki-z)-c_var**2*z_log(-s12,-1._ki)+c_var*d_var-d_var**2)/d_var*&
+ &*2
+ !
+ else if (nb_par == 1) then
+ !
+ select case(par3)
+ !
+ case(1)
+ !
+ fg=-1._ki/18._ki*z*(6._ki*c_var**3*log(-c_var)-6._ki*d_var**3*log(z)-&
+ &6._ki*d_var**3*log(1._ki-z)-6._ki*d_var**3*z_log(-s12,-1._ki)-6._ki*&
+ &c_var**3*log(z)-6._ki*c_var**3*log(1._ki-z)-6._ki*c_var**3*z_log(-&
+ &s12,-1._ki)+4._ki*d_var**3+6._ki*c_var**2*d_var-3._ki*c_var*d_var**&
+ &2)/d_var**3
+ !
+ case(2)
+ !
+ fg=1._ki/18._ki*(6._ki*c_var**3*log(-c_var)-6._ki*d_var**3*log(z)-6._k&
+ &i*d_var**3*log(1._ki-z)-6._ki*d_var**3*z_log(-s12,-1._ki)-6._ki*c_v&
+ &ar**3*log(z)-6._ki*c_var**3*log(1._ki-z)-6._ki*c_var**3*z_log(-s12&
+ &,-1._ki)+4._ki*d_var**3+6._ki*c_var**2*d_var-3._ki*c_var*d_var**2)*&
+ &(-1._ki+z)/d_var**3
+ !
+ case(3)
+ !
+ fg=1._ki/18._ki*(9._ki*c_var**2*log(-c_var)*d_var+6._ki*c_var**3*log(&
+ &-c_var)-9._ki*c_var**2*d_var*log(z)-9._ki*c_var**2*d_var*log(1._ki&
+ &-z)-9._ki*c_var**2*d_var*z_log(-s12,-1._ki)-6._ki*c_var**3*log(z)-&
+ &6._ki*c_var**3*log(1._ki-z)-6._ki*c_var**3*z_log(-s12,-1._ki)+3._ki*&
+ &d_var**3*log(z)+3._ki*d_var**3*log(1._ki-z)+3._ki*d_var**3*z_log(-&
+ &s12,-1._ki)-5._ki*d_var**3+6._ki*c_var**2*d_var+6._ki*c_var*d_var**&
+ &2)/d_var**3
+ !
+ case default
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'par3 should be 1, 2 or 3 but is %d0'
+ tab_erreur_par(2)%arg_int = par3
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'Unexpected value for nb_par = %d0'
+ tab_erreur_par(2)%arg_int = nb_par
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function fg (function_3p3m.f90):'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = &
+ & 'Unexpected value for dim = %c0'
+ tab_erreur_par(2)%arg_char = dim
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ end function fg
+ !
+end module function_3p3m
+!
diff --git a/golem95c-1.2.1/integrals/three_point/function_3p_finite.f90 b/golem95c-1.2.1/integrals/three_point/function_3p_finite.f90
new file mode 100644
index 0000000..85befa7
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/function_3p_finite.f90
@@ -0,0 +1,1708 @@
+!
+!~ 30.4.2010: adapted from function_3p3m.f90 for internal masses
+!
+!~ 24.6.2010: uses Andre van Hameren's OneLOop for finite C0
+!~ 14.1.2011: include LT option in addition
+!
+!****h* src/integral/three_point/function_3pC0i
+! NAME
+!
+! Module function_3p_finite
+!
+! USAGE
+!
+! use function_3p_finite
+!
+! DESCRIPTION
+!
+! This module is used to compute IR finite three point functions
+! with/without Feynman parameters in n, n+2 dimensions
+!
+! OUTPUT
+!
+! This module exports the functions:
+! * f3p_finite, C0 -- functions for the computation of IR finite
+! three-point functions with/without Feynman parameters in n, n+2 dimensions
+! * f3p_finite_c -- a function which computes the same thing as f3p_finite, only
+! the format of the return values is different
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * generic_function_2p (src/integrals/two_point/generic_function_2p.f90)
+! * multiply_div (src/module/multiply_div.f90)
+! * s_matrix_type (src/module/s_matrix_type.f90)
+!
+!*****
+module function_3p_finite
+ !
+ use precision_golem
+ use numerical_evaluation
+ use dilogarithme
+ use logarithme
+ use constante
+ use parametre
+ use array
+ use equal
+ use sortie_erreur
+ use generic_function_2p
+ use multiply_div
+ use s_matrix_type
+ use matrice_s, only : prepare_s_matrix_local
+ implicit none
+ !
+ private :: ki
+ real(ki) :: s12_glob,s23_glob,s13_glob
+ real(ki) :: eps_glob
+ integer :: par1_glob,par2_glob,par3_glob
+ character (len=3) :: dim_glob
+ !
+ real(ki), dimension(3) :: b_real
+ real(ki) :: sumb_real
+ real(ki), dimension(3,3) :: invs_real, s_mat_real
+ !
+ complex(ki), dimension(3) :: b_complex
+ complex(ki) :: sumb_complex
+ complex(ki), dimension(3,3) :: invs_complex, s_mat_complex
+ !
+ type (s_matrix_poly) :: s_mat_p_loc
+ !
+ integer, dimension(3) :: par
+ integer, dimension(3) :: s = (/1,2,3/)
+ !
+ logical, dimension(:), allocatable :: deja_calcule
+ real(ki),dimension(:,:), allocatable :: resultat
+ logical, dimension(:), allocatable :: deja_calcule_c
+ complex(ki), dimension(:,:), allocatable :: resultat_c
+ !
+ logical, dimension(:,:), allocatable :: deja_calcule2
+ real(ki),dimension(:,:,:), allocatable :: resultat2
+ logical, dimension(:,:), allocatable :: deja_calcule2_c
+ complex(ki),dimension(:,:,:), allocatable :: resultat2_c
+ !
+ logical, dimension(:), allocatable :: deja_calcule_np2
+ real(ki),dimension(:,:), allocatable :: resultat_np2
+ logical, dimension(:), allocatable :: deja_calcule_np2_c
+ complex(ki),dimension(:,:), allocatable :: resultat_np2_c
+ !
+ logical, dimension(:,:,:), allocatable :: deja_calcule22
+ real(ki),dimension(:,:,:,:), allocatable :: resultat22
+ logical, dimension(:,:,:), allocatable :: deja_calcule22_c
+ complex(ki),dimension(:,:,:,:), allocatable :: resultat22_c
+ !
+ private :: eps_glob,s12_glob,s23_glob,s13_glob,par1_glob,par2_glob,par3_glob,dim_glob
+ private :: b_real, b_complex, sumb_real, sumb_complex, invs_real, invs_complex, s_mat_real, s_mat_complex, par, s
+ private :: deja_calcule,resultat,deja_calcule2,resultat2,deja_calcule_np2,resultat_np2,deja_calcule22,resultat22
+ private :: deja_calcule_c,resultat_c,deja_calcule2_c,resultat2_c,deja_calcule_np2_c,resultat_np2_c,deja_calcule22_c,resultat22_c
+ private :: s_mat_p_loc
+ !
+ interface f3p_finite
+ !
+ module procedure f3p_finite_rarg
+ module procedure f3p_finite_carg
+ !
+ end interface
+ !
+ interface C0
+ !
+ module procedure C0_rarg
+ module procedure C0_carg
+ !
+ end interface
+ !
+ public :: f3p_finite,f3p_finite_c,C0
+ !
+ !
+ interface
+ subroutine avh_olo_c0m(rslt,p1,p2,p3,m1,m2,m3)
+ use precision_golem, only: ki_avh
+ implicit none
+ complex(ki_avh), intent(out) :: rslt(0:2)
+ real(ki_avh), intent(in) :: p1,p2,p3,m1,m2,m3
+ end subroutine avh_olo_c0m
+ end interface
+ !
+ !
+ interface
+ subroutine avh_olo_c0c(rslt,p1,p2,p3,m1,m2,m3)
+ use precision_golem, only: ki_avh
+ implicit none
+ complex(ki_avh), intent(out) :: rslt(0:2)
+ complex(ki_avh), intent(in) :: p1,p2,p3,m1,m2,m3
+ end subroutine avh_olo_c0c
+ end interface
+ !
+ ! added Jan2011 for LT option
+!AC! interface
+!AC! function C0(p1, p2, p1p2, m1, m2, m3)
+!AC! use precision_golem, only: ki_lt
+!AC! implicit none
+!AC! real(ki_lt), intent(in) :: p1, p2, p1p2, m1, m2, m3
+!AC! complex(ki_lt) :: C0
+!AC! end function
+!AC! end interface
+!AC! interface
+!AC! function C0C(p1, p2, p1p2, m1, m2, m3)
+!AC! use precision_golem, only: ki_lt
+!AC! implicit none
+!AC! real(ki_lt), intent(in) :: p1, p2, p1p2
+!AC! complex(ki_lt), intent(in) :: m1, m2, m3
+!AC! complex(ki_lt) :: C0C
+!AC! end function
+!AC! end interface
+ !
+contains
+ !
+ !****f* src/integral/three_point/function_3p_finite/f3p_finite
+ ! NAME
+ !
+ ! Function f3p_finite
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f3p_finite(dim,s1,s2,s3,m1,m2,m3,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the IR finite three-point
+ ! function in n and n+2 dimensions.
+ !
+ ! INPUTS
+ !
+ ! * s1 -- a real (type ki), p1^2
+ ! * s2 -- a real (type ki), p2^2
+ ! * s3 -- a real (type ki), p3^2
+ ! * m1 -- a real/complex (type ki), the first mass squared
+ ! * m2 -- a real/complex (type ki), the second mass squared
+ ! * m3 -- a real/complex (type ki), the third mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real (type ki) array of rank 1 and shape 6,
+ ! where the last two entries corresponding to
+ ! the real/imaginary part of the constant term.
+ ! the first 4 entries are always zero, but the shape should be
+ ! uniform for all triangles called in generic_function_3p
+ !
+ !*****
+ function f3p_finite_rarg(dim,s1,s2,s3,m1,m2,m3,par1,par2,par3)
+ implicit none
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p_finite_rarg
+ integer :: nb_par
+ real(ki) :: lamb, detS3
+ real(ki) :: plus_grand
+ real(ki) :: norma
+ !complex(ki) :: resto,abserro
+ !
+ par = (/par1,par2,par3/)
+ !
+ s_mat_real(1,:) = (/-m1*2._ki,s2-m1-m2,s1-m1-m3/)
+ s_mat_real(2,:) = (/s2-m1-m2,-m2*2._ki,s3-m2-m3/)
+ s_mat_real(3,:) = (/s1-m1-m3,s3-m2-m3,-m3*2._ki/)
+ !
+ ! on redefinit la matrice S de telle facon a ce que ces elements
+ ! soient entre -1 et 1
+ ! this can't be done if partly invariants instead of
+ ! s_mat_real are used as arguments
+ !
+ plus_grand = 1._ki
+ ! if (rat_or_tot_par%tot_selected) then
+ !
+ ! plus_grand = maxval(array=abs(s_mat_real))
+ !
+ ! else if (rat_or_tot_par%rat_selected) then
+ !
+ ! plus_grand = 1._ki
+ !
+ ! end if
+ !
+ !
+ s_mat_real = s_mat_real/plus_grand
+ !
+ s_mat_p_loc = assign_s_matrix(s_mat_real)
+ call prepare_s_matrix_local(s_mat_p_loc,s)
+ !
+ detS3 = -(s_mat_real(1, 3)**2*s_mat_real(2, 2)) + 2*s_mat_real(1, 2)*s_mat_real(1, 3)*s_mat_real(2, 3) - &
+ & s_mat_real(1, 2)**2*s_mat_real(3, 3) + s_mat_real(1, 1)*(-s_mat_real(2, 3)**2 + &
+ & s_mat_real(2, 2)*s_mat_real(3, 3))
+
+ b_real(1) = (-s_mat_real(2, 3)**2 + s_mat_real(1, 3)*(-s_mat_real(2, 2) + s_mat_real(2, 3)) + &
+ & s_mat_real(1, 2)*(s_mat_real(2, 3) - s_mat_real(3, 3)) + s_mat_real(2, 2)*s_mat_real(3, 3))/detS3
+ b_real(2) = (-s_mat_real(1, 3)**2 + s_mat_real(1, 3)*s_mat_real(2, 3) + &
+ & s_mat_real(1, 2)*(s_mat_real(1, 3) - s_mat_real(3, 3)) + &
+ & s_mat_real(1, 1)*(-s_mat_real(2, 3) + s_mat_real(3, 3)))/detS3
+ b_real(3) = (-s_mat_real(1, 2)**2 - s_mat_real(1, 3)*s_mat_real(2, 2) + &
+ & s_mat_real(1, 1)*(s_mat_real(2, 2) - s_mat_real(2, 3)) + &
+ & s_mat_real(1, 2)*(s_mat_real(1, 3) + s_mat_real(2, 3)))/detS3
+ !
+ sumb_real = (-s_mat_real(1, 2)**2 - s_mat_real(1, 3)**2 + s_mat_real(1, 1)*s_mat_real(2, 2) - &
+ & 2*s_mat_real(1, 3)*(s_mat_real(2, 2) - s_mat_real(2, 3)) - 2*s_mat_real(1, 1)*s_mat_real(2, 3) - &
+ & s_mat_real(2, 3)**2 + 2*s_mat_real(1, 2)*(s_mat_real(1, 3) + s_mat_real(2, 3) - s_mat_real(3, 3)) + &
+ & s_mat_real(1, 1)*s_mat_real(3, 3) + s_mat_real(2, 2)*s_mat_real(3, 3))/detS3
+ !
+ invs_real(1,1) = (-s_mat_real(2, 3)**2 + s_mat_real(2, 2)*s_mat_real(3, 3))/detS3
+ invs_real(1,2) = (s_mat_real(1, 3)*s_mat_real(2, 3) - s_mat_real(1, 2)*s_mat_real(3, 3))/detS3
+ invs_real(1,3) = (-(s_mat_real(1, 3)*s_mat_real(2, 2)) + s_mat_real(1, 2)*s_mat_real(2, 3))/detS3
+ invs_real(2,1) = invs_real(1,2)
+ invs_real(2,2) = (-s_mat_real(1, 3)**2 + s_mat_real(1, 1)*s_mat_real(3, 3))/detS3
+ invs_real(2,3) = (s_mat_real(1, 2)*s_mat_real(1, 3) - s_mat_real(1, 1)*s_mat_real(2, 3))/detS3
+ invs_real(3,1) = invs_real(1,3)
+ invs_real(3,2) = invs_real(2,3)
+ invs_real(3,3) = (-s_mat_real(1, 2)**2 + s_mat_real(1, 1)*s_mat_real(2, 2))/detS3
+ !
+ lamb = 2._ki*s_mat_real(1,3)*s_mat_real(2,3)+2._ki*s_mat_real(1,2)*s_mat_real(2,3)&
+ +2._ki*s_mat_real(1,3)*s_mat_real(1,2)-s_mat_real(1,3)*s_mat_real(1,3)-s_mat_real(1,2)*s_mat_real(1,2)&
+ -s_mat_real(2,3)*s_mat_real(2,3)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ !
+ norma = -1._ki/2._ki
+ !
+ else if (nb_par == 1) then
+ !
+ norma = -1._ki/6._ki
+ !
+ else
+ !
+ norma = 0._ki
+ !
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule(4))
+ allocate(resultat(4,2))
+ allocate(deja_calcule2(3,4))
+ allocate(resultat2(3,4,4))
+ allocate(deja_calcule_np2(4))
+ allocate(resultat_np2(4,4))
+ allocate(deja_calcule22(3,4,4))
+ allocate(resultat22(3,4,4,4))
+ !
+ ! initialisation
+ !
+ deja_calcule = .false.
+ resultat = 0._ki
+ deja_calcule2 = .false.
+ resultat2 = 0._ki
+ deja_calcule_np2 = .false.
+ resultat_np2 = 0._ki
+ deja_calcule22 = .false.
+ resultat22 = 0._ki
+ !
+ !
+ f3p_finite_rarg = 0._ki
+ !
+ ! if (abs(sumb_real) > coupure_3p3m) then
+ ! if (abs(sumb_real) > 0._ki) then
+ !
+ ! always use analytic computation until massive numerical is implemented
+ ! branching removed completely Feb 4, 2011 because if detS3=0,
+ ! sumb_real=NAN so numerical branch was entered, although scalar integral
+ ! still finite if detS3=0 without any z_i=0 (LLS)
+ !
+ ! when invariants as input are used, no division by plus_grand!
+ !
+ if (dim == "ndi") then
+ !
+ f3p_finite_rarg(3:4)= a3pC0i_rarg(s1,s2,s3,m1,m2,m3,par1,par2,par3)
+ !
+ else if (dim == "n+2") then
+ !
+ f3p_finite_rarg = a3pC0i_np2_rarg(s1,s2,s3,m1,m2,m3,par1,par2,par3)
+ ! f3p_finite(3) = f3p_finite(3)-log(plus_grand)*norma
+ ! mu2_scale_par is already contained in the bubbles,
+ ! scaling of s_mat_real does not enter here
+ !
+ end if
+ !
+ ! else
+ !
+ ! numerical computation
+ !
+ !dim_glob = dim
+ !par1_glob = par1
+ ! par2_glob = par2
+ !par3_glob = par3
+ !
+ !s13_glob = s_mat_real(1,3)
+ !s12_glob = s_mat_real(1,2)
+ !s23_glob = s_mat_real(2,3)
+ !
+ !resto = 0._ki
+ !abserro = 0._ki
+ !
+ ! eps_glob = sign(1._ki,s23_glob-s13_glob)
+ !
+ !origine_info_par = "f3p_finite, dimension "//dim
+ ! num_grand_b_info_par = lamb
+ ! denom_grand_b_info_par = (2._ki*s_mat_real(1,3)*s_mat_real(1,2)*s_mat_real(2,3))
+ !
+ ! call generic_eval_numer(eval_numer_gi,0._ki,1._ki,tolerance,resto,abserro)
+ !
+ ! if (dim == "ndi") then
+ !
+ ! resto = resto/plus_grand
+ !
+ ! else if (dim == "n+2") then
+ !
+ ! f3p_finite_rarg(1) = norma
+ ! f3p_finite_rarg(2) = 0._ki
+ ! resto = resto-log(plus_grand/mu2_scale_par)*norma
+ !
+ ! end if
+ !
+ ! f3p_finite_rarg(3) = real(resto,ki)
+ ! f3p_finite_rarg(4) = aimag(resto)
+ !
+ !end if ! end if analytic or numeric
+ !
+ deallocate(deja_calcule)
+ deallocate(resultat)
+ deallocate(deja_calcule2)
+ deallocate(resultat2)
+ deallocate(deja_calcule_np2)
+ deallocate(resultat_np2)
+ deallocate(deja_calcule22)
+ deallocate(resultat22)
+ !
+ call nullify_s_matrix(s_mat_p_loc)
+ !
+ end function f3p_finite_rarg
+ !
+ function f3p_finite_carg(dim,s1r,s2r,s3r,m1,m2,m3,par1,par2,par3)
+ implicit none
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s1r, s2r, s3r
+ complex(ki), intent (in) :: m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: f3p_finite_carg
+ !
+ complex(ki) :: s1, s2, s3
+ integer :: nb_par
+ complex(ki) :: lamb, detS3
+ real(ki) :: plus_grand
+ complex(ki) :: norma
+ !complex(ki) :: resto,abserro
+ complex(ki) :: temp0
+ complex(ki), dimension(2) :: temp
+ !
+ par = (/par1,par2,par3/)
+ !
+ s1 = cmplx(s1r, 0._ki,ki)
+ s2 = cmplx(s2r, 0._ki,ki)
+ s3 = cmplx(s3r, 0._ki,ki)
+ !
+ s_mat_complex(1,:) = (/-m1*2._ki,s2-m1-m2,s1-m1-m3/)
+ s_mat_complex(2,:) = (/s2-m1-m2,-m2*2._ki,s3-m2-m3/)
+ s_mat_complex(3,:) = (/s1-m1-m3,s3-m2-m3,-m3*2._ki/)
+ !
+ ! on redefinit la matrice S de telle facon a ce que ces elements
+ ! soient entre -1 et 1
+ ! this can't be done if partly invariants instead of
+ ! s_mat_complex are used as arguments
+ !
+ plus_grand = 1._ki
+ ! if (rat_or_tot_par%tot_selected) then
+ !
+ ! plus_grand = maxval(array=abs(s_mat_complex))
+ !
+ ! else if (rat_or_tot_par%rat_selected) then
+ !
+ ! plus_grand = 1._ki
+ !
+ ! end if
+ !
+ s_mat_complex = s_mat_complex/plus_grand
+ !
+ s_mat_real = real(s_mat_complex,ki)
+ !
+ s_mat_p_loc = assign_s_matrix(s_mat_complex,s_mat_real)
+ call prepare_s_matrix_local(s_mat_p_loc, s)
+ !
+ detS3 = -(s_mat_complex(1, 3)**2*s_mat_complex(2, 2)) + 2*s_mat_complex(1, 2)*s_mat_complex(1, 3)*s_mat_complex(2, 3) - &
+ & s_mat_complex(1, 2)**2*s_mat_complex(3, 3) + s_mat_complex(1, 1)*(-s_mat_complex(2, 3)**2 + &
+ & s_mat_complex(2, 2)*s_mat_complex(3, 3))
+
+ b_complex(1) = (-s_mat_complex(2, 3)**2 + s_mat_complex(1, 3)*(-s_mat_complex(2, 2) + s_mat_complex(2, 3)) + &
+ & s_mat_complex(1, 2)*(s_mat_complex(2, 3) - s_mat_complex(3, 3)) + s_mat_complex(2, 2)*s_mat_complex(3, 3))/detS3
+ b_complex(2) = (-s_mat_complex(1, 3)**2 + s_mat_complex(1, 3)*s_mat_complex(2, 3) + &
+ & s_mat_complex(1, 2)*(s_mat_complex(1, 3) - s_mat_complex(3, 3)) + &
+ & s_mat_complex(1, 1)*(-s_mat_complex(2, 3) + s_mat_complex(3, 3)))/detS3
+ b_complex(3) = (-s_mat_complex(1, 2)**2 - s_mat_complex(1, 3)*s_mat_complex(2, 2) + &
+ & s_mat_complex(1, 1)*(s_mat_complex(2, 2) - s_mat_complex(2, 3)) + &
+ & s_mat_complex(1, 2)*(s_mat_complex(1, 3) + s_mat_complex(2, 3)))/detS3
+ !
+ sumb_complex = (-s_mat_complex(1, 2)**2 - s_mat_complex(1, 3)**2 + s_mat_complex(1, 1)*s_mat_complex(2, 2) - &
+ & 2*s_mat_complex(1, 3)*(s_mat_complex(2, 2) - s_mat_complex(2, 3)) - 2*s_mat_complex(1, 1)*s_mat_complex(2, 3) - &
+ & s_mat_complex(2, 3)**2 + 2*s_mat_complex(1, 2)*(s_mat_complex(1, 3) + s_mat_complex(2, 3) - s_mat_complex(3, 3)) + &
+ & s_mat_complex(1, 1)*s_mat_complex(3, 3) + s_mat_complex(2, 2)*s_mat_complex(3, 3))/detS3
+ !
+ invs_complex(1,1) = (-s_mat_complex(2, 3)**2 + s_mat_complex(2, 2)*s_mat_complex(3, 3))/detS3
+ invs_complex(1,2) = (s_mat_complex(1, 3)*s_mat_complex(2, 3) - s_mat_complex(1, 2)*s_mat_complex(3, 3))/detS3
+ invs_complex(1,3) = (-(s_mat_complex(1, 3)*s_mat_complex(2, 2)) + s_mat_complex(1, 2)*s_mat_complex(2, 3))/detS3
+ invs_complex(2,1) = invs_complex(1,2)
+ invs_complex(2,2) = (-s_mat_complex(1, 3)**2 + s_mat_complex(1, 1)*s_mat_complex(3, 3))/detS3
+ invs_complex(2,3) = (s_mat_complex(1, 2)*s_mat_complex(1, 3) - s_mat_complex(1, 1)*s_mat_complex(2, 3))/detS3
+ invs_complex(3,1) = invs_complex(1,3)
+ invs_complex(3,2) = invs_complex(2,3)
+ invs_complex(3,3) = (-s_mat_complex(1, 2)**2 + s_mat_complex(1, 1)*s_mat_complex(2, 2))/detS3
+ !
+ lamb = 2._ki*s_mat_complex(1,3)*s_mat_complex(2,3)+2._ki*s_mat_complex(1,2)*s_mat_complex(2,3)&
+ +2._ki*s_mat_complex(1,3)*s_mat_complex(1,2)-s_mat_complex(1,3)*s_mat_complex(1,3)-s_mat_complex(1,2)*s_mat_complex(1,2)&
+ -s_mat_complex(2,3)*s_mat_complex(2,3)
+ !
+ nb_par = count(mask=par/=0)
+ !
+ if (nb_par == 0) then
+ !
+ norma = -1._ki/2._ki
+ !
+ else if (nb_par == 1) then
+ !
+ norma = -1._ki/6._ki
+ !
+ else
+ !
+ norma = 0._ki
+ !
+ end if
+ !
+ ! memory allocation to save time in the recursion
+ !
+ allocate(deja_calcule_c(4))
+ allocate(resultat_c(4,1) )
+ allocate(deja_calcule2_c(3,4))
+ allocate(resultat2_c(3,4,2))
+ allocate(deja_calcule_np2_c(4))
+ allocate(resultat_np2_c(4,2))
+ allocate(deja_calcule22_c(3,4,4))
+ allocate(resultat22_c(3,4,4,2))
+ !
+ ! initialisation
+ !
+ deja_calcule_c = .false.
+ resultat_c = czero
+ deja_calcule2_c = .false.
+ resultat2_c = czero
+ deja_calcule_np2_c = .false.
+ resultat_np2_c = czero
+ deja_calcule22_c = .false.
+ resultat22_c = czero
+ !
+ !
+ f3p_finite_carg(:) = 0._ki
+ !
+ ! if (abs(sumb_complex) > coupure_3p3m) then
+ ! if (abs(sumb_complex) > 0._ki) then
+ !
+ ! always use analytic computation until massive numerical is implemented
+ !
+ !
+ if (dim == "ndi") then
+ !
+ temp0 = a3pC0i_carg(s1r,s2r,s3r,m1,m2,m3,par1,par2,par3)
+ f3p_finite_carg(3) = real(temp0,ki)
+ f3p_finite_carg(4) = aimag(temp0)
+ !
+ else if (dim == "n+2") then
+ !
+ temp = a3pC0i_np2_carg(s1r,s2r,s3r,m1,m2,m3,par1,par2,par3)
+ f3p_finite_carg(1) = real(temp(1),ki)
+ f3p_finite_carg(2) = aimag(temp(1))
+ f3p_finite_carg(3) = real(temp(2),ki)
+ f3p_finite_carg(4) = aimag(temp(2))
+ ! f3p_finite(3) = f3p_finite(3)-log(plus_grand)*norma
+ ! mu2_scale_par is already contained in the bubbles,
+ ! scaling of s_mat_complex does not enter here
+ !
+ end if
+ !
+ ! numerical computation disabled
+ !
+ deallocate(deja_calcule_c)
+ deallocate(resultat_c)
+ deallocate(deja_calcule2_c)
+ deallocate(resultat2_c)
+ deallocate(deja_calcule_np2_c)
+ deallocate(resultat_np2_c)
+ deallocate(deja_calcule22_c)
+ deallocate(resultat22_c)
+ !
+ call nullify_s_matrix(s_mat_p_loc)
+ !
+ end function f3p_finite_carg
+ !
+ !****f* src/integral/three_point/function_3pC0i/f3p_finite_c
+ ! NAME
+ !
+ ! Function f3p_finite_c
+ !
+ ! USAGE
+ !
+ ! complex_dim2 = f3p_finite_c(s1,s2,s3,m1,m2,m3,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! It computes the same as the function f3p_finite, but the returned
+ ! value is a complex (type ki) array of rank 1 and shape 2
+ !
+ ! INPUTS
+ !
+ ! * dim -- a character (length 3), to compute in n or n+2 dimensions
+ ! * s1 -- a real (type ki), p1^2
+ ! * s2 -- a real (type ki), p2^2
+ ! * s3 -- a real (type ki), p3^2
+ ! * m1 -- a real (type ki), the first mass^2
+ ! * m2 -- a real (type ki), the second mass^2
+ ! * m3 -- a real (type ki), the third mass^2
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ ! Note that par1,par2 and par3 are supposed to be ordered, i.e.
+ ! par1 <= par2 <= par3, note also that put zero for par1, par2 or par3
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An complex (type ki) array of rank 1 and shape 2 corresponding to
+ ! the (real part,imaginary part) of the coefficient of the 1/epsilon term
+ ! and the (real part,imaginary part) of the constant term. if par1 and/or par2
+ ! are different from zero for dim="n+2", an error is returned.
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f3p_finite_c(dim,s1,s2,s3,m1,m2,m3,par1,par2,par3)
+ !
+ use translate
+ implicit none
+ !
+ character (len=3), intent (in) :: dim
+ real(ki), intent (in) :: s1,s2,s3,m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ complex(ki), dimension(2) :: f3p_finite_c
+ !
+ real(ki), dimension(4) :: res4
+ !
+ res4 = f3p_finite(dim,s1,s2,s3,m1,m2,m3,par1,par2,par3)
+ call to_complex(res4,f3p_finite_c)
+ !
+ end function f3p_finite_c
+ !
+ !****if* src/integral/three_point/function_3pC0i/a3pC0i
+ ! NAME
+ !
+ ! Function a3pC0i
+ !
+ ! USAGE
+ !
+ ! real_dim2 = a3pC0i_rarg(s1,s2,s3,m1r,m2r,m3r,par1,par2,par3)
+ ! complex_dim1 = a3pC0i_carg(s1,s2,s3,m1c,m2c,m3c,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This recursive function implements the formula of ref 1
+ !
+ ! INPUTS
+ !
+ ! * s1 -- a real (type ki), p1^2
+ ! * s2 -- a real (type ki), p2^2
+ ! * s3 -- a real (type ki), p3^2
+ ! * m1(r/c) -- a real/complex (type ki), the first internal mass squared
+ ! * m2(r/c) -- a real/complex (type ki), the second internal mass squared
+ ! * m3(r/c) -- a real/complex (type ki), the third internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! This function modifies the value of the local (for the module) variables:
+ ! * deja_calcule(_c), deja_calcule2, deja_calcule_np2(_c) and deja_calcule22
+ ! * resultat(_c), resultat2, resultat_np2(_c) and resultat22
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real/complex (type ki) array of rank 1 and shape 2/1
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ recursive function a3pC0i_rarg(s1,s2,s3,m1,m2,m3,par1,par2,par3) result(res_3pC0i_rarg)
+ !
+ implicit none
+ real(ki), intent (in) :: s1,s2,s3,m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(2) :: res_3pC0i_rarg
+ !
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(3) :: par_loc,par_plus
+ real(ki), dimension(4) :: truc1
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(4) :: temp1,temp2,temp3
+ real(ki), dimension(4) :: temp10,temp11,temp12
+ complex(ki) :: ctemp
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ ! write(6,*) 'calls a3pC0i_rarg'
+ ctemp = C0(s1,s2,s3,m1,m2,m3)
+ res_3pC0i_rarg(1) = real(ctemp,ki)
+ res_3pC0i_rarg(2) = aimag(ctemp)
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a3pC0i_rarg(s1,s2,s3,m1,m2,m3,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp1 = 0._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (deja_calcule2(j,1)) then
+ !
+ truc1 = resultat2(j,1,:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj) !returns real array!
+ resultat2(j,1,:) = truc1
+ deja_calcule2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b_real(j)*truc1
+ temp2 = temp2 + invs_real(j,par3)*truc1
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_rarg(1) = b_real(par3)*(temp0(1) - temp1(3))/sumb_real + temp2(3)
+ res_3pC0i_rarg(2) = b_real(par3)*(temp0(2) - temp1(4))/sumb_real + temp2(4)
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ if (deja_calcule_np2(par_plus(3))) then
+ !
+ temp11 = resultat_np2(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a3pC0i_np2_rarg(s1,s2,s3,m1,m2,m3,0,0,par3)
+ resultat_np2(par_plus(3),:) = temp11
+ deja_calcule_np2(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp10 = resultat_np2(1,:)
+ temp3 = invs_real(par2,par3)*temp10
+ temp1 = b_real(par2)*temp11
+ temp1 = mult_div(-2._ki/3._ki,temp1)*3._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule2(j,par_plus(3))) then
+ !
+ truc1 = resultat2(j,par_plus(3),:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj,par3) !returns real array!
+ resultat2(j,par_plus(3),:) = truc1
+ deja_calcule2(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + invs_real(j,par2)*truc1
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_rarg(1) = -temp3(3) + temp1(3) + temp2(3)
+ res_3pC0i_rarg(2) = -temp3(4) + temp1(4) + temp2(4)
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ temp12 = a3pC0i_np2_rarg(s1,s2,s3,m1,m2,m3,0,par2,par3)
+ temp10 = resultat_np2(par_plus(3),:)
+ temp11 = resultat_np2(par_plus(2),:)
+ temp3 = invs_real(par1,par2)*temp10 &
+ + invs_real(par1,par3)*temp11
+ temp1 = b_real(par1)*temp12
+ temp1 = mult_div(-1._ki/2._ki,temp1)*4._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if ( (j /= par3) .and. (j /= par2) ) then
+ !
+ truc1 = resultat22(j,par_plus(2),par_plus(3),:)
+ temp2 = temp2 + invs_real(j,par1)*truc1
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_rarg(1) = -temp3(3) + temp1(3) + temp2(3)
+ res_3pC0i_rarg(2) = -temp3(4) + temp1(4) + temp2(4)
+ !
+ end if
+ !
+ end function a3pC0i_rarg
+ !
+ recursive function a3pC0i_carg(s1,s2,s3,m1,m2,m3,par1,par2,par3) result(res_3pC0i_carg)
+ !
+ implicit none
+ real(ki), intent (in) :: s1,s2,s3
+ complex(ki), intent (in) :: m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ complex(ki) :: res_3pC0i_carg
+ !
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(3) :: par_loc,par_plus
+ complex(ki), dimension(2) :: truc1_c
+ complex(ki) :: temp0
+ complex(ki), dimension(2) :: temp1, temp2, temp3
+ complex(ki), dimension(2) :: temp10, temp11, temp12
+ complex(ki) :: ctemp
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ ctemp = C0(s1,s2,s3,m1,m2,m3)
+ res_3pC0i_carg = ctemp
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule_c(1)) then
+ !
+ temp0 = resultat_c(1,1)
+ !
+ else
+ !
+ temp0 = a3pC0i_carg(s1,s2,s3,m1,m2,m3,0,0,0)
+ resultat_c(1,1) = temp0
+ deja_calcule_c(1) = .true.
+ !
+ end if
+ !
+ temp1(:) = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (deja_calcule2_c(j,1)) then
+ !
+ truc1_c = resultat2_c(j,1,:)
+ !
+ else
+ !
+ truc1_c = f2p(s_mat_p_loc,b_pro_mj) !returns complex array!
+ resultat2_c(j,1,:) = truc1_c
+ deja_calcule2_c(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b_complex(j)*truc1_c
+ temp2 = temp2 + invs_complex(j,par3)*truc1_c
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_carg = b_complex(par3)*(temp0 - temp1(2))/sumb_complex + temp2(2)
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ if (deja_calcule_np2_c(par_plus(3))) then
+ !
+ temp11 = resultat_np2_c(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a3pC0i_np2_carg(s1,s2,s3,m1,m2,m3,0,0,par3)
+ resultat_np2_c(par_plus(3),:) = temp11
+ deja_calcule_np2_c(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp10 = resultat_np2_c(1,:)
+ temp3 = invs_complex(par2,par3)*temp10
+ temp1 = b_complex(par2)*temp11
+ temp1 = mult_div(-2._ki/3._ki,temp1)*3._ki
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule2_c(j,par_plus(3))) then
+ !
+ truc1_c = resultat2_c(j,par_plus(3),:)
+ !
+ else
+ !
+ truc1_c = f2p(s_mat_p_loc,b_pro_mj,par3) !returns complex array!
+ resultat2_c(j,par_plus(3),:) = truc1_c
+ deja_calcule2_c(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + invs_complex(j,par2)*truc1_c
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_carg = -temp3(2) + temp1(2) + temp2(2)
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ temp12 = a3pC0i_np2_carg(s1,s2,s3,m1,m2,m3,0,par2,par3)
+ temp10 = resultat_np2_c(par_plus(3),:)
+ temp11 = resultat_np2_c(par_plus(2),:)
+ temp3 = invs_complex(par1,par2)*temp10 &
+ + invs_complex(par1,par3)*temp11
+ temp1 = b_complex(par1)*temp12
+ temp1 = mult_div(-1._ki/2._ki,temp1)*4._ki
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if ( (j /= par3) .and. (j /= par2) ) then
+ !
+ truc1_c = resultat22_c(j,par_plus(2),par_plus(3),:) !!returns complex array!
+ temp2 = temp2 + invs_complex(j,par1)*truc1_c
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_carg = -temp3(2) + temp1(2) + temp2(2)
+ !
+ end if
+ !
+ end function a3pC0i_carg
+ !
+ !****if* src/integral/three_point/function_3pC0i/a3pC0i_np2
+ ! NAME
+ !
+ ! Function a3pC0i_np2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = a3pC0i_np2_rarg(s1,s2,s3,m1r,m2r,m3r,par1,par2,par3)
+ ! complex_dim2 = a3pC0i_np2_carg(s1,s2,s3,m1c,m2c,m3c,par1,par2,par3)
+ !
+ ! DESCRIPTION
+ !
+ ! This recursive function implements the formula of ref 1
+ !
+ ! INPUTS
+ !
+ ! * s1 -- a real (type ki), p1^2
+ ! * s2 -- a real (type ki), p2^2
+ ! * s3 -- a real (type ki), p3^2
+ ! * m1(r/c) -- a real/complex (type ki), the first internal mass squared
+ ! * m2(r/c) -- a real/complex (type ki), the second internal mass squared
+ ! * m3(r/c) -- a real/complex (type ki), the third internal mass squared
+ ! * par1 -- an integer, the label of the third Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! * par3 -- an integer, the label of the first Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! This function modifies the value of the local (for the module) variables:
+ ! * deja_calcule(_c), deja_calcule2, deja_calcule_np2(_c) and deja_calcule22
+ ! * resultat(_c), resultat2, resultat_np2(_c) and resultat22
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real/complex (type ki) array of rank 1 and shape 4/2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ recursive function a3pC0i_np2_rarg(s1,s2,s3,m1,m2,m3,par1,par2,par3) result(res_3pC0i_np2_rarg)
+ !
+ implicit none
+
+ real(ki), intent (in) :: s1,s2,s3,m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ real(ki), dimension(4) :: res_3pC0i_np2_rarg
+ !
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(3) :: par_loc,par_plus
+ real(ki), dimension(4) :: truc1,truc2
+ real(ki), dimension(2) :: temp0
+ real(ki), dimension(4) :: temp1,temp2,temp3
+ real(ki), dimension(4) :: temp10,temp11
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule(1)) then
+ !
+ temp0 = resultat(1,:)
+ !
+ else
+ !
+ temp0 = a3pC0i_rarg(s1,s2,s3,m1,m2,m3,0,0,0)
+ resultat(1,:) = temp0
+ deja_calcule(1) = .true.
+ !
+ end if
+ !
+ temp1 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (deja_calcule2(j,1)) then
+ !
+ truc1 = resultat2(j,1,:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj) !returns real array!
+ resultat2(j,1,:) = truc1
+ deja_calcule2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b_real(j)*truc1
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_np2_rarg(1) = (- temp1(1))/sumb_real
+ res_3pC0i_np2_rarg(2) = (- temp1(2))/sumb_real
+ res_3pC0i_np2_rarg(3) = (temp0(1) - temp1(3))/sumb_real
+ res_3pC0i_np2_rarg(4) = (temp0(2) - temp1(4))/sumb_real
+ res_3pC0i_np2_rarg = mult_div(1._ki,res_3pC0i_np2_rarg)/2._ki
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule_np2(1)) then
+ !
+ temp10 = resultat_np2(1,:)
+ !
+ else
+ !
+ temp10 = a3pC0i_np2_rarg(s1,s2,s3,m1,m2,m3,0,0,0)
+ resultat_np2(1,:) = temp10
+ deja_calcule_np2(1) = .true.
+ !
+ end if
+ !
+ temp3 = b_real(par3)*temp10
+ temp1 = 0._ki
+ temp2 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (deja_calcule2(j,1)) then
+ !
+ truc1 = resultat2(j,1,:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj) !returns real array!
+ resultat2(j,1,:) = truc1
+ deja_calcule2(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs_real(j,par3)*truc1
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule2(j,par_plus(3))) then
+ !
+ truc2 = resultat2(j,par_plus(3),:)
+ !
+ else
+ !
+ truc2 = f2p_ra(s_mat_p_loc,b_pro_mj,par3) !returns real array!
+ resultat2(j,par_plus(3),:) = truc2
+ deja_calcule2(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + b_real(j)*truc2
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ temp1 = mult_div(2._ki/3._ki,temp1)/3._ki
+ temp2 = mult_div(2._ki/3._ki,temp2)/3._ki
+ res_3pC0i_np2_rarg(1) = (temp3(1) + temp1(1) - temp2(1))/sumb_real
+ res_3pC0i_np2_rarg(2) = (temp3(2) + temp1(2) - temp2(2))/sumb_real
+ res_3pC0i_np2_rarg(3) = (temp3(3) + temp1(3) - temp2(3))/sumb_real
+ res_3pC0i_np2_rarg(4) = (temp3(4) + temp1(4) - temp2(4))/sumb_real
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ temp0 = a3pC0i_rarg(s1,s2,s3,m1,m2,m3,0,par2,par3)
+ !
+ if (deja_calcule_np2(par_plus(2))) then
+ !
+ temp10 = resultat_np2(par_plus(2),:)
+ !
+ else
+ !
+ temp10 = a3pC0i_np2_rarg(s1,s2,s3,m1,m2,m3,0,0,par2)
+ resultat_np2(par_plus(2),:) = temp10
+ deja_calcule_np2(par_plus(2)) = .true.
+ !
+ end if
+ !
+ !
+ if (deja_calcule_np2(par_plus(3))) then
+ !
+ temp11 = resultat_np2(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a3pC0i_np2_rarg(s1,s2,s3,m1,m2,m3,0,0,par3)
+ resultat_np2(par_plus(3),:) = temp11
+ deja_calcule_np2(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp3 = b_real(par3)*temp10 + b_real(par2)*temp11
+ temp1 = 0._ki
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if ( (j /= par2) .and. (j /= par3) ) then
+ !
+ if (deja_calcule22(j,par_plus(2),par_plus(3))) then
+ !
+ truc1 = resultat22(j,par_plus(2),par_plus(3),:)
+ !
+ else
+ !
+ truc1 = f2p_ra(s_mat_p_loc,b_pro_mj,par2,par3) !returns real array!
+ resultat22(j,par_plus(2),par_plus(3),:) = truc1
+ deja_calcule22(j,par_plus(2),par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b_real(j)*truc1
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_np2_rarg(1) = (temp3(1) - temp1(1))/sumb_real
+ res_3pC0i_np2_rarg(2) = (temp3(2) - temp1(2))/sumb_real
+ res_3pC0i_np2_rarg(3) = (temp0(1) + temp3(3) - temp1(3))/sumb_real
+ res_3pC0i_np2_rarg(4) = (temp0(2) + temp3(4) - temp1(4))/sumb_real
+ res_3pC0i_np2_rarg = mult_div(1._ki/2._ki,res_3pC0i_np2_rarg)/4._ki
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'Error in f3p_finite:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'rank 3 6-dim 3-point function should not be needed'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a3pC0i_np2_rarg
+ !
+ recursive function a3pC0i_np2_carg(s1,s2,s3,m1,m2,m3,par1,par2,par3) result(res_3pC0i_np2_carg)
+ !
+ implicit none
+ !
+ real(ki), intent (in) :: s1,s2,s3
+ complex(ki), intent (in) :: m1,m2,m3
+ integer, intent (in) :: par1,par2,par3
+ complex(ki), dimension(2) :: res_3pC0i_np2_carg
+ !
+ integer :: j
+ integer :: nb_par_loc
+ integer, dimension(3) :: par_loc,par_plus
+ complex(ki), dimension(2) :: truc1_c, truc2_c
+ complex(ki) :: temp0
+ complex(ki), dimension(2) :: temp1, temp2, temp3
+ complex(ki), dimension(2) :: temp10, temp11
+ integer :: ib,b_pro,b_pro_mj
+ !
+ b_pro = packb(s)
+ !
+ par_loc = (/par1,par2,par3/)
+ par_plus = par_loc+1
+ nb_par_loc = count(mask=par_loc/=0)
+ !
+ ! cas sans parametre de feynman au numerateur
+ !
+ if (nb_par_loc == 0) then
+ !
+ if (deja_calcule_c(1)) then
+ !
+ temp0 = resultat_c(1,1)
+ !
+ else
+ !
+ temp0 = a3pC0i_carg(s1,s2,s3,m1,m2,m3,0,0,0)
+ resultat_c(1,1) = temp0
+ deja_calcule_c(1) = .true.
+ !
+ end if
+ !
+ temp1(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (deja_calcule2_c(j,1)) then
+ !
+ truc1_c = resultat2_c(j,1,:)
+ !
+ else
+ !
+ truc1_c = f2p(s_mat_p_loc,b_pro_mj) !!! returns complex array!
+ resultat2_c(j,1,:) = truc1_c
+ deja_calcule2_c(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b_complex(j)*truc1_c
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_np2_carg(1) = (- temp1(1))/sumb_complex
+ res_3pC0i_np2_carg(2) = (temp0 - temp1(2))/sumb_complex
+ res_3pC0i_np2_carg = mult_div(1._ki,res_3pC0i_np2_carg)/2._ki
+ !
+ ! cas avec un parametre de feynman au numerateur
+ !
+ else if (nb_par_loc == 1) then
+ !
+ if (deja_calcule_np2_c(1)) then
+ !
+ temp10 = resultat_np2_c(1,:)
+ !
+ else
+ !
+ temp10 = a3pC0i_np2_carg(s1,s2,s3,m1,m2,m3,0,0,0)
+ resultat_np2_c(1,:) = temp10
+ deja_calcule_np2_c(1) = .true.
+ !
+ end if
+ !
+ temp3 = b_complex(par3)*temp10
+ temp1(:) = czero
+ temp2(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if (deja_calcule2_c(j,1)) then
+ !
+ truc1_c = resultat2_c(j,1,:)
+ !
+ else
+ !
+ truc1_c = f2p(s_mat_p_loc,b_pro_mj) !!! returns complex array!
+ resultat2_c(j,1,:) = truc1_c
+ deja_calcule2_c(j,1) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + invs_complex(j,par3)*truc1_c
+ !
+ if (j /= par3) then
+ !
+ if (deja_calcule2_c(j,par_plus(3))) then
+ !
+ truc2_c = resultat2_c(j,par_plus(3),:)
+ !
+ else
+ !
+ truc2_c = f2p(s_mat_p_loc,b_pro_mj,par3) !!! returns complex array!
+ resultat2_c(j,par_plus(3),:) = truc2_c
+ deja_calcule2_c(j,par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp2 = temp2 + b_complex(j)*truc2_c
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ temp1 = mult_div(2._ki/3._ki,temp1)/3._ki
+ temp2 = mult_div(2._ki/3._ki,temp2)/3._ki
+ res_3pC0i_np2_carg(1) = (temp3(1) + temp1(1) - temp2(1))/sumb_complex
+ res_3pC0i_np2_carg(2) = (temp3(2) + temp1(2) - temp2(2))/sumb_complex
+ !
+ ! cas avec deux parametres de feynman au numerateur
+ !
+ else if (nb_par_loc == 2) then
+ !
+ temp0 = a3pC0i_carg(s1,s2,s3,m1,m2,m3,0,par2,par3)
+ !
+ if (deja_calcule_np2_c(par_plus(2))) then
+ !
+ temp10 = resultat_np2_c(par_plus(2),:)
+ !
+ else
+ !
+ temp10 = a3pC0i_np2_carg(s1,s2,s3,m1,m2,m3,0,0,par2)
+ resultat_np2_c(par_plus(2),:) = temp10
+ deja_calcule_np2_c(par_plus(2)) = .true.
+ !
+ end if
+ !
+ if (deja_calcule_np2_c(par_plus(3))) then
+ !
+ temp11 = resultat_np2_c(par_plus(3),:)
+ !
+ else
+ !
+ temp11 = a3pC0i_np2_carg(s1,s2,s3,m1,m2,m3,0,0,par3)
+ resultat_np2_c(par_plus(3),:) = temp11
+ deja_calcule_np2_c(par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp3 = b_complex(par3)*temp10 + b_complex(par2)*temp11
+ temp1(:) = czero
+ !
+ ib = b_pro
+ j = 0
+ !
+ do while (ib /= 0)
+ !
+ if (modulo(ib,2) == 1) then
+ !
+ b_pro_mj = ibclr(b_pro,j)
+ !
+ if ( (j /= par2) .and. (j /= par3) ) then
+ !
+ if (deja_calcule22_c(j,par_plus(2),par_plus(3))) then
+ !
+ truc1_c = resultat22_c(j,par_plus(2),par_plus(3),:)
+ !
+ else
+ !
+ truc1_c = f2p(s_mat_p_loc,b_pro_mj,par2,par3) !!!returns complex array
+ resultat22_c(j,par_plus(2),par_plus(3),:) = truc1_c
+ deja_calcule22_c(j,par_plus(2),par_plus(3)) = .true.
+ !
+ end if
+ !
+ temp1 = temp1 + b_complex(j)*truc1_c
+ !
+ end if
+ !
+ end if
+ !
+ j = j+1
+ ib= ishft(ib,-1)
+ !
+ end do
+ !
+ res_3pC0i_np2_carg(1) = (temp3(1) - temp1(1))/sumb_complex
+ res_3pC0i_np2_carg(2) = (temp0 + temp3(2) - temp1(2))/sumb_complex
+ res_3pC0i_np2_carg = mult_div(1._ki/2._ki,res_3pC0i_np2_carg)/4._ki
+ !
+ ! cas avec trois parametres de feynman au numerateur
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'Error in f3p_finite:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'rank 3 6-dim 3-point function should not be needed'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function a3pC0i_np2_carg
+ !
+ !****f* src/integral/three_point/function_3pC0i/C0
+ ! NAME
+ !
+ ! Function C0
+ !
+ ! USAGE
+ !
+ ! complex = C0(s1,s2,s3,m1,m2,m3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes finite scalar three point functions
+ ! with internal masses in 4 dimensions
+ !
+ ! INPUTS
+ !
+ ! * s1 -- a real/complex (type ki), p1^2
+ ! * s2 -- a real/complex (type ki), p2^2
+ ! * s3 -- a real/complex (type ki), p3^2
+ ! * m1 -- a real/complex (type ki), the first internal mass squared
+ ! * m2 -- a real/complex (type ki), the second internal mass squared
+ ! * m3 -- a real/complex (type ki), the third internal mass squared
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of rat_or_tot_par
+ ! (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ !
+ !*****
+ function C0_rarg(s1,s2,s3,m1sq,m2sq,m3sq)
+ implicit none
+ !
+ ! s1,s2,s3 = SQUARED external momenta
+ ! m1sq,m2sq,m3sq = SQUARED internal masses
+ real(ki), intent(in) :: s1,s2,s3,m1sq,m2sq,m3sq
+ real(ki) :: s1r,s2r,s3r
+ ! real(ki) :: del
+ complex(ki) :: C0_rarg
+ complex(ki_avh), dimension(0:2) :: C0olo
+ !AC! complex(ki_lt) :: C0
+ ! del = epsilon(1._ki)
+ !
+ s1r = s1
+ s2r = s2
+ s3r = s3
+ !
+! if (equal_real(s1r,zero) ) s1r = 0._ki
+! if (equal_real(s2r,zero) ) s2r = 0._ki
+! if (equal_real(s3r,zero) ) s3r = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ ! changed to include LT option Jan2011
+ ! use avh_olo or LT in finite case
+!AC! if (withlt) then
+ !
+!AC! C0_rarg = C0(real(s1,ki_lt),real(s2,ki_lt),real(s3,ki_lt),&
+!AC! & real(m3sq,ki_lt),real(m1sq,ki_lt),real(m2sq,ki_lt))
+ !
+!AC! else
+ ! use avh_olo
+ if (.not. olo) then
+ ! call avh_olo_onshell(100._ki*del)
+ call avh_olo_onshell(1.e-10_ki)
+ call avh_olo_mu_set(sqrt(mu2_scale_par))
+ olo=.true.
+ end if
+ !
+ !
+ call avh_olo_c0m(C0olo,real(s1r,ki_avh),real(s2r,ki_avh),real(s3r,ki_avh), &
+ & real(m3sq,ki_avh),real(m1sq,ki_avh),real(m2sq,ki_avh))
+ !
+ !
+ C0_rarg=C0olo(0)
+ !
+!AC! end if ! end if withlt
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ C0_rarg = czero
+ !
+ end if
+ !
+ end function C0_rarg
+ !
+ function C0_carg(s1,s2,s3,m1sq,m2sq,m3sq)
+ implicit none
+ !
+ ! s1,s2,s3 = SQUARED external momenta
+ ! m1sq,m2sq,m3sq = SQUARED internal complex masses
+ real(ki), intent(in) :: s1,s2,s3
+ complex(ki), intent(in) :: m1sq,m2sq,m3sq
+ complex(ki_avh) :: cp1,cp2,cp3,cm1,cm2,cm3
+ real(ki) :: s1r,s2r,s3r
+ ! real(ki) :: del
+ complex(ki) :: C0_carg
+ complex(ki_avh), dimension(0:2) :: C0olo
+ !AC! complex(ki_lt) :: C0C
+ !integer :: i,j,k
+ ! del = epsilon(1._ki)
+ !
+ s1r = s1
+ s2r = s2
+ s3r = s3
+ !
+! if (equal_real(s1r,zero) ) s1r = 0._ki
+! if (equal_real(s2r,zero) ) s2r = 0._ki
+! if (equal_real(s3r,zero) ) s3r = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ ! changed to include LT option Jan2011
+ ! use avh_olo or LT in finite case
+!AC! if (withlt) then
+ !
+!AC! C0_carg = C0C(real(s1,ki_lt),real(s2,ki_lt),real(s3,ki_lt),&
+!AC! & cmplx(m3sq,kind=ki_lt),cmplx(m1sq,kind=ki_lt),cmplx(m2sq,kind=ki_lt))
+ !
+!AC! else
+ ! use avh_olo
+ if (.not. olo) then
+ ! call avh_olo_onshell(100._ki*del)
+ call avh_olo_onshell(1.e-10_ki)
+ call avh_olo_mu_set(sqrt(mu2_scale_par))
+ olo=.true.
+ end if
+ !
+ cp1 = cmplx(s1r,0._ki_avh,kind=ki_avh)
+ cp2 = cmplx(s2r,0._ki_avh,kind=ki_avh)
+ cp3 = cmplx(s3r,0._ki_avh,kind=ki_avh)
+ !
+ cm1 = cmplx(m1sq,kind=ki_avh)
+ cm2 = cmplx(m2sq,kind=ki_avh)
+ cm3 = cmplx(m3sq,kind=ki_avh)
+ !
+ call avh_olo_c0c(C0olo,cp1,cp2,cp3,cm3,cm1,cm2)
+ !
+ C0_carg=C0olo(0)
+ !
+!AC! end if !end if withlt
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ C0_carg = czero
+ !
+ end if
+ !
+ end function C0_carg
+ !
+ ! *************************************************
+ !
+end module function_3p_finite
diff --git a/golem95c-1.2.1/integrals/three_point/generic_function_3p.f90 b/golem95c-1.2.1/integrals/three_point/generic_function_3p.f90
new file mode 100644
index 0000000..fcd3cc9
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/generic_function_3p.f90
@@ -0,0 +1,1463 @@
+!****h* src/integrals/three_point/generic_function_3p
+! NAME
+!
+! Module generic_function_3p
+!
+! USAGE
+!
+! use generic_function_3p
+!
+! DESCRIPTION
+!
+! This module contains the generic routines to compute the
+! three point functions in n and n+2 dimensions
+!
+! OUTPUT
+!
+! It exports two public routines:
+! * f3p(_sc) -- a function to compute the three point function in n dimensions
+! * f3p_np2(_sc) -- a function to compute the three point function in n+2 dimensions
+! Calling the functions with _sc returns a real array. These calls will not be cached.
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s (src/kinematic/matrice_s.f90) ( only : dim_s, b_ref )
+! * s_matrix_type (src/module/s_matrix_type.f90)
+! * array (src/module/array.f90)
+! * tri_croissant (src/module/tri.f90)
+! * constante (src/module/constante.f90)
+! * function_3p1m (src/integrals/three_point/function_3p1m.f90)
+! * function_3p2m (src/integrals/three_point/function_3p2m.f90)
+! * function_3p3m (src/integrals/three_point/function_3p3m.f90)
+! * cache (src/module/cache.f90)
+! * equal (src/module/equal.f90)
+!
+!*****
+module generic_function_3p
+ !
+ use precision_golem
+ use matrice_s, only : dim_s,b_ref
+ use s_matrix_type
+ use array
+ use tri_croissant
+ use constante
+ use function_3p0m_1mi
+ use function_3p1m
+ use function_3p1m_1mi
+ use function_3p1m_2mi
+ use function_3p2m
+ use function_3p2m_1mi
+ use function_3p3m
+ use parametre
+ use function_3p_finite
+ use cache
+ use equal
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ implicit none
+ !
+ private
+ !
+ integer, dimension(:), allocatable :: set
+ integer, dimension(3) :: set_tot
+ !
+ interface f3p_sc
+ module procedure f3p_sc_r, f3p_sc_c
+ module procedure f3p_sc_p
+ end interface
+ !
+ interface f3p_np2_sc
+ module procedure f3p_np2_sc_r, f3p_np2_sc_c
+ module procedure f3p_np2_sc_p
+ end interface
+ !
+ public :: f3p, f3p_np2
+! public :: f3p_ra, f3p_np2_ra !!! return real arrays. not needed in current implementation
+ public :: f3p_sc, f3p_np2_sc !!! (non-cached) return real arrays.
+ !can be called with real/complex arrays in addition.
+ !
+contains
+ !
+ !****f* src/integrals/three_point/generic_function_3p/f3p
+ ! NAME
+ !
+ ! Function f3p
+ !
+ ! USAGE
+ !
+ ! complex_dim3 = f3p(s_mat_p, b_pro, parf1, parf2, parf3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic three point function in n dimensions,
+ ! with or without Feynman parameters in the numerator.
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a type s_matrix_poly object, the S matrix
+ ! * b_pro -- an integer whose digits represents the set of the three unpinched
+ ! propagators
+ ! * parf1 -- an integer (optional), the label of the one Feynman parameter
+ ! * parf2 -- an integer (optional), the label of the second Feynman parameter
+ ! * parf3 -- an integer (optional), the label of the third Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) array of rank 1 and shape 3
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ function f3p(s_mat_p, b_pro,parf1,parf2,parf3)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: parf1,parf2,parf3
+ complex(ki), dimension(3) :: f3p
+ real(ki), dimension(6) :: f3p_real
+ !
+ f3p_real = f3p_ra(s_mat_p,b_pro,parf1=parf1,parf2=parf2,parf3=parf3)
+ f3p(1) = f3p_real(1) + i_ * f3p_real(2)
+ f3p(2) = f3p_real(3) + i_ * f3p_real(4)
+ f3p(3) = f3p_real(5) + i_ * f3p_real(6)
+ !
+ end function f3p
+ !
+ function f3p_ra(s_mat_p,b_pro,parf1,parf2,parf3)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: parf1,parf2,parf3
+ real(ki),dimension(6) :: f3p_ra
+ !
+ integer :: par1,par2,par3
+ integer :: par_cache1,par_cache2,par_cache3
+ integer, dimension(3) :: z_param_ini,z_param_out
+ integer :: taille
+ integer :: b_pin
+ integer, dimension(3) :: s
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ !
+ if (present(parf1)) par1 = parf1
+ if (present(parf2)) par2 = parf2
+ if (present(parf3)) par3 = parf3
+ !
+ z_param_ini = (/ par1,par2,par3 /)
+ !
+ where (z_param_ini /= 0)
+ !
+ z_param_ini = locateb(z_param_ini,b_pro)
+ !
+ elsewhere
+ !
+ z_param_ini = 0
+ !
+ end where
+ !
+ if ( minval(z_param_ini) == -1 ) then
+ !
+ f3p_ra = 0.0_ki
+ !
+ else
+ !
+ s = unpackb(b_pro,countb(b_pro))
+ taille = dim_s - size(s)
+ !
+ select case(taille)
+ !
+ case(0)
+ !
+ set_tot = 0
+ !
+ case(1)
+ !
+ allocate(set(1:taille))
+ b_pin = pminus(b_ref,b_pro)
+ set = unpackb(b_pin,countb(b_pin))
+ set_tot(1:2) = 0
+ set_tot(3) = set(1)
+ !
+ case(2)
+ !
+ allocate(set(1:taille))
+ b_pin = pminus(b_ref,b_pro)
+ set = unpackb(b_pin,countb(b_pin))
+ set_tot(1) = 0
+ set_tot(2:3) = set
+ !
+ case(3)
+ !
+ allocate(set(1:taille))
+ b_pin = pminus(b_ref,b_pro)
+ set = unpackb(b_pin,countb(b_pin))
+ set_tot = set
+ !
+ case default
+ !
+ set_tot = 0
+ taille = 0
+ !
+ end select
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ par_cache1 = z_param_out(1)
+ par_cache2 = z_param_out(2)
+ par_cache3 = z_param_out(3)
+ !
+ cache : if ( computed_f3p(set_tot(1),set_tot(2),set_tot(3),&
+ &par_cache1,par_cache2,par_cache3) ) then
+ !
+ f3p_ra = results_f3p(set_tot(1),set_tot(2),set_tot(3),&
+ &par_cache1,par_cache2,par_cache3,:)
+ !
+ else cache
+ !
+ f3p_ra = f3p_sc(s_mat_p,s,par_cache1,par_cache2,par_cache3)
+ !
+ computed_f3p(set_tot(1),set_tot(2),set_tot(3),&
+ &par_cache1,par_cache2,par_cache3) = .true.
+ results_f3p(set_tot(1),set_tot(2),set_tot(3),&
+ &par_cache1,par_cache2,par_cache3,:) = f3p_ra
+ !
+ end if cache
+ !
+ if (taille /= 0) deallocate(set)
+ !
+ end if
+ !
+ end function f3p_ra
+ !
+ !****f* src/integrals/three_point/generic_function_3p/f3p_sc
+ ! NAME
+ !
+ ! Function f3p_sc
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f3p_sc(s_mat,s,parf1,parf2,parf3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic three point function in n dimensions,
+ ! with or without Feynman parameters in the numerator without using a cache
+ !
+ ! INPUTS
+ !
+ ! * s_mat -- a real/complex (type ki)/s_matrix_poly array of rank 2, the S matrix
+ ! * s -- an integer array of rank 1 and shape 3, the set of the three unpinched
+ ! propagators
+ ! * parf1 -- an integer (optional), the label of the one Feynman parameter
+ ! * parf2 -- an integer (optional), the label of the second Feynman parameter
+ ! * parf3 -- an integer (optional), the label of the third Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 6
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+
+ function f3p_sc_p(s_mat_p,s,parf1,parf2,parf3)
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in), dimension(3) :: s
+ integer, intent(in), optional :: parf1, parf2, parf3
+ real(ki), dimension(6) :: f3p_sc_p
+ !
+ if (iand(s_mat_p%b_cmplx, packb(s)) .eq. 0 ) then
+ !
+ f3p_sc_p = f3p_sc_r(s_mat_p%pt_real, s, parf1=parf1,parf2=parf2,parf3=parf3)
+ !
+ else
+ !
+ f3p_sc_p = f3p_sc_c(s_mat_p%pt_cmplx, s, parf1=parf1,parf2=parf2,parf3=parf3)
+ !
+ end if
+ !
+ end function f3p_sc_p
+ !
+ function f3p_sc_r(s_mat_r,s,parf1,parf2,parf3)
+ !
+ real(ki), intent (in), dimension(:,:) :: s_mat_r
+ integer, intent (in), dimension(3) :: s
+ integer, intent (in), optional :: parf1,parf2,parf3
+ real(ki),dimension(6) :: f3p_sc_r
+ !
+ integer :: par1,par2,par3
+ integer, dimension(3) :: z_param_ini,z_param_out
+ real(ki) :: arg1,arg2,arg3,s1,s2,s3
+ real(ki) :: mass1,mass2,mass3
+ integer :: m1,m2,m3
+ logical, dimension(3) :: argz, mz,sz
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ !
+ if (present(parf1)) par1 = parf1
+ if (present(parf2)) par2 = parf2
+ if (present(parf3)) par3 = parf3
+ !
+ if ( (par1 == -1) .or. (par2 == -1) .or. (par3 == -1) ) then
+ !
+ f3p_sc_r(:) = 0._ki
+ !
+ else
+ ! symetrie: la place de z1,z2,z3 n'a pas d'importance, on les met
+ ! dans l'ordre croissant
+ z_param_ini(1) = par1
+ z_param_ini(2) = par2
+ z_param_ini(3) = par3
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ !
+ arg1 = s_mat_r(m1,m2)
+ arg2 = s_mat_r(m2,m3)
+ arg3 = s_mat_r(m1,m3)
+ !
+ argz(1) = equal_real(arg1,zero)
+ argz(2) = equal_real(arg2,zero)
+ argz(3) = equal_real(arg3,zero)
+ !
+ ! internal masses
+ mass1 = -s_mat_r(m1,m1)/2._ki
+ mass2 = -s_mat_r(m2,m2)/2._ki
+ mass3 = -s_mat_r(m3,m3)/2._ki
+ !
+ mz(1) = equal_real(mass1,zero)
+ mz(2) = equal_real(mass2,zero)
+ mz(3) = equal_real(mass3,zero)
+ !
+ ! external p_i^2
+ s1=arg3+mass1+mass3
+ s2=arg1+mass1+mass2
+ s3=arg2+mass2+mass3
+ !
+ sz(1) = equal_real(s1,zero)
+ sz(2) = equal_real(s2,zero)
+ sz(3) = equal_real(s3,zero)
+ !
+ call cut_s(s1,mass1,mass3)
+ call cut_s(s2,mass1,mass2)
+ call cut_s(s3,mass2,mass3)
+ !
+ ! initialize all components
+ f3p_sc_r(:) = 0._ki
+ !
+ ! the integrals are classified by the off-shellness of the external legs
+ !
+ !~ case with one light-like, two massive on-shell legs: QL tri5
+ !
+ if ( ( argz(1) ) .and. ( argz(2) ) .and. ( argz(3) ) ) then
+ !
+ ! comment 11.08.10: single out call with s_matrix being zero:
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function generic_function_3p.f90:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'function call with all arguments zero!'
+ call catch_exception(1)
+ !
+ !
+ ! case with one internal mass, two on-shell massive legs
+ !~ QL tri5, two on-shell massive legs
+ !
+ else if ( ( .not.( mz(3) ) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ !
+ f3p_sc_r = f3p0m_1mi(mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( .not.( mz(1) ) ) .and. ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ !
+ f3p_sc_r = f3p0m_1mi(mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( .not.( mz(2) ) ) .and. ( mz(1) ) .and. ( mz(3) ) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ !
+ f3p_sc_r = f3p0m_1mi(mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ ! comment 11.08.10: only one internal mass possible kinematically!
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function generic_function_3p.f90:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'function call with one lightlike, two massive external legs &
+ & and more than one internal mass!'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'This should not be allowed kinematically!'
+ call catch_exception(1)
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ ! finite triangle
+ f3p_sc_r(3:6)=f3p_finite("ndi",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if ! end scan internal mass
+ !
+ !
+ ! cases with one off-shell leg (one argi nonzero):
+ !~ QL tri1,tri4,tri6
+ !
+ else if ( ( argz(1) ) .and. ( argz(2) ) ) then
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ !~ QL tri1
+ f3p_sc_r = f3p1m(arg3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ !~ case with one internal mass: QL tri4
+ !
+ else if ( ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_sc_r = f3p1m_1mi(arg3,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ call exchange_param(z_param_ini,(/1,3/),3,z_param_out)
+ !
+ f3p_sc_r = f3p1m_1mi(arg3,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(1) ) .and. ( mz(3) ) ) then
+ ! no, this one is finite, corrected June 3, 2010
+ f3p_sc_r(3:6)=f3p_finite("ndi",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ !~ case with two internal masses: QL tri6
+ !
+ else if ( mz(2) ) then
+ !
+ f3p_sc_r = f3p1m_2mi(arg3,mass1,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ ! finite triangle
+ f3p_sc_r(3:6)=f3p_finite("ndi",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ ! cyclic permutation of arguments
+ !
+ else if ( (argz(2)) .and. (argz(3)) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_sc_r = f3p1m(arg1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass
+ !
+ else if ( ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ f3p_sc_r = f3p1m_1mi(arg1,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(3) ) .and. ( mz(1) ) ) then
+ !
+ ! labels (/1,2/) -> (/2,3/) corrected 19.7.
+ call exchange_param(z_param_ini,(/2,3/),3,z_param_out)
+ !
+ f3p_sc_r = f3p1m_1mi(arg1,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(2) ) .and. ( mz(1) ) ) then
+ !
+ ! finite
+ f3p_sc_r(3:6)=f3p_finite("ndi",s2,s3,s1,mass2,mass3,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with two internal masses
+ !
+ else if ( mz(3) ) then
+ !
+ ! mass labels corrected 19.7.10
+ f3p_sc_r = f3p1m_2mi(arg1,mass2,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ ! finite triangle
+ f3p_sc_r(3:6)=f3p_finite("ndi",s2,s3,s1,mass2,mass3,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ else if ( (argz(1)) .and. (argz(3)) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_sc_r = f3p1m(arg2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass
+ !
+ else if ( ( mz(1) ) .and. ( mz(3) ) ) then
+ !
+ f3p_sc_r = f3p1m_1mi(arg2,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(2) ) .and. ( mz(1) ) ) then
+ !
+ call exchange_param(z_param_ini,(/1,2/),3,z_param_out)
+ !
+ f3p_sc_r = f3p1m_1mi(arg2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ f3p_sc_r(3:6) = f3p_finite("ndi",s3,s1,s2,mass3,mass1,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with two internal masses
+ !
+ else if ( mz(1) ) then
+ !
+ ! mass labels corrected 19.7.10
+ f3p_sc_r = f3p1m_2mi(arg2,mass3,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ ! finite triangle
+ f3p_sc_r(3:6)=f3p_finite("ndi",s3,s1,s2,mass3,mass1,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ !
+ ! cases with two off-shell legs: QL tri2,tri3
+ !
+ else if ( (argz(1)) .and. (.not.(argz(2))) .and. (.not.(argz(3))) ) then
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ !~ QL tri2
+ f3p_sc_r = f3p2m(arg2,arg3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass: QL tri3
+ !
+ else if ( ( mz(1) ) .and. ( mz(2) ) .and. &
+ ! corrected 3.6.10
+ & (.not. equal_real(mass3,s1) ) .and. (.not. equal_real(mass3,s3) ) ) then
+ !
+ f3p_sc_r = f3p2m_1mi(arg2,arg3,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ ! finite triangle
+ f3p_sc_r(3:6)=f3p_finite("ndi",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ ! permute arguments
+ else if ( (argz(2)) .and. (.not.(argz(1))) .and. (.not.(argz(3))) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_sc_r = f3p2m(arg3,arg1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass: QL tri3
+ !
+ else if ( ( mz(2) ) .and. ( mz(3) ) .and. &
+ ! corrected 3.6.10
+ & (.not. equal_real(mass1,s2) ) .and. (.not. equal_real(mass1,s1) ) ) then
+ !
+ f3p_sc_r = f3p2m_1mi(arg3,arg1,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ ! finite triangle
+ f3p_sc_r(3:6)=f3p_finite("ndi",s2,s3,s1,mass2,mass3,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ else if ( (argz(3)) .and. (.not.(argz(1))) .and. (.not.(argz(2))) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_sc_r = f3p2m(arg1,arg2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass: QL tri3
+ !
+ else if ( ( mz(1) ) .and. ( mz(3) ) .and. &
+ & (.not. equal_real(mass2,s3) ) .and. (.not. equal_real(mass2,s2) ) ) then
+ !
+ f3p_sc_r = f3p2m_1mi(arg1,arg2,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ ! finite triangle
+ f3p_sc_r(3:6)=f3p_finite("ndi",s3,s1,s2,mass3,mass1,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ else if ( .not.(argz(3)) .and. (.not.(argz(1))) .and. (.not.(argz(2))) ) then
+ ! finite
+ !
+ if ( ( mz(1) ) .and. ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ if ( (abs(arg3) >= abs(arg1)) .and. (abs(arg3) >= abs(arg2)) ) then
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ f3p_sc_r(3:6) = f3p3m("ndi",arg3,arg1,arg2, &
+ z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( (abs(arg1) >= abs(arg3)) .and. (abs(arg1) >= abs(arg2)) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ f3p_sc_r(3:6) = f3p3m("ndi",arg1,arg2,arg3, &
+ z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( (abs(arg2) >= abs(arg3)) .and. (abs(arg2) >= abs(arg1)) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ f3p_sc_r(3:6) = f3p3m("ndi",arg2,arg3,arg1, &
+ z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if ! end if scan abs(argi)
+ !
+ else ! internal masses present
+ !
+ ! finite triangle with internal masses
+ call tri_int3(z_param_ini,z_param_out)
+ f3p_sc_r(3:6)=f3p_finite("ndi",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if ! end if 3-off-shell legs triangle
+ !
+ else ! other values of arg should not occur
+ !
+ ! finite triangle with internal masses
+ f3p_sc_r(3:6)=f3p_finite("ndi",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if ! end if arg1, arg2,arg3 nonzero
+ !
+ end if ! end if par1==-1 ...
+ !
+ end function f3p_sc_r
+ !
+ function f3p_sc_c(s_mat_c,s,parf1,parf2,parf3)
+ !
+ complex(ki), intent (in), dimension(:,:) :: s_mat_c
+ integer, intent (in), dimension(3) :: s
+ integer, intent (in), optional :: parf1,parf2,parf3
+ real(ki),dimension(6) :: f3p_sc_c
+ !
+ integer :: par1,par2,par3
+ integer, dimension(3) :: z_param_ini,z_param_out
+ complex(ki) :: arg1,arg2,arg3
+ real(ki) ::s1,s2,s3
+ complex(ki) :: mass1,mass2,mass3
+ integer :: m1,m2,m3
+ logical, dimension(3) :: argz, mz
+ logical :: finite = .true.
+ !
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ !
+ if (present(parf1)) par1 = parf1
+ if (present(parf2)) par2 = parf2
+ if (present(parf3)) par3 = parf3
+ !
+ !
+ if ( (par1 == -1) .or. (par2 == -1) .or. (par3 == -1) ) then
+ !
+ f3p_sc_c(:) = 0._ki
+ !
+ else
+ ! symetrie: la place de z1,z2,z3 n'a pas d'importance, on les met
+ ! dans l'ordre croissant
+ z_param_ini(1) = par1
+ z_param_ini(2) = par2
+ z_param_ini(3) = par3
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ !
+ arg1 = s_mat_c(m1,m2)
+ arg2 = s_mat_c(m2,m3)
+ arg3 = s_mat_c(m1,m3)
+ !
+ argz(1) = equal_real(real(arg1,ki),zero) .and. equal_real(aimag(arg1),zero)
+ argz(2) = equal_real(real(arg2,ki),zero) .and. equal_real(aimag(arg2),zero)
+ argz(3) = equal_real(real(arg3,ki),zero) .and. equal_real(aimag(arg3),zero)
+ !
+ ! internal masses
+ mass1 = -s_mat_c(m1,m1)/2._ki
+ mass2 = -s_mat_c(m2,m2)/2._ki
+ mass3 = -s_mat_c(m3,m3)/2._ki
+ !
+ mz(1) = equal_real(real(mass1,ki),zero) .and. equal_real(aimag(mass1),zero)
+ mz(2) = equal_real(real(mass2,ki),zero) .and. equal_real(aimag(mass2),zero)
+ mz(3) = equal_real(real(mass3,ki),zero) .and. equal_real(aimag(mass3),zero)
+ !
+ ! external p_i^2
+ s1 = real(arg3+mass1+mass3,ki)
+ s2 = real(arg1+mass1+mass2,ki)
+ s3 = real(arg2+mass2+mass3,ki)
+ !
+ call cut_s(s1,mass1,mass3)
+ call cut_s(s2,mass1,mass2)
+ call cut_s(s3,mass2,mass3)
+ !
+ ! initialize all components
+ !
+ f3p_sc_c(:) = 0._ki
+ !
+ ! the integrals are classified by the off-shellness of the external legs
+ !
+ ! In complex case, there is only one divergent triangle, QL tri3
+ !
+ finite = .true.
+ !
+ if ( (argz(1)) .and. (.not.(argz(2))) .and. (.not.(argz(3))) ) then
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ !
+ if ( ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_sc_c = f3p2m_1mi(arg2,arg3,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ finite = .false.
+ !
+ end if
+ !
+ ! permute arguments
+ else if ( (argz(2)) .and. (.not.(argz(1))) .and. (.not.(argz(3))) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ !
+ if ( ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ f3p_sc_c = f3p2m_1mi(arg3,arg1,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ finite = .false.
+ !
+ end if
+ !
+ else if ( (argz(3)) .and. (.not.(argz(1))) .and. (.not.(argz(2))) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ !
+ if ( ( mz(1) ) .and. ( mz(3) ) ) then
+ ! .and. (.not. equal_real(s2,zero) )
+ !
+ f3p_sc_c = f3p2m_1mi(arg1,arg2,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ finite = .false.
+ !
+ end if
+ !
+ end if !argz
+ !
+ if (finite) then !finite triangle
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ !
+ f3p_sc_c(3:6)=f3p_finite("ndi",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if ! end if call finite
+ !
+ end if ! end if par1==-1 ...
+ !
+ end function f3p_sc_c
+ !
+ !****f* src/integrals/three_point/generic_function_3p/f3p_np2
+ ! NAME
+ !
+ ! Function f3p_np2
+ !
+ ! USAGE
+ !
+ ! complex_dim2 = f3p_np2_ca(s_mat,b_pro,parf1,parf2,parf3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic three point function in n+2 dimensions,
+ ! with or without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat -- a s_matrix_poly type object, the S matrix
+ ! * b_pro -- an integer whose digits represents the set of the three unpinched
+ ! propagators
+ ! * parf1 -- an integer (optional), the label of the one Feynman parameter
+ ! * parf2 -- an integer (optional), the label of the second Feynman parameter
+ ! * parf3 -- an integer (optional), the label of the third Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ function f3p_np2(s_mat_p, b_pro,parf1,parf2,parf3)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: parf1,parf2,parf3
+ complex(ki), dimension(2) :: f3p_np2
+ real(ki), dimension(4) :: f3p_np2_real
+ !
+ f3p_np2_real = f3p_np2_ra(s_mat_p,b_pro,parf1=parf1,parf2=parf2,parf3=parf3)
+ !
+ f3p_np2(1) = f3p_np2_real(1) + i_ * f3p_np2_real(2)
+ f3p_np2(2) = f3p_np2_real(3) + i_ * f3p_np2_real(4)
+ !
+ end function f3p_np2
+ !
+ function f3p_np2_ra(s_mat_p,b_pro,parf1,parf2,parf3)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: parf1,parf2,parf3
+ real(ki),dimension(4) :: f3p_np2_ra
+ !
+ integer :: par1,par2,par3
+ integer :: par_cache1,par_cache2,par_cache3
+ integer, dimension(3) :: z_param_ini,z_param_out
+ integer :: taille
+ integer :: b_pin
+ integer, dimension(3) :: s
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ !
+ if (present(parf1)) par1 = parf1
+ if (present(parf2)) par2 = parf2
+ if (present(parf3)) par3 = parf3
+ !
+ !
+ z_param_ini = (/ par1,par2,par3 /)
+ !
+ where (z_param_ini /= 0)
+ !
+ z_param_ini = locateb(z_param_ini,b_pro)
+ !
+ elsewhere
+ !
+ z_param_ini = 0
+ !
+ end where
+ !
+ if ( minval(z_param_ini) == -1 ) then
+ !
+ f3p_np2_ra = 0._ki
+ !
+ else
+ !
+ s = unpackb(b_pro,countb(b_pro))
+ taille = dim_s - size(s)
+ !
+ select case(taille)
+ !
+ case(0)
+ !
+ set_tot = 0
+ !
+ case(1)
+ !
+ allocate(set(1:taille))
+ b_pin = pminus(b_ref,b_pro)
+ set = unpackb(b_pin,countb(b_pin))
+ set_tot(1:2) = 0
+ set_tot(3) = set(1)
+ !
+ case(2)
+ !
+ allocate(set(1:taille))
+ b_pin = pminus(b_ref,b_pro)
+ set = unpackb(b_pin,countb(b_pin))
+ set_tot(1) = 0
+ set_tot(2:3) = set
+ !
+ case(3)
+ !
+ allocate(set(1:taille))
+ b_pin = pminus(b_ref,b_pro)
+ set = unpackb(b_pin,countb(b_pin))
+ set_tot = set
+ !
+ case default
+ !
+ set_tot = 0
+ taille = 0
+ !
+ !
+ end select
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ par_cache1 = z_param_out(1)
+ par_cache2 = z_param_out(2)
+ par_cache3 = z_param_out(3)
+ !
+ cache : if ( computed_f3p_np2(set_tot(1),set_tot(2),set_tot(3),&
+ &par_cache1,par_cache2,par_cache3) ) then
+ !
+ f3p_np2_ra = results_f3p_np2(set_tot(1),set_tot(2),set_tot(3),&
+ &par_cache1,par_cache2,par_cache3,:)
+ !
+ else cache
+ !
+ f3p_np2_ra = f3p_np2_sc(s_mat_p,s,par_cache1,par_cache2,par_cache3)
+ !
+ computed_f3p_np2(set_tot(1),set_tot(2),set_tot(3),&
+ &par_cache1,par_cache2,par_cache3) = .true.
+ results_f3p_np2(set_tot(1),set_tot(2),set_tot(3),&
+ &par_cache1,par_cache2,par_cache3,:) = f3p_np2_ra
+ !
+ end if cache
+ !
+ if (taille /= 0) deallocate(set)
+ !
+ end if
+ !
+ end function f3p_np2_ra
+ !
+ !****f* src/integrals/three_point/generic_function_3p/f3p_np2_sc
+ ! NAME
+ !
+ ! Function f3p_np2_sc
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f3p_np2_sc(s_mat,s,parf1,parf2,parf3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic three point function in n+2 dimensions,
+ ! with or without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat -- a real/complex (type ki)/s_matrix_poly array of rank 2, the S matrix
+ ! * s -- an integer array of rank 1 and shape 3, the set of the three unpinched
+ ! propagators
+ ! * parf1 -- an integer (optional), the label of the one Feynman parameter
+ ! * parf2 -- an integer (optional), the label of the second Feynman parameter
+ ! * parf3 -- an integer (optional), the label of the third Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 4
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function f3p_np2_sc_p(s_mat_p,s,parf1,parf2,parf3)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent (in), dimension(3) :: s
+ integer, intent (in), optional :: parf1,parf2,parf3
+ real(ki),dimension(4) :: f3p_np2_sc_p
+ !
+ if (iand(s_mat_p%b_cmplx, packb(s)) .eq. 0 ) then
+ !
+ f3p_np2_sc_p = f3p_np2_sc_r(s_mat_p%pt_real, s, parf1=parf1,parf2=parf2,parf3=parf3)
+ !
+ else
+ !
+ f3p_np2_sc_p = f3p_np2_sc_c(s_mat_p%pt_cmplx, s, parf1=parf1,parf2=parf2,parf3=parf3)
+ !
+ end if
+ !
+ end function f3p_np2_sc_p
+ !
+ function f3p_np2_sc_r(s_mat_r,s,parf1,parf2,parf3)
+ !
+ real(ki), intent (in), dimension(:,:) :: s_mat_r
+ integer, intent (in), dimension(3) :: s
+ integer, intent (in), optional :: parf1,parf2,parf3
+ real(ki),dimension(4) :: f3p_np2_sc_r
+ !
+ integer :: par1,par2,par3
+ integer, dimension(3) :: z_param_ini,z_param_out
+ real(ki) :: arg1,arg2,arg3
+ real(ki) :: mass1,mass2,mass3,s1,s2,s3
+ integer :: m1,m2,m3
+ logical, dimension(3) :: argz,mz
+ !
+! calls_f3p_np2_sc = calls_f3p_np2_sc + 1
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ !
+ if (present(parf1)) par1 = parf1
+ if (present(parf2)) par2 = parf2
+ if (present(parf3)) par3 = parf3
+ !
+ !
+ if ( (par1 == -1) .or. (par2 == -1) .or. (par3 == -1) ) then
+ !
+ f3p_np2_sc_r(:) = 0._ki
+ !
+ else
+ ! symetrie: la place de z1,z2,z3 n'a pas d'importance, on les met
+ ! dans l'ordre croissant
+ z_param_ini(1) = par1
+ z_param_ini(2) = par2
+ z_param_ini(3) = par3
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ !
+ !
+ arg1 = s_mat_r(m1,m2)
+ arg2 = s_mat_r(m2,m3)
+ arg3 = s_mat_r(m1,m3)
+ !
+ argz(1) = equal_real(arg1,zero)
+ argz(2) = equal_real(arg2,zero)
+ argz(3) = equal_real(arg3,zero)
+ !
+ ! internal masses
+ mass1 = -s_mat_r(m1,m1)/2._ki
+ mass2 = -s_mat_r(m2,m2)/2._ki
+ mass3 = -s_mat_r(m3,m3)/2._ki
+ !
+ mz(1) = equal_real(mass1,zero)
+ mz(2) = equal_real(mass2,zero)
+ mz(3) = equal_real(mass3,zero)
+ !
+ !
+ s1=arg3+mass1+mass3
+ s2=arg1+mass1+mass2
+ s3=arg2+mass2+mass3
+ !
+ call cut_s(s1,mass1,mass3)
+ call cut_s(s2,mass1,mass2)
+ call cut_s(s3,mass2,mass3)
+ !
+ ! the integrals are classified by the off-shellness of the external legs
+ !
+ ! case with all external legs on shell
+ !
+ ! initialize all components
+ f3p_np2_sc_r(:) = 0._ki
+ !
+ !
+ if ( ( argz(1) ) .and. ( argz(2) ) .and. ( argz(3) ) ) then
+ !
+ ! zero internal mass
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function generic_function_3p.f90:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'function call with all arguments zero!'
+ call catch_exception(1)
+ !
+ ! case with one internal mass
+ !
+ else if ( ( .not.( mz(3) ) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ !
+ f3p_np2_sc_r = f3p0m_1mi_np2(mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( .not.( mz(1) ) ) .and. ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ !
+ f3p_np2_sc_r = f3p0m_1mi_np2(mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( .not.( mz(2) ) ) .and. ( mz(1) ) .and. ( mz(3) ) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ !
+ f3p_np2_sc_r = f3p0m_1mi_np2(mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ !
+ ! comment 11.08.10: only one internal mass possible kinematically!
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function generic_function_3p.f90:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'function call with one lightlike, two massive external legs &
+ & and more than one internal mass!'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'This should not be allowed kinematically!'
+ call catch_exception(1)
+ !
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ f3p_np2_sc_r=f3p_finite("n+2",s1,s2,s3,mass1,mass2,mass3, &
+ & z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ !
+ ! case with one external leg off shell
+ !
+ else if ( ( argz(1) ) .and. ( argz(2) ) ) then
+ !
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_np2_sc_r = f3p1m_np2(arg3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass
+ !
+ else if ( ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_np2_sc_r = f3p1m_1mi_np2(arg3,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ call exchange_param(z_param_ini,(/1,3/),3,z_param_out)
+ !
+ f3p_np2_sc_r = f3p1m_1mi_np2(arg3,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(1) ) .and. ( mz(3) ) ) then
+ !
+ ! comment 11.08.10: this triangle is 'finite' (in 4dim).
+ f3p_np2_sc_r = f3p_finite("n+2",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with two internal masses
+ !
+ else if ( mz(2) ) then
+ !
+ f3p_np2_sc_r = f3p1m_2mi_np2(arg3,mass1,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ f3p_np2_sc_r=f3p_finite("n+2",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ !
+ else if ( (argz(2)) .and. (argz(3)) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_np2_sc_r = f3p1m_np2(arg1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass
+ !
+ else if ( ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ f3p_np2_sc_r = f3p1m_1mi_np2(arg1,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(3) ) .and. ( mz(1) ) ) then
+ !
+ ! changed 11.08.10: (/1,2/) -> (/2,3/)
+ !
+ call exchange_param(z_param_ini,(/2,3/),3,z_param_out)
+ !
+ f3p_np2_sc_r = f3p1m_1mi_np2(arg1,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(2) ) .and. ( mz(1) ) ) then
+ !
+ ! comment 11.08.10: this triangle is 'finite' (in 4dim)
+ f3p_np2_sc_r=f3p_finite("n+2",s2,s3,s1,mass2,mass3,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with two internal masses
+ !
+ else if ( mz(3) ) then
+ ! comment 11.08.10: masses swapped!
+ f3p_np2_sc_r = f3p1m_2mi_np2(arg1,mass2,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ f3p_np2_sc_r=f3p_finite("n+2",s2,s3,s1,mass2,mass3,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ !
+ else if ( (argz(1)) .and. (argz(3)) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_np2_sc_r = f3p1m_np2(arg2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal masse
+ !
+ else if ( ( mz(1) ) .and. ( mz(3) ) ) then
+ !
+ f3p_np2_sc_r = f3p1m_1mi_np2(arg2,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(2) ) .and. ( mz(1) ) ) then
+ !
+ call exchange_param(z_param_ini,(/1,2/),3,z_param_out)
+ !
+ f3p_np2_sc_r = f3p1m_1mi_np2(arg2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ ! comment 11.08.10: this triangle is 'finite' (in 4dim)
+ f3p_np2_sc_r=f3p_finite("n+2",s3,s1,s2,mass3,mass1,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with two internal masses
+ !
+ else if ( mz(1) ) then
+ !
+ ! comment 11.08.10: masses swapped!
+ f3p_np2_sc_r = f3p1m_2mi_np2(arg2,mass3,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ f3p_np2_sc_r=f3p_finite("n+2",s3,s1,s2,mass3,mass1,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ !
+ ! case with two external legs off shell
+ !
+ else if ( (argz(1)) .and. (.not.(argz(2))) .and. (.not.(argz(3))) ) then
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_np2_sc_r = f3p2m_np2(arg2,arg3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass
+ !
+ else if ( ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_np2_sc_r = f3p2m_1mi_np2(arg2,arg3,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ f3p_np2_sc_r=f3p_finite("n+2",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ else if ( (argz(2)) .and. (.not.(argz(1))) .and. (.not.(argz(3))) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_np2_sc_r = f3p2m_np2(arg3,arg1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass
+ !
+ else if ( ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ f3p_np2_sc_r = f3p2m_1mi_np2(arg3,arg1,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ f3p_np2_sc_r=f3p_finite("n+2",s2,s3,s1,mass2,mass3,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ !
+ else if ( (argz(3)) .and. (.not.(argz(1))) .and. (.not.(argz(2))) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ !
+ if ( ( mz(3) ) .and. ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_np2_sc_r = f3p2m_np2(arg1,arg2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ ! case with one internal mass
+ !
+ else if ( ( mz(1) ) .and. ( mz(3) ) ) then
+ !
+ f3p_np2_sc_r = f3p2m_1mi_np2(arg1,arg2,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else
+ f3p_np2_sc_r=f3p_finite("n+2",s3,s1,s2,mass3,mass1,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ !
+ else if ( .not.(argz(1)) .and. (.not.(argz(2))) .and. (.not.(argz(3))) ) then
+ !
+ if ( ( mz(1) ) .and. ( mz(2) ) .and. ( mz(3) ) ) then
+
+ if ( (abs(arg3) >= abs(arg1)) .and. (abs(arg3) >= abs(arg2)) ) then
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ f3p_np2_sc_r = f3p3m("n+2",arg3,arg1,arg2, &
+ z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( (abs(arg1) >= abs(arg3)) .and. (abs(arg1) >= abs(arg2)) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ f3p_np2_sc_r = f3p3m("n+2",arg1,arg2,arg3, &
+ z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ else if ( (abs(arg2) >= abs(arg3)) .and. (abs(arg2) >= abs(arg1)) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ f3p_np2_sc_r = f3p3m("n+2",arg2,arg3,arg1, &
+ z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if
+ !
+ else
+ call tri_int3(z_param_ini,z_param_out)
+ f3p_np2_sc_r=f3p_finite("n+2",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if ! end scan internal masses
+ !
+ end if ! end scan argi
+ !
+ end if ! end if par1=-1...
+ !
+ end function f3p_np2_sc_r
+ !
+ function f3p_np2_sc_c(s_mat_c,s,parf1,parf2,parf3)
+ !
+ complex(ki), intent (in), dimension(:,:) :: s_mat_c
+ integer, intent (in), dimension(3) :: s
+ integer, intent (in), optional :: parf1,parf2,parf3
+ real(ki),dimension(4) :: f3p_np2_sc_c
+ !
+ integer :: par1,par2,par3
+ integer, dimension(3) :: z_param_ini,z_param_out
+ complex(ki) :: arg1,arg2,arg3
+ complex(ki) :: mass1, mass2, mass3
+ real(ki) :: s1,s2,s3
+ integer :: m1,m2,m3
+ logical, dimension(3) :: argz,mz
+ logical :: finite = .true.
+ !
+ !
+ par1 = 0
+ par2 = 0
+ par3 = 0
+ !
+ if (present(parf1)) par1 = parf1
+ if (present(parf2)) par2 = parf2
+ if (present(parf3)) par3 = parf3
+ !
+ !
+ if ( (par1 == -1) .or. (par2 == -1) .or. (par3 == -1) ) then
+ !
+ f3p_np2_sc_c(:) = 0._ki
+ !
+ else
+ ! symetrie: la place de z1,z2,z3 n'a pas d'importance, on les met
+ ! dans l'ordre croissant
+ z_param_ini(1) = par1
+ z_param_ini(2) = par2
+ z_param_ini(3) = par3
+ !
+ m1 = s(1)
+ m2 = s(2)
+ m3 = s(3)
+ !
+ !
+ arg1 = s_mat_c(m1,m2)
+ arg2 = s_mat_c(m2,m3)
+ arg3 = s_mat_c(m1,m3)
+ !
+ argz(1) = equal_real(real(arg1,ki),zero) .and. equal_real(aimag(arg1),zero)
+ argz(2) = equal_real(real(arg2,ki),zero) .and. equal_real(aimag(arg2),zero)
+ argz(3) = equal_real(real(arg3,ki),zero) .and. equal_real(aimag(arg3),zero)
+ !
+ ! internal masses
+ mass1 = -s_mat_c(m1,m1)/2._ki
+ mass2 = -s_mat_c(m2,m2)/2._ki
+ mass3 = -s_mat_c(m3,m3)/2._ki
+ !
+ mz(1) = equal_real(real(mass1,ki),zero) .and. equal_real(aimag(mass1),zero)
+ mz(2) = equal_real(real(mass2,ki),zero) .and. equal_real(aimag(mass2),zero)
+ mz(3) = equal_real(real(mass3,ki),zero) .and. equal_real(aimag(mass3),zero)
+ !
+ ! external p_i^2
+ s1 = real(arg3+mass1+mass3,ki)
+ s2 = real(arg1+mass1+mass2,ki)
+ s3 = real(arg2+mass2+mass3,ki)
+ !
+ call cut_s(s1,mass1,mass3)
+ call cut_s(s2,mass1,mass2)
+ call cut_s(s3,mass2,mass3)
+ !
+ ! initialize all components
+ f3p_np2_sc_c(:) = 0._ki
+ !
+ !
+ finite = .true.
+ ! Similar to 4dim case, there is only one triangle with singular S-matrix.
+ ! case with two external legs off shell
+ !
+ if ( (argz(1)) .and. (.not.(argz(2))) .and. (.not.(argz(3))) ) then
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ !
+ ! case with one internal mass
+ !
+ if ( ( mz(1) ) .and. ( mz(2) ) ) then
+ !
+ f3p_np2_sc_c = f3p2m_1mi_np2(arg2,arg3,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ finite = .false.
+ !
+ end if
+ !
+ else if ( (argz(2)) .and. (.not.(argz(1))) .and. (.not.(argz(3))) ) then
+ !
+ call shift_param(z_param_ini,2,3,z_param_out)
+ !
+ ! case with one internal mass
+ !
+ if ( ( mz(2) ) .and. ( mz(3) ) ) then
+ !
+ f3p_np2_sc_c = f3p2m_1mi_np2(arg3,arg1,mass1,z_param_out(1),z_param_out(2),z_param_out(3))
+ finite = .false.
+ !
+ end if
+ !
+ !
+ else if ( (argz(3)) .and. (.not.(argz(1))) .and. (.not.(argz(2))) ) then
+ !
+ call shift_param(z_param_ini,1,3,z_param_out)
+ !
+ ! case with one internal mass
+ !
+ if ( ( mz(1) ) .and. ( mz(3) ) ) then
+ !
+ f3p_np2_sc_c = f3p2m_1mi_np2(arg1,arg2,mass2,z_param_out(1),z_param_out(2),z_param_out(3))
+ finite = .false.
+ !
+ end if
+ !
+ end if !args
+ !
+ if (finite) then ! call to finite triangle
+ !
+ call tri_int3(z_param_ini,z_param_out)
+ f3p_np2_sc_c=f3p_finite("n+2",s1,s2,s3,mass1,mass2,mass3,z_param_out(1),z_param_out(2),z_param_out(3))
+ !
+ end if ! end finite
+ !
+ end if ! end if par1=-1...
+ !
+ end function f3p_np2_sc_c
+ !
+end module generic_function_3p
diff --git a/golem95c-1.2.1/integrals/three_point/mod_gn.f90 b/golem95c-1.2.1/integrals/three_point/mod_gn.f90
new file mode 100644
index 0000000..1168a3c
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/mod_gn.f90
@@ -0,0 +1,1204 @@
+!
+!****h* src/integrals/three_point/func_gn
+! NAME
+!
+! Module func_gn
+!
+! USAGE
+!
+! use func_gn
+!
+! DESCRIPTION
+!
+! This module contains several functions for the computation of
+! int^1_0 dx x^(n-1)*ln(a*x^2+b*x+c-i*lambda)/(a*x^2+b*x+c-i*lambda)
+! where a, b and c are real numbers
+!
+! OUTPUT
+!
+! This modules exports four functions:
+! * ge -- a function
+! * ge_c -- a function
+! * gf -- a function
+! * gf_c -- a function
+!
+! USES
+!
+! * precision_golem (src/module/precision.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90) only : tab_erreur_par,catch_exception,origine_info_par,num_grand_b_info_par,denom_grand_b_info_par
+! * parametre (src/module/parametre.f90)
+! * logarithme (src/module/z_log.f90)
+! * dilogarithme (src/module/zdilog.f90)
+! * constante (src/module/constante.f90) only : i_,un,pi
+!
+!*****
+module func_gn
+ !
+ use precision_golem
+ use numerical_evaluation
+ use sortie_erreur, only : tab_erreur_par,catch_exception,origine_info_par,num_grand_b_info_par,denom_grand_b_info_par
+ use parametre
+ use logarithme
+ use dilogarithme
+ use constante, only : i_,un,pi
+ implicit none
+ !
+ private
+ real(ki) :: a_glob,b_glob,c_glob,eps_glob
+ complex(ki) :: x1_glob,x2_glob
+ real(ki) :: plus_grand_glob
+ real(ki) :: lambda_glob,alpha_glob,beta_glob
+ integer :: expo_glob
+ logical :: dist_glob
+ public :: gf,ge,gl
+ !
+ contains
+ !
+ !****f* src/integrals/three_point/func_gn/ge
+ ! NAME
+ !
+ ! Function ge
+ !
+ ! USAGE
+ !
+ ! real_dim2 = ge(n,a,b,c,dist)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes:
+ ! int^1_0 dx x^(n-1)/(a*x^2+b*x+c-i*lambda)
+ ! where a, b and c are reals
+ ! It switches to numerical evaluation if
+ ! (b^2-4*a*c) < coupure_3p1m_2mi
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the power of x in the integrand
+ ! * a -- a real (type ki), coefficient of x^2
+ ! * b -- a real (type ki), coefficient of x^1
+ ! * c -- a real (type ki), coefficient of x^0
+ ! * dist -- a logical, true if we are close to the real threshold
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, the returned value depends on the global variables
+ ! rat_or_tot_par, coupure_3p1m_2mi
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function ge(n,a,b,c,dist)
+ !~ function ge(n,a,b,c)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: a,b,c
+ logical, intent(in) :: dist
+ real(ki), dimension(2) :: ge
+ !
+ complex(ki) :: veri,veri_rat,rest,abserr
+ complex(ki) :: residue
+ complex(ki) :: extra_imag
+ real(ki) :: pole1
+ real(ki) :: x1,x2,deltax
+ complex(ki) :: cx1,cx2,cdeltax
+ real(ki) :: delta
+ logical :: l1
+ complex(ki) :: div_part
+ real(ki) :: coeff
+ !
+ plus_grand_glob = max(abs(a),abs(b),abs(c))
+ expo_glob = n
+ delta = b*b-4._ki*a*c
+ a_glob = a
+ b_glob = b
+ c_glob = c
+ lambda_glob = lambda_par
+ alpha_glob = alpha_par
+ beta_glob = beta_par
+ dist_glob = dist
+ !
+ if (dist) then
+ !
+ if (delta > 0._ki) then
+ !
+ if (a > 0._ki) then
+ !
+ div_part = 2._ki*i_*pi/sqrt(delta)
+ !
+ else if (a < 0._ki) then
+ !
+ div_part = 2._ki*i_*pi/sqrt(delta)
+ !
+ end if
+ !
+ else if (delta <= 0._ki) then
+ !
+ if (a > 0._ki) then
+ !
+ div_part = 2._ki*pi/sqrt(-delta)
+ !
+ else if (a < 0._ki) then
+ !
+ div_part = -2._ki*pi/sqrt(-delta)
+ !
+ end if
+ !
+ end if
+ !
+ else
+ !
+ div_part = 0._ki
+ !
+ end if
+ !
+ select case(n)
+ !
+ case(1)
+ !
+ coeff = 1._ki
+ !
+ case(2)
+ !
+ coeff = -b/(2._ki*a)
+ !
+ case(3)
+ !
+ coeff = (b**2-2._ki*a*c)/(2._ki*a**2)
+ !
+ case(4)
+ !
+ coeff = (3._ki*a*b*c-b**3)/(2._ki*a**3)
+ !
+ end select
+ !
+ if (delta >= 0._ki) then
+ !
+ x1 = (-b + sqrt(delta))/(2._ki*a)
+ x2 = (-b - sqrt(delta))/(2._ki*a)
+ x1_glob = cmplx(x1,0._ki)
+ x2_glob = cmplx(x2,0._ki)
+ deltax = x1-x2
+ !
+ if (sqrt(abs(delta)) > coupure_3p1m_2mi) then
+ !~ if (abs(delta) > 0._ki) then
+ !
+ if (n == 1) then
+ !
+ veri_rat = 0._ki
+ veri = ( z_log((x1-1._ki)/x1,1._ki) - z_log((x2-1._ki)/x2,-1._ki) ) &
+ /deltax/a
+ !
+ else if (n == 2) then
+ !
+ veri_rat = 0._ki
+ veri = ( x1*z_log((x1-1._ki)/x1,1._ki) - x2*z_log((x2-1._ki)/x2,-1._ki) ) &
+ /deltax/a
+ !
+ else if (n == 3) then
+ !
+ veri_rat = 1._ki/a
+ veri = ( x1**2*z_log((x1-1._ki)/x1,1._ki) - x2**2*z_log((x2-1._ki)/x2,-1._ki) ) &
+ /deltax/a
+ !
+ else if (n == 4) then
+ !
+ veri_rat = ( 1._ki/2._ki + x1 + x2 )/a
+ veri = ( x1**3*z_log((x1-1._ki)/x1,1._ki) - x2**3*z_log((x2-1._ki)/x2,-1._ki) ) &
+ /deltax/a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge (file mod_gn.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'n should be 1,2,3,4 but is %d0'
+ tab_erreur_par(3)%arg_int = n
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ if ( rat_or_tot_par%tot_selected ) then
+ !
+ rest = veri + veri_rat
+ !
+ else !if ( rat_or_tot_par%rat_selected ) then
+ !
+ rest = veri_rat
+ !
+ end if
+ !
+ else if ( (sqrt(abs(delta)) <= coupure_3p1m_2mi) .and. &
+ & (rat_or_tot_par%tot_selected) ) then
+ !
+ !~ pole1 = x2
+ !~ eps_glob = 1._ki
+ !
+ !~ call generic_eval_numer(eval_numer_ge,0._ki,1._ki,1.0E-8_ki,rest,abserr)
+ call generic_eval_numer(eval_numer_ge,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ !~ if ( (pole1 >= 0._ki) .and. (pole1 <= 1._ki) ) then
+ !~ !
+ !~ residue = x2**(n-1)/(x2-x1)/a_glob
+ !~ extra_imag = -2._ki*i_*pi*residue
+ !~ !
+ !~ else
+ !~ !
+ !~ extra_imag = 0._ki
+ !~ !
+ !~ end if
+ !~ !
+ !~ rest = rest + extra_imag
+ !
+ !~ write(*,*) 'exact result is:',coeff*div_part
+ !~ write(*,*) 'err numer result is:',abserr,rest
+ !~ write(*,*) 'n is:',n
+ !~ select case(n)
+ !~ case(1)
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( z_log((x1-1._ki)/x1,1._ki) - z_log((x2-1._ki)/x2,-1._ki) )/deltax/a
+ !~ case(2)
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( x1*z_log((x1-1._ki)/x1,1._ki) - x2*z_log((x2-1._ki)/x2,-1._ki) )/deltax/a
+ !~ case(3)
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( x1**2*z_log((x1-1._ki)/x1,1._ki) - x2**2*z_log((x2-1._ki)/x2,-1._ki) )/deltax/a + 1._ki/a
+ !~ case(4)
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( x1**3*z_log((x1-1._ki)/x1,1._ki) - x2**3*z_log((x2-1._ki)/x2,-1._ki) )/deltax/a + ( 1._ki/2._ki + x1 + x2 )/a
+ !~ end select
+ !~ if (dist) then
+ rest = rest + coeff*div_part
+ !~ write(*,*) 'numer result is:',rest
+ !~ end if
+ !else if ( (abs(delta) <= coupure_3p1m_2mi) .and. &
+ ! & (rat_or_tot_par%rat_selected) ) then
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge (file mod_gn.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the choice rat has been made, it is'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'singular when abs(delta) is too small: %f0'
+ tab_erreur_par(3)%arg_real = abs(delta)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ else
+ !
+ origine_info_par = "ge"
+ num_grand_b_info_par = n
+ !! Thomas Reiter, 01/March/2011:
+ !! original code:
+ ! denom_grand_b_info_par = abs(deltax)
+ !! cannot be right, deltax was never initialized
+ !! probably: delta instead of deltax.
+ denom_grand_b_info_par = abs(delta)
+ !
+ !
+ cx1 = -b/(2._ki*a) + i_*sqrt(-delta)/(2._ki*abs(a))
+ cx2 = -b/(2._ki*a) - i_*sqrt(-delta)/(2._ki*abs(a))
+ x1_glob = cx1
+ x2_glob = cx2
+ cdeltax = cx1-cx2
+ !
+ if (sqrt(abs(delta)) > coupure_3p1m_2mi) then
+ !~ if (abs(delta) > 0._ki) then
+ !
+ if (n == 1) then
+ !
+ veri_rat = 0._ki
+ veri = ( log((cx1-1._ki)/cx1) - log((cx2-1._ki)/cx2) ) &
+ /cdeltax/a
+ !
+ else if (n == 2) then
+ !
+ veri_rat = 0._ki
+ veri = ( cx1*log((cx1-1._ki)/cx1) - cx2*log((cx2-1._ki)/cx2) ) &
+ /cdeltax/a
+ !
+ else if (n == 3) then
+ !
+ veri_rat = 1._ki/a
+ veri = ( cx1**2*log((cx1-1._ki)/cx1) - cx2**2*log((cx2-1._ki)/cx2) ) &
+ /cdeltax/a
+ !
+ else if (n == 4) then
+ !
+ veri_rat = ( 1._ki/2._ki + cx1 + cx2 )/a
+ veri = ( cx1**3*log((cx1-1._ki)/cx1) - cx2**3*log((cx2-1._ki)/cx2) ) &
+ /cdeltax/a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge (file mod_gn.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'n should be 1,2,3,4 but is %d0'
+ tab_erreur_par(3)%arg_int = n
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ if ( rat_or_tot_par%tot_selected ) then
+ !
+ rest = veri + veri_rat
+ !
+ else !if ( rat_or_tot_par%rat_selected ) then
+ !
+ rest = veri_rat
+ !
+ end if
+ !
+ else if ( (sqrt(abs(delta)) <= coupure_3p1m_2mi) .and. &
+ & (rat_or_tot_par%tot_selected) ) then
+ !
+ !~ eps_glob = 1._ki
+ !~ !
+ !~ call inside_contour(cx2,l1)
+ !
+ !~ call generic_eval_numer(eval_numer_ge,0._ki,1._ki,1.0E-8_ki,rest,abserr)
+ call generic_eval_numer(eval_numer_ge,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ !~ if ( l1) then
+ !~ !
+ !~ residue = cx2**(n-1)/(cx2-cx1)/a_glob
+ !~ extra_imag = -2._ki*i_*pi*residue
+ !~ !
+ !~ else
+ !~ !
+ !~ extra_imag = 0._ki
+ !~ !
+ !~ end if
+ !~ !
+ !~ rest = rest + extra_imag
+ !
+ !else if ( (abs(delta) <= coupure_3p1m_2mi) .and. &
+ ! & (rat_or_tot_par%rat_selected) ) then
+ !~ write(*,*) 'exact result is:',coeff*div_part
+ !~ write(*,*) 'err numer result is:',abserr,rest
+ !~ write(*,*) 'n is:',n
+ !~ select case(n)
+ !~ case(1)
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( log((cx1-1._ki)/cx1) - log((cx2-1._ki)/cx2) )/cdeltax/a
+ !~ case(2)
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( cx1*log((cx1-1._ki)/cx1) - cx2*log((cx2-1._ki)/cx2) )/cdeltax/a
+ !~ case(3)
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( cx1**2*log((cx1-1._ki)/cx1) - cx2**2*log((cx2-1._ki)/cx2) )/cdeltax/a + 1._ki/a
+ !~ case(4)
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( cx1**3*log((cx1-1._ki)/cx1) - cx2**3*log((cx2-1._ki)/cx2) )/cdeltax/a + ( 1._ki/2._ki + cx1 + cx2 )/a
+ !~ end select
+ rest = rest + coeff*div_part
+ !~ write(*,*) 'numer result is:',rest
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge (file mod_gn.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the choice rat has been made, it is'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'singular when abs(delta) is too small: %f0'
+ tab_erreur_par(3)%arg_real = abs(delta)
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ end if
+ !
+ ge(1) = real(rest,ki)
+ ge(2) = aimag(rest)
+ !~ write(*,*) 'test ge :',rest,abserr
+ !
+ !
+ end function ge
+ !
+ !****f* src/integrals/three_point/func_gn/gl
+ ! NAME
+ !
+ ! Function gl
+ !
+ ! USAGE
+ !
+ ! real_dim2 = gl(n,a,b,c)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes:
+ ! int^1_0 dx x^(n-1)*ln(a*x^2+b*x+c-i*lambda)
+ ! where a, b and c are reals
+ ! here, no need to switch to numerical evaluation
+ ! no numerical problems when (b^2-4*a*c) = 0
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the power of x in the integrand
+ ! * a -- a real (type ki), coefficient of x^2
+ ! * b -- a real (type ki), coefficient of x^1
+ ! * c -- a real (type ki), coefficient of x^0
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, the returned value depends on the global variable
+ ! rat_or_tot_par
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function gl(n,a,b,c)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: a,b,c
+ real(ki), dimension(2) :: gl
+ !
+ complex(ki) :: veri,veri_rat,rest
+ real(ki) :: x1,x2
+ complex(ki) :: cx1,cx2
+ real(ki) :: delta
+ !
+ !~ plus_grand_glob = max(abs(a),abs(b),abs(c))
+ delta = b*b-4._ki*a*c
+ !
+ if (delta >= 0._ki) then
+ !
+ x1 = (-b + sqrt(delta))/(2._ki*a)
+ x2 = (-b - sqrt(delta))/(2._ki*a)
+ x1_glob = cmplx(x1,0._ki)
+ x2_glob = cmplx(x2,0._ki)
+ !
+ if (n == 1) then
+ !
+ veri_rat = -2._ki
+ veri = ( z_log(a,-1._ki) + (1._ki-x1)*z_log(1._ki-x1,-1._ki) + x1*z_log(-x1,-1._ki) &
+ + (1._ki-x2)*z_log(1._ki-x2,1._ki) + x2*z_log(-x2,1._ki) )
+ !
+ else if (n == 2) then
+ !
+ veri_rat = -(1._ki + x1 + x2)/2._ki
+ veri = ( z_log(a,-1._ki) + (1._ki-x1**2)*z_log(1._ki-x1,-1._ki) + x1**2*z_log(-x1,-1._ki) &
+ + (1._ki-x2**2)*z_log(1._ki-x2,1._ki) + x2**2*z_log(-x2,1._ki) )/2._ki
+ !
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gl (file mod_gn.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'value of n not implemented'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'n= %d0'
+ tab_erreur_par(3)%arg_int = n
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ veri = veri + veri_rat
+ rest = veri
+ !
+ else
+ !
+ !
+ cx1 = -b/(2._ki*a) + i_*sqrt(-delta)/(2._ki*abs(a))
+ cx2 = -b/(2._ki*a) - i_*sqrt(-delta)/(2._ki*abs(a))
+ x1_glob = cx1
+ x2_glob = cx2
+ !
+ if (n == 1) then
+ !
+ veri_rat = -2._ki
+ veri = ( z_log(a,-1._ki) + (1._ki-cx1)*log(1._ki-cx1) + cx1*log(-cx1) &
+ + (1._ki-cx2)*log(1._ki-cx2) + cx2*log(-cx2) )
+ !
+ else if (n == 2) then
+ !
+ veri_rat = -(1._ki + cx1 + cx2)/2._ki
+ veri = ( z_log(a,-1._ki) + (1._ki-cx1**2)*log(1._ki-cx1) + cx1**2*log(-cx1) &
+ + (1._ki-cx2**2)*log(1._ki-cx2) + cx2**2*log(-cx2) )/2._ki
+ !
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gl (file mod_gn.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'value of n not implemented'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'n= %d0'
+ tab_erreur_par(3)%arg_int = n
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ veri = veri + veri_rat
+ rest = veri
+ !
+ end if
+ !
+ gl(1) = real(rest,ki)
+ gl(2) = aimag(rest)
+ !
+ !
+ !
+ end function gl
+ !
+ !****f* src/integrals/three_point/func_gn/gf
+ ! NAME
+ !
+ ! Function gf
+ !
+ ! USAGE
+ !
+ ! real_dim2 = gf(n,a,b,c,dist)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes:
+ ! int^1_0 dx x^(n-1)*ln(a*x^2+b*x+c-i*lambda)/(a*x^2+b*x+c-i*lambda)
+ ! where a, b and c are reals
+ ! It switches to numerical evaluation if
+ ! (b^2-4*a*c) < coupure_3p1m_2mi
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the power of x in the integrand
+ ! * a -- a real (type ki), coefficient of x^2
+ ! * b -- a real (type ki), coefficient of x^1
+ ! * c -- a real (type ki), coefficient of x^0
+ ! * dist -- a logical, true if we are close to the real threshold
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, the returned value depends on the global variables
+ ! rat_or_tot_par, coupure_3p1m_2mi
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !~ function gf(n,a,b,c)
+ function gf(n,a,b,c,dist)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: a,b,c
+ logical, intent(in) :: dist
+ real(ki), dimension(2) :: gf
+ !
+ complex(ki) :: veri,rest,abserr
+ complex(ki) :: rest1,abserr1,rest2,abserr2,rest3,abserr3
+ complex(ki) :: residue1,residue2
+ complex(ki) :: extra_imag1,extra_imag2
+ real(ki) :: pole1,pole2
+ real(ki) :: x1,x2,deltax
+ complex(ki) :: cx1,cx2,cdeltax
+ real(ki) :: delta
+ logical :: l1,l2
+ complex(ki) :: div_part
+ !
+ plus_grand_glob = max(abs(a),abs(b),abs(c))
+ expo_glob = n
+ delta = b*b-4._ki*a*c
+ a_glob = a
+ b_glob = b
+ c_glob = c
+ lambda_glob = lambda_par
+ alpha_glob = alpha_par
+ beta_glob = beta_par
+ dist_glob = dist
+ !write(*,*) 'delta et a :',delta,a,dist
+ ! divergent part for Landau singularities
+ if (dist) then
+ !
+ if (delta > 0._ki) then
+ !
+ if (a > 0._ki) then
+ !
+ div_part = 2._ki*i_*pi/sqrt(delta)*(log(delta/a) - i_*pi)
+ !
+ else if (a < 0._ki) then
+ !
+ div_part = 2._ki*i_*pi/sqrt(delta)*log(-delta/a)
+ !
+ end if
+ !
+ else if (delta <= 0._ki) then
+ !
+ if (a > 0._ki) then
+ !
+ div_part = 2._ki*pi/sqrt(-delta)*log(-delta/a)
+ !
+ else if (a < 0._ki) then
+ !
+ div_part = -2._ki*pi/sqrt(-delta)*(log(delta/a) - i_*pi)
+ !
+ end if
+ !
+ end if
+ !
+ else
+ !
+ div_part = 0._ki
+ !
+ end if
+ !
+ if (delta >= 0._ki) then
+ !
+ x1 = (-b + sqrt(delta))/(2._ki*a)
+ x2 = (-b - sqrt(delta))/(2._ki*a)
+ x1_glob = cmplx(x1,0._ki)
+ x2_glob = cmplx(x2,0._ki)
+ deltax = x1-x2
+ !
+ if (sqrt(abs(delta)) > coupure_3p1m_2mi) then
+ !~ if (abs(delta) > 0._ki) then
+ !
+ veri = ( -zdilog((1._ki-x2)/(1._ki-x1),sign(1._ki,2._ki-x1-x2)) + zdilog(x2/x1,sign(1._ki,-x1-x2)) &
+ + zdilog((1._ki-x1)/(1._ki-x2),sign(1._ki,-2._ki+x1+x2)) - zdilog(x1/x2,sign(1._ki,x1+x2)) &
+ + ( 2._ki*z_log(deltax,1._ki) - i_*pi + z_log(a,-1._ki) ) &
+ *( z_log((x1-1._ki)/x1,1._ki) - z_log((x2-1._ki)/x2,-1._ki) ) &
+ )/deltax/a
+ !
+ rest = veri
+ !
+ else
+ !
+ !~ pole1 = x2
+ !~ eps_glob = 1._ki
+ !
+ !~ call generic_eval_numer(eval_numer_gf1,0._ki,1._ki,1.0E-8_ki,rest1,abserr1)
+ !~ call generic_eval_numer(eval_numer_gf1,0._ki,1._ki,tolerance,rest1,abserr1)
+ call generic_eval_numer(eval_numer_gf,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ !~ if ( (pole1 >= 0._ki) .and. (pole1 <= 1._ki) ) then
+ !~ !
+ !~ residue1 = ( z_log(a_glob,-1._ki) + z_log(x2-x1,-1._ki) )/(x2-x1)/a_glob
+ !~ extra_imag1 = -2._ki*i_*pi*residue1
+ !~ !
+ !~ else
+ !~ !
+ !~ extra_imag1 = 0._ki
+ !~ !
+ !~ end if
+ !~ !
+ !~ rest1 = rest1 + extra_imag1
+ !~ !
+ !~ pole2 = x1
+ !~ eps_glob = -1._ki
+ !~ !
+ !~ call generic_eval_numer(eval_numer_gf2,0._ki,1._ki,1.0E-8_ki,rest2,abserr2)
+ !~ call generic_eval_numer(eval_numer_gf2,0._ki,1._ki,tolerance,rest2,abserr2)
+ !~ !
+ !~ if ( (pole2 >= 0._ki) .and. (pole2 <= 1._ki) ) then
+ !~ !
+ !~ residue2 = z_log(x1-x2,1._ki)/(x1-x2)/a_glob
+ !~ extra_imag2 = 2._ki*i_*pi*residue2
+ !~ !
+ !~ else
+ !~ !
+ !~ extra_imag2 = 0._ki
+ !~ !
+ !~ end if
+ !~ !
+ !~ rest2 = rest2 + extra_imag2
+ !
+ !~ rest = rest1+rest2
+ !~ abserr = abserr1 + abserr2
+ !~ write(*,*) 'exact result is:',2._ki*i_*pi/sqrt(delta)*(log(delta/a)-i_*pi)
+ !~ write(*,*) 'err numer result is:',abserr
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( -zdilog((1._ki-x2)/(1._ki-x1),sign(1._ki,2._ki-x1-x2)) + zdilog(x2/x1,sign(1._ki,-x1-x2)) &
+ !~ + zdilog((1._ki-x1)/(1._ki-x2),sign(1._ki,-2._ki+x1+x2)) - zdilog(x1/x2,sign(1._ki,x1+x2)) &
+ !~ + ( 2._ki*z_log(deltax,1._ki) - i_*pi + z_log(a,-1._ki) ) &
+ !~ *( z_log((x1-1._ki)/x1,1._ki) - z_log((x2-1._ki)/x2,-1._ki) ) &
+ !~ )/deltax/a
+ !~ write(*,*) 'numer result is:',rest
+ !~ if (dist) then
+ !~ rest = rest + 2._ki*i_*pi/sqrt(delta)*(log(delta/a)-i_*pi)
+ rest = rest + div_part
+ !~ end if
+ !~ write(*,*) 'numer result is:',rest
+ !
+ end if
+ !
+ else
+ origine_info_par = "gf"
+ num_grand_b_info_par = n
+ denom_grand_b_info_par = abs(deltax)
+ !
+ !
+ cx1 = -b/(2._ki*a) + i_*sqrt(-delta)/(2._ki*abs(a))
+ cx2 = -b/(2._ki*a) - i_*sqrt(-delta)/(2._ki*abs(a))
+ x1_glob = cx1
+ x2_glob = cx2
+ cdeltax = cx1-cx2
+ !
+ if (sqrt(abs(delta)) > coupure_3p1m_2mi) then
+ !~ if (abs(delta) > 0._ki) then
+ !
+ veri = ( -cdilog((1._ki-cx2)/(1._ki-cx1)) + cdilog(cx2/cx1) &
+ + cdilog((1._ki-cx1)/(1._ki-cx2)) - cdilog(cx1/cx2) &
+ + ( 2._ki*log(cdeltax) - i_*pi + z_log(a,-1._ki) ) &
+ *( log((cx1-1._ki)/cx1) - log((cx2-1._ki)/cx2) ) &
+ )/cdeltax/a
+ !
+ rest = veri
+ !
+ else
+ !
+ !~ eps_glob = 1._ki
+ !~ call inside_contour(cx2,l1)
+ !~ !
+ !~ call generic_eval_numer(eval_numer_gf1,0._ki,1._ki,tolerance,rest1,abserr1)
+ call generic_eval_numer(eval_numer_gf,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ !~ if ( l1) then
+ !~ !
+ !~ residue1 = ( z_log(a_glob,-1._ki) + log(cx2-cx1) )/(cx2-cx1)/a_glob
+ !~ extra_imag1 = -2._ki*i_*pi*residue1
+ !~ !
+ !~ else
+ !~ !
+ !~ extra_imag1 = 0._ki
+ !~ !
+ !~ end if
+ !~ !
+ !~ rest1 = rest1 + extra_imag1
+ !~ !
+ !~ eps_glob = -1._ki
+ !~ call inside_contour(cx1,l2)
+ !~ !
+ !~ call generic_eval_numer(eval_numer_gf2,0._ki,1._ki,1.0E-8_ki,rest2,abserr2)
+ !~ !
+ !~ if ( l2 ) then
+ !~ !
+ !~ residue2 = log(cx1-cx2)/(cx1-cx2)/a_glob
+ !~ extra_imag2 = 2._ki*i_*pi*residue2
+ !~ !
+ !~ else
+ !~ !
+ !~ extra_imag2 = 0._ki
+ !~ !
+ !~ end if
+ !~ !
+ !~ rest2 = rest2 + extra_imag2
+ !~ !
+ !~ !
+ !~ rest = rest2 + rest1
+ !~ abserr = abserr1 + abserr2
+ !~ if (dist) then
+ !~ rest = rest + 2._ki*i_*pi/sqrt(delta)*(log(delta/a)-i_*pi)
+ !~ write(*,*) 'analytical result is:', &
+ !~ ( -cdilog((1._ki-cx2)/(1._ki-cx1)) + cdilog(cx2/cx1) &
+ !~ + cdilog((1._ki-cx1)/(1._ki-cx2)) - cdilog(cx1/cx2) &
+ !~ + ( 2._ki*log(cdeltax) - i_*pi + z_log(a,-1._ki) ) &
+ !~ *( log((cx1-1._ki)/cx1) - log((cx2-1._ki)/cx2) ) &
+ !~ )/cdeltax/a
+ rest = rest + div_part
+ !~ write(*,*) 'numer result is:',rest
+ !~ end if
+ !
+ end if
+ !
+ end if
+ !
+ gf(1) = real(rest,ki)
+ gf(2) = aimag(rest)
+ !~ write(*,*) 'test gf :',rest,abserr
+ !
+ !
+ end function gf
+ !
+ !****if* src/integrals/three_point/func_gn/eval_numer_ge
+ ! NAME
+ !
+ ! Function eval_numer_ge
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_ge(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of ge,
+ ! part 1/( (z-x_1)*(z-x_2) )
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables of type xxx_glob
+ ! are global in this module
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !~ function eval_numer_ge(u)
+ !~ !
+ !~ real(ki), intent (in) :: u
+ !~ complex(ki) :: eval_numer_ge
+ !~ !
+ !~ real(ki) :: x,y
+ !~ real(ki) :: eps
+ !~ complex(ki) :: z,jacob
+ !~ !
+ !~ eps = eps_glob
+ !~ x = u
+ !~ y = lambda_glob*u**alpha_glob*(1._ki-u)**beta_glob
+ !~ jacob = 1._ki - eps*i_*lambda_glob*u**(alpha_glob-1._ki)&
+ !~ *(1._ki-u)**(beta_glob-1._ki)*(alpha_glob*(1._ki-u)-beta_glob*u)
+ !~ z = x - eps*i_*y
+ !~ eval_numer_ge = z**(expo_glob-1)/(z-x1_glob)/(z-x2_glob)/a_glob
+ !~ eval_numer_ge = eval_numer_ge*jacob
+ !~ !
+ !~ end function eval_numer_ge
+ function eval_numer_ge(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_ge
+ !
+ real(ki) :: x,y
+ real(ki) :: eps
+ complex(ki) :: z,jacob
+ real(ki) :: sigma
+ !
+ !~ eps = eps_glob
+ sigma = -b_glob/a_glob/2._ki
+ !
+ x = u
+ !
+ if ( (sigma <= 1._ki) .and. (sigma >= 0._ki) ) then
+ !
+ y = lambda_glob*sign(un,a_glob)*u*(u-1._ki)*(u-sigma)
+ z = x + i_*y
+ jacob = 1._ki + i_*lambda_glob*sign(un,a_glob)*( (u-1._ki)*(u-sigma) + u*(u-1._ki) + u*(u-sigma) )
+ !
+ else
+ !
+ y = lambda_glob*sign(un,a_glob*sigma)*u*(u-1._ki)
+ z = x - i_*y
+ jacob = 1._ki - i_*lambda_glob*sign(un,a_glob*sigma)*( (u-1._ki) + u )
+ !
+ end if
+ !
+ if (dist_glob) then
+ select case(expo_glob)
+ !
+ case(1)
+ !
+ eval_numer_ge = -( &
+ &1._ki/(a_glob-b_glob*z+c_glob*z*z) + &
+ &1._ki/(a_glob+b_glob*z+c_glob*z*z) + &
+ &1._ki/(a_glob*z*z-b_glob*z+c_glob) )
+ !
+ case(2)
+ !
+ eval_numer_ge = -( &
+ &(-2._ki*b_glob) &
+ &/( (a_glob-b_glob*z+c_glob*z*z)*(a_glob+b_glob*z+c_glob*z*z) ) + &
+ &(-z)/(a_glob*z*z-b_glob*z+c_glob) )
+ !
+ case(3)
+ !
+ eval_numer_ge = ( &
+ &(-2._ki*b_glob**2 + 2._ki*c_glob*a_glob + 2._ki*c_glob*c_glob*z*z) &
+ &/( (a_glob-b_glob*z+c_glob*z*z)*(a_glob+b_glob*z+c_glob*z*z) ) + &
+ &(-b_glob*z+c_glob)/(a_glob*z*z-b_glob*z+c_glob) + 1._ki )/a_glob
+ !
+ case(4)
+ !
+ eval_numer_ge = -( &
+ &2._ki*b_glob*(-b_glob**2 + 2._ki*c_glob*a_glob + 2._ki*c_glob*c_glob*z*z) &
+ &/( (a_glob-b_glob*z+c_glob*z*z)*(a_glob+b_glob*z+c_glob*z*z) ) + &
+ &((c_glob*a_glob-b_glob**2)*z+b_glob*c_glob)/(a_glob*z*z-b_glob*z+c_glob) &
+ & - (a_glob*z-b_glob) )/a_glob**2
+ !
+ end select
+ else
+ eval_numer_ge = z**(expo_glob-1)/(a_glob*z*z+b_glob*z+c_glob)
+ end if
+ eval_numer_ge = eval_numer_ge*jacob
+ !
+ end function eval_numer_ge
+ !
+ !****if* src/integrals/three_point/func_gn/eval_numer_gf
+ ! NAME
+ !
+ ! Function eval_numer_gf
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_gf(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of gf,
+ ! part ln(z-x_1)/( (z-x_1)*(z-x_2) )
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables of type xxx_glob
+ ! are global in this module
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_gf(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_gf
+ !
+ real(ki) :: x,y
+ real(ki) :: eps
+ complex(ki) :: z,jacob
+ real(ki) :: sigma
+ !
+ !~ eps = eps_glob
+ !
+ !~ sigma = -real(b,ki)/a/2._ki
+ sigma = -b_glob/a_glob/2._ki
+ !
+ x = u
+ !
+ if ( (sigma <= 1._ki) .and. (sigma >= 0._ki) ) then
+ !
+ y = lambda_glob*sign(un,a_glob)*u*(u-1._ki)*(u-sigma)
+ z = x + i_*y
+ jacob = 1._ki + i_*lambda_glob*sign(un,a_glob)*( (u-1._ki)*(u-sigma) + u*(u-1._ki) + u*(u-sigma) )
+ !
+ else
+ !
+ y = lambda_glob*sign(un,a_glob*sigma)*u*(u-1._ki)
+ z = x - i_*y
+ jacob = 1._ki - i_*lambda_glob*sign(un,a_glob*sigma)*( (u-1._ki) + u )
+ !
+ end if
+ !
+ !~ eval_numer_gf = (z_log(a_glob,-1._ki) +log(z-x1_glob) )/(z-x1_glob)/(z-x2_glob)/a_glob
+ if (dist_glob) then
+ eval_numer_gf = -( &
+ &log((a_glob-b_glob*z+c_glob*z*z)/(z*z))/(a_glob-b_glob*z+c_glob*z*z) + &
+ &log((a_glob+b_glob*z+c_glob*z*z)/(z*z))/(a_glob+b_glob*z+c_glob*z*z) + &
+ &log(a_glob*z*z-b_glob*z+c_glob)/(a_glob*z*z-b_glob*z+c_glob) )
+ else
+ eval_numer_gf = log(a_glob*z*z+b_glob*z+c_glob)/(a_glob*z*z+b_glob*z+c_glob)
+ end if
+ eval_numer_gf = eval_numer_gf*jacob
+ !
+ end function eval_numer_gf
+ !
+ !****if* src/integrals/three_point/func_gn/eval_numer_gf1
+ ! NAME
+ !
+ ! Function eval_numer_gf1
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_gf1(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of gf,
+ ! part ln(z-x_1)/( (z-x_1)*(z-x_2) )
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables of type xxx_glob
+ ! are global in this module
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_gf1(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_gf1
+ !
+ real(ki) :: x,y
+ real(ki) :: eps
+ complex(ki) :: z,jacob
+ !
+ eps = eps_glob
+ x = u
+ y = lambda_glob*u**alpha_glob*(1._ki-u)**beta_glob
+ jacob = 1._ki - eps*i_*lambda_glob*u**(alpha_glob-1._ki)&
+ *(1._ki-u)**(beta_glob-1._ki)*(alpha_glob*(1._ki-u)-beta_glob*u)
+ z = x - eps*i_*y
+ eval_numer_gf1 = (z_log(a_glob,-1._ki) +log(z-x1_glob) )/(z-x1_glob)/(z-x2_glob)/a_glob
+ eval_numer_gf1 = eval_numer_gf1*jacob
+ !
+ end function eval_numer_gf1
+ !
+ !****if* src/integrals/three_point/func_gn/eval_numer_gf2
+ ! NAME
+ !
+ ! Function eval_numer_gf2
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_gf2(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of gf,
+ ! part ln(z-x_2)/( (z-x_1)*(z-x_2) )
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables of type xxx_glob
+ ! are global in this module
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_gf2(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_gf2
+ !
+ real(ki) :: x,y
+ real(ki) :: eps
+ complex(ki) :: z,jacob
+ !
+ eps = eps_glob
+ x = u
+ y = lambda_glob*u**alpha_glob*(1._ki-u)**beta_glob
+ jacob = 1._ki - eps*i_*lambda_glob*u**(alpha_glob-1._ki)&
+ *(1._ki-u)**(beta_glob-1._ki)*(alpha_glob*(1._ki-u)-beta_glob*u)
+ z = x - eps*i_*y
+ eval_numer_gf2 = log(z-x2_glob)/(z-x1_glob)/(z-x2_glob)/a_glob
+ eval_numer_gf2 = eval_numer_gf2*jacob
+ !
+ end function eval_numer_gf2
+ !
+ !****if* src/integrals/three_point/func_gn/inside_contour
+ ! NAME
+ !
+ ! Subroutine inside_contour
+ !
+ ! USAGE
+ !
+ ! call inside_contour(pole,yes_or_no)
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine tests if the pole is inside the contour or not
+ !
+ ! INPUTS
+ !
+ ! * pole -- a complex (type ki), the pole
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a logical, true if the pole is inside, false otherwise
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine inside_contour(pole,yes_or_no)
+ !
+ complex(ki), INTENT(IN) :: pole
+ logical, INTENT(OUT) :: yes_or_no
+ !
+ real(ki) :: distance,x,y
+ !
+ yes_or_no = .false.
+ x = real(pole,ki)
+ y = aimag(pole)
+ distance = lambda_glob*x**alpha_glob*(1._ki-x)**beta_glob
+ if ( abs(distance-y) <= 0.1_ki ) then
+ !
+ lambda_glob = 2._ki*lambda_glob
+ distance = lambda_glob*x**alpha_glob*(1._ki-x)**beta_glob
+ !
+ end if
+ !
+ if ( (x >= 0._ki) .and. (x <= 1._ki) .and. (abs(y) <= distance) .and. (sign(1._ki,y) == sign(1._ki,-eps_glob)) ) then
+ !
+ yes_or_no = .true.
+ !
+ end if
+ !
+ end subroutine inside_contour
+ !
+end module func_gn
+
diff --git a/golem95c-1.2.1/integrals/three_point/mod_h0.f90 b/golem95c-1.2.1/integrals/three_point/mod_h0.f90
new file mode 100644
index 0000000..329c361
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/mod_h0.f90
@@ -0,0 +1,185 @@
+!
+!****h* src/integrals/three_point/func_h0
+! NAME
+!
+! Module func_h0
+!
+! USAGE
+!
+! use func_h0
+!
+! DESCRIPTION
+!
+! This module is specific for the function h0 defined
+! by h0(x,alpha) = (-x-i lambda)^(alpha)/x
+! with alpha << 1. The three functions h0d, h0e and h0f
+! are defined as:
+! h0(x,alpha) = h0d(x) + alpha h0e(x) + alpha^2 h0f(x)
+!
+!
+! OUTPUT
+!
+! This module exports three functions:
+! * h0d -- function
+! * h0e -- function
+! * h0f -- function
+!
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * parametre (src/module/parametre.f90)
+! * logarithme (src/module/z_log.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+!
+!*****
+module func_h0
+ !
+ use precision_golem
+ use parametre
+ use logarithme
+ use sortie_erreur
+ implicit none
+ !
+ private
+ public :: h0d,h0e,h0f
+ !
+ contains
+ !
+ !****f* src/integrals/three_point/func_h0/h0d
+ ! NAME
+ !
+ ! Function h0d
+ !
+ ! USAGE
+ !
+ ! real_dim2 = h0d(x)
+ !
+ ! DESCRIPTION
+ !
+ ! Compute the function 1/x
+ !
+ ! INPUTS
+ !
+ ! * x -- a real (type ki)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function h0d(x)
+ !
+ real(ki), intent(in) :: x
+ real(ki), dimension(2) :: h0d
+ !
+ h0d(1) = 1._ki/x
+ h0d(2) = 0._ki
+ !
+ end function h0d
+ !
+ !****f* src/integrals/three_point/func_h0/h0e
+ ! NAME
+ !
+ ! Function h0e
+ !
+ ! USAGE
+ !
+ ! real_dim2 = h0e(x)
+ !
+ ! DESCRIPTION
+ !
+ ! Compute the function ln(-x)/x
+ !
+ ! INPUTS
+ !
+ ! * x -- a real (type ki)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, the returned value depends on the global variable rat_or_tot_par
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function h0e(x)
+ !
+ real(ki), intent(in) :: x
+ real(ki), dimension(2) :: h0e
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ h0e(1) = real(z_log(-x/mu2_scale_par,-1._ki)/x,ki)
+ h0e(2) = aimag(z_log(-x/mu2_scale_par,-1._ki)/x)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ h0e = 0._ki
+ !
+ end if
+ !
+ end function h0e
+ !
+ !****f* src/integrals/three_point/func_h0/h0f
+ ! NAME
+ !
+ ! Function h0f
+ !
+ ! USAGE
+ !
+ ! real_dim2 = h0f(x)
+ !
+ ! DESCRIPTION
+ !
+ ! Compute the function 1/2 ln(-x)^2/x
+ !
+ ! INPUTS
+ !
+ ! * x -- a real (type ki)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, the returned value depends on the global variable rat_or_tot_par
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function h0f(x)
+ !
+ real(ki), intent(in) :: x
+ real(ki), dimension(2) :: h0f
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ h0f(1) = real(1._ki/2._ki*z_log2(-x/mu2_scale_par,-1._ki)/x,ki)
+ h0f(2) = aimag(1._ki/2._ki*z_log2(-x/mu2_scale_par,-1._ki)/x)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ h0f = 0._ki
+ !
+ end if
+ !
+ end function h0f
+ !
+end module func_h0
diff --git a/golem95c-1.2.1/integrals/three_point/mod_he.f90 b/golem95c-1.2.1/integrals/three_point/mod_he.f90
new file mode 100644
index 0000000..bea3668
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/mod_he.f90
@@ -0,0 +1,597 @@
+!
+!****h* src/integrals/three_point/func_he
+! NAME
+!
+! Module func_he
+!
+! USAGE
+!
+! use func_he
+!
+! DESCRIPTION
+!
+! This module contains several functions for the computation of
+! int^1_0 dy y^(n-1)/(y*z1+(1-y)*z3) where z1 and z3 are complex numbers
+!
+! OUTPUT
+!
+! This modules exports three functions:
+! * he -- a function
+! * he_gen -- a function
+! * he_c -- a function
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * parametre (src/module/parametre.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+module func_he
+ !
+ use precision_golem
+ use numerical_evaluation
+ use sortie_erreur, only : tab_erreur_par,catch_exception,origine_info_par,num_grand_b_info_par,denom_grand_b_info_par
+ use parametre, only : coupure_3p2m,rat_or_tot_par,tolerance,alpha_par,&
+ & beta_par,lambda_par
+ use logarithme, only : z_log
+ use constante, only : i_,un,czero
+ implicit none
+ !
+ real(ki) :: a1_glob,a3_glob,eps_glob
+ complex(ki) :: a1_glob_c, a3_glob_c
+ real(ki) :: plus_grand_glob
+ integer :: expo_glob
+ !
+ private
+ !
+ interface he
+ !
+ module procedure he_rarg
+ module procedure he_carg
+ !
+ end interface
+ !
+ public :: he,he_gen,he_c
+ !
+contains
+ !
+ !****f* src/integrals/three_point/func_he/he
+ ! NAME
+ !
+ ! Function he
+ ! Note that this function is an interface for two other functions
+ ! he_rarg and he_carg
+ !
+ ! USAGE
+ !
+ ! real_dim2 = he(n,a1,a3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes:
+ ! - int^1_0 dy y^(n-1)/(y*z1+(1-y)*z3)
+ ! where z1 = -a1 -i lambda and z3 = -a3 - i lambda
+ ! For n=1, it is equal to: - (ln(z1)-ln(z3))/(z1-z3)
+ ! compatible with the definition of HnE
+ ! It switches to numerical evaluation if
+ ! |a1-a3|/max(|a1|,|a3|) < coupure_3p2m
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the power of y in the integrand
+ ! * a1 -- a real/complex (type ki), z1 (time -1)
+ ! * a3 -- a real/complex (type ki), z3 (time -1)
+ ! or
+ ! * n -- an integer, the power of y in the integrand
+ ! * a1 -- a complex (type ki), z1 (time -1)
+ ! * a3 -- a complex (type ki), z3 (time -1)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, the returned value depends on the global variables
+ ! rat_or_tot_par, coupure_3p2m
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function he_rarg(n,a1,a3)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: a1,a3
+ real(ki), dimension(2) :: he_rarg
+ !
+ complex(ki) :: rest
+ complex(ki) :: abserr
+ complex(ki), dimension(4) :: ver
+ real(ki) :: g1,g3
+ !
+ plus_grand_glob = max(abs(a1),abs(a3))
+ g1 = a1/plus_grand_glob
+ g3 = a3/plus_grand_glob
+ ! les variables a1_glob, a3_glob, expo_glob et eps_glob sont globales
+ a1_glob = -g1
+ a3_glob = -g3
+ expo_glob = n
+ ! on choisit eps_glob de telle facon que le pole soit hors du contour
+ eps_glob = -sign(un,a1-a3)
+ !
+ ! mettre une coupure d'ordre 1 !!!!!
+ if (abs(g1-g3) > coupure_3p2m) then
+ !
+ ver = 0._ki
+ !
+ if (n >= 1) then
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ ver(1) = (z_log(-g1,-1._ki)-z_log(-g3,-1._ki))/(g1-g3)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ ver(1) = 0._ki
+ !
+ end if
+ !
+ end if
+ !
+ if (n >= 2) then
+ !
+ ver(2) = (-g3*ver(1)+1._ki)/(g1-g3)
+ !
+ end if
+ !
+ if (n >= 3) then
+ !
+ ver(3) = (-g3*ver(2)+1._ki/2._ki)/(g1-g3)
+ !
+ end if
+ !
+ if (n >= 4) then
+ !
+ ver(4) = (-g3*ver(3)+1._ki/3._ki )/(g1-g3)
+ !
+ end if
+ !
+ he_rarg(1) = real(ver(n),ki)/plus_grand_glob
+ he_rarg(2) = aimag(ver(n))/plus_grand_glob
+ !
+ else if ( (abs(g1-g3) <= coupure_3p2m) .and. &
+ (rat_or_tot_par%tot_selected) ) then
+ !
+ origine_info_par = "he_arg"
+ num_grand_b_info_par = n
+ denom_grand_b_info_par = abs(a1-a3)
+ !
+ call generic_eval_numer(eval_numer_he,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function he_rarg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the error returned by adapt_gauss1 is: %z0'
+ tab_erreur_par(2)%arg_comp = abserr
+ call catch_exception(1)
+ !
+ he_rarg(1) = real(rest,ki)/plus_grand_glob
+ he_rarg(2) = aimag(rest)/plus_grand_glob
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function he_rarg (file mod_he.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the choice rat has been made, it is singular when a1=a3 %d0'
+ tab_erreur_par(2)%arg_real=abs(g1-g3)
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function he_rarg
+ !
+ function he_carg(n,a1,a3)
+ !
+ integer, intent(in) :: n
+ complex(ki), intent(in) :: a1,a3
+ real(ki), dimension(2) :: he_carg
+ !
+ complex(ki) :: rest
+ complex(ki) :: abserr
+ complex(ki), dimension(4) :: ver
+ complex(ki) :: g1,g3
+ !
+ !~ plus_grand_glob = max(abs(real(a1,ki)), abs(aimag(a1)), abs(real(a3,ki)), abs(aimag(a3)) )
+ plus_grand_glob = max(abs(a1),abs(a3))
+ g1 = a1/plus_grand_glob
+ g3 = a3/plus_grand_glob
+ ! les variables a1_glob, a3_glob, expo_glob et eps_glob sont globales
+ a1_glob_c = -g1
+ a3_glob_c = -g3
+ expo_glob = n
+ ! mettre une coupure d'ordre 1 !!!!!
+ if (abs(g1-g3) > coupure_3p2m) then
+ !
+ ver(:) = czero
+ !
+ if (n >= 1) then
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ ver(1) = (log(-g1)-log(-g3))/(g1-g3)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ ver(1) = 0._ki
+ !
+ end if
+ !
+ end if
+ !
+ if (n >= 2) then
+ !
+ ver(2) = (-g3*ver(1)+1._ki)/(g1-g3)
+ !
+ end if
+ !
+ if (n >= 3) then
+ !
+ ver(3) = (-g3*ver(2)+1._ki/2._ki)/(g1-g3)
+ !
+ end if
+ !
+ if (n >= 4) then
+ !
+ ver(4) = (-g3*ver(3)+1._ki/3._ki )/(g1-g3)
+ !
+ end if
+ !
+ he_carg(1) = real(ver(n),ki)/plus_grand_glob
+ he_carg(2) = aimag(ver(n))/plus_grand_glob
+ !
+ else if ( (abs(g1-g3) <= coupure_3p2m) .and. &
+ (rat_or_tot_par%tot_selected) ) then
+ !
+ ! we choose eps_glob in such a way that the pole is outside the contour
+ ! we are in the case that sign(Im(g3)) = sign(Im(g1)) and sign(Re(g3)) = sign(Re(g1))
+ ! in this case, we choose eps_glob such that eps_glob*(Re(g1)-Re(g3)) < 0 if Im(g1) > 0
+ ! and eps_glob*(Re(g1)-Re(g3)) > 0 if Im(g1) < 0
+ if ( sign(un,aimag(g1)) == sign(un,aimag(g3)) ) then
+ eps_glob = -sign(un,aimag(g1))*sign(un,real(g1,ki)-real(g3,ki))
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function he_carg (file mod_he.f90) Im(g1) and Im(g3) do not the same sign'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Im(g1): %z0'
+ tab_erreur_par(2)%arg_comp = aimag(g1)
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'Im(g3): %z0'
+ tab_erreur_par(3)%arg_comp = aimag(g3)
+ call catch_exception(0)
+ end if
+ !
+ origine_info_par = "he_carg"
+ num_grand_b_info_par = n
+ denom_grand_b_info_par = abs(a1-a3)
+ !
+ call generic_eval_numer(eval_numer_he_c,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function he_carg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the error returned by adapt_gauss1 is: %z0'
+ tab_erreur_par(2)%arg_comp = abserr
+ call catch_exception(1)
+ !
+ he_carg(1) = real(rest,ki)/plus_grand_glob
+ he_carg(2) = aimag(rest)/plus_grand_glob
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function he_carg (file mod_he.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the choice rat has been made, it is singular when a1=a3 %d0'
+ tab_erreur_par(2)%arg_real=abs(g1-g3)
+ call catch_exception(0)
+ !
+ end if
+ !
+ end function he_carg
+ !
+ !
+ !****if* src/integrals/three_point/func_he/eval_numer_he
+ ! NAME
+ !
+ ! Function eval_numer_he
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_he(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of he
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables a1_glob, a3_glob, expo_glob and eps_glob
+ ! are global in this module whereas variables lambda_par,beta_par,
+ ! alpha_par are given by the module parametre
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_he(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_he
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = -lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ z = x + eps_glob*i_*y
+ eval_numer_he = z**(expo_glob-1)/(z*a1_glob+(1._ki-z)*a3_glob)
+ eval_numer_he = -eval_numer_he*jacob
+ !
+ end function eval_numer_he
+ !
+ !****if* src/integrals/three_point/func_he/eval_numer_he
+ ! NAME
+ !
+ ! Function eval_numer_he_c
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_he_c(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of he_carg
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables a1_glob_c, a3_glob_c, expo_glob and eps_glob
+ ! are global in this module whereas variables lambda_par,beta_par,
+ ! alpha_par are given by the module parametre
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_he_c(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_he_c
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = -lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ z = x + eps_glob*i_*y
+ eval_numer_he_c = z**(expo_glob-1)/(z*a1_glob_c+(1._ki-z)*a3_glob_c)
+ eval_numer_he_c = -eval_numer_he_c*jacob
+ !
+ end function eval_numer_he_c
+ !
+ !****f* src/integrals/three_point/func_he/he_c
+ ! NAME
+ !
+ ! Function he_c
+ !
+ ! USAGE
+ !
+ ! complex = he_c(n,a1,a3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the same thing as he
+ ! but it returns a complex instead of a real array of rank 1 and shape 2
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the power of y in the integrand
+ ! * a1 -- a real (type ki), the real part of z1 (time -1)
+ ! * a3 -- a real (type ki), the real part of z3 (time -1)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function he_c(n,a1,a3)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: a1,a3
+ complex(ki) :: he_c
+ !
+ real(ki), dimension(2) :: temp
+ !
+ temp = he(n,a1,a3)
+ he_c = cmplx(temp(1),temp(2),ki)
+ !
+ end function he_c
+ !
+ !****f* src/integrals/three_point/func_he/he_gen
+ ! NAME
+ !
+ ! Function he_gen
+ !
+ ! USAGE
+ !
+ ! real_dim2 = he_gen(n,a1,b1,a3,b3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes:
+ ! int^1_0 dy y^n/(y*z1+(1-y)*z3)
+ ! where z1 = a1 + i b1 and z3 = a3 + i b3
+ ! For n=1, it is equal to: (ln(z1)-ln(z3))/(z1-z3)
+ ! It switches to numerical evaluation if
+ ! |a1-a3|/max(|a1|,|a3|) < coupure_3p2m
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the power of y in the integrand
+ ! * a1 -- a real (type ki), the real part of z1
+ ! * b1 -- a real (type ki), the imaginary part of z1
+ ! * a3 -- a real (type ki), the real part of z3
+ ! * b3 -- a real (type ki), the imaginary part of z3
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, the returned value depends on the global variables
+ ! rat_or_tot_par, coupure_3p2m
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function he_gen(n,a1,b1,a3,b3)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: a1,b1,a3,b3
+ real(ki), dimension(2) :: he_gen
+ !
+ complex(ki) :: rest
+ complex(ki) :: abserr
+ complex(ki), dimension(4) :: ver
+ !
+ plus_grand_glob = max(abs(a1),abs(a3))
+ ! les variables a1_gen_glob, a3_gen_glob, expo_gen_glob et eps_gen_glob
+ ! sont globales
+ a1_glob = a1/plus_grand_glob
+ a3_glob = a3/plus_grand_glob
+ expo_glob = n
+ ! on choisit eps de telle facon que le pole soit hors du contour
+ eps_glob = sign(un,b1*a3-b3*a1)
+ !
+ ! mettre une coupure d'ordre 1 !!!!!
+ if (abs(a1_glob-a3_glob) > coupure_3p2m) then
+ !
+ ver(1) = (z_log(a1,b1)-z_log(a3,b3))/(a1-a3)
+ ver(2) = (-a3*ver(1)+1._ki)/(a1-a3)
+ ver(3) = (-a3*ver(2)+1._ki/2._ki)/(a1-a3)
+ ver(4) = (-a3*ver(3)+1._ki/3._ki )/(a1-a3)
+ !
+ rest = ver(n)
+ !
+ else
+ !
+ origine_info_par = "he_gen"
+ num_grand_b_info_par = n
+ denom_grand_b_info_par = abs(a1-a3)
+ !
+ call generic_eval_numer(eval_numer_he_gen,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function he_gen:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the error returned by adapt_gauss1 is: %z0'
+ tab_erreur_par(2)%arg_comp = abserr
+ call catch_exception(1)
+ !
+ end if
+ !
+ he_gen(1) = real(rest,ki)/plus_grand_glob
+ he_gen(2) = aimag(rest)/plus_grand_glob
+ !
+ end function he_gen
+ !
+ !****if* src/integrals/three_point/func_he/eval_numer_he_gen
+ ! NAME
+ !
+ ! Function eval_numer_he_gen
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_he_gen(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of he_gen
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables a1_glob, a3_glob, expo_glob and eps_glob
+ ! are global in this module whereas variables lambda_par,beta_par,
+ ! alpha_par are given by the module parametre
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_he_gen(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_he_gen
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = -lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ z = x + eps_glob*i_*y
+ eval_numer_he_gen = z**(expo_glob-1)/(z*a1_glob+(1._ki-z)*a3_glob)
+ eval_numer_he_gen = eval_numer_he_gen*jacob
+ !
+ end function eval_numer_he_gen
+ !
+end module func_he
diff --git a/golem95c-1.2.1/integrals/three_point/mod_hf.f90 b/golem95c-1.2.1/integrals/three_point/mod_hf.f90
new file mode 100644
index 0000000..fc943d0
--- /dev/null
+++ b/golem95c-1.2.1/integrals/three_point/mod_hf.f90
@@ -0,0 +1,748 @@
+!
+!****h* src/integrals/three_point/func_hf
+! NAME
+!
+! Module func_hf
+!
+! USAGE
+!
+! use func_hf
+!
+! DESCRIPTION
+!
+! This module contains several functions for the computation of
+! - int^1_0 dy y^n*ln(y*z1+(1-y)*z3)/(y*z1+(1-y)*z3) where z1 and
+! z3 are complex numbers
+!
+! OUTPUT
+!
+! This modules exports three functions:
+! * hf -- a function
+! * hf_gen -- a function
+! * hf_c -- a function
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * numerical_evaluation (src/numerical/mod_numeric.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * parametre (src/module/parametre.f90)
+! * logarithme (src/module/z_log.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+module func_hf
+ use precision_golem
+ use numerical_evaluation
+ use sortie_erreur, only : tab_erreur_par,catch_exception,origine_info_par,num_grand_b_info_par,denom_grand_b_info_par
+ use parametre, only : coupure_3p2m,rat_or_tot_par,tolerance,alpha_par,beta_par,lambda_par,mu2_scale_par
+ use logarithme, only : z_log,z_log2
+ use constante, only : i_,un,czero
+ implicit none
+ !
+ real(ki) :: a1_glob,a3_glob,eps_glob
+ complex(ki) :: a1_glob_c, a3_glob_c
+ real(ki) :: plus_grand_glob
+ integer :: expo_glob
+ !
+ private
+ !
+ interface hf
+ !
+ module procedure hf_rarg
+ module procedure hf_carg
+ !
+ end interface
+ !
+ public :: hf,hf_gen,hf_c
+ !
+contains
+ !
+ !****f* src/integrals/three_point/func_hf/hf
+ ! NAME
+ !
+ ! Function hf
+ ! Note that this function is an interface for two other functions
+ ! hf_rarg and hf_carg
+ !
+ ! USAGE
+ !
+ ! real_dim2 = hf(n,a1,a3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes:
+ ! - int^1_0 dy y^(n-1)*ln(y*z1+(1-y)*z3)/(y*z1+(1-y)*z3)
+ ! where z1 = a1 + i b1 and z3 = a3 + i b3
+ ! For n=1, it is equal to: -(ln^2(z1)-ln^2(z3))/2/(z1-z3)
+ ! compatible with the definition of HnF
+ ! It switches to numerical evaluation if
+ ! |a1-a3|/max(|a1|,|a3|) < coupure_3p2m
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the power of y in the integrand
+ ! * a1 -- a real (type ki), the real part of z1 (time -1)
+ ! * a3 -- a real (type ki), the real part of z3 (time -1)
+ ! or
+ ! * n -- an integer, the power of y in the integrand
+ ! * a1 -- a complex (type ki), z1 (time -1)
+ ! * a3 -- a complex (type ki), z3 (time -1)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, the returned value depends on the global variables
+ ! rat_or_tot_par, coupure_3p2m
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function hf_rarg(n,a1,a3)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: a1,a3
+ real(ki), dimension(2) :: hf_rarg
+ !
+ complex(ki) :: rest
+ complex(ki) :: abserr
+ complex(ki), dimension(4) :: ver,verm,vert
+ real(ki) :: g1,g3,lm
+ !
+ plus_grand_glob = max(abs(a1),abs(a3))
+ g1 = a1/plus_grand_glob
+ g3 = a3/plus_grand_glob
+ ! les variables a1_glob, a3_glob, expo_glob et eps_glob sont globales
+ a1_glob = -g1
+ a3_glob = -g3
+ expo_glob = n
+ ! on choisit eps_glob de telle facon que le pole soit hors du contour
+ eps_glob = -sign(un,a1-a3)
+ !
+ ! mettre une coupure d'ordre 1 !!!!!
+ if (rat_or_tot_par%tot_selected) then
+ !
+ if (abs(g1-g3) > coupure_3p2m) then
+ !
+ lm = log(plus_grand_glob/mu2_scale_par)
+ ver = 0._ki
+ verm = 0._ki
+ vert = 0._ki
+ !
+ if (n >= 1) then
+ !
+ ver(1) = ( z_log2(-g1,-1._ki) - z_log2(-g3,-1._ki) )/(g1-g3)/2._ki
+ verm(1) = (z_log(-g1,-1._ki)-z_log(-g3,-1._ki))/(g1-g3)
+ vert(1) = ver(1)+lm*verm(1)
+ !
+ end if
+ !
+ if (n >= 2) then
+ !
+ ver(2) = ( -g3*ver(1) - 1._ki + ( g1*z_log(-g1,-1._ki) &
+ - g3*z_log(-g3,-1._ki) )/(g1-g3) )/(g1-g3)
+ verm(2) = (-g3*verm(1)+1._ki)/(g1-g3)
+ vert(2) = ver(2)+lm*verm(2)
+ !
+ end if
+ !
+ if (n >= 3) then
+ !
+ ver(3) = ( -g3*ver(2) + 1._ki/4._ki*( -3._ki*g3**2 &
+ + 2*z_log(-g3,-1._ki)*g3**2 - g1**2 + 4._ki*g1*g3 &
+ + 2._ki*z_log(-g1,-1._ki)*g1**2 &
+ - 4*z_log(-g1,-1._ki)*g1*g3 )/(g1-g3)**2 )/(g1-g3)
+ verm(3) = (-g3*verm(2)+1._ki/2._ki)/(g1-g3)
+ vert(3) = ver(3)+lm*verm(3)
+ !
+ end if
+ !
+ if (n >= 4) then
+ !
+ ver(4) = ( -g3*ver(3) + 1._ki/18._ki*( -6._ki*z_log(-g3,-1._ki)*g3**3 &
+ + 11._ki*g3**3 - 18._ki*g3**2*g1 - 2._ki*g1**3 &
+ + 9._ki*g1**2*g3 - 18._ki*z_log(-g1,-1._ki)*g1**2*g3 &
+ + 18._ki*z_log(-g1,-1._ki)*g1*g3**2 &
+ + 6._ki*z_log(-g1,-1._ki)*g1**3 )/(g1-g3)**3 )/(g1-g3)
+ verm(4) = (-g3*verm(3)+1._ki/3._ki )/(g1-g3)
+ vert(4) = ver(4)+lm*verm(4)
+ !
+ end if
+ !
+ rest = vert(n)
+ !
+ else if ( (abs(g1-g3) <= coupure_3p2m) .and. (abs(g1-g3) >= tiny(g1)) ) then
+ !
+ origine_info_par = "hf"
+ num_grand_b_info_par = n
+ denom_grand_b_info_par = abs(a1-a3)
+ !
+ call generic_eval_numer(eval_numer_hf,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hf_rarg:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the error returned by adapt_gauss1 is: %z0'
+ tab_erreur_par(2)%arg_comp = abserr
+ call catch_exception(1)
+ !
+ else if ( (abs(g1-g3) <= tiny(g1)) ) then
+ !
+ rest = (z_log(-g1,-1._ki) + log(plus_grand_glob/mu2_scale_par))/(g1*real(n,ki))
+ !
+ end if
+ !
+ hf_rarg(1) = real(rest,ki)/plus_grand_glob
+ hf_rarg(2) = aimag(rest)/plus_grand_glob
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ if (abs(g1-g3) > coupure_3p2m) then
+ !
+ ver = 0._ki
+ vert = 0._ki
+ !
+ if (n >= 1) then
+ ver(1) = 0._ki
+ vert(1) = 0._ki
+ end if
+ !
+ if (n >= 2) then
+ !
+ ver(2) = ( -g3*ver(1) - 1._ki )/(g1-g3)
+ vert(2) = ver(2)
+ !
+ end if
+ !
+ if (n >= 3) then
+ !
+ ver(3) = ( -g3*ver(2) + 1._ki/4._ki*( -3._ki*g3**2 &
+ - g1**2 + 4._ki*g1*g3 )/(g1-g3)**2 )/(g1-g3)
+ vert(3) = ver(3)
+ !
+ end if
+ !
+ if (n >= 4) then
+ !
+ ver(4) = ( -g3*ver(3) + 1._ki/18._ki*( &
+ + 11._ki*g3**3 - 18._ki*g3**2*g1 - 2._ki*g1**3 &
+ + 9._ki*g1**2*g3 )/(g1-g3)**3 )/(g1-g3)
+ vert(4) = ver(4)
+ !
+ end if
+ !
+ rest = vert(n)
+ !
+ hf_rarg(1) = real(rest,ki)/plus_grand_glob
+ hf_rarg(2) = aimag(rest)/plus_grand_glob
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hf_rarg (file mod_hf.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the choice rat has been made, it is singular when a1=a3 %d0'
+ tab_erreur_par(2)%arg_real=abs(g1-g3)
+ call catch_exception(0)
+ !
+ end if
+ !
+ end if
+ !
+ end function hf_rarg
+ !
+ function hf_carg(n,a1,a3)
+ !
+ integer, intent(in) :: n
+ complex(ki), intent(in) :: a1,a3
+ real(ki), dimension(2) :: hf_carg
+ !
+ complex(ki) :: rest
+ complex(ki) :: abserr
+ complex(ki), dimension(4) :: ver,verm,vert
+ complex(ki) :: g1,g3
+ real(ki) :: lm
+ !
+ !~ plus_grand_glob = max(abs(real(a1,ki)), abs(aimag(a1)), abs(real(a3,ki)), abs(aimag(a3)) )
+ plus_grand_glob = max(abs(a1), abs(a3))
+ g1 = a1/plus_grand_glob
+ g3 = a3/plus_grand_glob
+ ! les variables a1_glob, a3_glob, expo_glob et eps_glob sont globales
+ a1_glob_c = -g1
+ a3_glob_c = -g3
+ expo_glob = n
+ !
+ ! mettre une coupure d'ordre 1 !!!!!
+ if (rat_or_tot_par%tot_selected) then
+ !
+ if (abs(g1-g3) > coupure_3p2m) then
+ !
+ lm = log(plus_grand_glob/mu2_scale_par)
+ ver(:) = czero
+ verm(:) = czero
+ vert(:) = czero
+ !
+ if (n >= 1) then
+ !
+ ver(1) = ( log(-g1)**2 - log(-g3)**2 )/(g1-g3)/2._ki
+ verm(1) = (log(-g1)-log(-g3))/(g1-g3)
+ vert(1) = ver(1)+lm*verm(1)
+ !
+ end if
+ !
+ if (n >= 2) then
+ !
+ ver(2) = ( -g3*ver(1) - 1._ki + ( g1*log(-g1) &
+ - g3*log(-g3) )/(g1-g3) )/(g1-g3)
+ verm(2) = (-g3*verm(1)+1._ki)/(g1-g3)
+ vert(2) = ver(2)+lm*verm(2)
+ !
+ end if
+ !
+ if (n >= 3) then
+ !
+ ver(3) = ( -g3*ver(2) + 1._ki/4._ki*( -3._ki*g3**2 &
+ + 2*log(-g3)*g3**2 - g1**2 + 4._ki*g1*g3 &
+ + 2._ki*log(-g1)*g1**2 &
+ - 4*log(-g1)*g1*g3 )/(g1-g3)**2 )/(g1-g3)
+ verm(3) = (-g3*verm(2)+1._ki/2._ki)/(g1-g3)
+ vert(3) = ver(3)+lm*verm(3)
+ !
+ end if
+ !
+ if (n >= 4) then
+ !
+ ver(4) = ( -g3*ver(3) + 1._ki/18._ki*( -6._ki*log(-g3)*g3**3 &
+ + 11._ki*g3**3 - 18._ki*g3**2*g1 - 2._ki*g1**3 &
+ + 9._ki*g1**2*g3 - 18._ki*log(-g1)*g1**2*g3 &
+ + 18._ki*log(-g1)*g1*g3**2 &
+ + 6._ki*log(-g1)*g1**3 )/(g1-g3)**3 )/(g1-g3)
+ verm(4) = (-g3*verm(3)+1._ki/3._ki )/(g1-g3)
+ vert(4) = ver(4)+lm*verm(4)
+ !
+ end if
+ !
+ rest = vert(n)
+ !
+ else if ( (abs(g1-g3) <= coupure_3p2m) .and. (abs(g1-g3) >= tiny(real(g1,ki))) ) then
+ !
+ ! we choose eps_glob in such a way that the pole is outside the contour
+ ! we are in the case that sign(Im(g3)) = sign(Im(g1)) and sign(Re(g3)) = sign(Re(g1))
+ ! in this case, we choose eps_glob such that eps_glob*(Re(g1)-Re(g3)) < 0 if Im(g1) > 0
+ ! and eps_glob*(Re(g1)-Re(g3)) > 0 if Im(g1) < 0
+ if ( sign(un,aimag(g1)) == sign(un,aimag(g3)) ) then
+ eps_glob = -sign(un,aimag(g1))*sign(un,real(g1,ki)-real(g3,ki))
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hf_carg (file mod_hf.f90) Im(g1) and Im(g3) do not the same sign'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'Im(g1): %z0'
+ tab_erreur_par(2)%arg_comp = aimag(g1)
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'Im(g3): %z0'
+ tab_erreur_par(3)%arg_comp = aimag(g3)
+ call catch_exception(0)
+ end if
+ !
+ origine_info_par = "hf_carg"
+ num_grand_b_info_par = n
+ denom_grand_b_info_par = abs(a1-a3)
+ !
+ call generic_eval_numer(eval_numer_hf_c,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hf:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the error returned by adapt_gauss1 is: %z0'
+ tab_erreur_par(2)%arg_comp = abserr
+ call catch_exception(1)
+ !
+ else if ( (abs(g1-g3) <= tiny(real(g1,ki))) ) then
+ !
+ rest = (log(-g1) + log(plus_grand_glob/mu2_scale_par))/(g1*real(n,ki))
+ !
+ end if
+ !
+ hf_carg(1) = real(rest,ki)/plus_grand_glob
+ hf_carg(2) = aimag(rest)/plus_grand_glob
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ if (abs(g1-g3) > coupure_3p2m) then
+ !
+ ver = 0._ki
+ vert = 0._ki
+ !
+ if (n >= 1) then
+ ver(1) = 0._ki
+ vert(1) = 0._ki
+ end if
+ !
+ if (n >= 2) then
+ !
+ ver(2) = ( -g3*ver(1) - 1._ki )/(g1-g3)
+ vert(2) = ver(2)
+ !
+ end if
+ !
+ if (n >= 3) then
+ !
+ ver(3) = ( -g3*ver(2) + 1._ki/4._ki*( -3._ki*g3**2 &
+ - g1**2 + 4._ki*g1*g3 )/(g1-g3)**2 )/(g1-g3)
+ vert(3) = ver(3)
+ !
+ end if
+ !
+ if (n >= 4) then
+ !
+ ver(4) = ( -g3*ver(3) + 1._ki/18._ki*( &
+ + 11._ki*g3**3 - 18._ki*g3**2*g1 - 2._ki*g1**3 &
+ + 9._ki*g1**2*g3 )/(g1-g3)**3 )/(g1-g3)
+ vert(4) = ver(4)
+ !
+ end if
+ !
+ rest = vert(n)
+ !
+ hf_carg(1) = real(rest,ki)/plus_grand_glob
+ hf_carg(2) = aimag(rest)/plus_grand_glob
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hf (file mod_hf.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the choice rat has been made, it is singular when a1=a3 %d0'
+ tab_erreur_par(2)%arg_real=abs(g1-g3)
+ call catch_exception(0)
+ !
+ end if
+ !
+ end if
+ !
+ end function hf_carg
+ !
+ ! variables a1_glob, a3_glob, expo_glob and eps_glob are global in this
+ ! module whereas variables lambda_par,beta_par,alpha_par are given by the
+ ! module parametre
+ !****if* src/integrals/three_point/func_hf/eval_numer_hf
+ ! NAME
+ !
+ ! Function eval_numer_hf
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_hf(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of hf_rarg
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables a1_glob, a3_glob, expo_glob and eps_glob
+ ! are global in this module whereas variables lambda_par,beta_par,
+ ! alpha_par are given by the module parametre
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_hf(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_hf
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = -lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ z = x + eps_glob*i_*y
+ eval_numer_hf = z**(expo_glob-1)*( log(z*a1_glob+(1._ki-z)*a3_glob) &
+ + log(plus_grand_glob/mu2_scale_par) )/(z*a1_glob+(1._ki-z)*a3_glob)
+ eval_numer_hf = -eval_numer_hf*jacob
+ !
+ end function eval_numer_hf
+ !
+ ! variables a1_glob, a3_glob, expo_glob and eps_glob are global in this
+ ! module whereas variables lambda_par,beta_par,alpha_par are given by the
+ ! module parametre
+ !****if* src/integrals/three_point/func_hf/eval_numer_hf
+ ! NAME
+ !
+ ! Function eval_numer_hf_c
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_hf_c(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of hf_carg
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables a1_glob_c, a3_glob_c, expo_glob and eps_glob
+ ! are global in this module whereas variables lambda_par,beta_par,
+ ! alpha_par are given by the module parametre
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_hf_c(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_hf_c
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = -lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ z = x + eps_glob*i_*y
+ eval_numer_hf_c = z**(expo_glob-1)*( log(z*a1_glob_c+(1._ki-z)*a3_glob_c) &
+ + log(plus_grand_glob/mu2_scale_par) )/(z*a1_glob_c+(1._ki-z)*a3_glob_c)
+ eval_numer_hf_c = -eval_numer_hf_c*jacob
+ !
+ end function eval_numer_hf_c
+ !
+ ! This function computes the same thing as he
+ ! but it returns a complex instead of two dim array
+ !****f* src/integrals/three_point/func_hf/hf_c
+ ! NAME
+ !
+ ! Function hf_c
+ !
+ ! USAGE
+ !
+ ! complex = hf_c(n,a1,a3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the same thing as hf
+ ! but it returns a complex instead of a real array of rank 1 and shape 2
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the power of y in the integrand
+ ! * a1 -- a real (type ki), the real part of z1 (time -1)
+ ! * a3 -- a real (type ki), the real part of z3 (time -1)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function hf_c(n,a1,a3)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: a1,a3
+ complex(ki) :: hf_c
+ !
+ real(ki), dimension(2) :: temp
+ !
+ temp = hf(n,a1,a3)
+ hf_c = cmplx(temp(1),temp(2),ki)
+ !
+ end function hf_c
+ !
+ !****f* src/integrals/three_point/func_hf/hf_gen
+ ! NAME
+ !
+ ! Function hf_gen
+ !
+ ! USAGE
+ !
+ ! real_dim2 = hf_gen(n,a1,b1,a3,b3)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes:
+ ! int^1_0 dy y^n*ln(y*z1+(1-y)*z3)/(y*z1+(1-y)*z3)
+ ! where z1 = a1 + i b1 and z3 = a3 + i b3
+ ! For n=1, it is equal to: (ln^2(z1)-ln^2(z3))/(z1-z3)
+ ! It switches to numerical evaluation if
+ ! |a1-a3|/max(|a1|,|a3|) < coupure_3p2m
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the power of y in the integrand
+ ! * a1 -- a real (type ki), the real part of z1
+ ! * b1 -- a real (type ki), the imaginary part of z1
+ ! * a3 -- a real (type ki), the real part of z3
+ ! * b3 -- a real (type ki), the imaginary part of z3
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, the returned value depends on the global variables
+ ! rat_or_tot_par, coupure_3p2m
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function hf_gen(n,a1,b1,a3,b3)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: a1,b1,a3,b3
+ real(ki), dimension(2) :: hf_gen
+ !
+ complex(ki) :: rest
+ complex(ki) :: abserr
+ complex(ki), dimension(4) :: ver,verm
+ real(ki) :: lm
+ !
+ plus_grand_glob = max(abs(a1),abs(a3))
+ ! les variables a1_glob, a3_glob, expo_glob et eps_glob
+ ! sont globales
+ a1_glob = a1/plus_grand_glob
+ a3_glob = a3/plus_grand_glob
+ expo_glob = n
+ ! on choisit eps de telle facon que le pole soit hors du contour
+ eps_glob = sign(un,b1*a3-b3*a1)
+ !
+ ! mettre une coupure d'ordre 1 !!!!!
+ if (abs(a1_glob-a3_glob) > coupure_3p2m) then
+ !
+ lm = log(plus_grand_glob/mu2_scale_par)
+ !
+ ver(1) = (z_log2(a1,b1)-z_log2(a3,b3))/(a1-a3)/2._ki
+ ver(2) = (-a3*ver(1)-1._ki+(a1*z_log(a1,b1)-a3*z_log(a3,b3))/(a1-a3))&
+ /(a1-a3)
+ ver(3) = ( -a3*ver(2)+1._ki/4._ki*(-3._ki*a3**2+2._ki*z_log(a3,b3)*a3**2 &
+ -a1**2+4._ki*a1*a3+2._ki*z_log(a1,b1)*a1**2-4._ki*z_log(a1,b1) &
+ *a1*a3)/(a1-a3)**2 )/(a1-a3)
+ ver(4) = ( -a3*ver(3)+1._ki/18._ki*(-6._ki*z_log(a3,b3)*a3**3 &
+ +11._ki*a3**3-18._ki*a3**2*a1-18._ki*z_log(a1,b1)*a1**2*a3 &
+ +18._ki*z_log(a1,b1)*a1*a3**2-2._ki*a1**3+9._ki*a1**2*a3 &
+ +6._ki*z_log(a1,b1)*a1**3)/(a1-a3)**3 )/(a1-a3)
+ !
+ verm(1) = (z_log(a1,b1)-z_log(a3,b3))/(a1-a3)
+ verm(2) = (-a3*ver(1)+1._ki)/(a1-a3)
+ verm(3) = (-a3*ver(2)+1._ki/2._ki)/(a1-a3)
+ verm(4) = (-a3*ver(3)+1._ki/3._ki )/(a1-a3)
+ !
+ rest = ver(n)+lm*verm(n)
+ !
+ else if ( (abs(a1_glob-a3_glob) <= coupure_3p2m) .and. &
+ (abs(a1_glob-a3_glob) >= tiny(a1_glob)) ) then
+ !
+ origine_info_par = "hf_gen"
+ num_grand_b_info_par = n
+ denom_grand_b_info_par = abs(a1-a3)
+ !
+ call generic_eval_numer(eval_numer_hf_gen,0._ki,1._ki,tolerance,rest,abserr)
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hf_gen:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the error returned by adapt_gauss1 is: %z0'
+ tab_erreur_par(2)%arg_comp = abserr
+ call catch_exception(1)
+ !
+ else if ( (abs(a1_glob-a3_glob) <= tiny(a1_glob)) ) then
+ !
+ rest = (z_log(-a1_glob,-1._ki) + log(plus_grand_glob/mu2_scale_par))/a1_glob/real(n,ki)
+ !
+ end if
+ !
+ hf_gen(1) = real(rest,ki)/plus_grand_glob
+ hf_gen(2) = aimag(rest)/plus_grand_glob
+ !
+ end function hf_gen
+ !
+ !****if* src/integrals/three_point/func_hf/eval_numer_hf_gen
+ ! NAME
+ !
+ ! Function eval_numer_hf_gen
+ !
+ ! USAGE
+ !
+ ! complex = eval_numer_hf_gen(u)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the integrand for the numerical evaluation of hf_gen
+ !
+ ! INPUTS
+ !
+ ! * u -- a real (type ki), the integration variable
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect. The variables a1_glob, a3_glob, expo_glob and eps_glob
+ ! are global in this module whereas variables lambda_par,beta_par,
+ ! alpha_par are given by the module parametre
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function eval_numer_hf_gen(u)
+ !
+ real(ki), intent (in) :: u
+ complex(ki) :: eval_numer_hf_gen
+ !
+ real(ki) :: x,y
+ complex(ki) :: z,jacob
+ !
+ x = u
+ y = -lambda_par*u**alpha_par*(1._ki-u)**beta_par
+ jacob = 1._ki - eps_glob*i_*lambda_par*u**(alpha_par-1._ki)&
+ *(1._ki-u)**(beta_par-1._ki)*(alpha_par*(1._ki-u)-beta_par*u)
+ z = x + eps_glob*i_*y
+ eval_numer_hf_gen = z**(expo_glob-1)*( log(z*a1_glob+(1._ki-z)*a3_glob) &
+ + log(plus_grand_glob/mu2_scale_par) )&
+ /(z*a1_glob+(1._ki-z)*a3_glob)
+ eval_numer_hf_gen = eval_numer_hf_gen*jacob
+ !
+ end function eval_numer_hf_gen
+ !
+end module func_hf
diff --git a/golem95c-1.2.1/integrals/two_point/Makefile.am b/golem95c-1.2.1/integrals/two_point/Makefile.am
new file mode 100644
index 0000000..ea83e74
--- /dev/null
+++ b/golem95c-1.2.1/integrals/two_point/Makefile.am
@@ -0,0 +1,16 @@
+noinst_LTLIBRARIES=libgolem95_integrals_two_point.la
+
+libgolem95_integrals_two_point_la_SOURCES= \
+ function_2p0m_1mi.f90 function_2p_m1m2.f90 generic_function_2p.f90
+libgolem95_integrals_two_point_la_FCFLAGS=\
+ -I$(builddir)/../../module \
+ -I$(builddir)/../../kinematic \
+ -I$(builddir)/../../numerical \
+ -I$(builddir)/../one_point \
+ -I$(builddir)/../../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS= function_2p_m1m2.mod function_2p0m_1mi.mod \
+ generic_function_2p.mod
+CLEANFILES=*.mod
+
+include Makefile.dep
diff --git a/golem95c-1.2.1/integrals/two_point/Makefile.dep b/golem95c-1.2.1/integrals/two_point/Makefile.dep
new file mode 100644
index 0000000..7ec4bea
--- /dev/null
+++ b/golem95c-1.2.1/integrals/two_point/Makefile.dep
@@ -0,0 +1,7 @@
+# Module dependencies
+function_2p_m1m2.o: function_2p0m_1mi.o
+function_2p_m1m2.lo: function_2p0m_1mi.lo
+function_2p_m1m2.obj: function_2p0m_1mi.obj
+generic_function_2p.o: function_2p0m_1mi.o function_2p_m1m2.o
+generic_function_2p.lo: function_2p0m_1mi.lo function_2p_m1m2.lo
+generic_function_2p.obj: function_2p0m_1mi.obj function_2p_m1m2.obj
diff --git a/golem95c-1.2.1/integrals/two_point/Makefile.in b/golem95c-1.2.1/integrals/two_point/Makefile.in
new file mode 100644
index 0000000..bdb4a58
--- /dev/null
+++ b/golem95c-1.2.1/integrals/two_point/Makefile.in
@@ -0,0 +1,574 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.dep \
+ $(srcdir)/Makefile.in
+subdir = golem95c-1.2.1/integrals/two_point
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+LTLIBRARIES = $(noinst_LTLIBRARIES)
+libgolem95_integrals_two_point_la_LIBADD =
+am_libgolem95_integrals_two_point_la_OBJECTS = \
+ libgolem95_integrals_two_point_la-function_2p0m_1mi.lo \
+ libgolem95_integrals_two_point_la-function_2p_m1m2.lo \
+ libgolem95_integrals_two_point_la-generic_function_2p.lo
+libgolem95_integrals_two_point_la_OBJECTS = \
+ $(am_libgolem95_integrals_two_point_la_OBJECTS)
+libgolem95_integrals_two_point_la_LINK = $(LIBTOOL) --tag=FC \
+ $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(FCLD) \
+ $(libgolem95_integrals_two_point_la_FCFLAGS) $(FCFLAGS) \
+ $(AM_LDFLAGS) $(LDFLAGS) -o $@
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem95_integrals_two_point_la_SOURCES)
+DIST_SOURCES = $(libgolem95_integrals_two_point_la_SOURCES)
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgincludedir)"
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+noinst_LTLIBRARIES = libgolem95_integrals_two_point.la
+libgolem95_integrals_two_point_la_SOURCES = \
+ function_2p0m_1mi.f90 function_2p_m1m2.f90 generic_function_2p.f90
+
+libgolem95_integrals_two_point_la_FCFLAGS = \
+ -I$(builddir)/../../module \
+ -I$(builddir)/../../kinematic \
+ -I$(builddir)/../../numerical \
+ -I$(builddir)/../one_point \
+ -I$(builddir)/../../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS = function_2p_m1m2.mod function_2p0m_1mi.mod \
+ generic_function_2p.mod
+
+CLEANFILES = *.mod
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/two_point/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/integrals/two_point/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+
+clean-noinstLTLIBRARIES:
+ -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+ @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem95_integrals_two_point.la: $(libgolem95_integrals_two_point_la_OBJECTS) $(libgolem95_integrals_two_point_la_DEPENDENCIES)
+ $(libgolem95_integrals_two_point_la_LINK) $(libgolem95_integrals_two_point_la_OBJECTS) $(libgolem95_integrals_two_point_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+libgolem95_integrals_two_point_la-function_2p0m_1mi.lo: function_2p0m_1mi.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_two_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_two_point_la-function_2p0m_1mi.lo $(FCFLAGS_f90) `test -f 'function_2p0m_1mi.f90' || echo '$(srcdir)/'`function_2p0m_1mi.f90
+
+libgolem95_integrals_two_point_la-function_2p_m1m2.lo: function_2p_m1m2.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_two_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_two_point_la-function_2p_m1m2.lo $(FCFLAGS_f90) `test -f 'function_2p_m1m2.f90' || echo '$(srcdir)/'`function_2p_m1m2.f90
+
+libgolem95_integrals_two_point_la-generic_function_2p.lo: generic_function_2p.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_integrals_two_point_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_integrals_two_point_la-generic_function_2p.lo $(FCFLAGS_f90) `test -f 'generic_function_2p.f90' || echo '$(srcdir)/'`generic_function_2p.f90
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libtool clean-noinstLTLIBRARIES ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+function_2p_m1m2.o: function_2p0m_1mi.o
+function_2p_m1m2.lo: function_2p0m_1mi.lo
+function_2p_m1m2.obj: function_2p0m_1mi.obj
+generic_function_2p.o: function_2p0m_1mi.o function_2p_m1m2.o
+generic_function_2p.lo: function_2p0m_1mi.lo function_2p_m1m2.lo
+generic_function_2p.obj: function_2p0m_1mi.obj function_2p_m1m2.obj
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/integrals/two_point/function_2p0m_1mi.f90 b/golem95c-1.2.1/integrals/two_point/function_2p0m_1mi.f90
new file mode 100644
index 0000000..9b4ce0f
--- /dev/null
+++ b/golem95c-1.2.1/integrals/two_point/function_2p0m_1mi.f90
@@ -0,0 +1,975 @@
+!~ changed 13.5.2010 to include scale (mu^2)^eps
+!~ the default scale is 1, defined in parametre.f90
+!****h* src/integral/two_point/function_2p0m
+! NAME
+!
+! Module function_2p0m
+!
+! USAGE
+!
+! use function_2p0m
+!
+! DESCRIPTION
+!
+! This module is used to compute the two-point function
+! with zero momentum and two equal masses: I_2(0,m^2,m^2)
+! and the two-point function
+! with zero momentum and two different masses: I_2(0,m1^2,m2^2)
+! with/without Feynman parameters in n dimensions
+!
+! OUTPUT
+!
+! This module exports the functions:
+! * f2p0m_1mi -- a function for the computation of the
+! two-point integrals
+! with zero momentum and two equal masses: I2({j})(0,m^2,m^2)
+! with/without Feynman parameters, in n dimensions
+!
+! * f2p0m_m1m2 -- a function for the computation of the
+! two-point integrals
+! with zero momentum and two different masses: I2({j})(0,m1^2,m2^2)
+! with/without Feynman parameters, in n dimensions
+!
+! scalar functions:
+!
+! i20m1: computes the scalar two point function
+! with zero momentum and one propagator having nonzero mass:
+! I_2^n(0,0,m^2)
+!
+! i20mm: computes the scalar two point function
+! with zero momentum and two massive propagators
+! with equal masses: I_2^n(0,m^2,m^2)
+!
+! i20m1m2: computes the scalar two point function
+! with zero momentum and two massive propagators
+! with different masses: I_2^n(0,m1^2,m2^2)
+!
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * logarithme (src/module/z_log.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+module function_2p0m_1mi
+ !
+ use precision_golem
+ use logarithme
+ use sortie_erreur
+ use equal
+ use parametre
+ use constante, only : zero, czero
+ !
+ implicit none
+ !
+ private
+ !
+ interface i20m1
+ !
+ module procedure i20m1_r, i20m1_c
+ !
+ end interface
+ !
+ interface i20mm
+ !
+ module procedure i20mm_r, i20mm_c
+ !
+ end interface
+ !
+ interface f2p0m_1mi
+ !
+ module procedure f2p0m_1mi_r, f2p0m_1mi_c
+ !
+ end interface
+ !
+ interface f2p0m_m1m2
+ !
+ module procedure f2p0m_m1m2_r, f2p0m_m1m2_c
+ !
+ end interface
+ !
+ interface i20m1m2
+ !
+ module procedure i20m1m2_r, i20m1m2_c
+ !
+ end interface
+ !
+ public :: f2p0m_1mi, f2p0m_m1m2, i20m1, i20mm,i20m1m2
+ !
+contains
+ !
+ !
+ !****f* src/integral/two_point/function_2p0m/f2p0m_1mi
+ ! NAME
+ !
+ ! Function f2p0m_1mi
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f2p0m_1mi(msq_r,par1,par2)
+ ! complex_dim2 = f2p0m_1mi(msq_c,par1,par2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the two point function in n dimensions
+ ! with zero momentum and two massive propagators with m1=m2
+ ! with up to two Feynman parameters in the numerator.
+ ! It retuns an array of (4 reals / 2 complex) corresponding to the
+ ! real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! corresponds to eqs.(A.9),(A.10) in hep-ph/0504267
+ ! note overall minus sign has to be corrected in first line of (A.10)
+ ! note also that for rank one A_j^{2,1}=MINUS I_2(j,...)
+ !
+ ! INPUTS
+ !
+ ! * m1_sq -- real/complex (type ki), the value of the mass
+ ! * par1 -- an integer, the label of one Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! Note that par1,par2 are ordered internally, i.e.
+ ! par1 <= par2, note also to use zero for par1, par2
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real/complex (type ki) array of rank 1 and shape 4/2 corresponding to
+ ! the real/imaginary part of the coefficient of the coefficient
+ ! of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ ! light-like-momentum two point function without Feynman parameters
+ ! f2p0m_1mi(msq,0,0)
+ ! with one Feynman parameter in the numerator z_1
+ ! f2p0m_1mi(msq,0,1)
+ ! with two Feynman parameters in the numerator z_2**2
+ ! f2p0m_1mi(msq,2,2)
+ ! with two Feynman parameters in the numerator z1*z_2
+ ! f2p0m_1mi(msq,1,2)
+ !
+ !*****
+ !
+ function f2p0m_1mi_r(m1_sq,par1,par2)
+ !
+ real(ki), intent (in) :: m1_sq
+ integer, intent (in) :: par1,par2
+ real(ki), dimension(4) :: f2p0m_1mi_r
+ !
+ f2p0m_1mi_r(:) = 0._ki
+ !
+ ! scalar case
+ if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f2p0m_1mi_r = i20mm(m1_sq)
+ !
+ ! rank one
+ else if ( (par1 == 0) .and. (par2 == 1) ) then
+ !
+ f2p0m_1mi_r = i20mm(m1_sq)/2._ki
+ !
+ else if ( (par1 == 0) .and. (par2 == 2) ) then
+ !
+ f2p0m_1mi_r = i20mm(m1_sq)/2._ki
+ !
+ ! rank two
+ else if ( (par1 == 1) .and. (par2 == 1) ) then
+ !
+ f2p0m_1mi_r = i20mm(m1_sq)/3._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) ) then
+ !
+ f2p0m_1mi_r = i20mm(m1_sq)/6._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) ) then
+ !
+ f2p0m_1mi_r = i20mm(m1_sq)/3._ki
+ !
+ end if
+ !
+ !
+ end function f2p0m_1mi_r
+ !
+ function f2p0m_1mi_c(m1_sq,par1,par2)
+ !
+ complex(ki), intent (in) :: m1_sq
+ integer, intent (in) :: par1,par2
+ complex(ki), dimension(2) :: f2p0m_1mi_c
+ !
+ f2p0m_1mi_c(:) = czero
+ !
+ ! scalar case
+ if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f2p0m_1mi_c = i20mm(m1_sq)
+ !
+ ! rank one
+ else if ( (par1 == 0) .and. (par2 == 1) ) then
+ !
+ f2p0m_1mi_c = i20mm(m1_sq)/2._ki
+ !
+ else if ( (par1 == 0) .and. (par2 == 2) ) then
+ !
+ f2p0m_1mi_c = i20mm(m1_sq)/2._ki
+ !
+ ! rank two
+ else if ( (par1 == 1) .and. (par2 == 1) ) then
+ !
+ f2p0m_1mi_c = i20mm(m1_sq)/3._ki
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) ) then
+ !
+ f2p0m_1mi_c = i20mm(m1_sq)/6._ki
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) ) then
+ !
+ f2p0m_1mi_c = i20mm(m1_sq)/3._ki
+ !
+ end if
+ !
+ !
+ end function f2p0m_1mi_c
+ !
+ !****f* src/integral/two_point/function_2p0m/f2p0m_m1m2
+ ! NAME
+ !
+ ! Function f2p0m_m1m2
+ !
+ ! USAGE
+ !
+ ! real_dim6 = f2p0m_m1m2(m1sq_r,m2sq_r,par1,par2)
+ ! complex_dim3 = f2p0m_m1m2(m1sq_c,m2sq_c,par1,par2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the two point function in n dimensions
+ ! with zero momentum and two massive propagators with m1 not= m2
+ ! with up to two Feynman parameters in the numerator.
+ ! It retuns an array of (6 reals / 3 complex) corresponding to the real/imaginary
+ ! part of the coefficient of the 1/epsilon**2 term, real/imaginary part of the
+ ! coefficient of the 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ ! corresponds to eqs.(A.8) in hep-ph/0504267
+ ! note that for rank one A_j^{2,1}=MINUS I_2(j,...)
+ !
+ ! INPUTS
+ !
+ ! * m1_sq,m2_sq -- real/complex (type ki), the values of the masses
+ ! * par1 -- an integer, the label of one Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! Note that par1,par2 are ordered internally, i.e.
+ ! par1 <= par2, note also to use zero for par1, par2
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real/complex (type ki) array of rank 1 and shape 6/3 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon**2 term,
+ ! real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ ! light-like-momentum two point function without Feynman parameters
+ ! f2p0m_m1m2(m1sq,m2sq,0,0)
+ ! with one Feynman parameter in the numerator z_1
+ ! f2p0m_m1m2(m1sq,m2sq,0,1)
+ ! with two Feynman parameters in the numerator z_2**2
+ ! f2p0m_m1m2(m1sq,m2sq,2,2)
+ ! with two Feynman parameters in the numerator z1*z_2
+ ! f2p0m_m1m2(m1sq,m2sq,1,2)
+ !
+ !*****
+ function f2p0m_m1m2_r(m1_sq,m2_sq,par1,par2)
+ !
+ real(ki), intent (in) :: m1_sq,m2_sq
+ integer, intent (in) :: par1,par2
+ real(ki), dimension(4) :: f2p0m_m1m2_r
+ real(ki) :: small,diffrm
+ !
+ f2p0m_m1m2_r(:) = 0._ki
+ diffrm=sqrt(m1_sq)-sqrt(m2_sq)
+ small=1.e-6_ki
+ !
+ ! scalar case
+ if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f2p0m_m1m2_r = i20m1m2(m1_sq,m2_sq)
+ !
+ ! rank one, z1
+ else if ( (par1 == 0) .and. (par2 == 1) ) then
+ !
+ f2p0m_m1m2_r(1) = 1._ki/2._ki
+ f2p0m_m1m2_r(2) = 0._ki
+ !
+ !
+ if (abs(diffrm) > small ) then
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_r(3) = -(-m1_sq**2 + 4._ki*m1_sq*m2_sq - 3._ki*m2_sq**2 + &
+ & 2._ki*m1_sq*(m1_sq - 2._ki*m2_sq)*real(z_log(m1_sq/mu2_scale_par,-1._ki)) + &
+ & 2._ki*m2_sq**2*real(z_log(m2_sq/mu2_scale_par,-1._ki)))/(4._ki*(m1_sq - m2_sq)**2)
+ f2p0m_m1m2_r(4) =-(2._ki*m1_sq*(m1_sq - 2._ki*m2_sq)*aimag(z_log(m1_sq/mu2_scale_par,-1._ki)) + &
+ & 2._ki*m2_sq**2*aimag(z_log(m2_sq/mu2_scale_par,-1._ki)))/(4._ki*(m1_sq - m2_sq)**2)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m1_sq - 3._ki*m2_sq)/(4._ki*(m1_sq - m2_sq))
+ f2p0m_m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq) * ( 27._ki*m1_sq**2 - 9._ki*m1_sq*m2_sq + 2._ki*m2_sq**2 )/(120._ki*m1_sq**3) - &
+ & real(z_log(m1_sq/mu2_scale_par,-1._ki))/2._ki
+ !
+ f2p0m_m1m2_r(4) = - aimag(z_log(m1_sq/mu2_scale_par,-1._ki))/2._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq) * ( 27._ki*m1_sq**2 - 9._ki*m1_sq*m2_sq + 2._ki*m2_sq**2 )/(120._ki*m1_sq**3)
+ f2p0m_m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ ! rank one, z2
+ else if ( (par1 == 0) .and. (par2 == 2) ) then
+ !
+ f2p0m_m1m2_r(1) = 1._ki/2._ki
+ f2p0m_m1m2_r(2) = 0._ki
+ !
+ if (abs(diffrm) > small ) then
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_r(3) = -(-m2_sq**2 + 4._ki*m2_sq*m1_sq - 3._ki*m1_sq**2 + &
+ & 2._ki*m2_sq*(m2_sq - 2._ki*m1_sq)*real(z_log(m2_sq/mu2_scale_par,-1._ki)) + &
+ & 2._ki*m1_sq**2*real(z_log(m1_sq/mu2_scale_par,-1._ki)))/(4._ki*(m2_sq - m1_sq)**2)
+ f2p0m_m1m2_r(4) =-(2._ki*m2_sq*(m2_sq - 2._ki*m1_sq)*aimag(z_log(m2_sq/mu2_scale_par,-1._ki)) + &
+ & 2._ki*m1_sq**2*aimag(z_log(m1_sq/mu2_scale_par,-1._ki)))/(4._ki*(m2_sq - m1_sq)**2)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m2_sq - 3._ki*m1_sq)/(4._ki*(m2_sq - m1_sq))
+ f2p0m_m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq)*(63._ki*m1_sq**2 - 31._ki*m1_sq*m2_sq + 8._ki*m2_sq**2 )/(120._ki*m1_sq**3) - &
+ & real(z_log(m1_sq/mu2_scale_par,-1._ki),ki)/2._ki
+ !
+ f2p0m_m1m2_r(4) = - aimag(z_log(m1_sq/mu2_scale_par,-1._ki))/2._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq)*(63._ki*m1_sq**2 - 31._ki*m1_sq*m2_sq + 8._ki*m2_sq**2 )/(120._ki*m1_sq**3)
+ f2p0m_m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ ! rank two
+ else if ( (par1 == 1) .and. (par2 == 1) ) then
+ !
+ f2p0m_m1m2_r(1) = 1._ki/3._ki
+ f2p0m_m1m2_r(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ if (abs(diffrm) > small ) then
+ ! write(6,*) 'using unexpanded expression, diffrm=',diffrm
+ f2p0m_m1m2_r(3) = 1._ki/9._ki-m2_sq/(m1_sq-m2_sq)/6._ki + &
+ & m2_sq**2/(m1_sq-m2_sq)**2/3._ki - &
+ & real(z_log(m1_sq/mu2_scale_par,-1._ki))/3._ki - &
+ & m2_sq**3*(real(z_log(m1_sq/mu2_scale_par,-1._ki))- &
+ & real(z_log(m2_sq/mu2_scale_par,-1._ki)))/(m1_sq-m2_sq)**3/3._ki
+ !
+ f2p0m_m1m2_r(4) = - aimag(z_log(m1_sq/mu2_scale_par,-1._ki))/3._ki - &
+ & m2_sq**3*(aimag(z_log(m1_sq/mu2_scale_par,-1._ki))- &
+ & aimag(z_log(m2_sq/mu2_scale_par,-1._ki)))/(m1_sq-m2_sq)**3/3._ki
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq)*( 19._ki*m1_sq**2 - 5._ki*m1_sq*m2_sq + m2_sq**2 )/(180._ki*m1_sq**3) -&
+ & real(z_log(m1_sq/mu2_scale_par,-1._ki))/3._ki
+ !
+ ! mu2 dependence corrected 18.7.2012 GH
+ f2p0m_m1m2_r(4) = - aimag(z_log(m1_sq/mu2_scale_par,-1._ki))/3._ki
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ if (abs(diffrm) > small ) then
+ f2p0m_m1m2_r(3) = 1._ki/9._ki-m2_sq/(m1_sq-m2_sq)/6._ki + &
+ & m2_sq**2/(m1_sq-m2_sq)**2/3._ki
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq)*( 19._ki*m1_sq**2 - 5._ki*m1_sq*m2_sq + m2_sq**2 )/(180._ki*m1_sq**3)
+ end if ! end if abs(diffrm) > small
+ f2p0m_m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) ) then
+ !
+ f2p0m_m1m2_r(1) = 1._ki/6._ki
+ f2p0m_m1m2_r(2) = 0._ki
+ !
+ if (abs(diffrm) > small ) then
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_r(3) = (5._ki*m1_sq**3 - 27._ki*m1_sq**2*m2_sq + 27._ki*m1_sq*m2_sq**2 - &
+ & 5._ki*m2_sq**3 - 6._ki*m1_sq**2*(m1_sq - 3._ki*m2_sq)*real(z_log(m1_sq/mu2_scale_par,-1._ki),ki) + &
+ & 6._ki*m2_sq**2*(-3._ki*m1_sq + m2_sq)*real(z_log(m2_sq/mu2_scale_par,-1._ki),ki))/ &
+ & (36._ki*(m1_sq - m2_sq)**3)
+ f2p0m_m1m2_r(4) =( - 6._ki*m1_sq**2*(m1_sq - 3._ki*m2_sq)*aimag(z_log(m1_sq/mu2_scale_par,-1._ki)) + &
+ & 6._ki*m2_sq**2*(-3._ki*m1_sq + m2_sq)*aimag(z_log(m2_sq/mu2_scale_par,-1._ki)))/ &
+ & (36._ki*(m1_sq - m2_sq)**3)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_r(3) = (5._ki*m1_sq**2 - 22._ki*m1_sq*m2_sq + 5._ki*m2_sq**2)/(36._ki*(m1_sq - m2_sq)**2)
+ f2p0m_m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq)*(43._ki*m1_sq**2 - 17._ki*m1_sq*m2_sq + 4._ki*m2_sq**2 )/(360._ki*m1_sq**3) - &
+ & real(z_log(m1_sq/mu2_scale_par,-1._ki))/6._ki
+ !
+ f2p0m_m1m2_r(4) = - aimag(z_log(m1_sq/mu2_scale_par,-1._ki))/6._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq)*(43._ki*m1_sq**2 - 17._ki*m1_sq*m2_sq + 4._ki*m2_sq**2 )/(360._ki*m1_sq**3)
+ f2p0m_m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) ) then
+ !
+ f2p0m_m1m2_r(1) = 1._ki/3._ki
+ f2p0m_m1m2_r(2) = 0._ki
+ !
+ if (abs(diffrm) > small ) then
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_r(3) = (11._ki*m1_sq**3 - 18._ki*m1_sq**2*m2_sq + &
+ & 9._ki*m1_sq*m2_sq**2 - 2._ki*m2_sq**3 - &
+ & 6._ki*m1_sq**3*real(z_log(m1_sq/mu2_scale_par,-1._ki)) + &
+ & 6._ki*m2_sq*(3._ki*m1_sq**2 - 3._ki*m1_sq*m2_sq + &
+ & m2_sq**2)*real(z_log(m2_sq/mu2_scale_par,-1._ki)))/ &
+ & (18._ki*(m1_sq - m2_sq)**3)
+ f2p0m_m1m2_r(4) =( -6._ki*m1_sq**3*aimag(z_log(m1_sq/mu2_scale_par,-1._ki)) + &
+ & 6._ki*m2_sq*(3._ki*m1_sq**2 - 3._ki*m1_sq*m2_sq + &
+ & m2_sq**2)*aimag(z_log(m2_sq/mu2_scale_par,-1._ki)))/ &
+ & (18._ki*(m1_sq - m2_sq)**3)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_r(3) = (11._ki*m1_sq**2 - 7._ki*m1_sq*m2_sq + 2._ki*m2_sq**2 )/(18._ki*(m1_sq - m2_sq)**2)
+ f2p0m_m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2_sq-m1sq) up to order 3
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq)*(73._ki*m1_sq**2 - 38._ki*m1_sq*m2_sq + 10._ki*m2_sq**2 )/(180._ki*m1_sq**3) - &
+ & real(z_log(m1_sq/mu2_scale_par,-1._ki))/3._ki
+ !
+ f2p0m_m1m2_r(4) = - aimag(z_log(m1_sq/mu2_scale_par,-1._ki))/3._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_r(3) = (m1_sq-m2_sq)*(73._ki*m1_sq**2 - 38._ki*m1_sq*m2_sq + 10._ki*m2_sq**2 )/(180._ki*m1_sq**3)
+ f2p0m_m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ end if ! end test values of par1,par2
+ !
+ !
+ end function f2p0m_m1m2_r
+ !
+ !
+ function f2p0m_m1m2_c(m1_sq,m2_sq,par1,par2)
+ !
+ complex(ki), intent (in) :: m1_sq,m2_sq
+ integer, intent (in) :: par1,par2
+ complex(ki), dimension(2) :: f2p0m_m1m2_c
+ complex(ki) :: ratpart
+ real(ki) :: small,diffrm
+ !
+ f2p0m_m1m2_c(:) = czero
+ diffrm = sqrt(abs(m1_sq-m2_sq))
+ small = 1.e-6_ki
+ !
+ ! scalar case
+ if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f2p0m_m1m2_c = i20m1m2(m1_sq,m2_sq)
+ !
+ ! rank one, z1
+ else if ( (par1 == 0) .and. (par2 == 1) ) then
+ !
+ f2p0m_m1m2_c(1) = 1._ki/2._ki
+ !
+ !
+ if (diffrm > small ) then
+ !
+ ratpart = (m1_sq - 3._ki*m2_sq)/((m1_sq - m2_sq)*4._ki)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - ( m1_sq*(m1_sq - 2._ki*m2_sq)*z_log(m1_sq/mu2_scale_par,-1._ki) + &
+ & m2_sq**2*z_log(m2_sq/mu2_scale_par,-1._ki) )/(2._ki*(m1_sq - m2_sq)**2)
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ ratpart = (m1_sq-m2_sq)*(27._ki*m1_sq**2 - 9._ki*m1_sq*m2_sq + 2._ki*m2_sq**2)/(120._ki*m1_sq**3)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - z_log(m1_sq/mu2_scale_par,-1._ki)/2._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ ! rank one, z2
+ else if ( (par1 == 0) .and. (par2 == 2) ) then
+ !
+ f2p0m_m1m2_c(1) = 1._ki/2._ki
+ !
+ if (diffrm > small ) then
+ !
+ ratpart = (3._ki*m1_sq - m2_sq)/(4._ki*(m1_sq-m2_sq))
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - ( m2_sq*(m2_sq - 2._ki*m1_sq)*z_log(m2_sq/mu2_scale_par,-1._ki) + &
+ & m1_sq**2*z_log(m1_sq/mu2_scale_par,-1._ki) )/(2._ki*(m2_sq - m1_sq)**2)
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ ratpart = (m1_sq - m2_sq)*(63._ki*m1_sq**2 - 31._ki*m1_sq*m2_sq + 8._ki*m2_sq**2)/(120._ki*m1_sq**3)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - z_log(m1_sq/mu2_scale_par,-1._ki)/2._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ ! rank two
+ else if ( (par1 == 1) .and. (par2 == 1) ) then
+ !
+ f2p0m_m1m2_c(1) = 1._ki/3._ki
+ !
+ if (diffrm > small ) then
+ !
+ ratpart = (2._ki*m1_sq**2 - 7._ki*m1_sq*m2_sq + 11._ki*m2_sq**2)/(18._ki*(m1_sq - m2_sq)**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - ( m1_sq*(m1_sq**2-3._ki*m1_sq*m2_sq+3._ki*m2_sq**2)*z_log(m1_sq/mu2_scale_par,-1._ki) - &
+ & m2_sq**3*z_log(m2_sq/mu2_scale_par,-1._ki) )/(3._ki*(m1_sq - m2_sq)**3)
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ write(6,*) 'using expansion in m1s-m2s, diffrm=',diffrm
+ !
+ ratpart = (m1_sq - m2_sq)*(19._ki*m1_sq**2 - 5._ki*m1_sq*m2_sq + m2_sq**2)/(180._ki*m1_sq**3)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - z_log(m1_sq/mu2_scale_par,-1._ki)/3._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) ) then
+ !
+ f2p0m_m1m2_c(1) = 1._ki/6._ki
+ !
+ if (diffrm > small ) then
+ !
+ ratpart = (5._ki*m1_sq**2 - 22._ki*m1_sq*m2_sq + 5._ki*m2_sq**2)/(36._ki*(m1_sq - m2_sq)**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - ( m1_sq**2*(m1_sq - 3._ki*m2_sq)*z_log(m1_sq/mu2_scale_par,-1._ki) - &
+ & m2_sq**2*(m2_sq - 3._ki*m1_sq)*z_log(m2_sq/mu2_scale_par,-1._ki) )/(6._ki*(m1_sq - m2_sq)**3)
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ ratpart = (m1_sq - m2_sq)*(43._ki*m1_sq**2 - 17._ki*m1_sq*m2_sq + 4._ki*m2_sq**2)/(360._ki*m1_sq**3)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - z_log(m1_sq/mu2_scale_par,-1._ki)/6._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) ) then
+ !
+ f2p0m_m1m2_c(1) = 1._ki/3._ki
+ !
+ if (diffrm > small ) then
+ !
+ ratpart = (11._ki*m1_sq**2 - 7._ki*m1_sq*m2_sq + 2._ki*m2_sq**2)/(18._ki*(m1_sq - m2_sq)**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - ( m1_sq**3*z_log(m1_sq/mu2_scale_par,-1._ki) - &
+ & m2_sq*(3._ki*m1_sq**2-3._ki*m1_sq*m2_sq+m2_sq**2)*z_log(m2_sq/mu2_scale_par,-1._ki) )/ &
+ & (3._ki*(m1_sq-m2_sq)**3)
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2_sq-m1sq) up to order 3
+ !
+ ratpart = (m1_sq - m2_sq)*(73._ki*m1_sq**2 - 38._ki*m1_sq*m2_sq + 10._ki*m2_sq**2)/(180._ki*m1_sq**3)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p0m_m1m2_c(2) = ratpart - z_log(m1_sq/mu2_scale_par,-1._ki)/3._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ end if ! end test values of par1,par2
+ !
+ !
+ end function f2p0m_m1m2_c
+ !
+ !
+ !
+ ! ************* scalar functions *****************
+ !
+ ! ****f* src/integral/two_point/i20m1
+ ! NAME
+ !
+ ! Function i20m1
+ !
+ ! USAGE
+ !
+ ! real_dim4 = i20m1(msq_r)
+ ! complex_dim2 = i20m1(msq_c)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the scalar two point function
+ ! with zero momentum and one nonzero mass: I_2(0,0,m**2)
+ ! in n dimensions
+ !
+ ! INPUTS
+ !
+ ! * msq -- a real/complex (type ki), the mass squared
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of rat_or_tot_par
+ ! (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real/complex (type ki) array of rank 1 and shape 4/2
+ !
+ !*****
+ function i20m1_r(msq)
+ !
+ real(ki), intent(in) :: msq
+ real(ki), dimension(4) :: i20m1_r
+ !
+ i20m1_r(1) = 1._ki
+ i20m1_r(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ i20m1_r(3) = 1._ki-real(z_log(msq/mu2_scale_par,-1._ki))
+ i20m1_r(4) = -aimag(z_log(msq/mu2_scale_par,-1._ki))
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ i20m1_r(3) = 1._ki
+ i20m1_r(4) = 0._ki
+ !
+ end if
+ !
+ end function i20m1_r
+ !
+ function i20m1_c(msq)
+ !
+ complex(ki), intent(in) :: msq
+ complex(ki), dimension(2) :: i20m1_c
+ !
+ i20m1_c(1) = cmplx(1._ki,0._ki,ki)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ i20m1_c(2) = cmplx(1._ki,0._ki,ki)
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ i20m1_c(2) = 1._ki - z_log(msq/mu2_scale_par,-1._ki)
+ !
+ end if
+ !
+ end function i20m1_c
+ !
+ ! ****f* src/integral/two_point/i20mm
+ ! NAME
+ !
+ ! Function i20mm
+ !
+ ! USAGE
+ !
+ ! real_dim4 = i20mm(msq_r)
+ ! complex_dim2 = i20mm(msq_c)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the scalar two point function
+ ! with zero momentum and two equal nonzero masses: I_2(0,m^2,m^2)
+ ! in n dimensions
+ !
+ ! INPUTS
+ !
+ ! * msq -- a real/complex (type ki), the mass squared
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of rat_or_tot_par
+ ! (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real/complex (type ki) array of rank 1 and shape 4/2
+ !
+ !*****
+ function i20mm_r(msq)
+ !
+ real(ki), intent(in) :: msq
+ real(ki), dimension(4) :: i20mm_r
+ !
+ i20mm_r(1) = 1._ki
+ i20mm_r(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ i20mm_r(3) = -real(z_log(msq/mu2_scale_par,-1._ki))
+ i20mm_r(4) = -aimag(z_log(msq/mu2_scale_par,-1._ki))
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ i20mm_r(3) = 0._ki
+ i20mm_r(4) = 0._ki
+ !
+ end if
+ !
+ end function i20mm_r
+ !
+ function i20mm_c(msq)
+ !
+ complex(ki), intent(in) :: msq
+ complex(ki), dimension(2) :: i20mm_c
+ !
+ i20mm_c(1) = cmplx(1._ki,0._ki,ki)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ i20mm_c(2) = czero
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ ! scale dependence corrected 18.7.2012 GH
+ !
+ i20mm_c(2) = -z_log(msq/mu2_scale_par,-1._ki)
+ !
+ end if
+ !
+ end function i20mm_c
+ !
+ ! ****f* src/integral/two_point/i20m1m2
+ ! NAME
+ !
+ ! Function i20m1m2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = i20m1m2(msq1_r,msq2_r)
+ ! complex_dim2 = i20m1m2(msq1_c,msq2_c)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the scalar two point function
+ ! with zero momentum and two equal nonzero masses: I_2(0,m1**2,m2**2)
+ ! in n dimensions
+ !
+ ! INPUTS
+ !
+ ! * m1sq,m2sq -- real/complex (type ki), the masses squared
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of rat_or_tot_par
+ ! (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real/complex (type ki) array of rank 1 and shape 4/2
+ !
+ !*****
+ function i20m1m2_r(m1sq,m2sq)
+ !
+ real(ki), intent(in) :: m1sq,m2sq
+ real(ki), dimension(4) :: i20m1m2_r
+ !
+ if (equal_real(m1sq,m2sq)) then
+ !
+ i20m1m2_r = i20mm(m1sq)
+ !
+ else
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ i20m1m2_r = (m2sq*i20m1(m2sq)-m1sq*i20m1(m1sq))/(m2sq-m1sq)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ i20m1m2_r(1) = 1._ki
+ i20m1m2_r(2) = 0._ki
+ i20m1m2_r(3) = 1._ki
+ i20m1m2_r(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test if m1=m2
+ !
+ end function i20m1m2_r
+ !
+ function i20m1m2_c(m1sq,m2sq)
+ !
+ complex(ki), intent(in) :: m1sq,m2sq
+ complex(ki), dimension(2) :: i20m1m2_c
+ real(ki) :: diffm
+ !
+ diffm = abs(m1sq-m2sq)
+ !
+ if (equal_real(diffm,zero)) then
+ !
+ i20m1m2_c = i20mm(m1sq)
+ !
+ else
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ i20m1m2_c(1) = cmplx(1._ki,0._ki,ki)
+ i20m1m2_c(2) = cmplx(1._ki,0._ki,ki)
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ i20m1m2_c = (m2sq*i20m1(m2sq)-m1sq*i20m1(m1sq))/(m2sq-m1sq)
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test if m1=m2
+ !
+ end function i20m1m2_c
+ !
+ !
+ !
+end module function_2p0m_1mi
diff --git a/golem95c-1.2.1/integrals/two_point/function_2p_m1m2.f90 b/golem95c-1.2.1/integrals/two_point/function_2p_m1m2.f90
new file mode 100644
index 0000000..9bec894
--- /dev/null
+++ b/golem95c-1.2.1/integrals/two_point/function_2p_m1m2.f90
@@ -0,0 +1,679 @@
+!~ changed 13.5.2010 to include scale (mu^2)^eps
+!~ the default scale is 1, defined in parametre.f90
+!****h* src/integral/two_point/function_2p_m1m2
+! NAME
+!
+! Module function_2p_m1m2
+!
+! USAGE
+!
+! use function_2p_m1m2
+!
+! DESCRIPTION
+!
+! This module is used to compute the two-point function
+! I_2(s,m1^2,m2^2)
+! with/without Feynman parameters in n dimensions
+!
+! OUTPUT
+!
+! This module exports the functions:
+! * f2p_m1m2 -- a function for the computation of
+! two-point integrals
+! with non-zero momentum and two masses: I2^n({zj})(s,m1^2,m2^2)
+! with/without Feynman parameters, in n dimensions
+! one of the masses can be zero
+! massless case is already contained in generic_function_2p
+!
+!
+! i2sm1m2: computes the scalar two point function
+! where both propagators have nonzero mass:
+! I_2^n(s,m1^2,m2^2)
+!
+! i2sm1: computes the scalar two point function
+! where only one propagator has nonzero mass:
+! I_2^n(s,m^2,0)
+!
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * logarithme (src/module/z_log.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * function_2p0m_1mi (src/integrals/two_point/function_2p0m_1mi.f90)
+!
+!*****
+!
+module function_2p_m1m2
+ !
+ use precision_golem
+ use logarithme
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use constante
+ use equal
+ use function_2p0m_1mi
+ use parametre, only : rat_or_tot_par,mu2_scale_par
+ !
+ implicit none
+ !
+ private
+ !
+ interface f2p_m1m2
+ !
+ module procedure f2p_m1m2_r, f2p_m1m2_c
+ !
+ end interface
+ !
+ interface i2sm1m2
+ !
+ module procedure i2sm1m2_r, i2sm1m2_c
+ !
+ end interface
+ !
+ interface i2sm1
+ !
+ module procedure i2sm1_r, i2sm1_c
+ !
+ end interface
+ !
+ public :: f2p_m1m2, i2sm1m2, i2sm1, i2sm1m2_old
+ !
+contains
+ !
+ !
+ !****f* src/integral/two_point/function_2p_m1m2/f2p_m1m2
+ ! NAME
+ !
+ ! Function f2p_m1m2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = f2p_m1m2(s,msq1_r,msq2_r,par1,par2)
+ ! complex_dim2 = f2p_m1m2(s,msq1_c,msq2_c,par1,par2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the
+ ! two point function in n dimensions
+ ! with non-zero momentum and two massive propagators
+ ! with up to two Feynman parameters in the numerator.
+ ! It retuns an array of 4 reals / 2 complex corresponding to the real/imaginary
+ ! part of the coefficient of the
+ ! 1/epsilon term and the real/imaginary part of the
+ ! constant term.
+ ! corresponds to eqs.(A.5),(A.7) in hep-ph/0504267
+ ! note that for rank one A_j^{2,1}=MINUS I_2(j,...)
+ !
+ ! INPUTS
+ !
+ ! * m1,m2 -- real/complex (type ki), the value of the masses
+ ! * par1 -- an integer, the label of one Feynman parameter
+ ! * par2 -- an integer, the label of the second Feynman parameter
+ ! Note that par1,par2 are ordered internally, i.e.
+ ! par1 <= par2, note also to use zero for par1, par2
+ ! if this Feynman parameter does not exist.
+ ! Use the routine tri_int(t_in,t_out) to order the labels in the module
+ ! tri_croissant (src/module/tri.f90)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! An real/complex (type ki) array of rank 1 and shape 4/2 corresponding to
+ ! the real/imaginary part of the coefficient of the 1/epsilon term
+ ! and the real/imaginary part of the constant term.
+ !
+ ! EXAMPLE
+ !
+ ! light-like-momentum two point function without Feynman parameters
+ ! f2p_m1m2(s,m1sq,m2sq,0,0)
+ ! with one Feynman parameter in the numerator z_1
+ ! f2p_m1m2(s,m1sq,m2sq,0,1)
+ ! with two Feynman parameters in the numerator z_2^2
+ ! f2p_m1m2(s,m1sq,m2sq,2,2)
+ ! with two Feynman parameters in the numerator z1*z_2
+ ! f2p_m1m2(s,m1sq,m2sq,1,2)
+ !
+ !*****
+ function f2p_m1m2_r(s,m1,m2,par1,par2)
+ ! m1 and m2 are the squared masses
+ ! should only be called if s, m1, m2 are nonzero
+ !
+ real(ki), intent (in) :: s,m1,m2
+ integer, intent (in) :: par1,par2
+ real(ki), dimension(4) :: f2p_m1m2_r, i2sca
+ !
+ f2p_m1m2_r(:) = 0._ki
+ i2sca = i2sm1m2(s,m1,m2)
+ !
+ ! scalar case
+ if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f2p_m1m2_r = i2sca
+ !
+ ! rank one: note that rat or tot is distinguished in i2sm1m2
+ else if ( (par1 == 0) .and. (par2 == 1) ) then
+ !
+ f2p_m1m2_r = i2sca/2._ki - &
+ & (m1-m2)/s/2._ki*( i2sca - i20m1m2(m1,m2) )
+ !
+ else if ( (par1 == 0) .and. (par2 == 2) ) then
+ !
+ f2p_m1m2_r = i2sca/2._ki + &
+ & (m1-m2)/s/2._ki*( i2sca - i20m1m2(m1,m2) )
+ !
+ ! rank two: rat singled out explicitly here
+ else if ( (par1 == 1) .and. (par2 == 1) ) then
+ !
+ f2p_m1m2_r(1) = 1._ki/3._ki
+ f2p_m1m2_r(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_m1m2_r(3) = (-6._ki*m1**2 + 12._ki*m1*m2 - 6._ki*m2**2 + 9._ki*m1*s - 9._ki*m2*s + s**2 + &
+ & 6._ki*(m1**2 + m2**2 + m2*s + s**2 - 2._ki*m1*(m2 + s))* &
+ & i2sca(3) + &
+ & 6._ki*m1*(m1 - m2 - 2._ki*s)*real(z_log(m1/mu2_scale_par,-1._ki)) - &
+ & 6._ki*m2*(m1 - m2 - s)*real(z_log(m2/mu2_scale_par,-1._ki)))/(18._ki*s**2)
+ !
+ f2p_m1m2_r(4) = ( 6._ki*(m1**2 + m2**2 + m2*s + s**2 - 2._ki*m1*(m2 + s))* &
+ & i2sca(4) + &
+ & 6._ki*m1*(m1 - m2 - 2*s)*aimag(z_log(m1/mu2_scale_par,-1._ki)) - &
+ & 6._ki*m2*(m1 - m2 - s)*aimag(z_log(m2/mu2_scale_par,-1._ki)))/(18._ki*s**2)
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_m1m2_r(3) = (-6._ki*m1**2 + 12._ki*m1*m2 - 6._ki*m2**2 + 9._ki*m1*s - 9._ki*m2*s + s**2 + &
+ & 6._ki*(m1**2 + m2**2 + m2*s + s**2 - 2._ki*m1*(m2 + s))* &
+ & i2sca(3) )/(18._ki*s**2)
+ !
+ f2p_m1m2_r(4) = ( 6._ki*(m1**2 + m2**2 + m2*s + s**2 - 2._ki*m1*(m2 + s))* &
+ & i2sca(4) )/(18._ki*s**2)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) ) then
+ !
+ f2p_m1m2_r(1) = 1._ki/6._ki
+ f2p_m1m2_r(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_m1m2_r(3) = (6._ki*m1**2 - 12._ki*m1*m2 + 6._ki*m2**2 - s**2 + &
+ & 3._ki*(-2._ki*m1**2 - 2._ki*m2**2 + m2*s + s**2 + m1*(4._ki*m2 + s))* &
+ & i2sca(3) + &
+ & 3._ki*m1*(-2._ki*m1 + 2._ki*m2 + s)*real(z_log(m1/mu2_scale_par,-1._ki)) + &
+ & 3._ki*m2*( 2._ki*m1 - 2._ki*m2 + s)*&
+ & real(z_log(m2/mu2_scale_par,-1._ki)))/(18._ki*s**2)
+ !
+ f2p_m1m2_r(4) = (3._ki*(-2._ki*m1**2 - 2._ki*m2**2 + m2*s + s**2 + m1*(4._ki*m2 + s))* &
+ & i2sca(4) + &
+ & 3._ki*m1*(-2._ki*m1 + 2._ki*m2 + s)*aimag(z_log(m1/mu2_scale_par,-1._ki)) + &
+ & 3._ki*m2*( 2._ki*m1 - 2._ki*m2 + s)*aimag(z_log(m2/mu2_scale_par,-1._ki)))/ &
+ & (18._ki*s**2)
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_m1m2_r(3) = (6._ki*m1**2 - 12._ki*m1*m2 + 6._ki*m2**2 - s**2 + &
+ & 3._ki*(-2._ki*m1**2 - 2._ki*m2**2 + m2*s + s**2 + m1*(4._ki*m2 + s))* &
+ & i2sca(3) )/(18._ki*s**2)
+ !
+ f2p_m1m2_r(4) = (3._ki*(-2._ki*m1**2 - 2._ki*m2**2 + m2*s + s**2 + m1*(4._ki*m2 + s))* &
+ & i2sca(4) )/(18._ki*s**2)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) ) then
+ !
+ f2p_m1m2_r(1) = 1._ki/3._ki
+ f2p_m1m2_r(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_m1m2_r(3) = (-6._ki*m1**2 + 12._ki*m1*m2 - 6._ki*m2**2 - 9._ki*m1*s + 9._ki*m2*s + s**2 + &
+ & 6._ki*(m1**2 + (m2 - s)**2 + m1*(-2._ki*m2 + s))*i2sca(3) + &
+ & 6._ki*m1*(m1 - m2 + s)*real(z_log(m1/mu2_scale_par,-1._ki)) - &
+ & 6._ki*m2*(m1 - m2 + 2._ki*s)*real(z_log(m2/mu2_scale_par,-1._ki)))/(18._ki*s**2)
+ !
+ f2p_m1m2_r(4) = ( 6._ki*(m1**2 + (m2 - s)**2 + m1*(-2._ki*m2 + s))*i2sca(4) + &
+ & 6._ki*m1*(m1 - m2 + s)*aimag(z_log(m1/mu2_scale_par,-1._ki)) - &
+ & 6._ki*m2*(m1 - m2 + 2._ki*s)*aimag(z_log(m2/mu2_scale_par,-1._ki)))/(18._ki*s**2)
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_m1m2_r(3) = ( -6._ki*m1**2 + 12._ki*m1*m2 - 6._ki*m2**2 - 9._ki*m1*s + 9._ki*m2*s + s**2 + &
+ & 6._ki*(m1**2 + (m2 - s)**2 + m1*(-2._ki*m2 + s))* &
+ & i2sca(3) )/(18._ki*s**2)
+ !
+ f2p_m1m2_r(4) = ( 6._ki*(m1**2 + (m2 - s)**2 + m1*(-2._ki*m2 + s))* &
+ & i2sca(4) )/(18._ki*s**2)
+ !
+ end if ! end if rat or tot
+ !
+ end if
+ !
+ !
+ end function f2p_m1m2_r
+ !
+ !
+ function f2p_m1m2_c(s,m1,m2,par1,par2)
+ ! m1 and m2 are the squared masses
+ ! should only be called if s, m1, m2 are nonzero
+ !
+ real(ki), intent (in) :: s
+ complex(ki), intent(in) :: m1,m2
+ integer, intent (in) :: par1,par2
+ complex(ki), dimension(2) :: f2p_m1m2_c, i2sca
+ complex(ki) :: ratpart
+ !
+ f2p_m1m2_c(:) = czero
+ i2sca=i2sm1m2(s,m1,m2)
+ !
+ ! scalar case
+ if ( (par1 == 0) .and. (par2 == 0) ) then
+ !
+ f2p_m1m2_c = i2sca
+ !
+ ! rank one: note that rat or tot is distinguished in i2sm1m2
+ else if ( (par1 == 0) .and. (par2 == 1) ) then
+ !
+ f2p_m1m2_c = i2sca/2._ki - &
+ & (m1-m2)/s/2._ki*( i2sca - i20m1m2(m1,m2) )
+ !
+ else if ( (par1 == 0) .and. (par2 == 2) ) then
+ !
+ f2p_m1m2_c = i2sca/2._ki + &
+ & (m1-m2)/s/2._ki*( i2sca - i20m1m2(m1,m2) )
+ !
+ ! rank two: rat singled out explicitly here
+ else if ( (par1 == 1) .and. (par2 == 1) ) then
+ !
+ f2p_m1m2_c(1) = 1._ki/3._ki
+ !
+ ratpart = (-6._ki*(m1-m2)**2 + 9._ki*s*(m1-m2) + s**2 + &
+ & 6._ki*(m1**2 + m2**2 + m2*s + s**2 - 2._ki*m1*(m2 + s) )*i2sca(2) )/(18._ki*s**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_m1m2_c(2) = ratpart
+ !
+ else !if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_m1m2_c(2) = ratpart + ( m1*(m1 - m2 - 2._ki*s)*z_log(m1/mu2_scale_par,-1._ki) + &
+ & m2*(m2 - m1 + s)*z_log(m2/mu2_scale_par,-1._ki) )/(3._ki*s**2)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (par1 == 1) .and. (par2 == 2) ) then
+ !
+ f2p_m1m2_c(1) = 1._ki/6._ki
+ !
+ ratpart = ( 6._ki*(m1-m2)**2 - s**2 + 3._ki*(-2._ki*(m1-m2)**2 + s*(m1+m2) +s**2)*i2sca(2) )/(18._ki*s**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_m1m2_c(2) = ratpart
+ !
+ else !if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_m1m2_c(2) = ratpart + (m1*(s - 2._ki*(m1-m2))*z_log(m1/mu2_scale_par,-1._ki) + &
+ & m2*(s + 2._ki*(m1-m2))*z_log(m2/mu2_scale_par,-1._ki))/(6._ki*s**2)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (par1 == 2) .and. (par2 == 2) ) then
+ !
+ f2p_m1m2_c(1) = 1._ki/3._ki
+ !
+ ratpart = (-6._ki*(m1-m2)**2-9._ki*(m1-m2)*s+s**2+6._ki*((m1-m2)**2 + s*(m1-2*m2) + &
+ & s**2)*i2sca(2))/(18._ki*s**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_m1m2_c(2) = ratpart
+ !
+ else !if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_m1m2_c(2) = ratpart + (m1*(m1 - m2 + s)*z_log(m1/mu2_scale_par,-1._ki) + &
+ & m2*(m2 - m1 -2._ki*s)*z_log(m2/mu2_scale_par,-1._ki))/(3._ki*s**2)
+ !
+ end if ! end if rat or tot
+ !
+ end if
+ !
+ !
+ end function f2p_m1m2_c
+ !
+ ! ****f* src/integral/two_point/i2sm1m2
+ ! NAME
+ !
+ ! Function i2sm1m2
+ !
+ ! USAGE
+ !
+ ! real_dim4 = i2sm1m2(s,m1sq_r,m2sq_r)
+ ! complex_dim2 = i2sm1m2(s,m1sq_r,m2sq_r)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the scalar two point function
+ ! with non-zero momentum and two nonzero masses: I_2(s,m1^2,m2^2)
+ ! in n dimensions
+ !
+ ! INPUTS
+ !
+ ! * msq1,m2sq -- real/complex (type ki), the masses squared
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of rat_or_tot_par
+ ! (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real/complex (type ki) array of rank 1 and shape 4/2
+ !
+ !*****
+ function i2sm1m2_old(s,m1,m2)
+ !
+ real(ki), intent(in) :: s,m1,m2
+ real(ki), dimension(4) :: i2sm1m2_old
+ real(ki) :: delta,sig
+ complex(ki) :: i2fin,tlog1,tlog2,x1,x2,t1,t2,r1,r2,rlog1,rlog2
+ !
+ delta = s**2+m2**2+m1**2-2._ki*s*m2-2._ki*s*m1-2._ki*m2*m1
+ sig = sign(1._ki,s)
+ !
+ if (delta >= 0._ki) then
+ !
+ x1 = (s+m1-m2+sqrt(delta))/(2._ki*s) ! Im x1 =sign(s)*i*eps
+ x2 = (s+m1-m2-sqrt(delta))/(2._ki*s) ! Im x2 =-sign(s)*i*eps
+ !
+ else !if (delta < 0._ki) then
+ !
+ x1 = (s+m1-m2+(-sig*i_)*sqrt(-delta))/(2._ki*s)
+ x2 = (s+m1-m2-(-sig*i_)*sqrt(-delta))/(2._ki*s)
+ !
+ end if
+ !
+ t1=(x1-1._ki)
+ t2=(x2-1._ki)
+ r1=(x1-1._ki)/x1
+ r2=(x2-1._ki)/x2
+ !
+ if ( .not.(equal_real(aimag(t1),zero))) then
+ tlog1= log(t1)
+ else
+ tlog1=z_log(real(t1),1._ki*sig)
+ endif
+ !
+ if ( .not.(equal_real(aimag(t2),zero))) then
+ tlog2= log(t2)
+ else
+ tlog2=z_log(real(t2),-1._ki*sig)
+ endif
+ !
+ if ( .not.(equal_real(aimag(x1),zero))) then
+ rlog1= log(x1)
+ else
+ rlog1=z_log(real(x1),1._ki*sig)
+ endif
+ !
+ if ( .not.(equal_real(aimag(x2),zero))) then
+ rlog2= log(x2)
+ else
+ rlog2=z_log(real(x2),-1._ki*sig)
+ endif
+ !
+ !
+ ! ***** to be checked ! **************************
+ !
+ i2fin = 2._ki-z_log(s/mu2_scale_par,1._ki) + t1*tlog1-x1*rlog1 + t2*tlog2-x2*rlog2
+ !
+ ! *************************************************
+ !
+ i2sm1m2_old(1) = 1._ki
+ i2sm1m2_old(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ i2sm1m2_old(3) = real(i2fin)
+ i2sm1m2_old(4) = aimag(i2fin)
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ i2sm1m2_old(3) = 2._ki
+ i2sm1m2_old(4) = 0._ki
+ !
+ end if
+ !
+ end function i2sm1m2_old
+ !
+ function i2sm1m2_r(s,m1,m2)
+ !
+ real(ki), intent(in) :: s,m1,m2
+ real(ki), dimension(4) :: i2sm1m2_r
+ real(ki) :: delta, smm
+ complex(ki) :: xlog1, xlog2, x1, x2, sqrtd, lm1, lm2
+ complex(ki) :: i2fin
+ !
+ delta = s**2+m2**2+m1**2-2._ki*s*m2-2._ki*s*m1-2._ki*m2*m1
+ !
+ smm = -s+m1+m2
+ lm1 = cmplx(log(m1/mu2_scale_par),0._ki,ki)
+ lm2 = cmplx(log(m2/mu2_scale_par),0._ki,ki)
+ !
+ if (equal_real(delta,zero) ) then
+ !
+ sqrtd = czero
+ xlog1 = czero !!! this is set to zero to allow a faster evaluation
+ xlog2 = czero
+ !
+ else if (delta .gt. 0._ki) then
+ !
+ sqrtd = cmplx(sqrt(delta),0._ki,ki)
+ x1 = cmplx(smm,0._ki,ki) + sqrtd ! Im r1 = +i*eps
+ x2 = cmplx(smm,0._ki,ki) - sqrtd ! Im r2 = -i*eps
+ xlog1 = z_log(x1,1._ki)
+ xlog2 = z_log(x2,-1._ki)
+ !
+ else !if (delta .lt. 0._ki) then
+ !
+ sqrtd = cmplx(0._ki,sqrt(-delta),ki)
+ x1 = cmplx(smm,0._ki,ki) + sqrtd
+ x2 = cmplx(smm,0._ki,ki) - sqrtd
+ xlog1 = z_log(x1,1._ki)
+ xlog2 = z_log(x2,-1._ki)
+ !
+ end if
+ !
+ ! ***** to be checked ! **************************
+ !
+ i2fin = 2._ki+( (smm - cmplx(2._ki*m1,0._ki,ki) )*lm1 + &
+ & (smm - cmplx(2._ki*m2,0._ki,ki) )*lm2 + &
+ & sqrtd*(xlog1-xlog2) )/2._ki/s
+ !
+ ! *************************************************
+ !
+ i2sm1m2_r(1) = 1._ki
+ i2sm1m2_r(2) = 0._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ i2sm1m2_r(3) = 2._ki
+ i2sm1m2_r(4) = 0._ki
+ !
+ else !if (rat_or_tot_par%tot_selected) then
+ !
+ i2sm1m2_r(3) = real(i2fin,ki)
+ i2sm1m2_r(4) = aimag(i2fin)
+ !
+ end if
+ !
+ end function i2sm1m2_r
+ !
+ function i2sm1m2_c(s,m1,m2)
+ !
+ real(ki), intent(in) :: s
+ complex(ki) , intent(in) :: m1, m2
+ complex(ki), dimension(2) :: i2sm1m2_c
+ real(ki) :: sig
+ complex(ki) :: delta, smm, sc
+ complex(ki) :: i2fin, xlog1, xlog2, x1, x2, sqrtd, lm1, lm2
+ !
+ sc = cmplx(s,zero,ki)
+ !
+ smm = -sc+m1+m2
+ ! delta = sc**2+m2**2+m1**2-2._ki*sc*m2-2._ki*sc*m1-2._ki*m2*m1
+ delta = smm*smm - 4._ki * m1*m2
+ !
+ lm1 = z_log(m1/mu2_scale_par,-1._ki)
+ lm2 = z_log(m2/mu2_scale_par,-1._ki)
+ !
+ if ( (equal_real(aimag(delta),zero) .and. (real(delta,ki) .lt. zero) ) ) then
+ !
+ sig = sign(un,s)
+ sqrtd = (sig*i_)*sqrt(-delta)
+ !
+ else
+ !
+ sqrtd = sqrt(delta)
+ !
+ end if
+ !
+ x1 = (smm + sqrtd)/m1
+ x2 = (smm - sqrtd)/m1
+ !
+ !
+ xlog1 = z_log(x1, 1._ki) !!! If im-part vanishes, the real part is always positive! (for real s).
+ xlog2 = z_log(x2,-1._ki) !!! eps-prescription checked for maximal complex s,
+ !!! (si=-(Sqrt[m1gam1]+Sqrt[m2gam2])^2!
+ ! !!! in case of real masses, the right branch is taken!!
+ !
+ ! *** This needs to be checked ***
+ !
+ i2fin = 2._ki + ( (smm-2._ki*m1)*lm1 + &
+ & (smm-2._ki*m2)*lm2 + sqrtd*(xlog1-xlog2) )/2._ki/sc
+ !
+ ! *************************************************
+ !
+ i2sm1m2_c(1) = 1._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ i2sm1m2_c(2) = 2._ki
+ !
+ else !if (rat_or_tot_par%tot_selected) then
+ !
+ i2sm1m2_c(2) = i2fin
+ !
+ end if
+ !
+ end function i2sm1m2_c
+ !
+ !
+ !
+ ! ****f* src/integral/two_point/i2sm1
+ ! NAME
+ !
+ ! Function i2sm1
+ !
+ ! USAGE
+ !
+ ! real_dim4 = i2sm1(s,msq_r)
+ ! complex_dim2 = i2sm1(s,msq)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the scalar two point function
+ ! with non-zero momentum and m2=0: I_2(s,m^2,0)
+ ! in n dimensions
+ !
+ ! INPUTS
+ !
+ ! * msq -- a real/complex (type ki), the mass squared
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect, it uses the value of rat_or_tot_par
+ ! (in src/module/parametre.f90)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real/complex (type ki) array of rank 1 and shape 4/2
+ !
+ !*****
+ function i2sm1_r(s1,m1s)
+ !
+ real(ki), intent(in) :: s1,m1s
+ real(ki), dimension(4) :: i2sm1_r
+ real(ki) :: delta
+ !
+ delta=1000*epsilon(1._ki)
+ !
+ i2sm1_r(1) = 1._ki
+ i2sm1_r(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ if ( abs(m1s-s1) > delta) then
+ !
+ i2sm1_r(3) = real( -z_log(m1s/mu2_scale_par,-1._ki)+2._ki+ &
+ & (m1s-s1)/s1*( z_log((m1s-s1)/mu2_scale_par,-1._ki) - &
+ & z_log(m1s/mu2_scale_par,-1._ki) ) )
+ i2sm1_r(4) = aimag( -z_log(m1s/mu2_scale_par,-1._ki)+2._ki+ &
+ & (m1s-s1)/s1*( z_log((m1s-s1)/mu2_scale_par,-1._ki) - &
+ & z_log(m1s/mu2_scale_par,-1._ki) ) )
+ !
+ else
+ !
+ i2sm1_r(3) = real( -z_log(m1s/mu2_scale_par,-1._ki)+2._ki )
+ i2sm1_r(4) = aimag( -z_log(m1s/mu2_scale_par,-1._ki)+2._ki )
+ !
+ end if
+ !
+ else !if (rat_or_tot_par%rat_selected) then
+ !
+ i2sm1_r(3) = 2._ki
+ i2sm1_r(4) = 0._ki
+ !
+ end if
+ !
+ end function i2sm1_r
+ !
+ function i2sm1_c(s1,m1s)
+ !
+ real(ki), intent(in) :: s1
+ complex(ki), intent(in) :: m1s
+ complex(ki), dimension(2) :: i2sm1_c
+ real(ki) :: delta
+ !
+ delta=1000*epsilon(1._ki)
+ !
+ i2sm1_c(1) = cmplx(1._ki,0._ki,ki)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ i2sm1_c(2) = cmplx(2._ki,0._ki,ki)
+ !
+ else !if (rat_or_tot_par%tot_selected) then
+ !
+ if ( abs( m1s - cmplx(s1,0._ki,ki) ) > delta) then
+ !
+ i2sm1_c(2) = 2._ki + ( (m1s-s1)*z_log((m1s-s1)/mu2_scale_par,-1._ki) - &
+ & m1s*z_log(m1s/mu2_scale_par,-1._ki) )/s1
+ !
+ else
+ !
+ i2sm1_c(2) = 2._ki - z_log(m1s/mu2_scale_par,-1._ki)
+ !
+ end if
+ !
+ end if
+ !
+ end function i2sm1_c
+ !
+ !
+end module function_2p_m1m2
diff --git a/golem95c-1.2.1/integrals/two_point/generic_function_2p.f90 b/golem95c-1.2.1/integrals/two_point/generic_function_2p.f90
new file mode 100644
index 0000000..807c037
--- /dev/null
+++ b/golem95c-1.2.1/integrals/two_point/generic_function_2p.f90
@@ -0,0 +1,1928 @@
+!****h* src/integrals/two_point/generic_function_2p
+!~ changed 13.5.2010 to include scale (mu^2)^eps
+!~ the default scale is 1, defined in parametre.f90
+! NAME
+!
+! Module generic_function_2p
+!
+! USAGE
+!
+! use generic_function_2p
+!
+! DESCRIPTION
+!
+! This module contains the generic routines to compute the
+! two point functions in n and n+2 dimensions
+!
+! OUTPUT
+!
+! It exports two public routine:
+! * f2p -- a function to compute the two point function in n dimensions
+! * f2p_np2 -- a function to compute the two point function in n+2 dimensions
+!
+! USES
+!
+! * precision (src/module/precision.f90)
+! * array (src/module/array.f90)
+! * logarithme (src/module/z_log.f90)
+! * tri_croissant (src/module/tri.f90)
+! * constante (src/module/constante.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * parametre (src/module/parametre.f90)
+! * function_2p0m_1mi (src/integrals/two_point/function_2p0m_1mi.f90)
+! * function_2p_m1m2 (src/integrals/two_point/function_2p_m1m2.f90)
+! * s_matrix_type (src/module/s_matrix_type.f90)
+!
+!*****
+module generic_function_2p
+ !
+ use precision_golem
+ use array
+ use logarithme
+ use tri_croissant
+ use constante
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre
+ use equal
+ use s_matrix_type
+ use function_2p0m_1mi
+ use function_2p_m1m2
+ !
+ implicit none
+ !
+ private
+ !
+ interface f2p
+ !
+ module procedure f2p_p
+ !
+ end interface
+ !
+ interface f2p_np2
+ !
+ module procedure f2p_np2_p
+ !
+ end interface
+ !
+ public :: f2p, f2p_np2
+ public :: f2p_ra, f2p_np2_ra
+ !
+contains
+ !
+ !****f* src/integrals/two_point/generic_function_2p/f2p
+ ! NAME
+ !
+ ! Function f2p
+ !
+ ! USAGE
+ !
+ ! cmplx_dim2 = f2p(s_mat_p,b_pro,parf1,parf2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic two point function in n dimensions,
+ ! with or without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat -- a derived type s_matrix_poly, the S matrix
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ ! * parf1 -- an integer (optional), the label of the one Feynman parameter
+ ! * parf2 -- an integer (optional), the label of the second Feynman parameter
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) array of rank 1 and shape 2
+ !
+ !
+ !*****
+ function f2p_ra(s_mat_p,b_pro,parf1,parf2)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent(in) :: b_pro
+ integer, intent(in), optional :: parf1, parf2
+ real(ki), dimension(4) :: f2p_ra
+ complex(ki), dimension(2) :: f2p_ca
+ !
+ f2p_ca = f2p_p(s_mat_p,b_pro,parf1=parf1,parf2=parf2)
+ !
+ f2p_ra(1) = real(f2p_ca(1),ki)
+ f2p_ra(2) = aimag(f2p_ca(1))
+ f2p_ra(3) = real(f2p_ca(2),ki)
+ f2p_ra(4) = aimag(f2p_ca(2))
+ !
+ end function f2p_ra
+ !
+ function f2p_p(s_mat_p,b_pro,parf1,parf2)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent(in) :: b_pro
+ integer, intent(in), optional :: parf1, parf2
+ complex(ki), dimension(2) :: f2p_p
+ !
+ if (iand(s_mat_p%b_cmplx, b_pro) .eq. 0 ) then
+ !
+ f2p_p = f2p_r(s_mat_p%pt_real, b_pro, parf1=parf1, parf2=parf2)
+ !
+ else
+ !
+ f2p_p = f2p_c(s_mat_p%pt_cmplx, b_pro, parf1=parf1, parf2=parf2)
+ !
+ end if
+ !
+ end function f2p_p
+ !
+ function f2p_r(s_mat_r,b_pro,parf1,parf2)
+ !
+ real(ki), intent (in), dimension(:,:) :: s_mat_r
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: parf1,parf2
+ complex(ki), dimension(2) :: f2p_r
+ !
+ real(ki), dimension(4) :: i2sonem,f2p_rr
+ integer :: par1,par2
+ integer, dimension(2) :: z_param_ini,z_param_out
+ real(ki) :: arg1, s12, mass1, mass2, diffm
+ integer :: m1,m2,dim_pro
+ integer, dimension(2) :: s
+ logical :: sz, mz1, mz2
+ !
+ par1 = 0
+ par2 = 0
+ !
+ if (present(parf1)) par1 = parf1
+ if (present(parf2)) par2 = parf2
+ !
+ z_param_ini = (/ par1,par2 /)
+ !
+ where (z_param_ini /= 0)
+ !
+ z_param_ini = locateb(z_param_ini,b_pro)
+ !
+ elsewhere
+ !
+ z_param_ini = 0
+ !
+ end where
+ !
+ if ( minval(z_param_ini) == -1 ) then
+ !
+ f2p_rr(:) = 0._ki
+ !
+ else
+ !
+ call tri_int2(z_param_ini,z_param_out)
+ !
+ if (b_pro<256) then
+ dim_pro = bit_count(b_pro)
+ s = bit_sets(8*b_pro:8*b_pro+dim_pro-1)
+ else
+ dim_pro = countb(b_pro)
+ s = unpackb(b_pro,dim_pro)
+ end if
+ !
+ m1 = s(1)
+ m2 = s(2)
+ !
+ arg1 = s_mat_r(m1,m2)
+ !
+ ! internal masses
+ mass1 = -s_mat_r(m1,m1)/2._ki
+ mass2 = -s_mat_r(m2,m2)/2._ki
+ s12 = arg1+mass1+mass2
+ !
+ call cut_s(s12,mass1,mass2)
+ !
+ mz1 = equal_real(mass1, zero)
+ mz2 = equal_real(mass2, zero)
+ sz = equal_real(s12,zero)
+ !
+ diffm=mass1-mass2
+ !
+ if ( (sz) .and. (mz1) .and. (mz2) ) then
+ !
+ f2p_rr(:) = 0._ki
+ ! (scaleless two-point function is zero)
+ !
+ else if ( .not.(sz) .and. (mz1) .and. (mz2) ) then
+ ! massless case
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_rr(1) = 1._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = 2._ki-real(z_log(-s12/mu2_scale_par,-1._ki))
+ f2p_rr(4) = -aimag(z_log(-s12/mu2_scale_par,-1._ki))
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 2._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) /= 0) ) then
+ !
+ f2p_rr(1) = 1._ki/2._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = 1._ki-real(z_log(-s12/mu2_scale_par,-1._ki))/2._ki
+ f2p_rr(4) = -aimag(z_log(-s12/mu2_scale_par,-1._ki))/2._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 1._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if
+ !
+ else if ( (z_param_out(1) /= 0) .and. (z_param_out(2) /= 0) ) then
+ !
+ if (z_param_out(1) == z_param_out(2)) then
+ !
+ f2p_rr(1) = 1._ki/3._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = 13._ki/18._ki-real(z_log(-s12/mu2_scale_par,-1._ki))/3._ki
+ f2p_rr(4) = -aimag(z_log(-s12/mu2_scale_par,-1._ki))/3._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 13._ki/18._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if
+ !
+ else
+ !
+ f2p_rr(1) = 1._ki/6._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = 5._ki/18._ki-real(z_log(-s12/mu2_scale_par,-1._ki),ki)/6._ki
+ f2p_rr(4) = -aimag(z_log(-s12/mu2_scale_par,-1._ki))/6._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 5._ki/18._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if z1==z2
+ !
+ end if ! end test value of z1,z2
+ !
+ !
+ !*************** massive cases *******************************
+ ! added 07.08.09
+ ! assumes real masses in numerator
+ ! ************************************************************
+ else if ( (sz) .and. (.not.(mz1)) .and. (mz2) ) then
+ ! case p^2=0, m1 nonzero, m2=0
+ ! write(6,*) 'case (2b): s12 =0, m2 =0, m1 nonzero'
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_rr = i20m1(mass1)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr(1) = 1._ki/2._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = -(-1._ki + 2._ki*real(z_log(mass1/mu2_scale_par,-1._ki)))/4._ki
+ f2p_rr(4) = -aimag(z_log(mass1/mu2_scale_par,-1._ki))/2._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 1._ki/4._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/2._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = -(-3._ki + 2._ki*real(z_log(mass1/mu2_scale_par,-1._ki)))/4._ki
+ f2p_rr(4) = -aimag(z_log(mass1/mu2_scale_par,-1._ki))/2._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 3._ki/4._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr(1) = 1._ki/3._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (1._ki - 3._ki*real(z_log(mass1/mu2_scale_par,-1._ki)))/9._ki
+ f2p_rr(4) = - aimag(z_log(mass1/mu2_scale_par,-1._ki))/3._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 1._ki/9._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/6._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (5._ki - 6._ki*real(z_log(mass1/mu2_scale_par,-1._ki)))/36._ki
+ f2p_rr(4) = - aimag(z_log(mass1/mu2_scale_par,-1._ki))/6._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 5._ki/36._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/3._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (11 - 6*real(z_log(mass1/mu2_scale_par,-1._ki)))/18._ki
+ f2p_rr(4) = - aimag(z_log(mass1/mu2_scale_par,-1._ki))/3._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 11._ki/18._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ******************
+ else if ( (sz) .and. (mz1) .and. (.not.(mz2)) ) then
+ ! case p^2=0, m2 nonzero, m1=0
+ ! write(6,*) 'case (2a) s12 =0, m1 =0, m2 nonzero'
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_rr = i20m1(mass2)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr(1) = 1._ki/2._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = -(-3._ki + 2._ki*real(z_log(mass2/mu2_scale_par,-1._ki)))/4._ki
+ f2p_rr(4) = -aimag(z_log(mass2/mu2_scale_par,-1._ki))/2._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 3._ki/4._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/2._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = -(-1._ki + 2._ki*real(z_log(mass2/mu2_scale_par,-1._ki)))/4._ki
+ f2p_rr(4) = -aimag(z_log(mass2/mu2_scale_par,-1._ki))/2._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 1._ki/4._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr(1) = 1._ki/3._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (11._ki - 6._ki*real(z_log(mass2/mu2_scale_par,-1._ki)))/18._ki
+ f2p_rr(4) = - aimag(z_log(mass2/mu2_scale_par,-1._ki))/3._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 11._ki/18._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/6._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (5._ki - 6._ki*real(z_log(mass2/mu2_scale_par,-1._ki)))/36._ki
+ f2p_rr(4) = - aimag(z_log(mass2/mu2_scale_par,-1._ki))/6._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 5._ki/36._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/3._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (1._ki - 3._ki*real(z_log(mass2/mu2_scale_par,-1._ki)))/9._ki
+ f2p_rr(4) = - aimag(z_log(mass2/mu2_scale_par,-1._ki))/3._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = 1._ki/9._ki
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ******************
+ ! ** eq. (A.10) ****
+ else if ( (sz) .and. (.not.(mz1)) .and. (equal_real(diffm,zero)) ) then
+ ! case p^2=0, m1 nonzero, m2=m1
+ ! write(6,*) 'case (2c): s12 =0, m1 nonzero, m2=m1'
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_rr = f2p0m_1mi(mass1,0,0)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr = f2p0m_1mi(mass1,0,1)
+ !
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr = f2p0m_1mi(mass1,0,2)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr = f2p0m_1mi(mass1,1,1)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr = f2p0m_1mi(mass1,1,2)
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr = f2p0m_1mi(mass1,2,2)
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ******************
+ ! ** eq. (A.8) ****
+ else if ( (sz) .and. (.not.(mz1)) .and. (.not.(mz2)) .and. .not.(equal_real(diffm,zero)) ) then
+ ! case p^2=0, m1 nonzero, m2 nonzero, m2 NOT=m1
+ ! write(6,*) 'case (2d): s12 =0, m1 and m2 nonzero, m2 not= m1 '
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_rr = f2p0m_m1m2(mass1,mass2,0,0)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr = f2p0m_m1m2(mass1,mass2,0,1)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr = f2p0m_m1m2(mass1,mass2,0,2)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr = f2p0m_m1m2(mass1,mass2,1,1)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr = f2p0m_m1m2(mass1,mass2,1,2)
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr = f2p0m_m1m2(mass1,mass2,2,2)
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ************ now case s12 nonzero **********************
+ else if ( (.not.(sz)) .and. (mz1) .and. (.not.(mz2)) ) then
+ ! case p^2 nonzero, m1=0, m2 nonzero
+ ! write(6,*) 'case (1a): s12 nonzero, m2 nonzero, m1 =0'
+ !
+ i2sonem=i2sm1(s12,mass2)
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_rr = i2sonem
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr(1) = 1._ki/2._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = -(mass2 - (mass2 + s12)*i2sonem(3) - &
+ & mass2*real(z_log(mass2/mu2_scale_par,-1._ki)))/(2._ki*s12)
+ f2p_rr(4) = -( - (mass2 + s12)*i2sonem(4) - &
+ & mass2*aimag(z_log(mass2/mu2_scale_par,-1._ki)))/(2._ki*s12)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = -( mass2 - (mass2 + s12)*i2sonem(3) )/(2._ki*s12)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/2._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = -( (mass2 - s12)*i2sonem(3) + mass2*(-1._ki + &
+ & real(z_log(mass2/mu2_scale_par,-1._ki))) )/(2._ki*s12)
+ f2p_rr(4) = -( (mass2 - s12)*i2sonem(4) + &
+ & mass2*aimag(z_log(mass2/mu2_scale_par,-1._ki)) )/(2._ki*s12)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = -((mass2 - s12)*i2sonem(3) - mass2)/(2._ki*s12)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr(1) = 1._ki/3._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (-6._ki*mass2**2 - 9._ki*mass2*s12 + s12**2 + &
+ & 6._ki*(mass2**2 + mass2*s12 + s12**2)*i2sonem(3) + &
+ & 6._ki*mass2*(mass2 + s12)* &
+ & real(z_log(mass2/mu2_scale_par,-1._ki)) )/(18._ki*s12**2)
+ f2p_rr(4) = ( 6._ki*(mass2**2 + mass2*s12 + s12**2)*i2sonem(4) + &
+ & 6._ki*mass2*(mass2 + s12)* &
+ & aimag(z_log(mass2/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = ( -6._ki*mass2**2 - 9._ki*mass2*s12 + s12**2 + &
+ & 6._ki*(mass2**2 + mass2*s12 + s12**2)*i2sonem(3) )/(18._ki*s12**2)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/6._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (6._ki*mass2**2 - s12**2 + &
+ & 3._ki*(-2._ki*mass2**2 + mass2*s12 + s12**2)*i2sonem(3) + &
+ & 3._ki*mass2*(-2._ki*mass2 + s12)* &
+ & real(z_log(mass2/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ !
+ f2p_rr(4) = ( 3._ki*(-2._ki*mass2**2 + mass2*s12 + s12**2)*i2sonem(4) + &
+ & 3._ki*mass2*(-2._ki*mass2 + s12)* &
+ & aimag(z_log(mass2/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = (6._ki*mass2**2 - s12**2 + &
+ & 3._ki*(-2*mass2**2 + mass2*s12 + s12**2)*i2sonem(3) )/(18._ki*s12**2)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/3._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (-6._ki*mass2**2 + 9._ki*mass2*s12 + s12**2 + &
+ & 6._ki*(mass2 - s12)**2*i2sonem(3) + &
+ & 6._ki*mass2*(mass2 - 2._ki*s12)* &
+ & real(z_log(mass2/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ f2p_rr(4) = ( 6._ki*(mass2 - s12)**2*i2sonem(4) + &
+ & 6._ki*mass2*(mass2 - 2._ki*s12)* &
+ & aimag(z_log(mass2/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = (-6._ki*mass2**2 + 9._ki*mass2*s12 + s12**2 + &
+ & 6._ki*(mass2 - s12)**2*i2sonem(3) )/(18._ki*s12**2)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test value of z1,z2
+ ! ******************
+ else if ( (.not.(sz)) .and. (.not.(mz1)) .and. (mz2) ) then
+ ! case p^2 nonzero, m1 nonzero, m2=0
+ ! write(6,*) 'case (1b): s12 nonzero, m1 nonzero, m2 =0'
+ !
+ i2sonem=i2sm1(s12,mass1)
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_rr = i2sonem
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr(1) = 1._ki/2._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = -( (mass1 - s12)*i2sonem(3) + &
+ & mass1*(-1._ki + real(z_log(mass1/mu2_scale_par,-1._ki))))/(2._ki*s12)
+ f2p_rr(4) = -( (mass1 - s12)*i2sonem(4) + &
+ & mass1*aimag(z_log(mass1/mu2_scale_par,-1._ki)))/(2._ki*s12)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = -((mass1 - s12)*i2sonem(3) - mass1)/(2._ki*s12)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/2._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = -(mass1 - (mass1 + s12)*i2sonem(3) - &
+ & mass1*real(z_log(mass1/mu2_scale_par,-1._ki)))/(2._ki*s12)
+ f2p_rr(4) = -( - (mass1 + s12)*i2sonem(4) - &
+ & mass1*aimag(z_log(mass1/mu2_scale_par,-1._ki)))/(2._ki*s12)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = -( mass1 - (mass1 + s12)*i2sonem(3) )/(2._ki*s12)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr(1) = 1._ki/3._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (-6._ki*mass1**2 + 9._ki*mass1*s12 + s12**2 + &
+ & 6._ki*(mass1 - s12)**2*i2sonem(3) + &
+ & 6._ki*mass1*(mass1 - 2*s12)* &
+ & real(z_log(mass1/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ f2p_rr(4) =( 6._ki*(mass1 - s12)**2*i2sonem(4) + &
+ & 6._ki*mass1*(mass1 - 2._ki*s12)* &
+ & aimag(z_log(mass1/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = (-6._ki*mass1**2 + 9._ki*mass1*s12 + s12**2 + &
+ & 6._ki*(mass1 - s12)**2*i2sonem(3) )/(18._ki*s12**2)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/6._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (6._ki*mass1**2 - s12**2 + &
+ & 3._ki*(-2._ki*mass1**2 + mass1*s12 + s12**2)*i2sonem(3) + &
+ & 3._ki*mass1*(-2._ki*mass1 + s12)* &
+ & real(z_log(mass1/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ f2p_rr(4) = ( 3._ki*(-2._ki*mass1**2 + mass1*s12 + s12**2)*i2sonem(4) + &
+ & 3._ki*mass1*(-2._ki*mass1 + s12)* &
+ & aimag(z_log(mass1/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = (6._ki*mass1**2 - s12**2 + &
+ & 3._ki*(-2._ki*mass1**2 + mass1*s12 + s12**2)*i2sonem(3) )/(18._ki*s12**2)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr(1) = 1._ki/3._ki
+ f2p_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_rr(3) = (-6._ki*mass1**2 - 9._ki*mass1*s12 + s12**2 + &
+ & 6._ki*(mass1**2 + mass1*s12 + s12**2)*i2sonem(3) + &
+ & 6._ki*mass1*(mass1 + s12)* &
+ & real(z_log(mass1/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ f2p_rr(4) = ( 6._ki*(mass1**2 + mass1*s12 + s12**2)*i2sonem(4) + &
+ & 6._ki*mass1*(mass1 + s12)* &
+ & aimag(z_log(mass1/mu2_scale_par,-1._ki)))/(18._ki*s12**2)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_rr(3) = (-6._ki*mass1**2 - 9._ki*mass1*s12 + s12**2 + &
+ & 6._ki*(mass1**2 + mass1*s12 + s12**2)*i2sonem(3))/(18._ki*s12**2)
+ f2p_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ******************
+ else if ( (.not.(sz)) .and. (.not.(mz1)) .and. (.not.(mz2)) ) then
+ ! case p^2 nonzero, m1 nonzero, m2 nonzero, eq.(A.5)
+ ! includes case m1=m2
+ ! write(6,*) 'cases (1c) and (1d): s12 nonzero, m1 and m2 nonzero'
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_rr = f2p_m1m2(s12,mass1,mass2,0,0)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr = f2p_m1m2(s12,mass1,mass2,0,1)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr = f2p_m1m2(s12,mass1,mass2,0,2)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_rr = f2p_m1m2(s12,mass1,mass2,1,1)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr = f2p_m1m2(s12,mass1,mass2,1,2)
+ !
+
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_rr = f2p_m1m2(s12,mass1,mass2,2,2)
+ !
+ end if ! end test value of z1,z2
+ ! ******************************************************************
+ !
+ else
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'something wrong with arguments of two-point function f2p'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 's12= %f0'
+ tab_erreur_par(2)%arg_real = s12
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'm1s= %f0'
+ tab_erreur_par(3)%arg_real = mass1
+ tab_erreur_par(4)%a_imprimer = .true.
+ tab_erreur_par(4)%chaine = 'm2s= %f0'
+ tab_erreur_par(4)%arg_real = mass2
+ !
+ call catch_exception(0)
+ end if ! end if s12,m1,m2 eq. zero
+ !
+ end if ! end if ( minval(z_param_ini) == -1 )
+ !
+ f2p_r(1) = f2p_rr(1) + i_ * f2p_rr(2)
+ f2p_r(2) = f2p_rr(3) + i_ * f2p_rr(4)
+ !
+ end function f2p_r
+ !
+ function f2p_c(s_mat_c,b_pro,parf1,parf2)
+ !
+ complex(ki), intent (in), dimension(:,:) :: s_mat_c
+ integer, intent (in) :: b_pro
+ integer, intent (in), optional :: parf1,parf2
+ complex(ki), dimension(2) :: f2p_c
+ !
+ complex(ki), dimension(2) :: i2sonem
+ integer :: par1, par2
+ integer, dimension(2) :: z_param_ini, z_param_out
+ complex(ki) :: mass1, mass2, ratpart, diffm
+ real(ki) :: s12
+ integer :: m1,m2,dim_pro
+ integer, dimension(2) :: s
+ logical :: sz, mz1, mz2, diffz
+ !
+ par1 = 0
+ par2 = 0
+ !
+ if (present(parf1)) par1 = parf1
+ if (present(parf2)) par2 = parf2
+ !
+ z_param_ini = (/ par1,par2 /)
+ !
+ where (z_param_ini /= 0)
+ !
+ z_param_ini = locateb(z_param_ini,b_pro)
+ !
+ elsewhere
+ !
+ z_param_ini = 0
+ !
+ end where
+ !
+ if ( minval(z_param_ini) == -1 ) then
+ !
+ f2p_c(:) = czero
+ !
+ else
+ !
+ call tri_int2(z_param_ini,z_param_out)
+ !
+ if (b_pro<256) then
+ dim_pro = bit_count(b_pro)
+ s = bit_sets(8*b_pro:8*b_pro+dim_pro-1)
+ else
+ dim_pro = countb(b_pro)
+ s = unpackb(b_pro,dim_pro)
+ end if
+ !
+ m1 = s(1)
+ m2 = s(2)
+ !
+ ! internal masses
+ mass1 = -s_mat_c(m1,m1)/2._ki
+ mass2 = -s_mat_c(m2,m2)/2._ki
+ s12 = real(s_mat_c(m1,m2)+mass1+mass2,ki)
+ !
+ call cut_s(s12,mass1,mass2)
+ !
+ diffm = mass1-mass2
+ !
+ mz1 = ( equal_real(real(mass1,ki), zero) .and. equal_real(aimag(mass1), zero) )
+ mz2 = ( equal_real(real(mass2,ki), zero) .and. equal_real(aimag(mass2), zero) )
+ sz = equal_real(s12,zero)
+ !
+ diffz = ( equal_real(real(diffm,ki), zero) .and. equal_real(aimag(diffm), zero) )
+ !
+ !
+ ! *************** massive cases, complex *******************************
+ ! ** (this function is only called with at least one non-zero mass) **
+ ! **********************************************************************
+ !
+ if ( sz .and. (.not. mz1) .and. mz2 ) then
+ ! case p^2=0, m1 nonzero, m2=0
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_c = i20m1(mass1)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c(1) = 1._ki/2._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 1._ki/4._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = -(-1._ki + 2._ki*z_log(mass1/mu2_scale_par,-1._ki))/4._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/2._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 3._ki/4._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = -(-3._ki + 2._ki*z_log(mass1/mu2_scale_par,-1._ki))/4._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c(1) = 1._ki/3._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 1._ki/9._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = (1._ki - 3._ki*z_log(mass1/mu2_scale_par,-1._ki))/9._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/6._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 5._ki/36._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = (5._ki - 6._ki*z_log(mass1/mu2_scale_par,-1._ki))/36._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/3._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 11._ki/18._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = (11._ki - 6._ki*z_log(mass1/mu2_scale_par,-1._ki))/18._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ******************
+ else if ( sz .and. mz1 .and. (.not. mz2) ) then
+ ! case p^2=0, m2 nonzero, m1=0
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_c = i20m1(mass2)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c(1) = 1._ki/2._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 3._ki/4._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = -(-3._ki + 2._ki*z_log(mass2/mu2_scale_par,-1._ki))/4._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/2._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 1._ki/4._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = -(-1._ki + 2._ki*z_log(mass2/mu2_scale_par,-1._ki))/4._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c(1) = 1._ki/3._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 11._ki/18._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = (11._ki - 6._ki*z_log(mass2/mu2_scale_par,-1._ki))/18._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/6._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 5._ki/36._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = (5._ki - 6._ki*z_log(mass2/mu2_scale_par,-1._ki))/36._ki
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/3._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = 1._ki/9._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = (1 - 3*z_log(mass2/mu2_scale_par,-1._ki))/9._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ******************
+ ! ** eq. (A.10) ****
+ !
+ else if ( sz .and. (.not. mz1) .and. diffz ) then
+ ! case p^2=0, m1 nonzero, m2=m1
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_c = f2p0m_1mi(mass1,0,0)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c = f2p0m_1mi(mass1,0,1)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c = f2p0m_1mi(mass1,0,2)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c = f2p0m_1mi(mass1,1,1)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c = f2p0m_1mi(mass1,1,2)
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c = f2p0m_1mi(mass1,2,2)
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ******************
+ ! ** eq. (A.8) ****
+ else if ( sz .and. (.not. mz1) .and. (.not. mz2) .and. (.not. diffz) ) then
+ ! case p^2=0, m1 nonzero, m2 nonzero, m2 NOT=m1
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_c = f2p0m_m1m2(mass1,mass2,0,0)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c = f2p0m_m1m2(mass1,mass2,0,1)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c = f2p0m_m1m2(mass1,mass2,0,2)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c = f2p0m_m1m2(mass1,mass2,1,1)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c = f2p0m_m1m2(mass1,mass2,1,2)
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c = f2p0m_m1m2(mass1,mass2,2,2)
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ************ now case s12 nonzero **********************
+ !
+ else if ( (.not. sz) .and. mz1 .and. (.not.mz2) ) then
+ ! case p^2 nonzero, m1=0, m2 nonzero
+ !
+ i2sonem=i2sm1(s12,mass2)
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_c = i2sonem
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c(1) = 1._ki/2._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = -( mass2 - (mass2 + s12)*i2sonem(2) )/(2._ki*s12)
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = -(mass2 - (mass2 + s12)*i2sonem(2) - &
+ & mass2*z_log(mass2/mu2_scale_par,-1._ki))/(2._ki*s12)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/2._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = -((mass2 - s12)*i2sonem(2) - mass2)/(2._ki*s12)
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = -((mass2 - s12)*i2sonem(2) + &
+ & mass2*(-1._ki + z_log(mass2/mu2_scale_par,-1._ki)))/(2._ki*s12)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c(1) = 1._ki/3._ki
+ !
+ ratpart = (-6._ki*mass2**2 - 9._ki*mass2*s12 + s12**2 + &
+ & 6._ki*(mass2**2 + mass2*s12 + s12**2)*i2sonem(2))/(18._ki*s12**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then !!!checked!!!
+ !
+ f2p_c(2) = ratpart + mass2*(mass2 + s12)* &
+ & z_log(mass2/mu2_scale_par,-1._ki)/(3._ki*s12**2)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/6._ki
+ !
+ ratpart = (6._ki*mass2**2 - s12**2 + &
+ & 3._ki*(-2._ki*mass2**2 + mass2*s12 + s12**2)*i2sonem(2) )/(18._ki*s12**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = ratpart + mass2*(-2._ki*mass2 + s12)* &
+ & z_log(mass2/mu2_scale_par,-1._ki)/(6._ki*s12**2)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/3._ki
+ !
+ ratpart = (-6._ki*mass2**2 + 9._ki*mass2*s12 + s12**2 + &
+ & 6._ki*(mass2 - s12)**2*i2sonem(2) )/(18._ki*s12**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = ratpart + mass2*(mass2 - 2._ki*s12)* &
+ & z_log(mass2/mu2_scale_par,-1._ki)/(3._ki*s12**2)
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ******************
+ !
+ else if ( (.not. sz) .and. (.not. mz1) .and. mz2 ) then
+ ! case p^2 nonzero, m1 nonzero, m2=0
+ !
+ i2sonem = i2sm1(s12,mass1)
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_c = i2sonem
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c(1) = 1._ki/2._ki
+ !
+ ratpart = -((mass1 - s12)*i2sonem(2) - mass1)/(2._ki*s12)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = ratpart - mass1*z_log(mass1/mu2_scale_par,-1._ki)/(2._ki*s12)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/2._ki
+ !
+ ratpart = -( mass1 - (mass1 + s12)*i2sonem(2) )/(2._ki*s12)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = ratpart + mass1*z_log(mass1/mu2_scale_par,-1._ki)/(2._ki*s12)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c(1) = 1._ki/3._ki
+ !
+ ratpart = (-6._ki*mass1**2 + 9._ki*mass1*s12 + s12**2 + &
+ & 6._ki*(mass1 - s12)**2*i2sonem(2) )/(18._ki*s12**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = ratpart + mass1*(mass1 - 2._ki*s12)* &
+ & z_log(mass1/mu2_scale_par,-1._ki)/(3._ki*s12**2)
+ !
+ end if ! end if rat or tot
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/6._ki
+ !
+ ratpart = (6._ki*mass1**2 - s12**2 + &
+ & 3._ki*(-2._ki*mass1**2 + mass1*s12 + s12**2)*i2sonem(2) )/(18._ki*s12**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = ratpart + mass1*(-2._ki*mass1 + s12)* &
+ & z_log(mass1/mu2_scale_par,-1._ki)/(6._ki*s12**2)
+ !
+ end if ! end if rat or tot
+ !
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c(1) = 1._ki/3._ki
+ !
+ ratpart = (-6._ki*mass1**2 - 9._ki*mass1*s12 + s12**2 + &
+ & 6._ki*(mass1**2 + mass1*s12 + s12**2)*i2sonem(2))/(18._ki*s12**2)
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_c(2) = ratpart
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_c(2) = ratpart + mass1*(mass1 + s12)* &
+ & z_log(mass1/mu2_scale_par,-1._ki)/(3._ki*s12**2)
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end test value of z1,z2
+ !
+ ! ******************
+ !
+ else if ( (.not. sz) .and. (.not. mz1) .and. (.not. mz2) ) then
+ ! case p^2 nonzero, m1 nonzero, m2 nonzero, eq.(A.5)
+ ! includes case m1=m2
+ !
+ if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 0) ) then
+ !
+ f2p_c = f2p_m1m2(s12,mass1,mass2,0,0)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c = f2p_m1m2(s12,mass1,mass2,0,1)
+ !
+ else if ( (z_param_out(1) == 0) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c = f2p_m1m2(s12,mass1,mass2,0,2)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 1) ) then
+ !
+ f2p_c = f2p_m1m2(s12,mass1,mass2,1,1)
+ !
+ else if ( (z_param_out(1) == 1) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c = f2p_m1m2(s12,mass1,mass2,1,2)
+ !
+ else if ( (z_param_out(1) == 2) .and. (z_param_out(2) == 2) ) then
+ !
+ f2p_c = f2p_m1m2(s12,mass1,mass2,2,2)
+ !
+ end if ! end test value of z1,z2
+ ! ******************************************************************
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'something wrong with arguments of two-point function f2p'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 's12= %f0'
+ tab_erreur_par(2)%arg_real = s12
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'm1s= %f0'
+ tab_erreur_par(3)%arg_real = mass1
+ tab_erreur_par(4)%a_imprimer = .true.
+ tab_erreur_par(4)%chaine = 'm2s= %f0'
+ tab_erreur_par(4)%arg_real = mass2
+ !
+ call catch_exception(0)
+ !
+ end if ! end if s12,m1,m2 eq. zero
+ !
+ end if ! end if ( minval(z_param_ini) == -1 )
+ !
+ end function f2p_c
+ !
+ !****f* src/integrals/two_point/generic_function_2p/f2p_np2
+ ! NAME
+ !
+ ! Function f2p_np2
+ !
+ ! USAGE
+ !
+ ! cmplx_dim2 = f2p_np2(s_mat_p,b_pro)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the generic two point function in n+2 dimensions,
+ ! without Feynman parameters in the numerator
+ !
+ ! INPUTS
+ !
+ ! * s_mat_p -- a s_matrix_poly type object
+ ! * b_pro -- an integer which represents the set of the four unpinched
+ ! propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki) array of rank 1 and shape 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ function f2p_np2_ra(s_mat_p,b_pro)
+ !
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent(in) :: b_pro
+ real(ki), dimension(4) :: f2p_np2_ra
+ complex(ki), dimension(2) :: f2p_np2_ca
+ !
+ f2p_np2_ca = f2p_np2_p(s_mat_p,b_pro)
+ !
+ f2p_np2_ra(1) = real(f2p_np2_ca(1),ki)
+ f2p_np2_ra(2) = aimag(f2p_np2_ca(1))
+ f2p_np2_ra(3) = real(f2p_np2_ca(2),ki)
+ f2p_np2_ra(4) = aimag(f2p_np2_ca(2))
+ !
+ end function f2p_np2_ra
+ !
+ function f2p_np2_p(s_mat_p,b_pro)
+ type(s_matrix_poly) :: s_mat_p
+ integer, intent(in) :: b_pro
+ complex(ki), dimension(2) :: f2p_np2_p
+ !
+ if (iand(s_mat_p%b_cmplx, b_pro) .eq. 0 ) then
+ !
+ f2p_np2_p = f2p_np2_r(s_mat_p%pt_real, b_pro)
+ !
+ else
+ !
+ f2p_np2_p = f2p_np2_c(s_mat_p%pt_cmplx, b_pro)
+ !
+ end if
+ !
+ end function f2p_np2_p
+ !
+ function f2p_np2_r(s_mat_r,b_pro)
+ !
+ real(ki), intent (in), dimension(:,:) :: s_mat_r
+ integer, intent (in) :: b_pro
+ complex(ki),dimension(2) :: f2p_np2_r
+ !
+ real(ki), dimension(4) :: f2p_np2_rr,i2sonem,i2sca
+ real(ki) :: arg1,s12,mass1,mass2,diffrm,small
+ real(ki) :: arg_log
+ integer :: m1,m2
+ integer, dimension(2) :: s
+ logical :: sz, mz1, mz2
+ !
+ small=1.e-6_ki
+ !
+ s = unpackb(b_pro,countb(b_pro))
+ !
+ m1 = s(1)
+ m2 = s(2)
+ !
+ arg1 = s_mat_r(m1,m2)
+ !
+ ! internal masses
+ mass1 = -s_mat_r(m1,m1)/2._ki
+ mass2 = -s_mat_r(m2,m2)/2._ki
+ diffrm = sqrt(mass1)-sqrt(mass2)
+ !
+ s12 = arg1+mass1+mass2
+ !
+ call cut_s(s12, mass1, mass2)
+ !
+ mz1 = equal_real(mass1, zero)
+ mz2 = equal_real(mass2, zero)
+ sz = equal_real(s12, zero)
+ !
+ !
+ if ( (sz) .and. (mz1) .and. (mz2) ) then
+ !
+ f2p_np2_rr(:) = 0._ki
+ ! (f2p_np2_rr with no scale is zero)
+ !
+ else if ( (.not.(sz)) .and. (mz1) .and. (mz2) ) then
+ ! massless case
+ !
+ arg_log = arg1/mu2_scale_par
+ !
+ f2p_np2_rr(1) = 1._ki/6._ki
+ f2p_np2_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_rr(3) = 4._ki/9._ki-real(z_log(-arg_log,-1._ki),ki)/6._ki
+ f2p_np2_rr(4) = -aimag(z_log(-arg_log,-1._ki))/6._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_rr(3) = 4._ki/9._ki
+ f2p_np2_rr(4) = 0._ki
+ !
+ end if
+ !
+ f2p_np2_rr = s12*f2p_np2_rr
+ !
+ !*************** massive cases *******************************
+ ! added 07.08.09
+ ! ************************************************************
+ else if ( (sz) .and. (.not.(mz1)) .and. (mz2) ) then
+ ! case p^2=0, m1 nonzero, m2=0
+ !
+ f2p_np2_rr(1) = -1._ki/2._ki
+ f2p_np2_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_rr(3) = -2._ki*(3._ki - 2*real(z_log(mass1/mu2_scale_par,-1._ki)))/8._ki
+ f2p_np2_rr(4) = aimag(z_log(mass1/mu2_scale_par,-1._ki))/2._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_rr(3) = -3._ki/4._ki
+ f2p_np2_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ f2p_np2_rr = mass1*f2p_np2_rr
+ !
+ ! ******************
+ else if ( (sz) .and. (mz1) .and. (.not.(mz2)) ) then
+ ! case p^2=0, m2 nonzero, m1=0
+ !
+ f2p_np2_rr(1) = -1._ki/2._ki
+ f2p_np2_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_rr(3) = - (3._ki - 2*real(z_log(mass2/mu2_scale_par,-1._ki)))/4._ki
+ f2p_np2_rr(4) = aimag(z_log(mass2/mu2_scale_par,-1._ki))/2._ki
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_rr(3) = -3._ki/4._ki
+ f2p_np2_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ f2p_np2_rr = mass2*f2p_np2_rr
+ !
+ ! ******************
+ ! ** eq. (A.10), uses f2p_np2_rr = -2*B22 ****
+ else if ( (sz).and.(.not.(mz1)).and. &
+ & (equal_real(diffrm,zero)) ) then
+ ! case p^2=0, m1 nonzero, m2=m1
+ !
+ f2p_np2_rr = -mass1*i20m1(mass1)
+ !
+ ! ******************
+ else if ( (sz) .and. (.not.(mz1)) .and. (.not.(mz2)) .and. .not.(equal_real(diffrm,zero)) ) then
+ ! case p^2=0, m1 nonzero, m2 nonzero, m1 not= m2
+ !
+ f2p_np2_rr(1) = -(mass1+mass2)/2._ki
+ f2p_np2_rr(2) = 0._ki
+ !
+ if (abs(diffrm) > small ) then
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_rr(3) = - (3._ki*mass1**2 - 3._ki*mass2**2 - &
+ & 2._ki*mass1**2*real(z_log(mass1/mu2_scale_par,-1._ki)) + &
+ & 2._ki*mass2**2*real(z_log(mass2/mu2_scale_par,-1._ki)))/ &
+ & (4._ki*(mass1 - mass2))
+ f2p_np2_rr(4) = - ( - 2*mass1**2*aimag(z_log(mass1/mu2_scale_par,-1._ki)) + &
+ & 2*mass2**2*aimag(z_log(mass2/mu2_scale_par,-1._ki)))/ &
+ & (4._ki*(mass1 - mass2))
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_rr(3) = - (3*mass1**2 - 3*mass2**2)/(4._ki*(mass1 - mass2))
+ f2p_np2_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ ! write(6,*) 'using expanded expression for B22, diffrm=',diffrm
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_rr(3) = (mass1 + mass2)*( -19._ki*mass1**2 + 8._ki*mass1*mass2 - mass2**2 + &
+ & 12._ki*mass1**2*real(z_log(mass1/mu2_scale_par,-1._ki)))/(24._ki*mass1**2)
+ f2p_np2_rr(4) = (mass1 + mass2)*( 12._ki*mass1**2* &
+ & aimag(z_log(mass1/mu2_scale_par,-1._ki)))/(24._ki*mass1**2)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_rr(3) = (mass1 + mass2)*( -19._ki*mass1**2 + &
+ & 8._ki*mass1*mass2 - mass2**2 )/(24._ki*mass1**2)
+ f2p_np2_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ !
+ ! ******************
+ ! s12 nonzero
+ !********************
+ else if ( (.not.(sz)) .and. (mz1) .and. (.not.(mz2)) ) then
+ ! case p^2 nonzero, m1=0, m2 nonzero
+ !
+ i2sonem=i2sm1(s12,mass2)
+ !
+ f2p_np2_rr(1) = -(3._ki*mass2 - s12)/6._ki
+ f2p_np2_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_rr(3) = - (3._ki*mass2**2 + 9._ki*mass2*s12 - 2._ki*s12**2 - &
+ & 3._ki*(mass2 - s12)**2*i2sonem(3) - 3._ki*mass2*(mass2 + s12)* &
+ & real(z_log(mass2/mu2_scale_par,-1._ki)))/(18._ki*s12)
+ !
+ f2p_np2_rr(4) = - ( - 3._ki*(mass2 - s12)**2*i2sonem(4) - 3._ki*mass2*(mass2 + s12)* &
+ & aimag(z_log(mass2/mu2_scale_par,-1._ki)))/(18._ki*s12)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_rr(3) = - (3._ki*mass2**2 + 9._ki*mass2*s12 - 2._ki*s12**2 - &
+ & 3._ki*(mass2 - s12)**2*i2sonem(3) )/(18._ki*s12)
+ !
+ f2p_np2_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ ! ******************
+ else if ( (.not.(sz)) .and. (.not.(mz1)) .and. (mz2) ) then
+ ! case p^2 nonzero, m1 nonzero, m2=0
+ !
+ i2sonem=i2sm1(s12,mass1)
+ !
+ f2p_np2_rr(1) = -(3._ki*mass1 - s12)/6._ki
+ f2p_np2_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_rr(3) = - (3._ki*mass1**2 + 9._ki*mass1*s12 - 2._ki*s12**2 - &
+ & 3._ki*(mass1 - s12)**2*i2sonem(3) - &
+ & 3._ki*mass1*(mass1 + s12)* &
+ & real(z_log(mass1/mu2_scale_par,-1._ki)))/(18._ki*s12)
+ !
+ f2p_np2_rr(4) = - ( - 3._ki*(mass1 - s12)**2*i2sonem(4) - &
+ & 3._ki*mass1*(mass1 + s12)* &
+ & aimag(z_log(mass1/mu2_scale_par,-1._ki)))/(18._ki*s12)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_rr(3) = - (3*mass1**2 + 9*mass1*s12 - 2*s12**2 - &
+ & 3*(mass1 - s12)**2*i2sonem(3) )/(18._ki*s12)
+ !
+ f2p_np2_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ ! ******************
+ else if ( (.not.(sz)) .and. (.not.(mz1)) .and. (.not.(mz2)) ) then
+ ! case p^2 nonzero, m1 nonzero, m2 nonzero, -2*B22 of eq.(A.5)
+ !
+ i2sca=i2sm1m2(s12,mass1,mass2)
+ !
+ f2p_np2_rr(1) = - (3._ki*mass1 + 3._ki*mass2 - s12)/6._ki
+ f2p_np2_rr(2) = 0._ki
+ !
+ if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_rr(3) = - (3._ki*mass1**2 - 6._ki*mass1*mass2 + 3._ki*mass2**2 + &
+ & 9._ki*mass1*s12 + 9._ki*mass2*s12 - 2._ki*s12**2 - &
+ & 3._ki*(mass1**2 + (mass2 - s12)**2 - &
+ & 2._ki*mass1*(mass2 + s12))*i2sca(3) - &
+ & 3._ki*mass1*(mass1 - mass2 + s12)* &
+ & real(z_log(mass1/mu2_scale_par,-1._ki)) + &
+ & 3._ki*mass2*(mass1 - mass2 - s12)* &
+ & real(z_log(mass2/mu2_scale_par,-1._ki)))/(18._ki*s12)
+ !
+ f2p_np2_rr(4) = - (-3._ki*( mass1**2 + (mass2 - s12)**2 - &
+ & 2._ki*mass1*(mass2 + s12) )*i2sca(4) - &
+ & 3._ki*mass1*(mass1 - mass2 + s12)* &
+ & aimag(z_log(mass1/mu2_scale_par,-1._ki)) + &
+ & 3._ki*mass2*(mass1 - mass2 - s12)* &
+ & aimag(z_log(mass2/mu2_scale_par,-1._ki)))/(18._ki*s12)
+ !
+ else if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_rr(3) = - (3._ki*mass1**2 - 6._ki*mass1*mass2 + 3._ki*mass2**2 + &
+ & 9._ki*mass1*s12 + 9._ki*mass2*s12 - 2._ki*s12**2 - &
+ & 3._ki*(mass1**2 + (mass2 - s12)**2 - &
+ & 2._ki*mass1*(mass2 + s12))*i2sca(3) )/(18._ki*s12)
+ !
+ f2p_np2_rr(4) = 0._ki
+ !
+ end if ! end if rat or tot
+ !
+ ! ******************************************************************
+ end if ! end test if s12,m1,m2 zero
+ !
+ f2p_np2_r(1) = f2p_np2_rr(1) + i_ * f2p_np2_rr(2)
+ f2p_np2_r(2) = f2p_np2_rr(3) + i_ * f2p_np2_rr(4)
+ !
+ end function f2p_np2_r
+ !
+ !
+ function f2p_np2_c(s_mat_c,b_pro)
+ !
+ complex(ki), intent (in), dimension(:,:) :: s_mat_c
+ integer, intent (in) :: b_pro
+ complex(ki),dimension(2) :: f2p_np2_c
+ !
+ complex(ki), dimension(2) :: i2sonem_c, i2sca_c
+ complex(ki) :: mass1, mass2, lambda
+ real(ki) :: s12, diffrm, small
+ integer :: m1,m2
+ integer, dimension(2) :: s
+ logical :: sz, m1z, m2z, diffz
+ !
+ small=1.e-6_ki
+ !
+ s = unpackb(b_pro,countb(b_pro))
+ !
+ m1 = s(1)
+ m2 = s(2)
+ !
+ ! internal masses
+ mass1 = -s_mat_c(m1,m1)/2._ki
+ mass2 = -s_mat_c(m2,m2)/2._ki
+ diffrm = sqrt(abs(mass1-mass2))
+ !
+ s12 = real(s_mat_c(m1,m2)+mass1+mass2,ki)
+ !
+ call cut_s(s12, mass1, mass2)
+ !
+ m1z = ( equal_real(real(mass1,ki), zero) .and. equal_real(aimag(mass1), zero) )
+ m2z = ( equal_real(real(mass2,ki), zero) .and. equal_real(aimag(mass2), zero) )
+ !
+ sz = equal_real(s12,zero)
+ !
+ diffz = equal_real(diffrm, zero)
+ !
+ ! *************** massive cases, complex ************************
+ ! ** (this function is called with at least one non-zero mass) **
+ ! ***************************************************************
+ !
+ if ( sz .and. (.not. m1z) .and. m2z ) then
+ ! case p^2=0, m1 nonzero, m2=0
+ !
+ f2p_np2_c(1) = -1._ki/2._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_c(2) = -3._ki/4._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_c(2) = - (3._ki - 2._ki*z_log(mass1/mu2_scale_par,-1._ki))/4._ki
+ !
+ end if ! end if rat or tot
+ !
+ f2p_np2_c = mass1*f2p_np2_c
+ !
+ ! ******************
+ else if ( sz .and. m1z .and. (.not. m2z) ) then
+ ! case p^2=0, m2 nonzero, m1=0
+ !
+ f2p_np2_c(1) = -1._ki/2._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_c(2) = -3._ki/4._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_c(2) = - (3._ki - 2._ki*z_log(mass2/mu2_scale_par,-1._ki))/4._ki
+ !
+ end if ! end if rat or tot
+ !
+ f2p_np2_c = mass2*f2p_np2_c
+ !
+ ! ******************
+ ! ** eq. (A.10), uses f2p_np2_c = -2*B22 ****
+ else if ( sz .and. (.not. m1z) .and. diffz ) then
+ ! case p^2=0, m1 nonzero, m2=m1
+ !
+ f2p_np2_c = -mass1*i20m1(mass1)
+ !
+ ! ******************
+ else if ( sz .and. (.not. m1z) .and. (.not. m2z) .and. (.not. diffz) ) then
+ ! case p^2=0, m1 nonzero, m2 nonzero, m1 not= m2
+ !
+ f2p_np2_c(1) = -(mass1+mass2)/2._ki
+ !
+ if (diffrm > small ) then
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_c(2) = -3._ki*(mass1 + mass2)/4._ki
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_c(2) = (-3*mass1 - 3*mass2 + &
+ & (2*mass1**2*z_log(mass1/mu2_scale_par,-1._ki) - &
+ & 2*mass2**2*z_log(mass2/mu2_scale_par,-1._ki) )/(mass1 - mass2) )/4._ki
+ !
+ end if ! end if rat or tot
+ !
+ else ! use expansion in (m2sq-m1sq) up to order 3
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_c(2) = (mass1 + mass2)*( &
+ & -19._ki*mass1**2 + 8._ki*mass1*mass2 - mass2**2 )/(24._ki*mass1**2)
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_c(2) = (mass1 + mass2)*( &
+ & -19._ki*mass1**2 + 8._ki*mass1*mass2 - mass2**2 + &
+ & 12._ki*mass1**2*z_log(mass1/mu2_scale_par,-1._ki) )/(24._ki*mass1**2)
+ !
+ end if ! end if rat or tot
+ !
+ end if ! end if abs(diffrm) > small
+ !
+ !
+ ! ******************
+ ! s12 nonzero
+ !********************
+ !
+ else if ( (.not. sz) .and. m1z .and. (.not. m2z) ) then
+ ! case p^2 nonzero, m1=0, m2 nonzero
+ !
+ i2sonem_c = i2sm1(s12,mass2)
+ !
+ f2p_np2_c(1) = (s12 - 3._ki*mass2)/6._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_c(2) = - (3._ki*mass2**2 + 9._ki*mass2*s12 - 2._ki*s12**2 - &
+ & 3._ki*(mass2 - s12)**2*i2sonem_c(2) )/(18._ki*s12)
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_c(2) = - (3._ki*mass2**2 + 9._ki*mass2*s12 - 2._ki*s12**2 - &
+ & 3._ki*(mass2 - s12)**2*i2sonem_c(2) - &
+ & 3._ki*mass2*(mass2 + s12)* &
+ & z_log(mass2/mu2_scale_par,-1._ki))/(18._ki*s12)
+ !
+ end if ! end if rat or tot
+ !
+ ! ******************
+ else if ( (.not. sz) .and. (.not. m1z) .and. m2z ) then
+ ! case p^2 nonzero, m1 nonzero, m2=0
+ !
+ i2sonem_c=i2sm1(s12,mass1)
+ !
+ f2p_np2_c(1) = (s12 - 3._ki*mass1)/6._ki
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_c(2) = - (3._ki*mass1**2 + 9._ki*mass1*s12 - 2._ki*s12**2 - &
+ & 3._ki*(mass1 - s12)**2*i2sonem_c(2) )/(18._ki*s12)
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_c(2) = - (3._ki*mass1**2 + 9._ki*mass1*s12 - 2._ki*s12**2 - &
+ & 3._ki*(mass1 - s12)**2*i2sonem_c(2) - &
+ & 3._ki*mass1*(mass1 + s12)* &
+ & z_log(mass1/mu2_scale_par,-1._ki))/(18._ki*s12)
+ !
+ end if ! end if rat or tot
+ !
+ ! ******************
+ else if ( (.not. sz) .and. (.not. m1z) .and. (.not.m2z) ) then
+ ! case p^2 nonzero, m1 nonzero, m2 nonzero, -2*B22 of eq.(A.5)
+ !
+ i2sca_c=i2sm1m2(s12,mass1,mass2)
+ !
+ f2p_np2_c(1) = (s12 - 3._ki*mass1 - 3._ki*mass2)/6._ki
+ !
+ lambda = s12**2 + mass1**2 + mass2**2 - 2._ki*s12*(mass1 + mass2) - 2._ki*mass1*mass2
+ !
+ if (rat_or_tot_par%rat_selected) then
+ !
+ f2p_np2_c(2) = - (3._ki*(mass1 - mass2)**2 + 9._ki*s12*(mass1 + mass2) - &
+ & 2._ki*s12**2 - 3._ki*lambda*i2sca_c(2) )/(18._ki*s12)
+ !
+ else if (rat_or_tot_par%tot_selected) then
+ !
+ f2p_np2_c(2) = - (3._ki*(mass1 - mass2)**2 + 9._ki*s12*(mass1 + mass2) - &
+ & 2._ki*s12**2 - 3._ki*lambda*i2sca_c(2) - &
+ & 3._ki*mass1*(mass1 - mass2 + s12)* &
+ & z_log(mass1/mu2_scale_par,-1._ki) + &
+ & 3._ki*mass2*(mass1 - mass2 - s12)* &
+ & z_log(mass2/mu2_scale_par,-1._ki) )/(18._ki*s12)
+ !
+ end if ! end if rat or tot
+ !
+ ! ******************************************************************
+ end if ! end test if s12,m1,m2 zero
+ !
+ end function f2p_np2_c
+ !
+end module generic_function_2p
diff --git a/golem95c-1.2.1/interface/Makefile.am b/golem95c-1.2.1/interface/Makefile.am
new file mode 100644
index 0000000..57ddc0f
--- /dev/null
+++ b/golem95c-1.2.1/interface/Makefile.am
@@ -0,0 +1,26 @@
+noinst_LTLIBRARIES=libgolem95_interface.la
+
+AM_FCFLAGS= \
+ -I$(builddir)/../module \
+ -I$(builddir)/../kinematic \
+ -I$(builddir)/../form_factor \
+ -I$(builddir)/../integrals/one_point \
+ -I$(builddir)/../integrals/two_point \
+ -I$(builddir)/../integrals/three_point \
+ -I$(builddir)/../integrals/four_point \
+ -I$(builddir)/../numerical
+
+libgolem95_interface_la_SOURCES= \
+ tool_lt_to_golem.f90 tensor_integrals.f90 \
+ gb0.f90 gc0.f90 gd0.f90 ge0.f90 gf0.f90
+
+libgolem95_interface_la_FCFLAGS=$(AM_FCFLAGS)
+nodist_pkginclude_HEADERS= tool_lt_to_golem.mod tensor_integrals.mod
+if COMPILE_TENSREC
+libgolem95_interface_la_SOURCES+=tens_rec.f90 tens_comb.f90
+nodist_pkginclude_HEADERS+=tens_rec.mod tens_comb.mod
+endif
+
+CLEANFILES=*.mod
+
+include Makefile.dep
diff --git a/golem95c-1.2.1/interface/Makefile.dep b/golem95c-1.2.1/interface/Makefile.dep
new file mode 100644
index 0000000..6a2f9fd
--- /dev/null
+++ b/golem95c-1.2.1/interface/Makefile.dep
@@ -0,0 +1,19 @@
+# Module dependencies
+gb0.o: tool_lt_to_golem.o
+gb0.lo: tool_lt_to_golem.lo
+gb0.obj: tool_lt_to_golem.obj
+gc0.o: tool_lt_to_golem.o
+gc0.lo: tool_lt_to_golem.lo
+gc0.obj: tool_lt_to_golem.obj
+gd0.o: tool_lt_to_golem.o
+gd0.lo: tool_lt_to_golem.lo
+gd0.obj: tool_lt_to_golem.obj
+ge0.o: tool_lt_to_golem.o
+ge0.lo: tool_lt_to_golem.lo
+ge0.obj: tool_lt_to_golem.obj
+gf0.o: tool_lt_to_golem.o
+gf0.lo: tool_lt_to_golem.lo
+gf0.obj: tool_lt_to_golem.obj
+tens_comb.o: tens_rec.o
+tens_comb.lo: tens_rec.lo
+tens_comb.obj: tens_rec.obj
diff --git a/golem95c-1.2.1/interface/Makefile.in b/golem95c-1.2.1/interface/Makefile.in
new file mode 100644
index 0000000..6bfd694
--- /dev/null
+++ b/golem95c-1.2.1/interface/Makefile.in
@@ -0,0 +1,617 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+@COMPILE_TENSREC_TRUE@am__append_1 = tens_rec.f90 tens_comb.f90
+@COMPILE_TENSREC_TRUE@am__append_2 = tens_rec.mod tens_comb.mod
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.dep \
+ $(srcdir)/Makefile.in
+subdir = golem95c-1.2.1/interface
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+LTLIBRARIES = $(noinst_LTLIBRARIES)
+libgolem95_interface_la_LIBADD =
+am__libgolem95_interface_la_SOURCES_DIST = tool_lt_to_golem.f90 \
+ tensor_integrals.f90 gb0.f90 gc0.f90 gd0.f90 ge0.f90 gf0.f90 \
+ tens_rec.f90 tens_comb.f90
+@COMPILE_TENSREC_TRUE@am__objects_1 = \
+@COMPILE_TENSREC_TRUE@ libgolem95_interface_la-tens_rec.lo \
+@COMPILE_TENSREC_TRUE@ libgolem95_interface_la-tens_comb.lo
+am_libgolem95_interface_la_OBJECTS = \
+ libgolem95_interface_la-tool_lt_to_golem.lo \
+ libgolem95_interface_la-tensor_integrals.lo \
+ libgolem95_interface_la-gb0.lo libgolem95_interface_la-gc0.lo \
+ libgolem95_interface_la-gd0.lo libgolem95_interface_la-ge0.lo \
+ libgolem95_interface_la-gf0.lo $(am__objects_1)
+libgolem95_interface_la_OBJECTS = \
+ $(am_libgolem95_interface_la_OBJECTS)
+libgolem95_interface_la_LINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=link $(FCLD) \
+ $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem95_interface_la_SOURCES)
+DIST_SOURCES = $(am__libgolem95_interface_la_SOURCES_DIST)
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgincludedir)"
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+noinst_LTLIBRARIES = libgolem95_interface.la
+AM_FCFLAGS = \
+ -I$(builddir)/../module \
+ -I$(builddir)/../kinematic \
+ -I$(builddir)/../form_factor \
+ -I$(builddir)/../integrals/one_point \
+ -I$(builddir)/../integrals/two_point \
+ -I$(builddir)/../integrals/three_point \
+ -I$(builddir)/../integrals/four_point \
+ -I$(builddir)/../numerical
+
+libgolem95_interface_la_SOURCES = tool_lt_to_golem.f90 \
+ tensor_integrals.f90 gb0.f90 gc0.f90 gd0.f90 ge0.f90 gf0.f90 \
+ $(am__append_1)
+libgolem95_interface_la_FCFLAGS = $(AM_FCFLAGS)
+nodist_pkginclude_HEADERS = tool_lt_to_golem.mod tensor_integrals.mod \
+ $(am__append_2)
+CLEANFILES = *.mod
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/interface/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/interface/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+
+clean-noinstLTLIBRARIES:
+ -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+ @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem95_interface.la: $(libgolem95_interface_la_OBJECTS) $(libgolem95_interface_la_DEPENDENCIES)
+ $(libgolem95_interface_la_LINK) $(libgolem95_interface_la_OBJECTS) $(libgolem95_interface_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+libgolem95_interface_la-tool_lt_to_golem.lo: tool_lt_to_golem.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_interface_la-tool_lt_to_golem.lo $(FCFLAGS_f90) `test -f 'tool_lt_to_golem.f90' || echo '$(srcdir)/'`tool_lt_to_golem.f90
+
+libgolem95_interface_la-tensor_integrals.lo: tensor_integrals.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_interface_la-tensor_integrals.lo $(FCFLAGS_f90) `test -f 'tensor_integrals.f90' || echo '$(srcdir)/'`tensor_integrals.f90
+
+libgolem95_interface_la-gb0.lo: gb0.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_interface_la-gb0.lo $(FCFLAGS_f90) `test -f 'gb0.f90' || echo '$(srcdir)/'`gb0.f90
+
+libgolem95_interface_la-gc0.lo: gc0.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_interface_la-gc0.lo $(FCFLAGS_f90) `test -f 'gc0.f90' || echo '$(srcdir)/'`gc0.f90
+
+libgolem95_interface_la-gd0.lo: gd0.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_interface_la-gd0.lo $(FCFLAGS_f90) `test -f 'gd0.f90' || echo '$(srcdir)/'`gd0.f90
+
+libgolem95_interface_la-ge0.lo: ge0.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_interface_la-ge0.lo $(FCFLAGS_f90) `test -f 'ge0.f90' || echo '$(srcdir)/'`ge0.f90
+
+libgolem95_interface_la-gf0.lo: gf0.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_interface_la-gf0.lo $(FCFLAGS_f90) `test -f 'gf0.f90' || echo '$(srcdir)/'`gf0.f90
+
+libgolem95_interface_la-tens_rec.lo: tens_rec.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_interface_la-tens_rec.lo $(FCFLAGS_f90) `test -f 'tens_rec.f90' || echo '$(srcdir)/'`tens_rec.f90
+
+libgolem95_interface_la-tens_comb.lo: tens_comb.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_interface_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_interface_la-tens_comb.lo $(FCFLAGS_f90) `test -f 'tens_comb.f90' || echo '$(srcdir)/'`tens_comb.f90
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libtool clean-noinstLTLIBRARIES ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+gb0.o: tool_lt_to_golem.o
+gb0.lo: tool_lt_to_golem.lo
+gb0.obj: tool_lt_to_golem.obj
+gc0.o: tool_lt_to_golem.o
+gc0.lo: tool_lt_to_golem.lo
+gc0.obj: tool_lt_to_golem.obj
+gd0.o: tool_lt_to_golem.o
+gd0.lo: tool_lt_to_golem.lo
+gd0.obj: tool_lt_to_golem.obj
+ge0.o: tool_lt_to_golem.o
+ge0.lo: tool_lt_to_golem.lo
+ge0.obj: tool_lt_to_golem.obj
+gf0.o: tool_lt_to_golem.o
+gf0.lo: tool_lt_to_golem.lo
+gf0.obj: tool_lt_to_golem.obj
+tens_comb.o: tens_rec.o
+tens_comb.lo: tens_rec.lo
+tens_comb.obj: tens_rec.obj
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/interface/gb0.f90 b/golem95c-1.2.1/interface/gb0.f90
new file mode 100644
index 0000000..9de1364
--- /dev/null
+++ b/golem95c-1.2.1/interface/gb0.f90
@@ -0,0 +1,457 @@
+!
+!****f* src/interface/gb0i
+! NAME
+!
+! Function gb0i
+!
+! USAGE
+!
+! complex = gb0i(idt,s1,m1,m2,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function corresponds to the LoopTools b0i function.
+! The first argument is a character of length <= 4
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * idt -- a character of length <= 4, the type of form factors
+! * s1 -- a real (type ki), p1^2
+! * m1 -- a real (type ki), mass of propagator 2
+! * m2 -- a real (type ki), mass of propagator 1
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_2p (src/form_factor/form_factor_2p.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * tool_lt_to_golem, only : extract (src/interface/tool_lt_to_golem.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function gb0i(idt,s1,m1,m2,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_2p
+ use constante
+ use tool_lt_to_golem, only : extract
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ character (len=*), intent (in) :: idt
+ real(ki), intent (in) :: s1,m1,m2,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gb0i
+ !
+ integer, dimension(4) :: tab
+ integer :: n1,n2
+ integer, dimension(2) :: temp
+ integer :: j1,j2
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ character (len=4) :: idt_temp
+ !
+ ! to avoid confusion if mu2_scale_par is not=1 in main program:
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(2)
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ idt_temp = idt ! on complete la chaine entrante par des blancs
+ call extract(idt_temp,tab)
+ n1= count(tab/=-1)
+ n2= count(tab/=-1 .and. tab/=0)
+ !
+ temp = -2
+ temp(1:n1) = pack(tab,tab/=-1)
+ !
+ select case(n1)
+ !
+ case(1)
+ !
+ j1 = temp(1)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = a20(b_null)
+ !
+ case(1)
+ !
+ ff = a21(j1,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gb0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = b22(b_null)
+ !
+ case(2)
+ !
+ ff = a22(j1,j2,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gb0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gb0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n1 is not correct %d0'
+ tab_erreur_par(2)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ !gb0i = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ ! mu2_scale_par scale contained already in basic function,
+ ! but local mu2 is used here
+ gb0i = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! gb0i = ff%b + lmu2*ff%a
+ gb0i = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gb0i = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gb0i (gb0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+end function gb0i
+!
+!****f* src/interface/gb0
+! NAME
+!
+! Function gb0
+!
+! USAGE
+!
+! complex = gb0(s1,m1,m2,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function corresponds to the scalar b0 function.
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * s1 -- a real (type ki), p1^2
+! * m1 -- a real (type ki), mass^2 of propagator 2
+! * m2 -- a real (type ki), mass^2 of propagator 1
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_2p (src/form_factor/form_factor_2p.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function gb0(s1,m1,m2,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_2p
+ use constante
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ real(ki), intent (in) :: s1,m1,m2,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gb0
+ !
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(2)
+ !
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ ff = a20(b_null)
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! gb0 = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ ! mu2_scale_par contained already in basic function
+ ! use local mu2 !
+ gb0 = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ !gb0 = ff%b + lmu2*ff%a
+ gb0 = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gb0 = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gb0 (gb0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+end function gb0
+!
+!****f* src/interface/gb0c
+! NAME
+!
+! Function gb0c
+!
+! USAGE
+!
+! complex = gb0c(s1,m1,m2,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function corresponds to the scalar b0 function.
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * s1 -- a complex (type ki), p1^2
+! * m1 -- a complex (type ki), mass^2 of propagator 2
+! * m2 -- a complex (type ki), mass^2 of propagator 1
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_2p (src/form_factor/form_factor_2p.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function gb0c(s1,m1,m2,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_2p
+ use constante
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ complex(ki), intent (in) :: s1,m1,m2
+ real(ki), intent(in) :: mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gb0c
+ !
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(2)
+ !
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ ff = a20(b_null)
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! gb0c = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ ! mu2_scale_par contained already in basic function
+ ! use local mu2 !
+ gb0c = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ !gb0c = ff%b + lmu2*ff%a
+ gb0c = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gb0c = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gb0c (gb0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+end function gb0c
diff --git a/golem95c-1.2.1/interface/gc0.f90 b/golem95c-1.2.1/interface/gc0.f90
new file mode 100644
index 0000000..5829cdc
--- /dev/null
+++ b/golem95c-1.2.1/interface/gc0.f90
@@ -0,0 +1,523 @@
+!
+!****f* src/interface/gc0i
+! NAME
+!
+! Function gc0i
+!
+! USAGE
+!
+! complex = gc0i(idt,s1,s2,s3,m1,m2,m3,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function corresponds to the LoopTools C0i function.
+! The first argument is a character of length <= 5
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * idt -- a character of length <= 5, the type of form factors
+! * s1 -- a real (type ki), p1^2
+! * s2 -- a real (type ki), p2^2
+! * s3 -- a real (type ki), p3^2
+! * m1 -- a real (type ki), mass of propagator 3
+! * m2 -- a real (type ki), mass of propagator 1
+! * m3 -- a real (type ki), mass of propagator 2
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_3p (src/form_factor/form_factor_3p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * tool_lt_to_golem, only : extract (src/interface/tool_lt_to_golem.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function gc0i(idt,s1,s2,s3,m1,m2,m3,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_3p
+ use cache, only: allocate_cache, clear_cache
+ use constante, only: b_null
+ use tool_lt_to_golem, only : extract
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use array, only: packb
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ character (len=*), intent (in) :: idt
+ real(ki), intent (in) :: s1,s2,s3,m1,m2,m3,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gc0i
+ !
+ integer, dimension(5) :: tab
+ integer :: n1,n2
+ integer, dimension(3) :: temp
+ integer :: j1,j2,j3
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ character (len=5) :: idt_temp
+ !
+ ! to avoid confusion if mu2_scale_par is not=1 in main program:
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(3)
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ idt_temp = idt ! on complete la chaine entrante par des blancs
+ call extract(idt_temp,tab)
+ n1= count(tab/=-1)
+ n2= count(tab/=-1 .and. tab/=0)
+ !
+ temp = -2
+ temp(1:n1) = pack(tab,tab/=-1)
+ !
+ select case(n1)
+ !
+ case(1)
+ !
+ j1 = temp(1)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = a30(b_null)
+ !
+ case(1)
+ !
+ ff = a31(j1,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gc0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = b32(b_null)
+ !
+ case(2)
+ !
+ ff = a32(j1,j2,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gc0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ !
+ select case(n2)
+ !
+ case(1)
+ !
+ ff = b33(j3,b_null)
+ !
+ case(3)
+ !
+ ff = a33(j1,j2,j3,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gc0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gc0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n1 is not correct %d0'
+ tab_erreur_par(2)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! mu2_scale_par already contained in basic triangle functions
+ ! note that local mu2 is used here
+ ! gc0i = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ gc0i = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! gc0i = ff%b + lmu2*ff%a
+ gc0i = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gc0i = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gc0i (gc0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+ end function gc0i
+!
+!****f* src/interface/gc0
+! NAME
+!
+! Function gc0
+!
+! USAGE
+!
+! complex = gc0(s1,s2,s3,m1,m2,m3,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function corresponds to the scalar C0 function.
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * s1 -- a real (type ki), p1^2
+! * s2 -- a real (type ki), p2^2
+! * s3 -- a real (type ki), p3^2
+! * m1 -- a real (type ki), mass^2 of propagator 3
+! * m2 -- a real (type ki), mass^2 of propagator 1
+! * m3 -- a real (type ki), mass^2 of propagator 2
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the pole coefficient
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_3p (src/form_factor/form_factor_3p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function gc0(s1,s2,s3,m1,m2,m3,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type
+ use form_factor_3p ! module containing the three-point form factors (export all)
+ use cache, only: allocate_cache, clear_cache
+ use constante
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use array, only: packb
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ real(ki), intent (in) :: s1,s2,s3,m1,m2,m3,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gc0
+ !
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(3)
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ ff = a30(s_null)
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ !gc0 = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ ! mu scale already contained in basic triangle functions
+ ! but here use local mu2
+ gc0 = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! gc0 = ff%b + lmu2*ff%a
+ gc0 = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gc0 = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gc0 (gc0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+ end function gc0
+!
+!****f* src/interface/gc0c
+! NAME
+!
+! Function gc0c
+!
+! USAGE
+!
+! complex = gc0c(s1,s2,s3,m1,m2,m3,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function corresponds to the scalar C0 function.
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * s1 -- a complex (type ki), p1^2
+! * s2 -- a complex (type ki), p2^2
+! * s3 -- a complex (type ki), p3^2
+! * m1 -- a complex (type ki), mass^2 of propagator 3
+! * m2 -- a complex (type ki), mass^2 of propagator 1
+! * m3 -- a complex (type ki), mass^2 of propagator 2
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the pole coefficient
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_3p (src/form_factor/form_factor_3p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function gc0c(s1,s2,s3,m1,m2,m3,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type
+ use form_factor_3p ! module containing the three-point form factors (export all)
+ use cache, only: allocate_cache, clear_cache
+ use constante
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use array, only: packb
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ complex(ki), intent (in) :: s1,s2,s3,m1,m2,m3
+ real(ki), intent (in) :: mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gc0c
+ !
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(3)
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ ff = a30(s_null)
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ !gc0c = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ ! mu scale already contained in basic triangle functions
+ ! but here use local mu2
+ gc0c = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! gc0c = ff%b + lmu2*ff%a
+ gc0c = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gc0c = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gc0c (gc0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+ end function gc0c
diff --git a/golem95c-1.2.1/interface/gd0.f90 b/golem95c-1.2.1/interface/gd0.f90
new file mode 100644
index 0000000..cb04a8a
--- /dev/null
+++ b/golem95c-1.2.1/interface/gd0.f90
@@ -0,0 +1,584 @@
+!
+!****f* src/interface/gd0i
+! NAME
+!
+! Function gd0i
+!
+! USAGE
+!
+! complex = gd0i(idt,s1,s2,s3,s4,s,t,m1,m2,m3,m4,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function is the LoopTools D0i function.
+! The first argument is a character of length <= 6
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * idt -- a character of length <= 6, the type of form factors
+! * s1 -- a real (type ki), p1^2
+! * s2 -- a real (type ki), p2^2
+! * s3 -- a real (type ki), p3^2
+! * s4 -- a real (type ki), p4^2
+! * s -- a real (type ki), (p1+p2)^2
+! * t -- a real (type ki), (p2+p3)^2
+! * m1 -- a real (type ki), mass^2 of propagator 4
+! * m2 -- a real (type ki), mass^2 of propagator 1
+! * m3 -- a real (type ki), mass^2 of propagator 2
+! * m4 -- a real (type ki), mass^2 of propagator 3
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_4p (src/form_factor/form_factor_4p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * tool_lt_to_golem, only : extract (src/interface/tool_lt_to_golem.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function gd0i(idt,s1,s2,s3,s4,s,t,m1,m2,m3,m4,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_4p ! module containing the four-point form factors (export all)
+ use cache, only: allocate_cache, clear_cache
+ use constante, only: b_null
+ use tool_lt_to_golem, only : extract
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ character (len=*), intent (in) :: idt
+ real(ki), intent (in) :: s1,s2,s3,s4,s,t,m1,m2,m3,m4,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gd0i
+ !
+ integer, dimension(6) :: tab
+ integer :: n1,n2
+ integer, dimension(4) :: temp
+ integer :: j1,j2,j3,j4
+ type(form_factor) :: ff
+ ! real(ki) :: lmu2
+ real(ki) :: mu2store
+ character (len=6) :: idt_temp
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(4)
+ !
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = t-m2-m4
+ s_mat(1,4) = s1-m2-m1
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m4
+ s_mat(2,4) = s-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m4
+ s_mat(3,4) = s4-m4-m1
+ !
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ idt_temp = idt ! on complete la chaine entrante par des blancs
+ call extract(idt_temp,tab)
+ n1= count(tab/=-1)
+ n2= count(tab/=-1 .and. tab/=0)
+ !
+ temp = -2
+ temp(1:n1) = pack(tab,tab/=-1)
+ !
+ select case(n1)
+ !
+ case(1)
+ !
+ j1 = temp(1)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = a40(b_null)
+ !
+ case(1)
+ !
+ ff = a41(j1,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gd0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = b42(b_null)
+ !
+ case(2)
+ !
+ ff = a42(j1,j2,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gd0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ !
+ select case(n2)
+ !
+ case(1)
+ !
+ ff = b43(j3,b_null)
+ !
+ case(3)
+ !
+ ff = a43(j1,j2,j3,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gd0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ j4 = temp(4)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = c44(b_null)
+ !
+ case(2)
+ !
+ ff = b44(j3,j4,b_null)
+ !
+ case(4)
+ !
+ ff = a44(j1,j2,j3,j4,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gd0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gd0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n1 is not correct %d0'
+ tab_erreur_par(2)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ ! lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! gd0i = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ gd0i = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! gd0i = ff%b + lmu2*ff%a
+ gd0i = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gd0i = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gd0i (gd0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+ end function gd0i
+!
+!
+!****f* src/interface/gd0
+! NAME
+!
+! Function gd0
+!
+! USAGE
+!
+! complex = gd0(s1,s2,s3,s4,s,t,m1,m2,m3,m4,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function is the scalar LoopTools D0 function.
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * s1 -- a real (type ki), p1^2
+! * s2 -- a real (type ki), p2^2
+! * s3 -- a real (type ki), p3^2
+! * s4 -- a real (type ki), p4^2
+! * s -- a real (type ki), (p1+p2)^2
+! * t -- a real (type ki), (p2+p3)^2
+! * m1 -- a real (type ki), mass^2 of propagator 4
+! * m2 -- a real (type ki), mass^2 of propagator 1
+! * m3 -- a real (type ki), mass^2 of propagator 2
+! * m4 -- a real (type ki), mass^2 of propagator 3
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_4p (src/form_factor/form_factor_4p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+!*****
+function gd0(s1,s2,s3,s4,s,t,m1,m2,m3,m4,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_4p ! module containing the four-point form factors (export all)
+ use cache, only: allocate_cache, clear_cache
+ use constante, only: b_null
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s,t,m1,m2,m3,m4,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gd0
+ !
+ type(form_factor) :: ff
+ ! real(ki) :: lmu2
+ real(ki) :: mu2store
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(4)
+ !
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = t-m2-m4
+ s_mat(1,4) = s1-m2-m1
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m4
+ s_mat(2,4) = s-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m4
+ s_mat(3,4) = s4-m4-m1
+ !
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ ff = a40(b_null)
+ !
+ ! lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! gd0 = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ gd0 = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! gd0 = ff%b + lmu2*ff%a
+ gd0 = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gd0 = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gd0 (gd0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+end function gd0
+!
+!****f* src/interface/gd0c
+! NAME
+!
+! Function gd0c
+!
+! USAGE
+!
+! complex = gd0c(s1,s2,s3,s4,s,t,m1,m2,m3,m4,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function is the scalar LoopTools D0 function.
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * s1 -- a complex (type ki), p1^2
+! * s2 -- a complex (type ki), p2^2
+! * s3 -- a complex (type ki), p3^2
+! * s4 -- a complex (type ki), p4^2
+! * s -- a complex (type ki), (p1+p2)^2
+! * t -- a complex (type ki), (p2+p3)^2
+! * m1 -- a complex (type ki), mass^2 of propagator 4
+! * m2 -- a complex (type ki), mass^2 of propagator 1
+! * m3 -- a complex (type ki), mass^2 of propagator 2
+! * m4 -- a complex (type ki), mass^2 of propagator 3
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_4p (src/form_factor/form_factor_4p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+!*****
+function gd0c(s1,s2,s3,s4,s,t,m1,m2,m3,m4,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_4p ! module containing the four-point form factors (export all)
+ use cache, only: allocate_cache, clear_cache
+ use constante, only: b_null
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ complex(ki), intent (in) :: s1,s2,s3,s4,s,t,m1,m2,m3,m4
+ real(ki), intent (in) :: mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gd0c
+ !
+ type(form_factor) :: ff
+ ! real(ki) :: lmu2
+ real(ki) :: mu2store
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(4)
+ !
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = t-m2-m4
+ s_mat(1,4) = s1-m2-m1
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m4
+ s_mat(2,4) = s-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m4
+ s_mat(3,4) = s4-m4-m1
+ !
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ ff = a40(b_null)
+ !
+ ! lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! gd0c = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ gd0c = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! gd0c = ff%b + lmu2*ff%a
+ gd0c = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gd0c = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gd0c (gd0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+end function gd0c
diff --git a/golem95c-1.2.1/interface/ge0.f90 b/golem95c-1.2.1/interface/ge0.f90
new file mode 100644
index 0000000..f6c639e
--- /dev/null
+++ b/golem95c-1.2.1/interface/ge0.f90
@@ -0,0 +1,516 @@
+!
+!****f* src/interface/ge0i
+! NAME
+!
+! Function ge0i
+!
+! USAGE
+!
+! complex = ge0i(idt,s1,s2,s3,s4,s5,s12,s23,s34,s45,s51,m1,m2,m3,m4,m5,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function is the LoopTools E0i function.
+! The first argument is a character of length <= 7
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * idt -- a character of length <= 7, the type of form factors
+! * s1 -- a real (type ki), p1^2
+! * s2 -- a real (type ki), p2^2
+! * s3 -- a real (type ki), p3^2
+! * s4 -- a real (type ki), p4^2
+! * s5 -- a real (type ki), p5^2
+! * s12 -- a real (type ki), (p1+p2)^2
+! * s23 -- a real (type ki), (p2+p3)^2
+! * s34 -- a real (type ki), (p3+p4)^2
+! * s45 -- a real (type ki), (p4+p5)^2
+! * s51 -- a real (type ki), (p5+p1)^2
+! * m1 -- a real (type ki), mass^2 of propagator 5
+! * m2 -- a real (type ki), mass^2 of propagator 1
+! * m3 -- a real (type ki), mass^2 of propagator 2
+! * m4 -- a real (type ki), mass^2 of propagator 3
+! * m5 -- a real (type ki), mass^2 of propagator 4
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_5p (src/form_factor/form_factor_5p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * tool_lt_to_golem, only : extract (src/interface/tool_lt_to_golem.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function ge0i(idt,s1,s2,s3,s4,s5,s12,s23,s34,s45,s51,m1,m2,m3,m4,m5,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_5p ! module containing the four-point form factors (export all)
+ use cache, only: allocate_cache, clear_cache
+ use constante, only: b_null
+ use tool_lt_to_golem, only : extract
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ character (len=*), intent (in) :: idt
+ real(ki), intent (in) :: s1,s2,s3,s4,s5,s12,s23,s34,s45,s51,m1,m2,m3,m4,m5,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: ge0i
+ !
+ integer, dimension(7) :: tab
+ integer :: n1,n2
+ integer, dimension(5) :: temp
+ integer :: j1,j2,j3,j4,j5
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ character (len=7) :: idt_temp
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(5)
+ !
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = s23-m2-m4
+ s_mat(1,4) = s51-m2-m5
+ s_mat(1,5) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m4
+ s_mat(2,4) = s34-m3-m5
+ s_mat(2,5) = s12-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m4
+ s_mat(3,4) = s4-m4-m5
+ s_mat(3,5) = s45-m4-m1
+ !
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -2._ki*m5
+ s_mat(4,5) = s5-m1-m5
+ !
+ s_mat(5,1) = s_mat(1,5)
+ s_mat(5,2) = s_mat(2,5)
+ s_mat(5,3) = s_mat(3,5)
+ s_mat(5,4) = s_mat(4,5)
+ s_mat(5,5) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ idt_temp = idt ! on complete la chaine entrante par des blancs
+ call extract(idt_temp,tab)
+ n1= count(tab/=-1)
+ n2= count(tab/=-1 .and. tab/=0)
+ !
+ temp = -2
+ temp(1:n1) = pack(tab,tab/=-1)
+ !
+ select case(n1)
+ !
+ case(1)
+ !
+ j1 = temp(1)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = a50(b_null)
+ !
+ case(1)
+ !
+ ff = a51(j1,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = b52(b_null)
+ !
+ case(2)
+ !
+ ff = a52(j1,j2,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(3)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ !
+ select case(n2)
+ !
+ case(1)
+ !
+ ff = b53(j3,b_null)
+ !
+ case(3)
+ !
+ ff = a53(j1,j2,j3,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(4)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ j4 = temp(4)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = c54(b_null)
+ !
+ case(2)
+ !
+ ff = b54(j3,j4,b_null)
+ !
+ case(4)
+ !
+ ff = a54(j1,j2,j3,j4,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(5)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ j4 = temp(4)
+ j5 = temp(5)
+ !
+ select case(n2)
+ !
+ case(1)
+ !
+ ff = c55(j5,b_null)
+ !
+ case(3)
+ !
+ ff = b55(j3,j4,j5,b_null)
+ !
+ case(5)
+ !
+ ff = a55(j1,j2,j3,j4,j5,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n1 is not correct %d0'
+ tab_erreur_par(2)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! mu2_scale_par contained in basis integrals
+ !ge0i = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ ge0i = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! ge0i = ff%b + lmu2*ff%a
+ ge0i = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ ge0i = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge0i (ge0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+ end function ge0i
+!
+!****f* src/interface/ge0
+! NAME
+!
+! Function ge0
+!
+! USAGE
+!
+! complex = ge0(s1,s2,s3,s4,s5,s12,s23,s34,s45,s51,m1,m2,m3,m4,m5,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function is the scalar E0 function.
+! The last two arguments are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * s1 -- a real (type ki), p1^2
+! * s2 -- a real (type ki), p2^2
+! * s3 -- a real (type ki), p3^2
+! * s4 -- a real (type ki), p4^2
+! * s5 -- a real (type ki), p5^2
+! * s12 -- a real (type ki), (p1+p2)^2
+! * s23 -- a real (type ki), (p2+p3)^2
+! * s34 -- a real (type ki), (p3+p4)^2
+! * s45 -- a real (type ki), (p4+p5)^2
+! * s51 -- a real (type ki), (p5+p1)^2
+! * m1 -- a real (type ki), mass^2 of propagator 5
+! * m2 -- a real (type ki), mass^2 of propagator 1
+! * m3 -- a real (type ki), mass^2 of propagator 2
+! * m4 -- a real (type ki), mass^2 of propagator 3
+! * m5 -- a real (type ki), mass^2 of propagator 4
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_5p (src/form_factor/form_factor_5p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function ge0(s1,s2,s3,s4,s5,s12,s23,s34,s45,s51,m1,m2,m3,m4,m5,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_5p ! module containing the four-point form factors (export all)
+ use cache, only: allocate_cache, clear_cache
+ use constante, only: b_null
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s5,s12,s23,s34,s45,s51,m1,m2,m3,m4,m5,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: ge0
+ !
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(5)
+ !
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = s23-m2-m4
+ s_mat(1,4) = s51-m2-m5
+ s_mat(1,5) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m4
+ s_mat(2,4) = s34-m3-m5
+ s_mat(2,5) = s12-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m4
+ s_mat(3,4) = s4-m4-m5
+ s_mat(3,5) = s45-m4-m1
+ !
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -2._ki*m5
+ s_mat(4,5) = s5-m1-m5
+ !
+ s_mat(5,1) = s_mat(1,5)
+ s_mat(5,2) = s_mat(2,5)
+ s_mat(5,3) = s_mat(3,5)
+ s_mat(5,4) = s_mat(4,5)
+ s_mat(5,5) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ !
+ ff = a50(b_null)
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! ge0 = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ ge0 = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! ge0 = ff%b + lmu2*ff%a
+ ge0 = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ ge0 = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function ge0 (ge0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+ !
+end function ge0
diff --git a/golem95c-1.2.1/interface/gf0.f90 b/golem95c-1.2.1/interface/gf0.f90
new file mode 100644
index 0000000..84dc084
--- /dev/null
+++ b/golem95c-1.2.1/interface/gf0.f90
@@ -0,0 +1,462 @@
+!
+!****f* src/interface/gf0i
+! NAME
+!
+! Function gf0i
+!
+! USAGE
+!
+! complex = gf0i(idt,s1,s2,s3,s4,s5,s6,s12,s23,s34,s45,s56,s61,s123,s234,s345,m1,m2,m3,m4,m5,m6,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function is the LoopTools F0i function.
+! The first argument is a character of length <= 8
+! There are two arguments more which are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * idt -- a character of length <= 8, the type of form factors
+! * s1 -- a real (type ki), p1^2
+! * s2 -- a real (type ki), p2^2
+! * s3 -- a real (type ki), p3^2
+! * s4 -- a real (type ki), p4^2
+! * s5 -- a real (type ki), p5^2
+! * s6 -- a real (type ki), p6^2
+! * s12 -- a real (type ki), (p1+p2)^2
+! * s23 -- a real (type ki), (p2+p3)^2
+! * s34 -- a real (type ki), (p3+p4)^2
+! * s45 -- a real (type ki), (p4+p5)^2
+! * s56 -- a real (type ki), (p5+p6)^2
+! * s61 -- a real (type ki), (p6+p1)^2
+! * s123 -- a real (type ki), (p1+p2+p3)^2
+! * s234 -- a real (type ki), (p2+p3+p4)^2
+! * s345 -- a real (type ki), (p3+p4+p5)^2
+! * m1 -- a real (type ki), mass of propagator 6
+! * m2 -- a real (type ki), mass of propagator 1
+! * m3 -- a real (type ki), mass of propagator 2
+! * m4 -- a real (type ki), mass of propagator 3
+! * m5 -- a real (type ki), mass of propagator 4
+! * m6 -- a real (type ki), mass of propagator 5
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_6p (src/form_factor/form_factor_6p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * tool_lt_to_golem, only : extract (src/interface/tool_lt_to_golem.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function gf0i(idt,s1,s2,s3,s4,s5,s6,s12,s23,s34,s45,s56,s61,s123,s234,s345,m1,m2,m3,m4,m5,m6,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_6p ! module containing the four-point form factors (export all)
+ use cache, only: allocate_cache, clear_cache
+ use constante, only: b_null
+ use tool_lt_to_golem, only : extract
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ character (len=*), intent (in) :: idt
+ real(ki), intent (in) :: s1,s2,s3,s4,s5,s6,s12,s23,s34,s45,s56,s61,s234,s345,s123,m1,m2,m3,m4,m5,m6,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gf0i
+ !
+ integer, dimension(8) :: tab
+ integer :: n1,n2
+ integer, dimension(6) :: temp
+ integer :: j1,j2,j3,j4,j5,j6
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ character (len=8) :: idt_temp
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(6)
+ !
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = s23-m2-m4
+ s_mat(1,4) = s123-m2-m5
+ s_mat(1,5) = s61-m2-m6
+ s_mat(1,6) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m4
+ s_mat(2,4) = s34-m3-m5
+ s_mat(2,5) = s234-m3-m6
+ s_mat(2,6) = s12-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m4
+ s_mat(3,4) = s4-m4-m5
+ s_mat(3,5) = s45-m4-m6
+ s_mat(3,6) = s345-m4-m1
+ !
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -2._ki*m5
+ s_mat(4,5) = s5-m5-m6
+ s_mat(4,6) = s56-m5-m1
+ !
+ s_mat(5,1) = s_mat(1,5)
+ s_mat(5,2) = s_mat(2,5)
+ s_mat(5,3) = s_mat(3,5)
+ s_mat(5,4) = s_mat(4,5)
+ s_mat(5,5) = -2._ki*m6
+ s_mat(5,6) = s6-m6-m1
+ !
+ s_mat(6,1) = s_mat(1,6)
+ s_mat(6,2) = s_mat(2,6)
+ s_mat(6,3) = s_mat(3,6)
+ s_mat(6,4) = s_mat(4,6)
+ s_mat(6,5) = s_mat(5,6)
+ s_mat(6,6) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ idt_temp = idt ! on complete la chaine entrante par des blancs
+ call extract(idt_temp,tab)
+ n1= count(tab/=-1)
+ n2= count(tab/=-1 .and. tab/=0)
+ !
+ temp = -2
+ temp(1:n1) = pack(tab,tab/=-1)
+ !
+ select case(n1)
+ !
+ case(1)
+ !
+ j1 = temp(1)
+ !
+ select case(n2)
+ !
+ case(0)
+ !
+ ff = a60(b_null)
+ !
+ case(1)
+ !
+ ff = a61(j1,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gf0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n2 %d0'
+ tab_erreur_par(2)%arg_int = n2
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'is not compatible with n1 %d0'
+ tab_erreur_par(3)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ case(2)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ !
+ ff = a62(j1,j2,b_null)
+ !
+ case(3)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ !
+ ff = a63(j1,j2,j3,b_null)
+ !
+ case(4)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ j4 = temp(4)
+ !
+ ff = a64(j1,j2,j3,j4,b_null)
+ !
+ case(5)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ j4 = temp(4)
+ j5 = temp(5)
+ !
+ ff = a65(j1,j2,j3,j4,j5,b_null)
+ !
+ case(6)
+ !
+ j1 = temp(1)
+ j2 = temp(2)
+ j3 = temp(3)
+ j4 = temp(4)
+ j5 = temp(5)
+ j6 = temp(6)
+ !
+ ff = a66(j1,j2,j3,j4,j5,j6,b_null)
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gf0i (lt_to_golem.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The value of n1 is not correct %d0'
+ tab_erreur_par(2)%arg_int = n1
+ call catch_exception(0)
+ !
+ stop
+ !
+ end select
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! gf0i = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ gf0i = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! gf0i = ff%b + lmu2*ff%a
+ gf0i = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gf0i = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gf0i (gf0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+ end function gf0i
+!
+!
+!****f* src/interface/gf0
+! NAME
+!
+! Function gf0
+!
+! USAGE
+!
+! complex = gf0(s1,s2,s3,s4,s5,s6,s12,s23,s34,s45,s56,s61,s123,s234,s345,m1,m2,m3,m4,m5,m6,mu2,eps_flag)
+!
+! DESCRIPTION
+!
+! This function is the scalar F0 function.
+! The last two arguments are the renormalisation
+! scale squared and a flag which selects the coefficient of
+! the Laurent series in epsilon
+!
+! INPUTS
+!
+! * s1 -- a real (type ki), p1^2
+! * s2 -- a real (type ki), p2^2
+! * s3 -- a real (type ki), p3^2
+! * s4 -- a real (type ki), p4^2
+! * s5 -- a real (type ki), p5^2
+! * s6 -- a real (type ki), p6^2
+! * s12 -- a real (type ki), (p1+p2)^2
+! * s23 -- a real (type ki), (p2+p3)^2
+! * s34 -- a real (type ki), (p3+p4)^2
+! * s45 -- a real (type ki), (p4+p5)^2
+! * s56 -- a real (type ki), (p5+p6)^2
+! * s61 -- a real (type ki), (p6+p1)^2
+! * s123 -- a real (type ki), (p1+p2+p3)^2
+! * s234 -- a real (type ki), (p2+p3+p4)^2
+! * s345 -- a real (type ki), (p3+p4+p5)^2
+! * m1 -- a real (type ki), mass^2 of propagator 6
+! * m2 -- a real (type ki), mass^2 of propagator 1
+! * m3 -- a real (type ki), mass^2 of propagator 2
+! * m4 -- a real (type ki), mass^2 of propagator 3
+! * m5 -- a real (type ki), mass^2 of propagator 4
+! * m6 -- a real (type ki), mass^2 of propagator 5
+! * mu2 -- a real (type ki), renormalisation scale squared
+! * eps_flag -- an integer, a flag to select the coefficient in front the power of epsilon
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! It returns a complex (type ki) corresponding
+! to the real part, imaginary part of the coefficient in front 1/epsilon^2 (eps_flag=-2),
+! the real part, imaginary part of the 1/epsilon term (eps_flag=-1) and the real part,
+! imaginary part of the constant term (eps_flag=0).
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs (src/kinematic/matrice_s.f90)
+! * form_factor_type, only: form_factor (src/module/form_factor_type.f90)
+! * form_factor_6p (src/form_factor/form_factor_6p.f90)
+! * cache, only: allocate_cache, clear_cache (src/module/cache.f90)
+! * constante, only : b_null (src/module/constante.f90)
+! * sortie_erreur, only : tab_erreur_par,catch_exception (src/module/sortie_erreur.f90)
+!
+!
+! EXAMPLE
+!
+!
+!
+!*****
+function gf0(s1,s2,s3,s4,s5,s6,s12,s23,s34,s45,s56,s61,s123,s234,s345,m1,m2,m3,m4,m5,m6,mu2,eps_flag)
+ !
+ use precision_golem ! to get the type ki (for real and complex)
+ use matrice_s
+ use form_factor_type, only: form_factor
+ use form_factor_6p ! module containing the four-point form factors (export all)
+ use cache, only: allocate_cache, clear_cache
+ use constante, only: b_null
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use parametre, only: mu2_scale_par
+ implicit none
+ !
+ real(ki), intent (in) :: s1,s2,s3,s4,s5,s6,s12,s23,s34,s45,s56,s61,s234,s345,s123,m1,m2,m3,m4,m5,m6,mu2
+ integer, intent(in) :: eps_flag
+ complex(ki) :: gf0
+ !
+ type(form_factor) :: ff
+ real(ki) :: lmu2,mu2store
+ !
+ mu2store=mu2_scale_par
+ mu2_scale_par=mu2
+ !
+ call initgolem95(6)
+ !
+ !
+ s_mat(1,1) = -2._ki*m2
+ s_mat(1,2) = s2-m2-m3
+ s_mat(1,3) = s23-m2-m4
+ s_mat(1,4) = s123-m2-m5
+ s_mat(1,5) = s61-m2-m6
+ s_mat(1,6) = s1-m1-m2
+ !
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -2._ki*m3
+ s_mat(2,3) = s3-m3-m4
+ s_mat(2,4) = s34-m3-m5
+ s_mat(2,5) = s234-m3-m6
+ s_mat(2,6) = s12-m3-m1
+ !
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -2._ki*m4
+ s_mat(3,4) = s4-m4-m5
+ s_mat(3,5) = s45-m4-m6
+ s_mat(3,6) = s345-m4-m1
+ !
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -2._ki*m5
+ s_mat(4,5) = s5-m5-m6
+ s_mat(4,6) = s56-m5-m1
+ !
+ s_mat(5,1) = s_mat(1,5)
+ s_mat(5,2) = s_mat(2,5)
+ s_mat(5,3) = s_mat(3,5)
+ s_mat(5,4) = s_mat(4,5)
+ s_mat(5,5) = -2._ki*m6
+ s_mat(5,6) = s6-m6-m1
+ !
+ s_mat(6,1) = s_mat(1,6)
+ s_mat(6,2) = s_mat(2,6)
+ s_mat(6,3) = s_mat(3,6)
+ s_mat(6,4) = s_mat(4,6)
+ s_mat(6,5) = s_mat(5,6)
+ s_mat(6,6) = -2._ki*m1
+ !
+ call preparesmatrix()
+ !
+ !
+ ff = a60(b_null)
+ !
+ !
+ lmu2 = log(mu2)
+ !
+ if (eps_flag == 0) then
+ !
+ ! expanded scale already contained in basis integrals
+ ! gf0 = ff%c + lmu2*ff%b + lmu2**2*ff%a/2._ki
+ gf0 = ff%c
+ !
+ else if (eps_flag == -1) then
+ !
+ ! gf0 = ff%b + lmu2*ff%a
+ gf0 = ff%b
+ !
+ else if (eps_flag == -2) then
+ !
+ gf0 = ff%a
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function gf0 (gf0.f90)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'eps_flag should be -2, -1 or 0 but is %d0'
+ tab_erreur_par(2)%arg_int = eps_flag
+ call catch_exception(0)
+ !
+ stop
+ !
+ end if
+ !
+ mu2_scale_par=mu2store
+ !
+ call exitgolem95()
+ !
+ !
+ end function gf0
+
diff --git a/golem95c-1.2.1/interface/tens_comb.f90 b/golem95c-1.2.1/interface/tens_comb.f90
new file mode 100644
index 0000000..decb9a5
--- /dev/null
+++ b/golem95c-1.2.1/interface/tens_comb.f90
@@ -0,0 +1,11709 @@
+!****h* src/interface/tens_comb
+! NAME
+!
+! Module tens_comb
+!
+! USAGE
+!
+! use tens_comb
+!
+! DESCRIPTION
+!
+! This module contains the routines necessary for the contraction
+! of the tensor coefficients as reconstructed by the module tens_rec
+! with the according tensor integrals.
+!
+! Please, note that this module is generated by a script and should not
+! be modified manually. In order to make changes to this module rerun
+! the Python script
+!
+! tool/tens_rec/tens.py
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+! * matrice_s (src/kinematics/matrice_s.f90)
+! * array (src/module/array.f90)
+! * form_factor_type (src/module/form_factor_type.f90)
+! * form_factor_2p (src/form_factor/form_factor_2p.f90)
+! * form_factor_3p (src/form_factor/form_factor_3p.f90)
+! * form_factor_4p (src/form_factor/form_factor_4p.f90)
+! * form_factor_5p (src/form_factor/form_factor_5p.f90)
+! * form_factor_6p (src/form_factor/form_factor_6p.f90)
+! * tens_rec (src/interface/tens_rec.f90)
+!
+!*****
+module tens_comb
+! This module has been generated using a script.
+! Please, refrain from modifying it directly!
+use precision_golem, only: ki
+use matrice_s, only: b_ref, inv_s
+use array, only: packb, unpackb, countb, pminus, punion
+use form_factor_type, only: form_factor, operator(+), operator(-), &
+ & operator(*), assignment(=)
+use form_factor_1p, only: a10
+use form_factor_2p, only: a20, a21, a22, b22
+use form_factor_3p, only: a30, a31, a32, b32, a33, b33
+use form_factor_4p, only: a40, a41, a42, b42, a43, b43, a44, b44, c44
+use form_factor_5p, only: a50, a51, a52, b52, a53, b53, a54, b54, c54, a55, &
+ & b55, c55
+use form_factor_6p, only: a60, a61, a62, a63, a64, a65, a66
+use tens_rec, only: coeff_type_1, reconstruct1, coeff_type_2, reconstruct2, &
+ & coeff_type_3, reconstruct3, coeff_type_4, reconstruct4, coeff_type_5, &
+ & reconstruct5, coeff_type_6, reconstruct6
+implicit none
+private :: ki, b_ref, unpackb, packb, pminus, form_factor
+private :: coeff_type_1, reconstruct1, coeff_type_2, reconstruct2, &
+ & coeff_type_3, reconstruct3, coeff_type_4, reconstruct4, coeff_type_5, &
+ & reconstruct5, coeff_type_6, reconstruct6
+private :: a10
+private :: a20, a21, a22, b22
+private :: a30, a31, a32, b32, a33, b33
+private :: a40, a41, a42, b42, a43, b43, a44, b44, c44
+private :: a50, a51, a52, b52, a53, b53, a54, b54, c54, a55, b55, c55
+private :: a60, a61, a62, a63, a64, a65, a66
+real(ki), dimension(0:3), parameter, private :: null_vec = &
+ & (/0.0_ki,0.0_ki,0.0_ki,0.0_ki/)
+interface evaluate
+ module procedure evaluate_b
+ module procedure evaluate_s
+end interface
+contains
+!****f* src/interface/tens_comb/evaluate_s
+! NAME
+!
+! Function evaluate_s
+!
+! Accessible through interface evaluate
+!
+! USAGE
+!
+! amp = evaluate(numeval, momenta, set, rank)
+!
+! DESCRIPTION
+!
+! Evaluates a diagram by first reconstructing its tensor coefficients
+! and then contracting with the tensor integrals.
+!
+! INPUTS
+!
+! * numeval -- the numerator function
+! * momenta -- real array of dimension(:,0:3) containing the
+! momenta r_i of the loop propagators
+! * set -- the set of pinched propagators as integer array
+! * rank -- optional integer, specifying the maximum rank of the diagram
+! If omitted, rank is assumed to be the equal to the number of
+! loop propagators.
+! RETURN VALUE
+!
+! Value of the diagram as a type(form_factor)
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function evaluate_s(numeval, momenta, set, rank) result(amp)
+ ! generated by: write_function_evaluate
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ real(ki), dimension(:,:), intent(in) :: momenta
+ integer, dimension(:), intent(in) :: set
+ integer, intent(in), optional :: rank
+ type(form_factor) :: amp
+ if (present(rank)) then
+ amp = evaluate_b(numeval, momenta, packb(set), rank)
+ else
+ amp = evaluate_b(numeval, momenta, packb(set))
+ end if
+end function evaluate_s
+!****f* src/interface/tens_comb/evaluate_b
+! NAME
+!
+! Function evaluate_b
+!
+! Accessible through interface evaluate
+!
+! USAGE
+!
+! amp = evaluate(numeval, momenta, b_set, rank)
+!
+! DESCRIPTION
+!
+! Evaluates a diagram by first reconstructing its tensor coefficients
+! and then contracting with the tensor integrals.
+!
+! INPUTS
+!
+! * numeval -- the numerator function
+! * momenta -- real array of dimension(:,0:3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer (bit-set)
+! * rank -- optional integer, specifying the maximum rank of the diagram
+! If omitted, rank is assumed to be the equal to the number of
+! loop propagators.
+! RETURN VALUE
+!
+! Value of the diagram as a type(form_factor)
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function evaluate_b(numeval, momenta, b_set, rank) result(amp)
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ real(ki), dimension(:,:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ integer, intent(in), optional :: rank
+ type(form_factor) :: amp
+ integer :: N, r
+ complex(ki) :: coeffs0
+ type(coeff_type_1) :: coeffs1
+ type(coeff_type_2) :: coeffs2, coeffs2x
+ type(coeff_type_3) :: coeffs3
+ type(coeff_type_4) :: coeffs4
+ type(coeff_type_5) :: coeffs5
+ type(coeff_type_6) :: coeffs6
+ N = size(momenta,1) - countb(b_set)
+ if (present(rank)) then
+ r = rank
+ else
+ r = N
+ end if
+ select case(N)
+ case(1)
+ select case(r)
+ case(0)
+ coeffs0 = numeval(null_vec, 0.0_ki)
+ print*, "Tadpoles not implemented yet"
+ stop
+ case(1)
+ call reconstruct1(numeval, coeffs1)
+ print*, "Tadpoles not implemented yet"
+ stop
+ case default
+ print*, "Not yet implemented: N, r = ", 1, r
+ stop
+ end select
+ case(2)
+ select case(r)
+ case(0)
+ coeffs0 = numeval(null_vec, 0.0_ki)
+ amp = coeffs0 * a20(b_set)
+ case(1)
+ call reconstruct1(numeval, coeffs1)
+ amp = contract2_1(coeffs1,momenta,b_set)
+ case(2)
+ call reconstruct2(numeval, coeffs2, coeffs0)
+ amp = contract2_2(coeffs2,momenta,b_set)
+ amp = amp + contract2_2s1(coeffs0,momenta,b_set)
+ case default
+ print*, "Not yet implemented: N, r = ", 2, r
+ stop
+ end select
+ case(3)
+ select case(r)
+ case(0)
+ coeffs0 = numeval(null_vec, 0.0_ki)
+ amp = coeffs0 * a30(b_set)
+ case(1)
+ call reconstruct1(numeval, coeffs1)
+ amp = contract3_1(coeffs1,momenta,b_set)
+ case(2)
+ call reconstruct2(numeval, coeffs2, coeffs0)
+ amp = contract3_2(coeffs2,momenta,b_set)
+ amp = amp + contract3_2s1(coeffs0,momenta,b_set)
+ case(3)
+ call reconstruct3(numeval, coeffs3, coeffs1)
+ amp = contract3_3(coeffs3,momenta,b_set)
+ amp = amp + contract3_3s1(coeffs1,momenta,b_set)
+ case default
+ print*, "Not yet implemented: N, r = ", 3, r
+ stop
+ end select
+ case(4)
+ select case(r)
+ case(0)
+ coeffs0 = numeval(null_vec, 0.0_ki)
+ amp = coeffs0 * a40(b_set)
+ case(1)
+ call reconstruct1(numeval, coeffs1)
+ amp = contract4_1(coeffs1,momenta,b_set)
+ case(2)
+ call reconstruct2(numeval, coeffs2, coeffs0)
+ amp = contract4_2(coeffs2,momenta,b_set)
+ amp = amp + contract4_2s1(coeffs0,momenta,b_set)
+ case(3)
+ call reconstruct3(numeval, coeffs3, coeffs1)
+ amp = contract4_3(coeffs3,momenta,b_set)
+ amp = amp + contract4_3s1(coeffs1,momenta,b_set)
+ case(4)
+ call reconstruct4(numeval, coeffs4, coeffs2, coeffs2x)
+ amp = contract4_4(coeffs4,momenta,b_set)
+ amp = amp + contract4_4s1(coeffs2,momenta,b_set)
+ amp = amp + contract4_4s2(coeffs2x,momenta,b_set)
+ case default
+ print*, "Not yet implemented: N, r = ", 4, r
+ stop
+ end select
+ case(5)
+ select case(r)
+ case(0)
+ coeffs0 = numeval(null_vec, 0.0_ki)
+ amp = coeffs0 * a50(b_set)
+ case(1)
+ call reconstruct1(numeval, coeffs1)
+ amp = contract5_1(coeffs1,momenta,b_set)
+ case(2)
+ call reconstruct2(numeval, coeffs2)
+ amp = contract5_2(coeffs2,momenta,b_set)
+ case(3)
+ call reconstruct3(numeval, coeffs3)
+ amp = contract5_3(coeffs3,momenta,b_set)
+ case(4)
+ call reconstruct4(numeval, coeffs4)
+ amp = contract5_4(coeffs4,momenta,b_set)
+ case(5)
+ call reconstruct5(numeval, coeffs5)
+ amp = contract5_5(coeffs5,momenta,b_set)
+ case default
+ print*, "Not yet implemented: N, r = ", 5, r
+ stop
+ end select
+ case(6)
+ select case(r)
+ case(0)
+ coeffs0 = numeval(null_vec, 0.0_ki)
+ amp = coeffs0 * a60(b_set)
+ case(1)
+ call reconstruct1(numeval, coeffs1)
+ amp = contract6_1(coeffs1,momenta,b_set)
+ case(2)
+ call reconstruct2(numeval, coeffs2)
+ amp = contract6_2(coeffs2,momenta,b_set)
+ case(3)
+ call reconstruct3(numeval, coeffs3)
+ amp = contract6_3(coeffs3,momenta,b_set)
+ case(4)
+ call reconstruct4(numeval, coeffs4)
+ amp = contract6_4(coeffs4,momenta,b_set)
+ case(5)
+ call reconstruct5(numeval, coeffs5)
+ amp = contract6_5(coeffs5,momenta,b_set)
+ case(6)
+ call reconstruct6(numeval, coeffs6)
+ amp = contract6_6(coeffs6,momenta,b_set)
+ case default
+ print*, "Not yet implemented: N, r = ", 6, r
+ stop
+ end select
+ case default
+ print*, "Not yet implemented: N=", N
+ stop
+ end select
+end function evaluate_b
+!****f* src/interface/tens_comb/contract1_1
+! NAME
+!
+! Function contract1_1
+!
+! USAGE
+!
+! amp = contract1_1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 1-point rank 1 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_1)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract1_1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ integer :: l1
+ integer, dimension(1) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 1)
+ l1 = unpinched(1)
+ amp = coeffs%c0 * a10(b_set)
+end function contract1_1
+!****f* src/interface/tens_comb/contract2_1
+! NAME
+!
+! Function contract2_1
+!
+! USAGE
+!
+! amp = contract2_1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 2-point rank 1 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_1)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract2_1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ integer :: l1, l2
+ integer, dimension(2) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 2)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ amp = coeffs%c0 * a20(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a21(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a21(l2, b_set)
+end function contract2_1
+!****f* src/interface/tens_comb/contract2_2
+! NAME
+!
+! Function contract2_2
+!
+! USAGE
+!
+! amp = contract2_2(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 2-point rank 2 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_2)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract2_2(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ integer :: l1, l2
+ integer, dimension(2) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 2)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ amp = coeffs%c0 * a20(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a21(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a21(l2, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a22(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a22(l1, l2, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a22(l2, l2, b_set)
+ amp = amp + contract_b_tensor_2(coeffs) * b22(b_set)
+end function contract2_2
+!****f* src/interface/tens_comb/contract2_2s1
+! NAME
+!
+! Function contract2_2s1
+!
+! USAGE
+!
+! amp = contract2_2s1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 2-point rank 2 tensor integral
+! with (mu^2)^1 in the numerator with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(complex(ki))
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract2_2s1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ complex(ki), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ integer :: l1, l2
+ integer, dimension(2) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 2)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ amp = coeffs * b22(b_set)
+ ! multiply by 2*epsilon
+ amp%c = 2.0_ki*amp%b
+ amp%b = 2.0_ki*amp%a
+ amp%a = 0.0_ki
+end function contract2_2s1
+!****f* src/interface/tens_comb/contract3_1
+! NAME
+!
+! Function contract3_1
+!
+! USAGE
+!
+! amp = contract3_1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 3-point rank 1 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_1)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract3_1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ integer :: l1, l2, l3
+ integer, dimension(3) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 3)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ amp = coeffs%c0 * a30(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a31(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a31(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a31(l3, b_set)
+end function contract3_1
+!****f* src/interface/tens_comb/contract3_2
+! NAME
+!
+! Function contract3_2
+!
+! USAGE
+!
+! amp = contract3_2(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 3-point rank 2 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_2)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract3_2(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ integer :: l1, l2, l3
+ integer, dimension(3) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 3)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ amp = coeffs%c0 * a30(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a31(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a31(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a31(l3, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a32(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a32(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a32(l1, l3, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a32(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a32(l2, l3, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a32(l3, l3, b_set)
+ amp = amp + contract_b_tensor_2(coeffs) * b32(b_set)
+end function contract3_2
+!****f* src/interface/tens_comb/contract3_2s1
+! NAME
+!
+! Function contract3_2s1
+!
+! USAGE
+!
+! amp = contract3_2s1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 3-point rank 2 tensor integral
+! with (mu^2)^1 in the numerator with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(complex(ki))
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract3_2s1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ complex(ki), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ integer :: l1, l2, l3
+ integer, dimension(3) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 3)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ amp = coeffs * b32(b_set)
+ ! multiply by 2*epsilon
+ amp%c = 2.0_ki*amp%b
+ amp%b = 2.0_ki*amp%a
+ amp%a = 0.0_ki
+end function contract3_2s1
+!****f* src/interface/tens_comb/contract3_3
+! NAME
+!
+! Function contract3_3
+!
+! USAGE
+!
+! amp = contract3_3(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 3-point rank 3 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_3)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract3_3(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_3), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ real(ki), dimension(3,0:3) :: mom3
+ integer :: l1, l2, l3
+ integer, dimension(3) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 3)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ amp = coeffs%c0 * a30(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a31(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a31(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a31(l3, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a32(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a32(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a32(l1, l3, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a32(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a32(l2, l3, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a32(l3, l3, b_set)
+ amp = amp + contract_b_tensor_3(coeffs) * b32(b_set)
+ mom3 = momenta((/l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a33(l1, l1, l1, b_set)
+ mom3 = momenta((/l1,l1,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a33(l1, l1, l2, b_set)
+ mom3 = momenta((/l1,l1,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a33(l1, l1, l3, b_set)
+ mom3 = momenta((/l1,l2,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a33(l1, l2, l2, b_set)
+ mom3 = momenta((/l1,l2,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a33(l1, l2, l3, b_set)
+ mom3 = momenta((/l1,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a33(l1, l3, l3, b_set)
+ mom3 = momenta((/l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a33(l2, l2, l2, b_set)
+ mom3 = momenta((/l2,l2,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a33(l2, l2, l3, b_set)
+ mom3 = momenta((/l2,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a33(l2, l3, l3, b_set)
+ mom3 = momenta((/l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a33(l3, l3, l3, b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b33(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b33(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b33(l3, b_set)
+end function contract3_3
+!****f* src/interface/tens_comb/contract3_3s1
+! NAME
+!
+! Function contract3_3s1
+!
+! USAGE
+!
+! amp = contract3_3s1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 3-point rank 3 tensor integral
+! with (mu^2)^1 in the numerator with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_1)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract3_3s1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ integer :: l1, l2, l3
+ integer, dimension(3) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 3)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ amp = coeffs%c0 * b32(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * b33(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * b33(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * b33(l3, b_set)
+ ! multiply by 2*epsilon
+ amp%c = 2.0_ki*amp%b
+ amp%b = 2.0_ki*amp%a
+ amp%a = 0.0_ki
+end function contract3_3s1
+!****f* src/interface/tens_comb/contract4_1
+! NAME
+!
+! Function contract4_1
+!
+! USAGE
+!
+! amp = contract4_1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 4-point rank 1 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_1)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract4_1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ integer :: l1, l2, l3, l4
+ integer, dimension(4) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 4)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ amp = coeffs%c0 * a40(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a41(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a41(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a41(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a41(l4, b_set)
+end function contract4_1
+!****f* src/interface/tens_comb/contract4_2
+! NAME
+!
+! Function contract4_2
+!
+! USAGE
+!
+! amp = contract4_2(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 4-point rank 2 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_2)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract4_2(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ integer :: l1, l2, l3, l4
+ integer, dimension(4) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 4)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ amp = coeffs%c0 * a40(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a41(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a41(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a41(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a41(l4, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a42(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a42(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a42(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a42(l1, l4, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a42(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a42(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a42(l2, l4, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a42(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a42(l3, l4, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a42(l4, l4, b_set)
+ amp = amp + contract_b_tensor_2(coeffs) * b42(b_set)
+end function contract4_2
+!****f* src/interface/tens_comb/contract4_2s1
+! NAME
+!
+! Function contract4_2s1
+!
+! USAGE
+!
+! amp = contract4_2s1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 4-point rank 2 tensor integral
+! with (mu^2)^1 in the numerator with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(complex(ki))
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract4_2s1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ complex(ki), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ integer :: l1, l2, l3, l4
+ integer, dimension(4) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 4)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ amp = 0.0_ki
+end function contract4_2s1
+!****f* src/interface/tens_comb/contract4_3
+! NAME
+!
+! Function contract4_3
+!
+! USAGE
+!
+! amp = contract4_3(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 4-point rank 3 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_3)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract4_3(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_3), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ real(ki), dimension(3,0:3) :: mom3
+ integer :: l1, l2, l3, l4
+ integer, dimension(4) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 4)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ amp = coeffs%c0 * a40(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a41(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a41(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a41(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a41(l4, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a42(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a42(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a42(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a42(l1, l4, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a42(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a42(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a42(l2, l4, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a42(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a42(l3, l4, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a42(l4, l4, b_set)
+ amp = amp + contract_b_tensor_3(coeffs) * b42(b_set)
+ mom3 = momenta((/l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a43(l1, l1, l1, b_set)
+ mom3 = momenta((/l1,l1,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l1, l1, l2, b_set)
+ mom3 = momenta((/l1,l1,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l1, l1, l3, b_set)
+ mom3 = momenta((/l1,l1,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l1, l1, l4, b_set)
+ mom3 = momenta((/l1,l2,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l1, l2, l2, b_set)
+ mom3 = momenta((/l1,l2,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l1, l2, l3, b_set)
+ mom3 = momenta((/l1,l2,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l1, l2, l4, b_set)
+ mom3 = momenta((/l1,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l1, l3, l3, b_set)
+ mom3 = momenta((/l1,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l1, l3, l4, b_set)
+ mom3 = momenta((/l1,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l1, l4, l4, b_set)
+ mom3 = momenta((/l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a43(l2, l2, l2, b_set)
+ mom3 = momenta((/l2,l2,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l2, l2, l3, b_set)
+ mom3 = momenta((/l2,l2,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l2, l2, l4, b_set)
+ mom3 = momenta((/l2,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l2, l3, l3, b_set)
+ mom3 = momenta((/l2,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l2, l3, l4, b_set)
+ mom3 = momenta((/l2,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l2, l4, l4, b_set)
+ mom3 = momenta((/l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a43(l3, l3, l3, b_set)
+ mom3 = momenta((/l3,l3,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l3, l3, l4, b_set)
+ mom3 = momenta((/l3,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a43(l3, l4, l4, b_set)
+ mom3 = momenta((/l4,l4,l4/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a43(l4, l4, l4, b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b43(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b43(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b43(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b43(l4, b_set)
+end function contract4_3
+!****f* src/interface/tens_comb/contract4_3s1
+! NAME
+!
+! Function contract4_3s1
+!
+! USAGE
+!
+! amp = contract4_3s1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 4-point rank 3 tensor integral
+! with (mu^2)^1 in the numerator with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_1)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract4_3s1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ integer :: l1, l2, l3, l4
+ integer, dimension(4) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 4)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ amp = 0.0_ki
+end function contract4_3s1
+!****f* src/interface/tens_comb/contract4_4
+! NAME
+!
+! Function contract4_4
+!
+! USAGE
+!
+! amp = contract4_4(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 4-point rank 4 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_4)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract4_4(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_4), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ real(ki), dimension(3,0:3) :: mom3
+ real(ki), dimension(4,0:3) :: mom4
+ integer :: l1, l2, l3, l4
+ integer, dimension(4) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 4)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ amp = coeffs%c0 * a40(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom1) * a41(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom1) * a41(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom1) * a41(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom1) * a41(l4, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom2) * a42(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a42(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a42(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a42(l1, l4, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom2) * a42(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a42(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a42(l2, l4, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom2) * a42(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a42(l3, l4, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom2) * a42(l4, l4, b_set)
+ amp = amp + contract_b_tensor_4(coeffs) * b42(b_set)
+ mom3 = momenta((/l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom3) * a43(l1, l1, l1, b_set)
+ mom3 = momenta((/l1,l1,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l1, l1, l2, b_set)
+ mom3 = momenta((/l1,l1,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l1, l1, l3, b_set)
+ mom3 = momenta((/l1,l1,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l1, l1, l4, b_set)
+ mom3 = momenta((/l1,l2,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l1, l2, l2, b_set)
+ mom3 = momenta((/l1,l2,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l1, l2, l3, b_set)
+ mom3 = momenta((/l1,l2,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l1, l2, l4, b_set)
+ mom3 = momenta((/l1,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l1, l3, l3, b_set)
+ mom3 = momenta((/l1,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l1, l3, l4, b_set)
+ mom3 = momenta((/l1,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l1, l4, l4, b_set)
+ mom3 = momenta((/l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom3) * a43(l2, l2, l2, b_set)
+ mom3 = momenta((/l2,l2,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l2, l2, l3, b_set)
+ mom3 = momenta((/l2,l2,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l2, l2, l4, b_set)
+ mom3 = momenta((/l2,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l2, l3, l3, b_set)
+ mom3 = momenta((/l2,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l2, l3, l4, b_set)
+ mom3 = momenta((/l2,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l2, l4, l4, b_set)
+ mom3 = momenta((/l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom3) * a43(l3, l3, l3, b_set)
+ mom3 = momenta((/l3,l3,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l3, l3, l4, b_set)
+ mom3 = momenta((/l3,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a43(l3, l4, l4, b_set)
+ mom3 = momenta((/l4,l4,l4/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom3) * a43(l4, l4, l4, b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom1) * b43(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom1) * b43(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom1) * b43(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom1) * b43(l4, b_set)
+ mom4 = momenta((/l1,l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom4) * a44(l1, l1, l1, l1, b_set)
+ mom4 = momenta((/l1,l1,l1,l2/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l1, l1, l2, b_set)
+ mom4 = momenta((/l1,l1,l1,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l1, l1, l3, b_set)
+ mom4 = momenta((/l1,l1,l1,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l1, l1, l4, b_set)
+ mom4 = momenta((/l1,l1,l2,l2/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l1, l2, l2, b_set)
+ mom4 = momenta((/l1,l1,l2,l3/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l1, l2, l3, b_set)
+ mom4 = momenta((/l1,l1,l2,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l1, l2, l4, b_set)
+ mom4 = momenta((/l1,l1,l3,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l1, l3, l3, b_set)
+ mom4 = momenta((/l1,l1,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l1, l3, l4, b_set)
+ mom4 = momenta((/l1,l1,l4,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l1, l4, l4, b_set)
+ mom4 = momenta((/l1,l2,l2,l2/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l2, l2, l2, b_set)
+ mom4 = momenta((/l1,l2,l2,l3/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l2, l2, l3, b_set)
+ mom4 = momenta((/l1,l2,l2,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l2, l2, l4, b_set)
+ mom4 = momenta((/l1,l2,l3,l3/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l2, l3, l3, b_set)
+ mom4 = momenta((/l1,l2,l3,l4/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l2, l3, l4, b_set)
+ mom4 = momenta((/l1,l2,l4,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l2, l4, l4, b_set)
+ mom4 = momenta((/l1,l3,l3,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l3, l3, l3, b_set)
+ mom4 = momenta((/l1,l3,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l3, l3, l4, b_set)
+ mom4 = momenta((/l1,l3,l4,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l3, l4, l4, b_set)
+ mom4 = momenta((/l1,l4,l4,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l1, l4, l4, l4, b_set)
+ mom4 = momenta((/l2,l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom4) * a44(l2, l2, l2, l2, b_set)
+ mom4 = momenta((/l2,l2,l2,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l2, l2, l2, l3, b_set)
+ mom4 = momenta((/l2,l2,l2,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l2, l2, l2, l4, b_set)
+ mom4 = momenta((/l2,l2,l3,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l2, l2, l3, l3, b_set)
+ mom4 = momenta((/l2,l2,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l2, l2, l3, l4, b_set)
+ mom4 = momenta((/l2,l2,l4,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l2, l2, l4, l4, b_set)
+ mom4 = momenta((/l2,l3,l3,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l2, l3, l3, l3, b_set)
+ mom4 = momenta((/l2,l3,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l2, l3, l3, l4, b_set)
+ mom4 = momenta((/l2,l3,l4,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l2, l3, l4, l4, b_set)
+ mom4 = momenta((/l2,l4,l4,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l2, l4, l4, l4, b_set)
+ mom4 = momenta((/l3,l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom4) * a44(l3, l3, l3, l3, b_set)
+ mom4 = momenta((/l3,l3,l3,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l3, l3, l3, l4, b_set)
+ mom4 = momenta((/l3,l3,l4,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l3, l3, l4, l4, b_set)
+ mom4 = momenta((/l3,l4,l4,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a44(l3, l4, l4, l4, b_set)
+ mom4 = momenta((/l4,l4,l4,l4/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom4) * a44(l4, l4, l4, l4, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom2) * b44(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b44(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b44(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b44(l1, l4, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom2) * b44(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b44(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b44(l2, l4, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom2) * b44(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b44(l3, l4, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom2) * b44(l4, l4, b_set)
+ amp = amp + contract_c_tensor_4(coeffs) * c44(b_set)
+end function contract4_4
+!****f* src/interface/tens_comb/contract4_4s1
+! NAME
+!
+! Function contract4_4s1
+!
+! USAGE
+!
+! amp = contract4_4s1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 4-point rank 4 tensor integral
+! with (mu^2)^1 in the numerator with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_2)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract4_4s1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ integer :: l1, l2, l3, l4
+ integer, dimension(4) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 4)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ amp = contract_b_tensor_2(coeffs) * c44(b_set)
+ ! multiply by 2*epsilon
+ amp%c = 2.0_ki*amp%b
+ amp%b = 2.0_ki*amp%a
+ amp%a = 0.0_ki
+end function contract4_4s1
+!****f* src/interface/tens_comb/contract4_4s2
+! NAME
+!
+! Function contract4_4s2
+!
+! USAGE
+!
+! amp = contract4_4s2(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 4-point rank 4 tensor integral
+! with (mu^2)^2 in the numerator with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_2)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract4_4s2(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ integer :: l1, l2, l3, l4
+ integer, dimension(4) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 4)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ amp = coeffs%c0 * c44(b_set)
+ ! multiply by -4*(epsilon-epsilon^2)
+ amp%c = -4.0_ki*(amp%b-amp%a)
+ amp%b = -4.0_ki*amp%a
+ amp%a = 0.0_ki
+end function contract4_4s2
+!****f* src/interface/tens_comb/contract5_1
+! NAME
+!
+! Function contract5_1
+!
+! USAGE
+!
+! amp = contract5_1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 5-point rank 1 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_1)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract5_1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ integer :: l1, l2, l3, l4, l5
+ integer, dimension(5) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 5)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ l5 = unpinched(5)
+ amp = coeffs%c0 * a50(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a51(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a51(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a51(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a51(l4, b_set)
+ mom1 = momenta((/l5/),:)
+ amp = amp + contract_a_tensor_1(coeffs, mom1) * a51(l5, b_set)
+end function contract5_1
+!****f* src/interface/tens_comb/contract5_2
+! NAME
+!
+! Function contract5_2
+!
+! USAGE
+!
+! amp = contract5_2(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 5-point rank 2 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_2)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract5_2(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ integer :: l1, l2, l3, l4, l5
+ integer, dimension(5) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 5)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ l5 = unpinched(5)
+ amp = coeffs%c0 * a50(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a51(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a51(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a51(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a51(l4, b_set)
+ mom1 = momenta((/l5/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom1) * a51(l5, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a52(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l1, l4, b_set)
+ mom2 = momenta((/l1,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l1, l5, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a52(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l2, l4, b_set)
+ mom2 = momenta((/l2,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l2, l5, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a52(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l3, l4, b_set)
+ mom2 = momenta((/l3,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l3, l5, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a52(l4, l4, b_set)
+ mom2 = momenta((/l4,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_2(coeffs, mom2) * a52(l4, l5, b_set)
+ mom2 = momenta((/l5,l5/),:)
+ amp = amp + contract_a_tensor_2(coeffs, mom2) * a52(l5, l5, b_set)
+ amp = amp + contract_b_tensor_2(coeffs) * b52(b_set)
+end function contract5_2
+!****f* src/interface/tens_comb/contract5_3
+! NAME
+!
+! Function contract5_3
+!
+! USAGE
+!
+! amp = contract5_3(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 5-point rank 3 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_3)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract5_3(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_3), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ real(ki), dimension(3,0:3) :: mom3
+ integer :: l1, l2, l3, l4, l5
+ integer, dimension(5) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 5)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ l5 = unpinched(5)
+ amp = coeffs%c0 * a50(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a51(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a51(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a51(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a51(l4, b_set)
+ mom1 = momenta((/l5/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom1) * a51(l5, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a52(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l1, l4, b_set)
+ mom2 = momenta((/l1,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l1, l5, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a52(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l2, l4, b_set)
+ mom2 = momenta((/l2,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l2, l5, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a52(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l3, l4, b_set)
+ mom2 = momenta((/l3,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l3, l5, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a52(l4, l4, b_set)
+ mom2 = momenta((/l4,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_3(coeffs, mom2) * a52(l4, l5, b_set)
+ mom2 = momenta((/l5,l5/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom2) * a52(l5, l5, b_set)
+ amp = amp + contract_b_tensor_3(coeffs) * b52(b_set)
+ mom3 = momenta((/l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a53(l1, l1, l1, b_set)
+ mom3 = momenta((/l1,l1,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l1, l2, b_set)
+ mom3 = momenta((/l1,l1,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l1, l3, b_set)
+ mom3 = momenta((/l1,l1,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l1, l4, b_set)
+ mom3 = momenta((/l1,l1,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l1, l5, b_set)
+ mom3 = momenta((/l1,l2,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l2, l2, b_set)
+ mom3 = momenta((/l1,l2,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l2, l3, b_set)
+ mom3 = momenta((/l1,l2,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l2, l4, b_set)
+ mom3 = momenta((/l1,l2,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l2, l5, b_set)
+ mom3 = momenta((/l1,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l3, l3, b_set)
+ mom3 = momenta((/l1,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l3, l4, b_set)
+ mom3 = momenta((/l1,l3,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l3, l5, b_set)
+ mom3 = momenta((/l1,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l4, l4, b_set)
+ mom3 = momenta((/l1,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l4, l5, b_set)
+ mom3 = momenta((/l1,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l1, l5, l5, b_set)
+ mom3 = momenta((/l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a53(l2, l2, l2, b_set)
+ mom3 = momenta((/l2,l2,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l2, l2, l3, b_set)
+ mom3 = momenta((/l2,l2,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l2, l2, l4, b_set)
+ mom3 = momenta((/l2,l2,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l2, l2, l5, b_set)
+ mom3 = momenta((/l2,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l2, l3, l3, b_set)
+ mom3 = momenta((/l2,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l2, l3, l4, b_set)
+ mom3 = momenta((/l2,l3,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l2, l3, l5, b_set)
+ mom3 = momenta((/l2,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l2, l4, l4, b_set)
+ mom3 = momenta((/l2,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l2, l4, l5, b_set)
+ mom3 = momenta((/l2,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l2, l5, l5, b_set)
+ mom3 = momenta((/l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a53(l3, l3, l3, b_set)
+ mom3 = momenta((/l3,l3,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l3, l3, l4, b_set)
+ mom3 = momenta((/l3,l3,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l3, l3, l5, b_set)
+ mom3 = momenta((/l3,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l3, l4, l4, b_set)
+ mom3 = momenta((/l3,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l3, l4, l5, b_set)
+ mom3 = momenta((/l3,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l3, l5, l5, b_set)
+ mom3 = momenta((/l4,l4,l4/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a53(l4, l4, l4, b_set)
+ mom3 = momenta((/l4,l4,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l4, l4, l5, b_set)
+ mom3 = momenta((/l4,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_3(coeffs, mom3) &
+ & * a53(l4, l5, l5, b_set)
+ mom3 = momenta((/l5,l5,l5/),:)
+ amp = amp + contract_a_tensor_3(coeffs, mom3) * a53(l5, l5, l5, b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b53(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b53(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b53(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b53(l4, b_set)
+ mom1 = momenta((/l5/),:)
+ amp = amp + contract_b_tensor_3(coeffs, mom1) * b53(l5, b_set)
+end function contract5_3
+!****f* src/interface/tens_comb/contract5_4
+! NAME
+!
+! Function contract5_4
+!
+! USAGE
+!
+! amp = contract5_4(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 5-point rank 4 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_4)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract5_4(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_4), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ real(ki), dimension(3,0:3) :: mom3
+ real(ki), dimension(4,0:3) :: mom4
+ integer :: l1, l2, l3, l4, l5
+ integer, dimension(5) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 5)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ l5 = unpinched(5)
+ amp = coeffs%c0 * a50(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom1) * a51(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom1) * a51(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom1) * a51(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom1) * a51(l4, b_set)
+ mom1 = momenta((/l5/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom1) * a51(l5, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom2) * a52(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l1, l4, b_set)
+ mom2 = momenta((/l1,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l1, l5, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom2) * a52(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l2, l4, b_set)
+ mom2 = momenta((/l2,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l2, l5, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom2) * a52(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l3, l4, b_set)
+ mom2 = momenta((/l3,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l3, l5, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom2) * a52(l4, l4, b_set)
+ mom2 = momenta((/l4,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_4(coeffs, mom2) * a52(l4, l5, b_set)
+ mom2 = momenta((/l5,l5/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom2) * a52(l5, l5, b_set)
+ amp = amp + contract_b_tensor_4(coeffs) * b52(b_set)
+ mom3 = momenta((/l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom3) * a53(l1, l1, l1, b_set)
+ mom3 = momenta((/l1,l1,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l1, l2, b_set)
+ mom3 = momenta((/l1,l1,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l1, l3, b_set)
+ mom3 = momenta((/l1,l1,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l1, l4, b_set)
+ mom3 = momenta((/l1,l1,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l1, l5, b_set)
+ mom3 = momenta((/l1,l2,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l2, l2, b_set)
+ mom3 = momenta((/l1,l2,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l2, l3, b_set)
+ mom3 = momenta((/l1,l2,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l2, l4, b_set)
+ mom3 = momenta((/l1,l2,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l2, l5, b_set)
+ mom3 = momenta((/l1,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l3, l3, b_set)
+ mom3 = momenta((/l1,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l3, l4, b_set)
+ mom3 = momenta((/l1,l3,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l3, l5, b_set)
+ mom3 = momenta((/l1,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l4, l4, b_set)
+ mom3 = momenta((/l1,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l4, l5, b_set)
+ mom3 = momenta((/l1,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l1, l5, l5, b_set)
+ mom3 = momenta((/l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom3) * a53(l2, l2, l2, b_set)
+ mom3 = momenta((/l2,l2,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l2, l2, l3, b_set)
+ mom3 = momenta((/l2,l2,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l2, l2, l4, b_set)
+ mom3 = momenta((/l2,l2,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l2, l2, l5, b_set)
+ mom3 = momenta((/l2,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l2, l3, l3, b_set)
+ mom3 = momenta((/l2,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l2, l3, l4, b_set)
+ mom3 = momenta((/l2,l3,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l2, l3, l5, b_set)
+ mom3 = momenta((/l2,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l2, l4, l4, b_set)
+ mom3 = momenta((/l2,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l2, l4, l5, b_set)
+ mom3 = momenta((/l2,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l2, l5, l5, b_set)
+ mom3 = momenta((/l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom3) * a53(l3, l3, l3, b_set)
+ mom3 = momenta((/l3,l3,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l3, l3, l4, b_set)
+ mom3 = momenta((/l3,l3,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l3, l3, l5, b_set)
+ mom3 = momenta((/l3,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l3, l4, l4, b_set)
+ mom3 = momenta((/l3,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l3, l4, l5, b_set)
+ mom3 = momenta((/l3,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l3, l5, l5, b_set)
+ mom3 = momenta((/l4,l4,l4/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom3) * a53(l4, l4, l4, b_set)
+ mom3 = momenta((/l4,l4,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l4, l4, l5, b_set)
+ mom3 = momenta((/l4,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_4(coeffs, mom3) &
+ & * a53(l4, l5, l5, b_set)
+ mom3 = momenta((/l5,l5,l5/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom3) * a53(l5, l5, l5, b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom1) * b53(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom1) * b53(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom1) * b53(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom1) * b53(l4, b_set)
+ mom1 = momenta((/l5/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom1) * b53(l5, b_set)
+ mom4 = momenta((/l1,l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom4) * a54(l1, l1, l1, l1, b_set)
+ mom4 = momenta((/l1,l1,l1,l2/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l1, l2, b_set)
+ mom4 = momenta((/l1,l1,l1,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l1, l3, b_set)
+ mom4 = momenta((/l1,l1,l1,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l1, l4, b_set)
+ mom4 = momenta((/l1,l1,l1,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l1, l5, b_set)
+ mom4 = momenta((/l1,l1,l2,l2/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l2, l2, b_set)
+ mom4 = momenta((/l1,l1,l2,l3/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l2, l3, b_set)
+ mom4 = momenta((/l1,l1,l2,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l2, l4, b_set)
+ mom4 = momenta((/l1,l1,l2,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l2, l5, b_set)
+ mom4 = momenta((/l1,l1,l3,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l3, l3, b_set)
+ mom4 = momenta((/l1,l1,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l3, l4, b_set)
+ mom4 = momenta((/l1,l1,l3,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l3, l5, b_set)
+ mom4 = momenta((/l1,l1,l4,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l4, l4, b_set)
+ mom4 = momenta((/l1,l1,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l4, l5, b_set)
+ mom4 = momenta((/l1,l1,l5,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l1, l5, l5, b_set)
+ mom4 = momenta((/l1,l2,l2,l2/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l2, l2, b_set)
+ mom4 = momenta((/l1,l2,l2,l3/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l2, l3, b_set)
+ mom4 = momenta((/l1,l2,l2,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l2, l4, b_set)
+ mom4 = momenta((/l1,l2,l2,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l2, l5, b_set)
+ mom4 = momenta((/l1,l2,l3,l3/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l3, l3, b_set)
+ mom4 = momenta((/l1,l2,l3,l4/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l3, l4, b_set)
+ mom4 = momenta((/l1,l2,l3,l5/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l3, l5, b_set)
+ mom4 = momenta((/l1,l2,l4,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l4, l4, b_set)
+ mom4 = momenta((/l1,l2,l4,l5/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l4, l5, b_set)
+ mom4 = momenta((/l1,l2,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l2, l5, l5, b_set)
+ mom4 = momenta((/l1,l3,l3,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l3, l3, l3, b_set)
+ mom4 = momenta((/l1,l3,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l3, l3, l4, b_set)
+ mom4 = momenta((/l1,l3,l3,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l3, l3, l5, b_set)
+ mom4 = momenta((/l1,l3,l4,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l3, l4, l4, b_set)
+ mom4 = momenta((/l1,l3,l4,l5/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l3, l4, l5, b_set)
+ mom4 = momenta((/l1,l3,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l3, l5, l5, b_set)
+ mom4 = momenta((/l1,l4,l4,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l4, l4, l4, b_set)
+ mom4 = momenta((/l1,l4,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l4, l4, l5, b_set)
+ mom4 = momenta((/l1,l4,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l4, l5, l5, b_set)
+ mom4 = momenta((/l1,l5,l5,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l1, l5, l5, l5, b_set)
+ mom4 = momenta((/l2,l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom4) * a54(l2, l2, l2, l2, b_set)
+ mom4 = momenta((/l2,l2,l2,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l2, l2, l3, b_set)
+ mom4 = momenta((/l2,l2,l2,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l2, l2, l4, b_set)
+ mom4 = momenta((/l2,l2,l2,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l2, l2, l5, b_set)
+ mom4 = momenta((/l2,l2,l3,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l2, l3, l3, b_set)
+ mom4 = momenta((/l2,l2,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l2, l3, l4, b_set)
+ mom4 = momenta((/l2,l2,l3,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l2, l3, l5, b_set)
+ mom4 = momenta((/l2,l2,l4,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l2, l4, l4, b_set)
+ mom4 = momenta((/l2,l2,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l2, l4, l5, b_set)
+ mom4 = momenta((/l2,l2,l5,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l2, l5, l5, b_set)
+ mom4 = momenta((/l2,l3,l3,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l3, l3, l3, b_set)
+ mom4 = momenta((/l2,l3,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l3, l3, l4, b_set)
+ mom4 = momenta((/l2,l3,l3,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l3, l3, l5, b_set)
+ mom4 = momenta((/l2,l3,l4,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l3, l4, l4, b_set)
+ mom4 = momenta((/l2,l3,l4,l5/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l3, l4, l5, b_set)
+ mom4 = momenta((/l2,l3,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l3, l5, l5, b_set)
+ mom4 = momenta((/l2,l4,l4,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l4, l4, l4, b_set)
+ mom4 = momenta((/l2,l4,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l4, l4, l5, b_set)
+ mom4 = momenta((/l2,l4,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l4, l5, l5, b_set)
+ mom4 = momenta((/l2,l5,l5,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l2, l5, l5, l5, b_set)
+ mom4 = momenta((/l3,l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom4) * a54(l3, l3, l3, l3, b_set)
+ mom4 = momenta((/l3,l3,l3,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l3, l3, l3, l4, b_set)
+ mom4 = momenta((/l3,l3,l3,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l3, l3, l3, l5, b_set)
+ mom4 = momenta((/l3,l3,l4,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l3, l3, l4, l4, b_set)
+ mom4 = momenta((/l3,l3,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l3, l3, l4, l5, b_set)
+ mom4 = momenta((/l3,l3,l5,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l3, l3, l5, l5, b_set)
+ mom4 = momenta((/l3,l4,l4,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l3, l4, l4, l4, b_set)
+ mom4 = momenta((/l3,l4,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l3, l4, l4, l5, b_set)
+ mom4 = momenta((/l3,l4,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l3, l4, l5, l5, b_set)
+ mom4 = momenta((/l3,l5,l5,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l3, l5, l5, l5, b_set)
+ mom4 = momenta((/l4,l4,l4,l4/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom4) * a54(l4, l4, l4, l4, b_set)
+ mom4 = momenta((/l4,l4,l4,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l4, l4, l4, l5, b_set)
+ mom4 = momenta((/l4,l4,l5,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l4, l4, l5, l5, b_set)
+ mom4 = momenta((/l4,l5,l5,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_4(coeffs, mom4) &
+ & * a54(l4, l5, l5, l5, b_set)
+ mom4 = momenta((/l5,l5,l5,l5/),:)
+ amp = amp + contract_a_tensor_4(coeffs, mom4) * a54(l5, l5, l5, l5, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom2) * b54(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l1, l4, b_set)
+ mom2 = momenta((/l1,l5/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l1, l5, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom2) * b54(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l2, l4, b_set)
+ mom2 = momenta((/l2,l5/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l2, l5, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom2) * b54(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l3, l4, b_set)
+ mom2 = momenta((/l3,l5/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l3, l5, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom2) * b54(l4, l4, b_set)
+ mom2 = momenta((/l4,l5/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_4(coeffs, mom2) * b54(l4, l5, b_set)
+ mom2 = momenta((/l5,l5/),:)
+ amp = amp + contract_b_tensor_4(coeffs, mom2) * b54(l5, l5, b_set)
+ amp = amp + contract_c_tensor_4(coeffs) * c54(b_set)
+end function contract5_4
+!****f* src/interface/tens_comb/contract5_5
+! NAME
+!
+! Function contract5_5
+!
+! USAGE
+!
+! amp = contract5_5(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 5-point rank 5 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_5)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract5_5(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_5), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_simple
+ real(ki), dimension(1,0:3) :: mom1
+ real(ki), dimension(2,0:3) :: mom2
+ real(ki), dimension(3,0:3) :: mom3
+ real(ki), dimension(4,0:3) :: mom4
+ real(ki), dimension(5,0:3) :: mom5
+ integer :: l1, l2, l3, l4, l5
+ integer, dimension(5) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 5)
+ l1 = unpinched(1)
+ l2 = unpinched(2)
+ l3 = unpinched(3)
+ l4 = unpinched(4)
+ l5 = unpinched(5)
+ amp = coeffs%c0 * a50(b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom1) * a51(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom1) * a51(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom1) * a51(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom1) * a51(l4, b_set)
+ mom1 = momenta((/l5/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom1) * a51(l5, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom2) * a52(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l1, l4, b_set)
+ mom2 = momenta((/l1,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l1, l5, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom2) * a52(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l2, l4, b_set)
+ mom2 = momenta((/l2,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l2, l5, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom2) * a52(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l3, l4, b_set)
+ mom2 = momenta((/l3,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l3, l5, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom2) * a52(l4, l4, b_set)
+ mom2 = momenta((/l4,l5/),:)
+ amp = amp + 2.0_ki * contract_a_tensor_5(coeffs, mom2) * a52(l4, l5, b_set)
+ mom2 = momenta((/l5,l5/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom2) * a52(l5, l5, b_set)
+ amp = amp + contract_b_tensor_5(coeffs) * b52(b_set)
+ mom3 = momenta((/l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom3) * a53(l1, l1, l1, b_set)
+ mom3 = momenta((/l1,l1,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l1, l2, b_set)
+ mom3 = momenta((/l1,l1,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l1, l3, b_set)
+ mom3 = momenta((/l1,l1,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l1, l4, b_set)
+ mom3 = momenta((/l1,l1,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l1, l5, b_set)
+ mom3 = momenta((/l1,l2,l2/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l2, l2, b_set)
+ mom3 = momenta((/l1,l2,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l2, l3, b_set)
+ mom3 = momenta((/l1,l2,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l2, l4, b_set)
+ mom3 = momenta((/l1,l2,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l2, l5, b_set)
+ mom3 = momenta((/l1,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l3, l3, b_set)
+ mom3 = momenta((/l1,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l3, l4, b_set)
+ mom3 = momenta((/l1,l3,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l3, l5, b_set)
+ mom3 = momenta((/l1,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l4, l4, b_set)
+ mom3 = momenta((/l1,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l4, l5, b_set)
+ mom3 = momenta((/l1,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l1, l5, l5, b_set)
+ mom3 = momenta((/l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom3) * a53(l2, l2, l2, b_set)
+ mom3 = momenta((/l2,l2,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l2, l2, l3, b_set)
+ mom3 = momenta((/l2,l2,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l2, l2, l4, b_set)
+ mom3 = momenta((/l2,l2,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l2, l2, l5, b_set)
+ mom3 = momenta((/l2,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l2, l3, l3, b_set)
+ mom3 = momenta((/l2,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l2, l3, l4, b_set)
+ mom3 = momenta((/l2,l3,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l2, l3, l5, b_set)
+ mom3 = momenta((/l2,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l2, l4, l4, b_set)
+ mom3 = momenta((/l2,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l2, l4, l5, b_set)
+ mom3 = momenta((/l2,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l2, l5, l5, b_set)
+ mom3 = momenta((/l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom3) * a53(l3, l3, l3, b_set)
+ mom3 = momenta((/l3,l3,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l3, l3, l4, b_set)
+ mom3 = momenta((/l3,l3,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l3, l3, l5, b_set)
+ mom3 = momenta((/l3,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l3, l4, l4, b_set)
+ mom3 = momenta((/l3,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l3, l4, l5, b_set)
+ mom3 = momenta((/l3,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l3, l5, l5, b_set)
+ mom3 = momenta((/l4,l4,l4/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom3) * a53(l4, l4, l4, b_set)
+ mom3 = momenta((/l4,l4,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l4, l4, l5, b_set)
+ mom3 = momenta((/l4,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_a_tensor_5(coeffs, mom3) &
+ & * a53(l4, l5, l5, b_set)
+ mom3 = momenta((/l5,l5,l5/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom3) * a53(l5, l5, l5, b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom1) * b53(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom1) * b53(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom1) * b53(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom1) * b53(l4, b_set)
+ mom1 = momenta((/l5/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom1) * b53(l5, b_set)
+ mom4 = momenta((/l1,l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom4) * a54(l1, l1, l1, l1, b_set)
+ mom4 = momenta((/l1,l1,l1,l2/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l1, l2, b_set)
+ mom4 = momenta((/l1,l1,l1,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l1, l3, b_set)
+ mom4 = momenta((/l1,l1,l1,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l1, l4, b_set)
+ mom4 = momenta((/l1,l1,l1,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l1, l5, b_set)
+ mom4 = momenta((/l1,l1,l2,l2/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l2, l2, b_set)
+ mom4 = momenta((/l1,l1,l2,l3/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l2, l3, b_set)
+ mom4 = momenta((/l1,l1,l2,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l2, l4, b_set)
+ mom4 = momenta((/l1,l1,l2,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l2, l5, b_set)
+ mom4 = momenta((/l1,l1,l3,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l3, l3, b_set)
+ mom4 = momenta((/l1,l1,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l3, l4, b_set)
+ mom4 = momenta((/l1,l1,l3,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l3, l5, b_set)
+ mom4 = momenta((/l1,l1,l4,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l4, l4, b_set)
+ mom4 = momenta((/l1,l1,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l4, l5, b_set)
+ mom4 = momenta((/l1,l1,l5,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l1, l5, l5, b_set)
+ mom4 = momenta((/l1,l2,l2,l2/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l2, l2, b_set)
+ mom4 = momenta((/l1,l2,l2,l3/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l2, l3, b_set)
+ mom4 = momenta((/l1,l2,l2,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l2, l4, b_set)
+ mom4 = momenta((/l1,l2,l2,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l2, l5, b_set)
+ mom4 = momenta((/l1,l2,l3,l3/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l3, l3, b_set)
+ mom4 = momenta((/l1,l2,l3,l4/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l3, l4, b_set)
+ mom4 = momenta((/l1,l2,l3,l5/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l3, l5, b_set)
+ mom4 = momenta((/l1,l2,l4,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l4, l4, b_set)
+ mom4 = momenta((/l1,l2,l4,l5/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l4, l5, b_set)
+ mom4 = momenta((/l1,l2,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l2, l5, l5, b_set)
+ mom4 = momenta((/l1,l3,l3,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l3, l3, l3, b_set)
+ mom4 = momenta((/l1,l3,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l3, l3, l4, b_set)
+ mom4 = momenta((/l1,l3,l3,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l3, l3, l5, b_set)
+ mom4 = momenta((/l1,l3,l4,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l3, l4, l4, b_set)
+ mom4 = momenta((/l1,l3,l4,l5/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l3, l4, l5, b_set)
+ mom4 = momenta((/l1,l3,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l3, l5, l5, b_set)
+ mom4 = momenta((/l1,l4,l4,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l4, l4, l4, b_set)
+ mom4 = momenta((/l1,l4,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l4, l4, l5, b_set)
+ mom4 = momenta((/l1,l4,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l4, l5, l5, b_set)
+ mom4 = momenta((/l1,l5,l5,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l1, l5, l5, l5, b_set)
+ mom4 = momenta((/l2,l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom4) * a54(l2, l2, l2, l2, b_set)
+ mom4 = momenta((/l2,l2,l2,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l2, l2, l3, b_set)
+ mom4 = momenta((/l2,l2,l2,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l2, l2, l4, b_set)
+ mom4 = momenta((/l2,l2,l2,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l2, l2, l5, b_set)
+ mom4 = momenta((/l2,l2,l3,l3/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l2, l3, l3, b_set)
+ mom4 = momenta((/l2,l2,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l2, l3, l4, b_set)
+ mom4 = momenta((/l2,l2,l3,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l2, l3, l5, b_set)
+ mom4 = momenta((/l2,l2,l4,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l2, l4, l4, b_set)
+ mom4 = momenta((/l2,l2,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l2, l4, l5, b_set)
+ mom4 = momenta((/l2,l2,l5,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l2, l5, l5, b_set)
+ mom4 = momenta((/l2,l3,l3,l3/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l3, l3, l3, b_set)
+ mom4 = momenta((/l2,l3,l3,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l3, l3, l4, b_set)
+ mom4 = momenta((/l2,l3,l3,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l3, l3, l5, b_set)
+ mom4 = momenta((/l2,l3,l4,l4/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l3, l4, l4, b_set)
+ mom4 = momenta((/l2,l3,l4,l5/),:)
+ amp = amp + 24.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l3, l4, l5, b_set)
+ mom4 = momenta((/l2,l3,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l3, l5, l5, b_set)
+ mom4 = momenta((/l2,l4,l4,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l4, l4, l4, b_set)
+ mom4 = momenta((/l2,l4,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l4, l4, l5, b_set)
+ mom4 = momenta((/l2,l4,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l4, l5, l5, b_set)
+ mom4 = momenta((/l2,l5,l5,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l2, l5, l5, l5, b_set)
+ mom4 = momenta((/l3,l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom4) * a54(l3, l3, l3, l3, b_set)
+ mom4 = momenta((/l3,l3,l3,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l3, l3, l3, l4, b_set)
+ mom4 = momenta((/l3,l3,l3,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l3, l3, l3, l5, b_set)
+ mom4 = momenta((/l3,l3,l4,l4/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l3, l3, l4, l4, b_set)
+ mom4 = momenta((/l3,l3,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l3, l3, l4, l5, b_set)
+ mom4 = momenta((/l3,l3,l5,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l3, l3, l5, l5, b_set)
+ mom4 = momenta((/l3,l4,l4,l4/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l3, l4, l4, l4, b_set)
+ mom4 = momenta((/l3,l4,l4,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l3, l4, l4, l5, b_set)
+ mom4 = momenta((/l3,l4,l5,l5/),:)
+ amp = amp + 12.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l3, l4, l5, l5, b_set)
+ mom4 = momenta((/l3,l5,l5,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l3, l5, l5, l5, b_set)
+ mom4 = momenta((/l4,l4,l4,l4/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom4) * a54(l4, l4, l4, l4, b_set)
+ mom4 = momenta((/l4,l4,l4,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l4, l4, l4, l5, b_set)
+ mom4 = momenta((/l4,l4,l5,l5/),:)
+ amp = amp + 6.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l4, l4, l5, l5, b_set)
+ mom4 = momenta((/l4,l5,l5,l5/),:)
+ amp = amp + 4.0_ki * contract_a_tensor_5(coeffs, mom4) &
+ & * a54(l4, l5, l5, l5, b_set)
+ mom4 = momenta((/l5,l5,l5,l5/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom4) * a54(l5, l5, l5, l5, b_set)
+ mom2 = momenta((/l1,l1/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom2) * b54(l1, l1, b_set)
+ mom2 = momenta((/l1,l2/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l1, l2, b_set)
+ mom2 = momenta((/l1,l3/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l1, l3, b_set)
+ mom2 = momenta((/l1,l4/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l1, l4, b_set)
+ mom2 = momenta((/l1,l5/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l1, l5, b_set)
+ mom2 = momenta((/l2,l2/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom2) * b54(l2, l2, b_set)
+ mom2 = momenta((/l2,l3/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l2, l3, b_set)
+ mom2 = momenta((/l2,l4/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l2, l4, b_set)
+ mom2 = momenta((/l2,l5/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l2, l5, b_set)
+ mom2 = momenta((/l3,l3/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom2) * b54(l3, l3, b_set)
+ mom2 = momenta((/l3,l4/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l3, l4, b_set)
+ mom2 = momenta((/l3,l5/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l3, l5, b_set)
+ mom2 = momenta((/l4,l4/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom2) * b54(l4, l4, b_set)
+ mom2 = momenta((/l4,l5/),:)
+ amp = amp + 2.0_ki * contract_b_tensor_5(coeffs, mom2) * b54(l4, l5, b_set)
+ mom2 = momenta((/l5,l5/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom2) * b54(l5, l5, b_set)
+ amp = amp + contract_c_tensor_5(coeffs) * c54(b_set)
+ mom5 = momenta((/l1,l1,l1,l1,l1/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l1, l1, b_set)
+ mom5 = momenta((/l1,l1,l1,l1,l2/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l1, l2, b_set)
+ mom5 = momenta((/l1,l1,l1,l1,l3/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l1, l3, b_set)
+ mom5 = momenta((/l1,l1,l1,l1,l4/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l1, l4, b_set)
+ mom5 = momenta((/l1,l1,l1,l1,l5/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l1, l5, b_set)
+ mom5 = momenta((/l1,l1,l1,l2,l2/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l2, l2, b_set)
+ mom5 = momenta((/l1,l1,l1,l2,l3/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l2, l3, b_set)
+ mom5 = momenta((/l1,l1,l1,l2,l4/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l2, l4, b_set)
+ mom5 = momenta((/l1,l1,l1,l2,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l2, l5, b_set)
+ mom5 = momenta((/l1,l1,l1,l3,l3/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l3, l3, b_set)
+ mom5 = momenta((/l1,l1,l1,l3,l4/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l3, l4, b_set)
+ mom5 = momenta((/l1,l1,l1,l3,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l3, l5, b_set)
+ mom5 = momenta((/l1,l1,l1,l4,l4/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l4, l4, b_set)
+ mom5 = momenta((/l1,l1,l1,l4,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l4, l5, b_set)
+ mom5 = momenta((/l1,l1,l1,l5,l5/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l1, l5, l5, b_set)
+ mom5 = momenta((/l1,l1,l2,l2,l2/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l2, l2, b_set)
+ mom5 = momenta((/l1,l1,l2,l2,l3/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l2, l3, b_set)
+ mom5 = momenta((/l1,l1,l2,l2,l4/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l2, l4, b_set)
+ mom5 = momenta((/l1,l1,l2,l2,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l2, l5, b_set)
+ mom5 = momenta((/l1,l1,l2,l3,l3/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l3, l3, b_set)
+ mom5 = momenta((/l1,l1,l2,l3,l4/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l3, l4, b_set)
+ mom5 = momenta((/l1,l1,l2,l3,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l3, l5, b_set)
+ mom5 = momenta((/l1,l1,l2,l4,l4/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l4, l4, b_set)
+ mom5 = momenta((/l1,l1,l2,l4,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l4, l5, b_set)
+ mom5 = momenta((/l1,l1,l2,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l2, l5, l5, b_set)
+ mom5 = momenta((/l1,l1,l3,l3,l3/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l3, l3, l3, b_set)
+ mom5 = momenta((/l1,l1,l3,l3,l4/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l3, l3, l4, b_set)
+ mom5 = momenta((/l1,l1,l3,l3,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l3, l3, l5, b_set)
+ mom5 = momenta((/l1,l1,l3,l4,l4/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l3, l4, l4, b_set)
+ mom5 = momenta((/l1,l1,l3,l4,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l3, l4, l5, b_set)
+ mom5 = momenta((/l1,l1,l3,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l3, l5, l5, b_set)
+ mom5 = momenta((/l1,l1,l4,l4,l4/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l4, l4, l4, b_set)
+ mom5 = momenta((/l1,l1,l4,l4,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l4, l4, l5, b_set)
+ mom5 = momenta((/l1,l1,l4,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l4, l5, l5, b_set)
+ mom5 = momenta((/l1,l1,l5,l5,l5/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l1, l5, l5, l5, b_set)
+ mom5 = momenta((/l1,l2,l2,l2,l2/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l2, l2, b_set)
+ mom5 = momenta((/l1,l2,l2,l2,l3/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l2, l3, b_set)
+ mom5 = momenta((/l1,l2,l2,l2,l4/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l2, l4, b_set)
+ mom5 = momenta((/l1,l2,l2,l2,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l2, l5, b_set)
+ mom5 = momenta((/l1,l2,l2,l3,l3/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l3, l3, b_set)
+ mom5 = momenta((/l1,l2,l2,l3,l4/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l3, l4, b_set)
+ mom5 = momenta((/l1,l2,l2,l3,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l3, l5, b_set)
+ mom5 = momenta((/l1,l2,l2,l4,l4/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l4, l4, b_set)
+ mom5 = momenta((/l1,l2,l2,l4,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l4, l5, b_set)
+ mom5 = momenta((/l1,l2,l2,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l2, l5, l5, b_set)
+ mom5 = momenta((/l1,l2,l3,l3,l3/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l3, l3, l3, b_set)
+ mom5 = momenta((/l1,l2,l3,l3,l4/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l3, l3, l4, b_set)
+ mom5 = momenta((/l1,l2,l3,l3,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l3, l3, l5, b_set)
+ mom5 = momenta((/l1,l2,l3,l4,l4/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l3, l4, l4, b_set)
+ mom5 = momenta((/l1,l2,l3,l4,l5/),:)
+ amp = amp + 120.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l3, l4, l5, b_set)
+ mom5 = momenta((/l1,l2,l3,l5,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l3, l5, l5, b_set)
+ mom5 = momenta((/l1,l2,l4,l4,l4/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l4, l4, l4, b_set)
+ mom5 = momenta((/l1,l2,l4,l4,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l4, l4, l5, b_set)
+ mom5 = momenta((/l1,l2,l4,l5,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l4, l5, l5, b_set)
+ mom5 = momenta((/l1,l2,l5,l5,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l2, l5, l5, l5, b_set)
+ mom5 = momenta((/l1,l3,l3,l3,l3/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l3, l3, l3, b_set)
+ mom5 = momenta((/l1,l3,l3,l3,l4/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l3, l3, l4, b_set)
+ mom5 = momenta((/l1,l3,l3,l3,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l3, l3, l5, b_set)
+ mom5 = momenta((/l1,l3,l3,l4,l4/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l3, l4, l4, b_set)
+ mom5 = momenta((/l1,l3,l3,l4,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l3, l4, l5, b_set)
+ mom5 = momenta((/l1,l3,l3,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l3, l5, l5, b_set)
+ mom5 = momenta((/l1,l3,l4,l4,l4/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l4, l4, l4, b_set)
+ mom5 = momenta((/l1,l3,l4,l4,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l4, l4, l5, b_set)
+ mom5 = momenta((/l1,l3,l4,l5,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l4, l5, l5, b_set)
+ mom5 = momenta((/l1,l3,l5,l5,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l3, l5, l5, l5, b_set)
+ mom5 = momenta((/l1,l4,l4,l4,l4/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l4, l4, l4, l4, b_set)
+ mom5 = momenta((/l1,l4,l4,l4,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l4, l4, l4, l5, b_set)
+ mom5 = momenta((/l1,l4,l4,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l4, l4, l5, l5, b_set)
+ mom5 = momenta((/l1,l4,l5,l5,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l4, l5, l5, l5, b_set)
+ mom5 = momenta((/l1,l5,l5,l5,l5/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l1, l5, l5, l5, l5, b_set)
+ mom5 = momenta((/l2,l2,l2,l2,l2/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l2, l2, b_set)
+ mom5 = momenta((/l2,l2,l2,l2,l3/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l2, l3, b_set)
+ mom5 = momenta((/l2,l2,l2,l2,l4/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l2, l4, b_set)
+ mom5 = momenta((/l2,l2,l2,l2,l5/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l2, l5, b_set)
+ mom5 = momenta((/l2,l2,l2,l3,l3/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l3, l3, b_set)
+ mom5 = momenta((/l2,l2,l2,l3,l4/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l3, l4, b_set)
+ mom5 = momenta((/l2,l2,l2,l3,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l3, l5, b_set)
+ mom5 = momenta((/l2,l2,l2,l4,l4/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l4, l4, b_set)
+ mom5 = momenta((/l2,l2,l2,l4,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l4, l5, b_set)
+ mom5 = momenta((/l2,l2,l2,l5,l5/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l2, l5, l5, b_set)
+ mom5 = momenta((/l2,l2,l3,l3,l3/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l3, l3, l3, b_set)
+ mom5 = momenta((/l2,l2,l3,l3,l4/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l3, l3, l4, b_set)
+ mom5 = momenta((/l2,l2,l3,l3,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l3, l3, l5, b_set)
+ mom5 = momenta((/l2,l2,l3,l4,l4/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l3, l4, l4, b_set)
+ mom5 = momenta((/l2,l2,l3,l4,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l3, l4, l5, b_set)
+ mom5 = momenta((/l2,l2,l3,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l3, l5, l5, b_set)
+ mom5 = momenta((/l2,l2,l4,l4,l4/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l4, l4, l4, b_set)
+ mom5 = momenta((/l2,l2,l4,l4,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l4, l4, l5, b_set)
+ mom5 = momenta((/l2,l2,l4,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l4, l5, l5, b_set)
+ mom5 = momenta((/l2,l2,l5,l5,l5/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l2, l5, l5, l5, b_set)
+ mom5 = momenta((/l2,l3,l3,l3,l3/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l3, l3, l3, b_set)
+ mom5 = momenta((/l2,l3,l3,l3,l4/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l3, l3, l4, b_set)
+ mom5 = momenta((/l2,l3,l3,l3,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l3, l3, l5, b_set)
+ mom5 = momenta((/l2,l3,l3,l4,l4/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l3, l4, l4, b_set)
+ mom5 = momenta((/l2,l3,l3,l4,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l3, l4, l5, b_set)
+ mom5 = momenta((/l2,l3,l3,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l3, l5, l5, b_set)
+ mom5 = momenta((/l2,l3,l4,l4,l4/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l4, l4, l4, b_set)
+ mom5 = momenta((/l2,l3,l4,l4,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l4, l4, l5, b_set)
+ mom5 = momenta((/l2,l3,l4,l5,l5/),:)
+ amp = amp + 60.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l4, l5, l5, b_set)
+ mom5 = momenta((/l2,l3,l5,l5,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l3, l5, l5, l5, b_set)
+ mom5 = momenta((/l2,l4,l4,l4,l4/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l4, l4, l4, l4, b_set)
+ mom5 = momenta((/l2,l4,l4,l4,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l4, l4, l4, l5, b_set)
+ mom5 = momenta((/l2,l4,l4,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l4, l4, l5, l5, b_set)
+ mom5 = momenta((/l2,l4,l5,l5,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l4, l5, l5, l5, b_set)
+ mom5 = momenta((/l2,l5,l5,l5,l5/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l2, l5, l5, l5, l5, b_set)
+ mom5 = momenta((/l3,l3,l3,l3,l3/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l3, l3, l3, b_set)
+ mom5 = momenta((/l3,l3,l3,l3,l4/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l3, l3, l4, b_set)
+ mom5 = momenta((/l3,l3,l3,l3,l5/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l3, l3, l5, b_set)
+ mom5 = momenta((/l3,l3,l3,l4,l4/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l3, l4, l4, b_set)
+ mom5 = momenta((/l3,l3,l3,l4,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l3, l4, l5, b_set)
+ mom5 = momenta((/l3,l3,l3,l5,l5/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l3, l5, l5, b_set)
+ mom5 = momenta((/l3,l3,l4,l4,l4/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l4, l4, l4, b_set)
+ mom5 = momenta((/l3,l3,l4,l4,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l4, l4, l5, b_set)
+ mom5 = momenta((/l3,l3,l4,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l4, l5, l5, b_set)
+ mom5 = momenta((/l3,l3,l5,l5,l5/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l3, l5, l5, l5, b_set)
+ mom5 = momenta((/l3,l4,l4,l4,l4/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l4, l4, l4, l4, b_set)
+ mom5 = momenta((/l3,l4,l4,l4,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l4, l4, l4, l5, b_set)
+ mom5 = momenta((/l3,l4,l4,l5,l5/),:)
+ amp = amp + 30.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l4, l4, l5, l5, b_set)
+ mom5 = momenta((/l3,l4,l5,l5,l5/),:)
+ amp = amp + 20.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l4, l5, l5, l5, b_set)
+ mom5 = momenta((/l3,l5,l5,l5,l5/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l3, l5, l5, l5, l5, b_set)
+ mom5 = momenta((/l4,l4,l4,l4,l4/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l4, l4, l4, l4, l4, b_set)
+ mom5 = momenta((/l4,l4,l4,l4,l5/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l4, l4, l4, l4, l5, b_set)
+ mom5 = momenta((/l4,l4,l4,l5,l5/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l4, l4, l4, l5, l5, b_set)
+ mom5 = momenta((/l4,l4,l5,l5,l5/),:)
+ amp = amp + 10.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l4, l4, l5, l5, l5, b_set)
+ mom5 = momenta((/l4,l5,l5,l5,l5/),:)
+ amp = amp + 5.0_ki * contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l4, l5, l5, l5, l5, b_set)
+ mom5 = momenta((/l5,l5,l5,l5,l5/),:)
+ amp = amp + contract_a_tensor_5(coeffs, mom5) &
+ & * a55(l5, l5, l5, l5, l5, b_set)
+ mom3 = momenta((/l1,l1,l1/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom3) * b55(l1, l1, l1, b_set)
+ mom3 = momenta((/l1,l1,l2/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l1, l2, b_set)
+ mom3 = momenta((/l1,l1,l3/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l1, l3, b_set)
+ mom3 = momenta((/l1,l1,l4/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l1, l4, b_set)
+ mom3 = momenta((/l1,l1,l5/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l1, l5, b_set)
+ mom3 = momenta((/l1,l2,l2/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l2, l2, b_set)
+ mom3 = momenta((/l1,l2,l3/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l2, l3, b_set)
+ mom3 = momenta((/l1,l2,l4/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l2, l4, b_set)
+ mom3 = momenta((/l1,l2,l5/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l2, l5, b_set)
+ mom3 = momenta((/l1,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l3, l3, b_set)
+ mom3 = momenta((/l1,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l3, l4, b_set)
+ mom3 = momenta((/l1,l3,l5/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l3, l5, b_set)
+ mom3 = momenta((/l1,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l4, l4, b_set)
+ mom3 = momenta((/l1,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l4, l5, b_set)
+ mom3 = momenta((/l1,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l1, l5, l5, b_set)
+ mom3 = momenta((/l2,l2,l2/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom3) * b55(l2, l2, l2, b_set)
+ mom3 = momenta((/l2,l2,l3/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l2, l2, l3, b_set)
+ mom3 = momenta((/l2,l2,l4/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l2, l2, l4, b_set)
+ mom3 = momenta((/l2,l2,l5/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l2, l2, l5, b_set)
+ mom3 = momenta((/l2,l3,l3/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l2, l3, l3, b_set)
+ mom3 = momenta((/l2,l3,l4/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l2, l3, l4, b_set)
+ mom3 = momenta((/l2,l3,l5/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l2, l3, l5, b_set)
+ mom3 = momenta((/l2,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l2, l4, l4, b_set)
+ mom3 = momenta((/l2,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l2, l4, l5, b_set)
+ mom3 = momenta((/l2,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l2, l5, l5, b_set)
+ mom3 = momenta((/l3,l3,l3/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom3) * b55(l3, l3, l3, b_set)
+ mom3 = momenta((/l3,l3,l4/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l3, l3, l4, b_set)
+ mom3 = momenta((/l3,l3,l5/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l3, l3, l5, b_set)
+ mom3 = momenta((/l3,l4,l4/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l3, l4, l4, b_set)
+ mom3 = momenta((/l3,l4,l5/),:)
+ amp = amp + 6.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l3, l4, l5, b_set)
+ mom3 = momenta((/l3,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l3, l5, l5, b_set)
+ mom3 = momenta((/l4,l4,l4/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom3) * b55(l4, l4, l4, b_set)
+ mom3 = momenta((/l4,l4,l5/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l4, l4, l5, b_set)
+ mom3 = momenta((/l4,l5,l5/),:)
+ amp = amp + 3.0_ki * contract_b_tensor_5(coeffs, mom3) &
+ & * b55(l4, l5, l5, b_set)
+ mom3 = momenta((/l5,l5,l5/),:)
+ amp = amp + contract_b_tensor_5(coeffs, mom3) * b55(l5, l5, l5, b_set)
+ mom1 = momenta((/l1/),:)
+ amp = amp + contract_c_tensor_5(coeffs, mom1) * c55(l1, b_set)
+ mom1 = momenta((/l2/),:)
+ amp = amp + contract_c_tensor_5(coeffs, mom1) * c55(l2, b_set)
+ mom1 = momenta((/l3/),:)
+ amp = amp + contract_c_tensor_5(coeffs, mom1) * c55(l3, b_set)
+ mom1 = momenta((/l4/),:)
+ amp = amp + contract_c_tensor_5(coeffs, mom1) * c55(l4, b_set)
+ mom1 = momenta((/l5/),:)
+ amp = amp + contract_c_tensor_5(coeffs, mom1) * c55(l5, b_set)
+end function contract5_5
+!****f* src/interface/tens_comb/contract6_1
+! NAME
+!
+! Function contract6_1
+!
+! USAGE
+!
+! amp = contract6_1(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 6-point rank 1 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_1)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract6_1(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_split
+ complex(ki), dimension(0:3) :: C
+ complex(ki) :: cprime
+ integer :: i, pnch, new_set
+ integer, dimension(1) :: pnch_set
+ integer, dimension(6) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 6)
+ amp = coeffs%c0 * a60(b_set)
+ do pnch=1,6
+ ! Eq. (54) in hep-ph/0504267
+ C(:) = 0.0_ki
+ do i=1,6
+ C(:) = C(:) + inv_s(unpinched(pnch),unpinched(i),b_set) * &
+ & momenta(unpinched(i),:)
+ end do
+ ! Eq. (63) in hep-ph/0504267
+ pnch_set(1) = pnch
+ new_set = punion(packb(pnch_set),b_set)
+ ! [] <-- [0]
+ cprime = C(0) * coeffs%c1(1, 1)
+ ! [] <-- [1]
+ cprime = cprime + C(1) * coeffs%c1(2, 1)
+ ! [] <-- [2]
+ cprime = cprime + C(2) * coeffs%c1(3, 1)
+ ! [] <-- [3]
+ cprime = cprime + C(3) * coeffs%c1(4, 1)
+ amp = amp - cprime * a50(new_set)
+ end do
+end function contract6_1
+!****f* src/interface/tens_comb/contract6_2
+! NAME
+!
+! Function contract6_2
+!
+! USAGE
+!
+! amp = contract6_2(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 6-point rank 2 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_2)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract6_2(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_split
+ complex(ki), dimension(0:3) :: C
+ type(coeff_type_1) :: cprime
+ integer :: i, pnch, new_set
+ integer, dimension(1) :: pnch_set
+ integer, dimension(6) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 6)
+ amp = coeffs%c0 * a60(b_set)
+ do pnch=1,6
+ ! Eq. (54) in hep-ph/0504267
+ C(:) = 0.0_ki
+ do i=1,6
+ C(:) = C(:) + inv_s(unpinched(pnch),unpinched(i),b_set) * &
+ & momenta(unpinched(i),:)
+ end do
+ ! Eq. (63) in hep-ph/0504267
+ pnch_set(1) = pnch
+ new_set = punion(packb(pnch_set),b_set)
+ ! [] <-- [0]
+ cprime%c0 = C(0) * coeffs%c1(1, 1)
+ ! [] <-- [1]
+ cprime%c0 = cprime%c0 + C(1) * coeffs%c1(2, 1)
+ ! [] <-- [2]
+ cprime%c0 = cprime%c0 + C(2) * coeffs%c1(3, 1)
+ ! [] <-- [3]
+ cprime%c0 = cprime%c0 + C(3) * coeffs%c1(4, 1)
+ ! [0] <-- [0, 0]
+ cprime%c1(1,1) = C(0) * coeffs%c1(1, 2)
+ ! [1] <-- [1, 1]
+ cprime%c1(2,1) = C(1) * coeffs%c1(2, 2)
+ ! [2] <-- [2, 2]
+ cprime%c1(3,1) = C(2) * coeffs%c1(3, 2)
+ ! [3] <-- [3, 3]
+ cprime%c1(4,1) = C(3) * coeffs%c1(4, 2)
+ ! [1] <-- [0, 1]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(0) * coeffs%c2(1, 1)
+ ! [0] <-- [0, 1]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(1) * coeffs%c2(1, 1)
+ ! [2] <-- [0, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(0) * coeffs%c2(2, 1)
+ ! [0] <-- [0, 2]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(2) * coeffs%c2(2, 1)
+ ! [3] <-- [0, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(0) * coeffs%c2(3, 1)
+ ! [0] <-- [0, 3]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(3) * coeffs%c2(3, 1)
+ ! [2] <-- [1, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(1) * coeffs%c2(4, 1)
+ ! [1] <-- [1, 2]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(2) * coeffs%c2(4, 1)
+ ! [3] <-- [1, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(1) * coeffs%c2(5, 1)
+ ! [1] <-- [1, 3]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(3) * coeffs%c2(5, 1)
+ ! [3] <-- [2, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(2) * coeffs%c2(6, 1)
+ ! [2] <-- [2, 3]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(3) * coeffs%c2(6, 1)
+ amp = amp - contract5_1(cprime, momenta, new_set)
+ end do
+end function contract6_2
+!****f* src/interface/tens_comb/contract6_3
+! NAME
+!
+! Function contract6_3
+!
+! USAGE
+!
+! amp = contract6_3(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 6-point rank 3 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_3)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract6_3(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_3), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_split
+ complex(ki), dimension(0:3) :: C
+ type(coeff_type_2) :: cprime
+ integer :: i, pnch, new_set
+ integer, dimension(1) :: pnch_set
+ integer, dimension(6) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 6)
+ amp = coeffs%c0 * a60(b_set)
+ do pnch=1,6
+ ! Eq. (54) in hep-ph/0504267
+ C(:) = 0.0_ki
+ do i=1,6
+ C(:) = C(:) + inv_s(unpinched(pnch),unpinched(i),b_set) * &
+ & momenta(unpinched(i),:)
+ end do
+ ! Eq. (63) in hep-ph/0504267
+ pnch_set(1) = pnch
+ new_set = punion(packb(pnch_set),b_set)
+ ! [] <-- [0]
+ cprime%c0 = C(0) * coeffs%c1(1, 1)
+ ! [] <-- [1]
+ cprime%c0 = cprime%c0 + C(1) * coeffs%c1(2, 1)
+ ! [] <-- [2]
+ cprime%c0 = cprime%c0 + C(2) * coeffs%c1(3, 1)
+ ! [] <-- [3]
+ cprime%c0 = cprime%c0 + C(3) * coeffs%c1(4, 1)
+ ! [0] <-- [0, 0]
+ cprime%c1(1,1) = C(0) * coeffs%c1(1, 2)
+ ! [1] <-- [1, 1]
+ cprime%c1(2,1) = C(1) * coeffs%c1(2, 2)
+ ! [2] <-- [2, 2]
+ cprime%c1(3,1) = C(2) * coeffs%c1(3, 2)
+ ! [3] <-- [3, 3]
+ cprime%c1(4,1) = C(3) * coeffs%c1(4, 2)
+ ! [1] <-- [0, 1]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(0) * coeffs%c2(1, 1)
+ ! [0] <-- [0, 1]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(1) * coeffs%c2(1, 1)
+ ! [2] <-- [0, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(0) * coeffs%c2(2, 1)
+ ! [0] <-- [0, 2]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(2) * coeffs%c2(2, 1)
+ ! [3] <-- [0, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(0) * coeffs%c2(3, 1)
+ ! [0] <-- [0, 3]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(3) * coeffs%c2(3, 1)
+ ! [2] <-- [1, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(1) * coeffs%c2(4, 1)
+ ! [1] <-- [1, 2]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(2) * coeffs%c2(4, 1)
+ ! [3] <-- [1, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(1) * coeffs%c2(5, 1)
+ ! [1] <-- [1, 3]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(3) * coeffs%c2(5, 1)
+ ! [3] <-- [2, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(2) * coeffs%c2(6, 1)
+ ! [2] <-- [2, 3]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(3) * coeffs%c2(6, 1)
+ ! [1, 1] <-- [0, 1, 1]
+ cprime%c1(2,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(1, 2)
+ ! [0, 1] <-- [0, 1, 1]
+ cprime%c2(1,1) = 2.0_ki/3.0_ki * C(1) * coeffs%c2(1, 2)
+ ! [2, 2] <-- [0, 2, 2]
+ cprime%c1(3,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(2, 2)
+ ! [0, 2] <-- [0, 2, 2]
+ cprime%c2(2,1) = 2.0_ki/3.0_ki * C(2) * coeffs%c2(2, 2)
+ ! [3, 3] <-- [0, 3, 3]
+ cprime%c1(4,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(3, 2)
+ ! [0, 3] <-- [0, 3, 3]
+ cprime%c2(3,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(3, 2)
+ ! [2, 2] <-- [1, 2, 2]
+ cprime%c1(3,2) = cprime%c1(3,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(4, 2)
+ ! [1, 2] <-- [1, 2, 2]
+ cprime%c2(4,1) = 2.0_ki/3.0_ki * C(2) * coeffs%c2(4, 2)
+ ! [3, 3] <-- [1, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(5, 2)
+ ! [1, 3] <-- [1, 3, 3]
+ cprime%c2(5,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(5, 2)
+ ! [3, 3] <-- [2, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(6, 2)
+ ! [2, 3] <-- [2, 3, 3]
+ cprime%c2(6,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(6, 2)
+ ! [1, 2] <-- [0, 1, 2]
+ cprime%c2(4,1) = cprime%c2(4,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(1, 1)
+ ! [0, 2] <-- [0, 1, 2]
+ cprime%c2(2,1) = cprime%c2(2,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(1, 1)
+ ! [0, 1] <-- [0, 1, 2]
+ cprime%c2(1,1) = cprime%c2(1,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(1, 1)
+ ! [1, 3] <-- [0, 1, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(2, 1)
+ ! [0, 3] <-- [0, 1, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(2, 1)
+ ! [0, 1] <-- [0, 1, 3]
+ cprime%c2(1,1) = cprime%c2(1,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(2, 1)
+ ! [2, 3] <-- [0, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(3, 1)
+ ! [0, 3] <-- [0, 2, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(3, 1)
+ ! [0, 2] <-- [0, 2, 3]
+ cprime%c2(2,1) = cprime%c2(2,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(3, 1)
+ ! [2, 3] <-- [1, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(4, 1)
+ ! [1, 3] <-- [1, 2, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(4, 1)
+ ! [1, 2] <-- [1, 2, 3]
+ cprime%c2(4,1) = cprime%c2(4,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(4, 1)
+ ! [0, 0] <-- [0, 0, 0]
+ cprime%c1(1,2) = C(0) * coeffs%c1(1, 3)
+ ! [1, 1] <-- [1, 1, 1]
+ cprime%c1(2,2) = cprime%c1(2,2) + C(1) * coeffs%c1(2, 3)
+ ! [2, 2] <-- [2, 2, 2]
+ cprime%c1(3,2) = cprime%c1(3,2) + C(2) * coeffs%c1(3, 3)
+ ! [3, 3] <-- [3, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + C(3) * coeffs%c1(4, 3)
+ ! [0, 1] <-- [0, 0, 1]
+ cprime%c2(1,1) = cprime%c2(1,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(1, 3)
+ ! [0, 0] <-- [0, 0, 1]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(1, 3)
+ ! [0, 2] <-- [0, 0, 2]
+ cprime%c2(2,1) = cprime%c2(2,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(2, 3)
+ ! [0, 0] <-- [0, 0, 2]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(2, 3)
+ ! [0, 3] <-- [0, 0, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(3, 3)
+ ! [0, 0] <-- [0, 0, 3]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(3, 3)
+ ! [1, 2] <-- [1, 1, 2]
+ cprime%c2(4,1) = cprime%c2(4,1) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(4, 3)
+ ! [1, 1] <-- [1, 1, 2]
+ cprime%c1(2,2) = cprime%c1(2,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(4, 3)
+ ! [1, 3] <-- [1, 1, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(5, 3)
+ ! [1, 1] <-- [1, 1, 3]
+ cprime%c1(2,2) = cprime%c1(2,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(5, 3)
+ ! [2, 3] <-- [2, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 2.0_ki/3.0_ki * C(2) * coeffs%c2(6, 3)
+ ! [2, 2] <-- [2, 2, 3]
+ cprime%c1(3,2) = cprime%c1(3,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(6, 3)
+ amp = amp - contract5_2(cprime, momenta, new_set)
+ end do
+end function contract6_3
+!****f* src/interface/tens_comb/contract6_4
+! NAME
+!
+! Function contract6_4
+!
+! USAGE
+!
+! amp = contract6_4(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 6-point rank 4 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_4)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract6_4(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_4), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_split
+ complex(ki), dimension(0:3) :: C
+ type(coeff_type_3) :: cprime
+ integer :: i, pnch, new_set
+ integer, dimension(1) :: pnch_set
+ integer, dimension(6) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 6)
+ amp = coeffs%c0 * a60(b_set)
+ do pnch=1,6
+ ! Eq. (54) in hep-ph/0504267
+ C(:) = 0.0_ki
+ do i=1,6
+ C(:) = C(:) + inv_s(unpinched(pnch),unpinched(i),b_set) * &
+ & momenta(unpinched(i),:)
+ end do
+ ! Eq. (63) in hep-ph/0504267
+ pnch_set(1) = pnch
+ new_set = punion(packb(pnch_set),b_set)
+ ! [] <-- [0]
+ cprime%c0 = C(0) * coeffs%c1(1, 1)
+ ! [] <-- [1]
+ cprime%c0 = cprime%c0 + C(1) * coeffs%c1(2, 1)
+ ! [] <-- [2]
+ cprime%c0 = cprime%c0 + C(2) * coeffs%c1(3, 1)
+ ! [] <-- [3]
+ cprime%c0 = cprime%c0 + C(3) * coeffs%c1(4, 1)
+ ! [0] <-- [0, 0]
+ cprime%c1(1,1) = C(0) * coeffs%c1(1, 2)
+ ! [1] <-- [1, 1]
+ cprime%c1(2,1) = C(1) * coeffs%c1(2, 2)
+ ! [2] <-- [2, 2]
+ cprime%c1(3,1) = C(2) * coeffs%c1(3, 2)
+ ! [3] <-- [3, 3]
+ cprime%c1(4,1) = C(3) * coeffs%c1(4, 2)
+ ! [1] <-- [0, 1]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(0) * coeffs%c2(1, 1)
+ ! [0] <-- [0, 1]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(1) * coeffs%c2(1, 1)
+ ! [2] <-- [0, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(0) * coeffs%c2(2, 1)
+ ! [0] <-- [0, 2]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(2) * coeffs%c2(2, 1)
+ ! [3] <-- [0, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(0) * coeffs%c2(3, 1)
+ ! [0] <-- [0, 3]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(3) * coeffs%c2(3, 1)
+ ! [2] <-- [1, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(1) * coeffs%c2(4, 1)
+ ! [1] <-- [1, 2]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(2) * coeffs%c2(4, 1)
+ ! [3] <-- [1, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(1) * coeffs%c2(5, 1)
+ ! [1] <-- [1, 3]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(3) * coeffs%c2(5, 1)
+ ! [3] <-- [2, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(2) * coeffs%c2(6, 1)
+ ! [2] <-- [2, 3]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(3) * coeffs%c2(6, 1)
+ ! [1, 1] <-- [0, 1, 1]
+ cprime%c1(2,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(1, 2)
+ ! [0, 1] <-- [0, 1, 1]
+ cprime%c2(1,1) = 2.0_ki/3.0_ki * C(1) * coeffs%c2(1, 2)
+ ! [2, 2] <-- [0, 2, 2]
+ cprime%c1(3,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(2, 2)
+ ! [0, 2] <-- [0, 2, 2]
+ cprime%c2(2,1) = 2.0_ki/3.0_ki * C(2) * coeffs%c2(2, 2)
+ ! [3, 3] <-- [0, 3, 3]
+ cprime%c1(4,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(3, 2)
+ ! [0, 3] <-- [0, 3, 3]
+ cprime%c2(3,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(3, 2)
+ ! [2, 2] <-- [1, 2, 2]
+ cprime%c1(3,2) = cprime%c1(3,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(4, 2)
+ ! [1, 2] <-- [1, 2, 2]
+ cprime%c2(4,1) = 2.0_ki/3.0_ki * C(2) * coeffs%c2(4, 2)
+ ! [3, 3] <-- [1, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(5, 2)
+ ! [1, 3] <-- [1, 3, 3]
+ cprime%c2(5,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(5, 2)
+ ! [3, 3] <-- [2, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(6, 2)
+ ! [2, 3] <-- [2, 3, 3]
+ cprime%c2(6,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(6, 2)
+ ! [1, 2] <-- [0, 1, 2]
+ cprime%c2(4,1) = cprime%c2(4,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(1, 1)
+ ! [0, 2] <-- [0, 1, 2]
+ cprime%c2(2,1) = cprime%c2(2,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(1, 1)
+ ! [0, 1] <-- [0, 1, 2]
+ cprime%c2(1,1) = cprime%c2(1,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(1, 1)
+ ! [1, 3] <-- [0, 1, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(2, 1)
+ ! [0, 3] <-- [0, 1, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(2, 1)
+ ! [0, 1] <-- [0, 1, 3]
+ cprime%c2(1,1) = cprime%c2(1,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(2, 1)
+ ! [2, 3] <-- [0, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(3, 1)
+ ! [0, 3] <-- [0, 2, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(3, 1)
+ ! [0, 2] <-- [0, 2, 3]
+ cprime%c2(2,1) = cprime%c2(2,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(3, 1)
+ ! [2, 3] <-- [1, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(4, 1)
+ ! [1, 3] <-- [1, 2, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(4, 1)
+ ! [1, 2] <-- [1, 2, 3]
+ cprime%c2(4,1) = cprime%c2(4,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(4, 1)
+ ! [0, 0] <-- [0, 0, 0]
+ cprime%c1(1,2) = C(0) * coeffs%c1(1, 3)
+ ! [1, 1] <-- [1, 1, 1]
+ cprime%c1(2,2) = cprime%c1(2,2) + C(1) * coeffs%c1(2, 3)
+ ! [2, 2] <-- [2, 2, 2]
+ cprime%c1(3,2) = cprime%c1(3,2) + C(2) * coeffs%c1(3, 3)
+ ! [3, 3] <-- [3, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + C(3) * coeffs%c1(4, 3)
+ ! [0, 1] <-- [0, 0, 1]
+ cprime%c2(1,1) = cprime%c2(1,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(1, 4)
+ ! [0, 0] <-- [0, 0, 1]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(1, 4)
+ ! [0, 2] <-- [0, 0, 2]
+ cprime%c2(2,1) = cprime%c2(2,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(2, 4)
+ ! [0, 0] <-- [0, 0, 2]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(2, 4)
+ ! [0, 3] <-- [0, 0, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(3, 4)
+ ! [0, 0] <-- [0, 0, 3]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(3, 4)
+ ! [1, 2] <-- [1, 1, 2]
+ cprime%c2(4,1) = cprime%c2(4,1) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(4, 4)
+ ! [1, 1] <-- [1, 1, 2]
+ cprime%c1(2,2) = cprime%c1(2,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(4, 4)
+ ! [1, 3] <-- [1, 1, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(5, 4)
+ ! [1, 1] <-- [1, 1, 3]
+ cprime%c1(2,2) = cprime%c1(2,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(5, 4)
+ ! [2, 3] <-- [2, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 2.0_ki/3.0_ki * C(2) * coeffs%c2(6, 4)
+ ! [2, 2] <-- [2, 2, 3]
+ cprime%c1(3,2) = cprime%c1(3,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(6, 4)
+ ! [1, 1, 2] <-- [0, 1, 1, 2]
+ cprime%c2(4,3) = 0.25_ki * C(0) * coeffs%c3(1, 3)
+ ! [0, 1, 2] <-- [0, 1, 1, 2]
+ cprime%c3(1,1) = 0.5_ki * C(1) * coeffs%c3(1, 3)
+ ! [0, 1, 1] <-- [0, 1, 1, 2]
+ cprime%c2(1,2) = 0.25_ki * C(2) * coeffs%c3(1, 3)
+ ! [1, 1, 3] <-- [0, 1, 1, 3]
+ cprime%c2(5,3) = 0.25_ki * C(0) * coeffs%c3(2, 3)
+ ! [0, 1, 3] <-- [0, 1, 1, 3]
+ cprime%c3(2,1) = 0.5_ki * C(1) * coeffs%c3(2, 3)
+ ! [0, 1, 1] <-- [0, 1, 1, 3]
+ cprime%c2(1,2) = cprime%c2(1,2) + 0.25_ki * C(3) * coeffs%c3(2, 3)
+ ! [2, 2, 3] <-- [0, 2, 2, 3]
+ cprime%c2(6,3) = 0.25_ki * C(0) * coeffs%c3(3, 3)
+ ! [0, 2, 3] <-- [0, 2, 2, 3]
+ cprime%c3(3,1) = 0.5_ki * C(2) * coeffs%c3(3, 3)
+ ! [0, 2, 2] <-- [0, 2, 2, 3]
+ cprime%c2(2,2) = 0.25_ki * C(3) * coeffs%c3(3, 3)
+ ! [2, 2, 3] <-- [1, 2, 2, 3]
+ cprime%c2(6,3) = cprime%c2(6,3) + 0.25_ki * C(1) * coeffs%c3(4, 3)
+ ! [1, 2, 3] <-- [1, 2, 2, 3]
+ cprime%c3(4,1) = 0.5_ki * C(2) * coeffs%c3(4, 3)
+ ! [1, 2, 2] <-- [1, 2, 2, 3]
+ cprime%c2(4,2) = 0.25_ki * C(3) * coeffs%c3(4, 3)
+ ! [1, 1, 1] <-- [0, 1, 1, 1]
+ cprime%c1(2,3) = 0.25_ki * C(0) * coeffs%c2(1, 3)
+ ! [0, 1, 1] <-- [0, 1, 1, 1]
+ cprime%c2(1,2) = cprime%c2(1,2) + 3.0_ki/4.0_ki * C(1) * coeffs%c2(1, 3)
+ ! [2, 2, 2] <-- [0, 2, 2, 2]
+ cprime%c1(3,3) = 0.25_ki * C(0) * coeffs%c2(2, 3)
+ ! [0, 2, 2] <-- [0, 2, 2, 2]
+ cprime%c2(2,2) = cprime%c2(2,2) + 3.0_ki/4.0_ki * C(2) * coeffs%c2(2, 3)
+ ! [3, 3, 3] <-- [0, 3, 3, 3]
+ cprime%c1(4,3) = 0.25_ki * C(0) * coeffs%c2(3, 3)
+ ! [0, 3, 3] <-- [0, 3, 3, 3]
+ cprime%c2(3,2) = 3.0_ki/4.0_ki * C(3) * coeffs%c2(3, 3)
+ ! [2, 2, 2] <-- [1, 2, 2, 2]
+ cprime%c1(3,3) = cprime%c1(3,3) + 0.25_ki * C(1) * coeffs%c2(4, 3)
+ ! [1, 2, 2] <-- [1, 2, 2, 2]
+ cprime%c2(4,2) = cprime%c2(4,2) + 3.0_ki/4.0_ki * C(2) * coeffs%c2(4, 3)
+ ! [3, 3, 3] <-- [1, 3, 3, 3]
+ cprime%c1(4,3) = cprime%c1(4,3) + 0.25_ki * C(1) * coeffs%c2(5, 3)
+ ! [1, 3, 3] <-- [1, 3, 3, 3]
+ cprime%c2(5,2) = 3.0_ki/4.0_ki * C(3) * coeffs%c2(5, 3)
+ ! [3, 3, 3] <-- [2, 3, 3, 3]
+ cprime%c1(4,3) = cprime%c1(4,3) + 0.25_ki * C(2) * coeffs%c2(6, 3)
+ ! [2, 3, 3] <-- [2, 3, 3, 3]
+ cprime%c2(6,2) = 3.0_ki/4.0_ki * C(3) * coeffs%c2(6, 3)
+ ! [0, 1, 2] <-- [0, 0, 1, 2]
+ cprime%c3(1,1) = cprime%c3(1,1) + 0.5_ki * C(0) * coeffs%c3(1, 4)
+ ! [0, 0, 2] <-- [0, 0, 1, 2]
+ cprime%c2(2,3) = 0.25_ki * C(1) * coeffs%c3(1, 4)
+ ! [0, 0, 1] <-- [0, 0, 1, 2]
+ cprime%c2(1,3) = 0.25_ki * C(2) * coeffs%c3(1, 4)
+ ! [0, 1, 3] <-- [0, 0, 1, 3]
+ cprime%c3(2,1) = cprime%c3(2,1) + 0.5_ki * C(0) * coeffs%c3(2, 4)
+ ! [0, 0, 3] <-- [0, 0, 1, 3]
+ cprime%c2(3,3) = 0.25_ki * C(1) * coeffs%c3(2, 4)
+ ! [0, 0, 1] <-- [0, 0, 1, 3]
+ cprime%c2(1,3) = cprime%c2(1,3) + 0.25_ki * C(3) * coeffs%c3(2, 4)
+ ! [0, 2, 3] <-- [0, 0, 2, 3]
+ cprime%c3(3,1) = cprime%c3(3,1) + 0.5_ki * C(0) * coeffs%c3(3, 4)
+ ! [0, 0, 3] <-- [0, 0, 2, 3]
+ cprime%c2(3,3) = cprime%c2(3,3) + 0.25_ki * C(2) * coeffs%c3(3, 4)
+ ! [0, 0, 2] <-- [0, 0, 2, 3]
+ cprime%c2(2,3) = cprime%c2(2,3) + 0.25_ki * C(3) * coeffs%c3(3, 4)
+ ! [1, 2, 3] <-- [1, 1, 2, 3]
+ cprime%c3(4,1) = cprime%c3(4,1) + 0.5_ki * C(1) * coeffs%c3(4, 4)
+ ! [1, 1, 3] <-- [1, 1, 2, 3]
+ cprime%c2(5,3) = cprime%c2(5,3) + 0.25_ki * C(2) * coeffs%c3(4, 4)
+ ! [1, 1, 2] <-- [1, 1, 2, 3]
+ cprime%c2(4,3) = cprime%c2(4,3) + 0.25_ki * C(3) * coeffs%c3(4, 4)
+ ! [0, 0, 1] <-- [0, 0, 0, 1]
+ cprime%c2(1,3) = cprime%c2(1,3) + 3.0_ki/4.0_ki * C(0) * coeffs%c2(1, 6)
+ ! [0, 0, 0] <-- [0, 0, 0, 1]
+ cprime%c1(1,3) = 0.25_ki * C(1) * coeffs%c2(1, 6)
+ ! [0, 0, 2] <-- [0, 0, 0, 2]
+ cprime%c2(2,3) = cprime%c2(2,3) + 3.0_ki/4.0_ki * C(0) * coeffs%c2(2, 6)
+ ! [0, 0, 0] <-- [0, 0, 0, 2]
+ cprime%c1(1,3) = cprime%c1(1,3) + 0.25_ki * C(2) * coeffs%c2(2, 6)
+ ! [0, 0, 3] <-- [0, 0, 0, 3]
+ cprime%c2(3,3) = cprime%c2(3,3) + 3.0_ki/4.0_ki * C(0) * coeffs%c2(3, 6)
+ ! [0, 0, 0] <-- [0, 0, 0, 3]
+ cprime%c1(1,3) = cprime%c1(1,3) + 0.25_ki * C(3) * coeffs%c2(3, 6)
+ ! [1, 1, 2] <-- [1, 1, 1, 2]
+ cprime%c2(4,3) = cprime%c2(4,3) + 3.0_ki/4.0_ki * C(1) * coeffs%c2(4, 6)
+ ! [1, 1, 1] <-- [1, 1, 1, 2]
+ cprime%c1(2,3) = cprime%c1(2,3) + 0.25_ki * C(2) * coeffs%c2(4, 6)
+ ! [1, 1, 3] <-- [1, 1, 1, 3]
+ cprime%c2(5,3) = cprime%c2(5,3) + 3.0_ki/4.0_ki * C(1) * coeffs%c2(5, 6)
+ ! [1, 1, 1] <-- [1, 1, 1, 3]
+ cprime%c1(2,3) = cprime%c1(2,3) + 0.25_ki * C(3) * coeffs%c2(5, 6)
+ ! [2, 2, 3] <-- [2, 2, 2, 3]
+ cprime%c2(6,3) = cprime%c2(6,3) + 3.0_ki/4.0_ki * C(2) * coeffs%c2(6, 6)
+ ! [2, 2, 2] <-- [2, 2, 2, 3]
+ cprime%c1(3,3) = cprime%c1(3,3) + 0.25_ki * C(3) * coeffs%c2(6, 6)
+ ! [1, 2, 3] <-- [0, 1, 2, 3]
+ cprime%c3(4,1) = cprime%c3(4,1) + 0.25_ki * C(0) * coeffs%c4(1, 1)
+ ! [0, 2, 3] <-- [0, 1, 2, 3]
+ cprime%c3(3,1) = cprime%c3(3,1) + 0.25_ki * C(1) * coeffs%c4(1, 1)
+ ! [0, 1, 3] <-- [0, 1, 2, 3]
+ cprime%c3(2,1) = cprime%c3(2,1) + 0.25_ki * C(2) * coeffs%c4(1, 1)
+ ! [0, 1, 2] <-- [0, 1, 2, 3]
+ cprime%c3(1,1) = cprime%c3(1,1) + 0.25_ki * C(3) * coeffs%c4(1, 1)
+ ! [1, 2, 2] <-- [0, 1, 2, 2]
+ cprime%c2(4,2) = cprime%c2(4,2) + 0.25_ki * C(0) * coeffs%c3(1, 2)
+ ! [0, 2, 2] <-- [0, 1, 2, 2]
+ cprime%c2(2,2) = cprime%c2(2,2) + 0.25_ki * C(1) * coeffs%c3(1, 2)
+ ! [0, 1, 2] <-- [0, 1, 2, 2]
+ cprime%c3(1,1) = cprime%c3(1,1) + 0.5_ki * C(2) * coeffs%c3(1, 2)
+ ! [1, 3, 3] <-- [0, 1, 3, 3]
+ cprime%c2(5,2) = cprime%c2(5,2) + 0.25_ki * C(0) * coeffs%c3(2, 2)
+ ! [0, 3, 3] <-- [0, 1, 3, 3]
+ cprime%c2(3,2) = cprime%c2(3,2) + 0.25_ki * C(1) * coeffs%c3(2, 2)
+ ! [0, 1, 3] <-- [0, 1, 3, 3]
+ cprime%c3(2,1) = cprime%c3(2,1) + 0.5_ki * C(3) * coeffs%c3(2, 2)
+ ! [2, 3, 3] <-- [0, 2, 3, 3]
+ cprime%c2(6,2) = cprime%c2(6,2) + 0.25_ki * C(0) * coeffs%c3(3, 2)
+ ! [0, 3, 3] <-- [0, 2, 3, 3]
+ cprime%c2(3,2) = cprime%c2(3,2) + 0.25_ki * C(2) * coeffs%c3(3, 2)
+ ! [0, 2, 3] <-- [0, 2, 3, 3]
+ cprime%c3(3,1) = cprime%c3(3,1) + 0.5_ki * C(3) * coeffs%c3(3, 2)
+ ! [2, 3, 3] <-- [1, 2, 3, 3]
+ cprime%c2(6,2) = cprime%c2(6,2) + 0.25_ki * C(1) * coeffs%c3(4, 2)
+ ! [1, 3, 3] <-- [1, 2, 3, 3]
+ cprime%c2(5,2) = cprime%c2(5,2) + 0.25_ki * C(2) * coeffs%c3(4, 2)
+ ! [1, 2, 3] <-- [1, 2, 3, 3]
+ cprime%c3(4,1) = cprime%c3(4,1) + 0.5_ki * C(3) * coeffs%c3(4, 2)
+ ! [0, 1, 1] <-- [0, 0, 1, 1]
+ cprime%c2(1,2) = cprime%c2(1,2) + 0.5_ki * C(0) * coeffs%c2(1, 5)
+ ! [0, 0, 1] <-- [0, 0, 1, 1]
+ cprime%c2(1,3) = cprime%c2(1,3) + 0.5_ki * C(1) * coeffs%c2(1, 5)
+ ! [0, 2, 2] <-- [0, 0, 2, 2]
+ cprime%c2(2,2) = cprime%c2(2,2) + 0.5_ki * C(0) * coeffs%c2(2, 5)
+ ! [0, 0, 2] <-- [0, 0, 2, 2]
+ cprime%c2(2,3) = cprime%c2(2,3) + 0.5_ki * C(2) * coeffs%c2(2, 5)
+ ! [0, 3, 3] <-- [0, 0, 3, 3]
+ cprime%c2(3,2) = cprime%c2(3,2) + 0.5_ki * C(0) * coeffs%c2(3, 5)
+ ! [0, 0, 3] <-- [0, 0, 3, 3]
+ cprime%c2(3,3) = cprime%c2(3,3) + 0.5_ki * C(3) * coeffs%c2(3, 5)
+ ! [1, 2, 2] <-- [1, 1, 2, 2]
+ cprime%c2(4,2) = cprime%c2(4,2) + 0.5_ki * C(1) * coeffs%c2(4, 5)
+ ! [1, 1, 2] <-- [1, 1, 2, 2]
+ cprime%c2(4,3) = cprime%c2(4,3) + 0.5_ki * C(2) * coeffs%c2(4, 5)
+ ! [1, 3, 3] <-- [1, 1, 3, 3]
+ cprime%c2(5,2) = cprime%c2(5,2) + 0.5_ki * C(1) * coeffs%c2(5, 5)
+ ! [1, 1, 3] <-- [1, 1, 3, 3]
+ cprime%c2(5,3) = cprime%c2(5,3) + 0.5_ki * C(3) * coeffs%c2(5, 5)
+ ! [2, 3, 3] <-- [2, 2, 3, 3]
+ cprime%c2(6,2) = cprime%c2(6,2) + 0.5_ki * C(2) * coeffs%c2(6, 5)
+ ! [2, 2, 3] <-- [2, 2, 3, 3]
+ cprime%c2(6,3) = cprime%c2(6,3) + 0.5_ki * C(3) * coeffs%c2(6, 5)
+ ! [0, 0, 0] <-- [0, 0, 0, 0]
+ cprime%c1(1,3) = cprime%c1(1,3) + C(0) * coeffs%c1(1, 4)
+ ! [1, 1, 1] <-- [1, 1, 1, 1]
+ cprime%c1(2,3) = cprime%c1(2,3) + C(1) * coeffs%c1(2, 4)
+ ! [2, 2, 2] <-- [2, 2, 2, 2]
+ cprime%c1(3,3) = cprime%c1(3,3) + C(2) * coeffs%c1(3, 4)
+ ! [3, 3, 3] <-- [3, 3, 3, 3]
+ cprime%c1(4,3) = cprime%c1(4,3) + C(3) * coeffs%c1(4, 4)
+ amp = amp - contract5_3(cprime, momenta, new_set)
+ end do
+end function contract6_4
+!****f* src/interface/tens_comb/contract6_5
+! NAME
+!
+! Function contract6_5
+!
+! USAGE
+!
+! amp = contract6_5(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 6-point rank 5 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_5)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract6_5(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_5), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_split
+ complex(ki), dimension(0:3) :: C
+ type(coeff_type_4) :: cprime
+ integer :: i, pnch, new_set
+ integer, dimension(1) :: pnch_set
+ integer, dimension(6) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 6)
+ amp = coeffs%c0 * a60(b_set)
+ do pnch=1,6
+ ! Eq. (54) in hep-ph/0504267
+ C(:) = 0.0_ki
+ do i=1,6
+ C(:) = C(:) + inv_s(unpinched(pnch),unpinched(i),b_set) * &
+ & momenta(unpinched(i),:)
+ end do
+ ! Eq. (63) in hep-ph/0504267
+ pnch_set(1) = pnch
+ new_set = punion(packb(pnch_set),b_set)
+ ! [] <-- [0]
+ cprime%c0 = C(0) * coeffs%c1(1, 1)
+ ! [] <-- [1]
+ cprime%c0 = cprime%c0 + C(1) * coeffs%c1(2, 1)
+ ! [] <-- [2]
+ cprime%c0 = cprime%c0 + C(2) * coeffs%c1(3, 1)
+ ! [] <-- [3]
+ cprime%c0 = cprime%c0 + C(3) * coeffs%c1(4, 1)
+ ! [0] <-- [0, 0]
+ cprime%c1(1,1) = C(0) * coeffs%c1(1, 2)
+ ! [1] <-- [1, 1]
+ cprime%c1(2,1) = C(1) * coeffs%c1(2, 2)
+ ! [2] <-- [2, 2]
+ cprime%c1(3,1) = C(2) * coeffs%c1(3, 2)
+ ! [3] <-- [3, 3]
+ cprime%c1(4,1) = C(3) * coeffs%c1(4, 2)
+ ! [1] <-- [0, 1]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(0) * coeffs%c2(1, 1)
+ ! [0] <-- [0, 1]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(1) * coeffs%c2(1, 1)
+ ! [2] <-- [0, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(0) * coeffs%c2(2, 1)
+ ! [0] <-- [0, 2]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(2) * coeffs%c2(2, 1)
+ ! [3] <-- [0, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(0) * coeffs%c2(3, 1)
+ ! [0] <-- [0, 3]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(3) * coeffs%c2(3, 1)
+ ! [2] <-- [1, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(1) * coeffs%c2(4, 1)
+ ! [1] <-- [1, 2]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(2) * coeffs%c2(4, 1)
+ ! [3] <-- [1, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(1) * coeffs%c2(5, 1)
+ ! [1] <-- [1, 3]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(3) * coeffs%c2(5, 1)
+ ! [3] <-- [2, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(2) * coeffs%c2(6, 1)
+ ! [2] <-- [2, 3]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(3) * coeffs%c2(6, 1)
+ ! [1, 1] <-- [0, 1, 1]
+ cprime%c1(2,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(1, 2)
+ ! [0, 1] <-- [0, 1, 1]
+ cprime%c2(1,1) = 2.0_ki/3.0_ki * C(1) * coeffs%c2(1, 2)
+ ! [2, 2] <-- [0, 2, 2]
+ cprime%c1(3,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(2, 2)
+ ! [0, 2] <-- [0, 2, 2]
+ cprime%c2(2,1) = 2.0_ki/3.0_ki * C(2) * coeffs%c2(2, 2)
+ ! [3, 3] <-- [0, 3, 3]
+ cprime%c1(4,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(3, 2)
+ ! [0, 3] <-- [0, 3, 3]
+ cprime%c2(3,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(3, 2)
+ ! [2, 2] <-- [1, 2, 2]
+ cprime%c1(3,2) = cprime%c1(3,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(4, 2)
+ ! [1, 2] <-- [1, 2, 2]
+ cprime%c2(4,1) = 2.0_ki/3.0_ki * C(2) * coeffs%c2(4, 2)
+ ! [3, 3] <-- [1, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(5, 2)
+ ! [1, 3] <-- [1, 3, 3]
+ cprime%c2(5,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(5, 2)
+ ! [3, 3] <-- [2, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(6, 2)
+ ! [2, 3] <-- [2, 3, 3]
+ cprime%c2(6,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(6, 2)
+ ! [1, 2] <-- [0, 1, 2]
+ cprime%c2(4,1) = cprime%c2(4,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(1, 1)
+ ! [0, 2] <-- [0, 1, 2]
+ cprime%c2(2,1) = cprime%c2(2,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(1, 1)
+ ! [0, 1] <-- [0, 1, 2]
+ cprime%c2(1,1) = cprime%c2(1,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(1, 1)
+ ! [1, 3] <-- [0, 1, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(2, 1)
+ ! [0, 3] <-- [0, 1, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(2, 1)
+ ! [0, 1] <-- [0, 1, 3]
+ cprime%c2(1,1) = cprime%c2(1,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(2, 1)
+ ! [2, 3] <-- [0, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(3, 1)
+ ! [0, 3] <-- [0, 2, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(3, 1)
+ ! [0, 2] <-- [0, 2, 3]
+ cprime%c2(2,1) = cprime%c2(2,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(3, 1)
+ ! [2, 3] <-- [1, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(4, 1)
+ ! [1, 3] <-- [1, 2, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(4, 1)
+ ! [1, 2] <-- [1, 2, 3]
+ cprime%c2(4,1) = cprime%c2(4,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(4, 1)
+ ! [0, 0] <-- [0, 0, 0]
+ cprime%c1(1,2) = C(0) * coeffs%c1(1, 3)
+ ! [1, 1] <-- [1, 1, 1]
+ cprime%c1(2,2) = cprime%c1(2,2) + C(1) * coeffs%c1(2, 3)
+ ! [2, 2] <-- [2, 2, 2]
+ cprime%c1(3,2) = cprime%c1(3,2) + C(2) * coeffs%c1(3, 3)
+ ! [3, 3] <-- [3, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + C(3) * coeffs%c1(4, 3)
+ ! [0, 1] <-- [0, 0, 1]
+ cprime%c2(1,1) = cprime%c2(1,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(1, 5)
+ ! [0, 0] <-- [0, 0, 1]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(1, 5)
+ ! [0, 2] <-- [0, 0, 2]
+ cprime%c2(2,1) = cprime%c2(2,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(2, 5)
+ ! [0, 0] <-- [0, 0, 2]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(2, 5)
+ ! [0, 3] <-- [0, 0, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(3, 5)
+ ! [0, 0] <-- [0, 0, 3]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(3, 5)
+ ! [1, 2] <-- [1, 1, 2]
+ cprime%c2(4,1) = cprime%c2(4,1) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(4, 5)
+ ! [1, 1] <-- [1, 1, 2]
+ cprime%c1(2,2) = cprime%c1(2,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(4, 5)
+ ! [1, 3] <-- [1, 1, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(5, 5)
+ ! [1, 1] <-- [1, 1, 3]
+ cprime%c1(2,2) = cprime%c1(2,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(5, 5)
+ ! [2, 3] <-- [2, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 2.0_ki/3.0_ki * C(2) * coeffs%c2(6, 5)
+ ! [2, 2] <-- [2, 2, 3]
+ cprime%c1(3,2) = cprime%c1(3,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(6, 5)
+ ! [1, 1, 2] <-- [0, 1, 1, 2]
+ cprime%c2(4,4) = 0.25_ki * C(0) * coeffs%c3(1, 4)
+ ! [0, 1, 2] <-- [0, 1, 1, 2]
+ cprime%c3(1,1) = 0.5_ki * C(1) * coeffs%c3(1, 4)
+ ! [0, 1, 1] <-- [0, 1, 1, 2]
+ cprime%c2(1,2) = 0.25_ki * C(2) * coeffs%c3(1, 4)
+ ! [1, 1, 3] <-- [0, 1, 1, 3]
+ cprime%c2(5,4) = 0.25_ki * C(0) * coeffs%c3(2, 4)
+ ! [0, 1, 3] <-- [0, 1, 1, 3]
+ cprime%c3(2,1) = 0.5_ki * C(1) * coeffs%c3(2, 4)
+ ! [0, 1, 1] <-- [0, 1, 1, 3]
+ cprime%c2(1,2) = cprime%c2(1,2) + 0.25_ki * C(3) * coeffs%c3(2, 4)
+ ! [2, 2, 3] <-- [0, 2, 2, 3]
+ cprime%c2(6,4) = 0.25_ki * C(0) * coeffs%c3(3, 4)
+ ! [0, 2, 3] <-- [0, 2, 2, 3]
+ cprime%c3(3,1) = 0.5_ki * C(2) * coeffs%c3(3, 4)
+ ! [0, 2, 2] <-- [0, 2, 2, 3]
+ cprime%c2(2,2) = 0.25_ki * C(3) * coeffs%c3(3, 4)
+ ! [2, 2, 3] <-- [1, 2, 2, 3]
+ cprime%c2(6,4) = cprime%c2(6,4) + 0.25_ki * C(1) * coeffs%c3(4, 4)
+ ! [1, 2, 3] <-- [1, 2, 2, 3]
+ cprime%c3(4,1) = 0.5_ki * C(2) * coeffs%c3(4, 4)
+ ! [1, 2, 2] <-- [1, 2, 2, 3]
+ cprime%c2(4,2) = 0.25_ki * C(3) * coeffs%c3(4, 4)
+ ! [1, 1, 1] <-- [0, 1, 1, 1]
+ cprime%c1(2,3) = 0.25_ki * C(0) * coeffs%c2(1, 3)
+ ! [0, 1, 1] <-- [0, 1, 1, 1]
+ cprime%c2(1,2) = cprime%c2(1,2) + 3.0_ki/4.0_ki * C(1) * coeffs%c2(1, 3)
+ ! [2, 2, 2] <-- [0, 2, 2, 2]
+ cprime%c1(3,3) = 0.25_ki * C(0) * coeffs%c2(2, 3)
+ ! [0, 2, 2] <-- [0, 2, 2, 2]
+ cprime%c2(2,2) = cprime%c2(2,2) + 3.0_ki/4.0_ki * C(2) * coeffs%c2(2, 3)
+ ! [3, 3, 3] <-- [0, 3, 3, 3]
+ cprime%c1(4,3) = 0.25_ki * C(0) * coeffs%c2(3, 3)
+ ! [0, 3, 3] <-- [0, 3, 3, 3]
+ cprime%c2(3,2) = 3.0_ki/4.0_ki * C(3) * coeffs%c2(3, 3)
+ ! [2, 2, 2] <-- [1, 2, 2, 2]
+ cprime%c1(3,3) = cprime%c1(3,3) + 0.25_ki * C(1) * coeffs%c2(4, 3)
+ ! [1, 2, 2] <-- [1, 2, 2, 2]
+ cprime%c2(4,2) = cprime%c2(4,2) + 3.0_ki/4.0_ki * C(2) * coeffs%c2(4, 3)
+ ! [3, 3, 3] <-- [1, 3, 3, 3]
+ cprime%c1(4,3) = cprime%c1(4,3) + 0.25_ki * C(1) * coeffs%c2(5, 3)
+ ! [1, 3, 3] <-- [1, 3, 3, 3]
+ cprime%c2(5,2) = 3.0_ki/4.0_ki * C(3) * coeffs%c2(5, 3)
+ ! [3, 3, 3] <-- [2, 3, 3, 3]
+ cprime%c1(4,3) = cprime%c1(4,3) + 0.25_ki * C(2) * coeffs%c2(6, 3)
+ ! [2, 3, 3] <-- [2, 3, 3, 3]
+ cprime%c2(6,2) = 3.0_ki/4.0_ki * C(3) * coeffs%c2(6, 3)
+ ! [0, 1, 2] <-- [0, 0, 1, 2]
+ cprime%c3(1,1) = cprime%c3(1,1) + 0.5_ki * C(0) * coeffs%c3(1, 7)
+ ! [0, 0, 2] <-- [0, 0, 1, 2]
+ cprime%c2(2,4) = 0.25_ki * C(1) * coeffs%c3(1, 7)
+ ! [0, 0, 1] <-- [0, 0, 1, 2]
+ cprime%c2(1,4) = 0.25_ki * C(2) * coeffs%c3(1, 7)
+ ! [0, 1, 3] <-- [0, 0, 1, 3]
+ cprime%c3(2,1) = cprime%c3(2,1) + 0.5_ki * C(0) * coeffs%c3(2, 7)
+ ! [0, 0, 3] <-- [0, 0, 1, 3]
+ cprime%c2(3,4) = 0.25_ki * C(1) * coeffs%c3(2, 7)
+ ! [0, 0, 1] <-- [0, 0, 1, 3]
+ cprime%c2(1,4) = cprime%c2(1,4) + 0.25_ki * C(3) * coeffs%c3(2, 7)
+ ! [0, 2, 3] <-- [0, 0, 2, 3]
+ cprime%c3(3,1) = cprime%c3(3,1) + 0.5_ki * C(0) * coeffs%c3(3, 7)
+ ! [0, 0, 3] <-- [0, 0, 2, 3]
+ cprime%c2(3,4) = cprime%c2(3,4) + 0.25_ki * C(2) * coeffs%c3(3, 7)
+ ! [0, 0, 2] <-- [0, 0, 2, 3]
+ cprime%c2(2,4) = cprime%c2(2,4) + 0.25_ki * C(3) * coeffs%c3(3, 7)
+ ! [1, 2, 3] <-- [1, 1, 2, 3]
+ cprime%c3(4,1) = cprime%c3(4,1) + 0.5_ki * C(1) * coeffs%c3(4, 7)
+ ! [1, 1, 3] <-- [1, 1, 2, 3]
+ cprime%c2(5,4) = cprime%c2(5,4) + 0.25_ki * C(2) * coeffs%c3(4, 7)
+ ! [1, 1, 2] <-- [1, 1, 2, 3]
+ cprime%c2(4,4) = cprime%c2(4,4) + 0.25_ki * C(3) * coeffs%c3(4, 7)
+ ! [0, 0, 1] <-- [0, 0, 0, 1]
+ cprime%c2(1,4) = cprime%c2(1,4) + 3.0_ki/4.0_ki * C(0) * coeffs%c2(1, 8)
+ ! [0, 0, 0] <-- [0, 0, 0, 1]
+ cprime%c1(1,3) = 0.25_ki * C(1) * coeffs%c2(1, 8)
+ ! [0, 0, 2] <-- [0, 0, 0, 2]
+ cprime%c2(2,4) = cprime%c2(2,4) + 3.0_ki/4.0_ki * C(0) * coeffs%c2(2, 8)
+ ! [0, 0, 0] <-- [0, 0, 0, 2]
+ cprime%c1(1,3) = cprime%c1(1,3) + 0.25_ki * C(2) * coeffs%c2(2, 8)
+ ! [0, 0, 3] <-- [0, 0, 0, 3]
+ cprime%c2(3,4) = cprime%c2(3,4) + 3.0_ki/4.0_ki * C(0) * coeffs%c2(3, 8)
+ ! [0, 0, 0] <-- [0, 0, 0, 3]
+ cprime%c1(1,3) = cprime%c1(1,3) + 0.25_ki * C(3) * coeffs%c2(3, 8)
+ ! [1, 1, 2] <-- [1, 1, 1, 2]
+ cprime%c2(4,4) = cprime%c2(4,4) + 3.0_ki/4.0_ki * C(1) * coeffs%c2(4, 8)
+ ! [1, 1, 1] <-- [1, 1, 1, 2]
+ cprime%c1(2,3) = cprime%c1(2,3) + 0.25_ki * C(2) * coeffs%c2(4, 8)
+ ! [1, 1, 3] <-- [1, 1, 1, 3]
+ cprime%c2(5,4) = cprime%c2(5,4) + 3.0_ki/4.0_ki * C(1) * coeffs%c2(5, 8)
+ ! [1, 1, 1] <-- [1, 1, 1, 3]
+ cprime%c1(2,3) = cprime%c1(2,3) + 0.25_ki * C(3) * coeffs%c2(5, 8)
+ ! [2, 2, 3] <-- [2, 2, 2, 3]
+ cprime%c2(6,4) = cprime%c2(6,4) + 3.0_ki/4.0_ki * C(2) * coeffs%c2(6, 8)
+ ! [2, 2, 2] <-- [2, 2, 2, 3]
+ cprime%c1(3,3) = cprime%c1(3,3) + 0.25_ki * C(3) * coeffs%c2(6, 8)
+ ! [1, 2, 3] <-- [0, 1, 2, 3]
+ cprime%c3(4,1) = cprime%c3(4,1) + 0.25_ki * C(0) * coeffs%c4(1, 1)
+ ! [0, 2, 3] <-- [0, 1, 2, 3]
+ cprime%c3(3,1) = cprime%c3(3,1) + 0.25_ki * C(1) * coeffs%c4(1, 1)
+ ! [0, 1, 3] <-- [0, 1, 2, 3]
+ cprime%c3(2,1) = cprime%c3(2,1) + 0.25_ki * C(2) * coeffs%c4(1, 1)
+ ! [0, 1, 2] <-- [0, 1, 2, 3]
+ cprime%c3(1,1) = cprime%c3(1,1) + 0.25_ki * C(3) * coeffs%c4(1, 1)
+ ! [1, 2, 2] <-- [0, 1, 2, 2]
+ cprime%c2(4,2) = cprime%c2(4,2) + 0.25_ki * C(0) * coeffs%c3(1, 2)
+ ! [0, 2, 2] <-- [0, 1, 2, 2]
+ cprime%c2(2,2) = cprime%c2(2,2) + 0.25_ki * C(1) * coeffs%c3(1, 2)
+ ! [0, 1, 2] <-- [0, 1, 2, 2]
+ cprime%c3(1,1) = cprime%c3(1,1) + 0.5_ki * C(2) * coeffs%c3(1, 2)
+ ! [1, 3, 3] <-- [0, 1, 3, 3]
+ cprime%c2(5,2) = cprime%c2(5,2) + 0.25_ki * C(0) * coeffs%c3(2, 2)
+ ! [0, 3, 3] <-- [0, 1, 3, 3]
+ cprime%c2(3,2) = cprime%c2(3,2) + 0.25_ki * C(1) * coeffs%c3(2, 2)
+ ! [0, 1, 3] <-- [0, 1, 3, 3]
+ cprime%c3(2,1) = cprime%c3(2,1) + 0.5_ki * C(3) * coeffs%c3(2, 2)
+ ! [2, 3, 3] <-- [0, 2, 3, 3]
+ cprime%c2(6,2) = cprime%c2(6,2) + 0.25_ki * C(0) * coeffs%c3(3, 2)
+ ! [0, 3, 3] <-- [0, 2, 3, 3]
+ cprime%c2(3,2) = cprime%c2(3,2) + 0.25_ki * C(2) * coeffs%c3(3, 2)
+ ! [0, 2, 3] <-- [0, 2, 3, 3]
+ cprime%c3(3,1) = cprime%c3(3,1) + 0.5_ki * C(3) * coeffs%c3(3, 2)
+ ! [2, 3, 3] <-- [1, 2, 3, 3]
+ cprime%c2(6,2) = cprime%c2(6,2) + 0.25_ki * C(1) * coeffs%c3(4, 2)
+ ! [1, 3, 3] <-- [1, 2, 3, 3]
+ cprime%c2(5,2) = cprime%c2(5,2) + 0.25_ki * C(2) * coeffs%c3(4, 2)
+ ! [1, 2, 3] <-- [1, 2, 3, 3]
+ cprime%c3(4,1) = cprime%c3(4,1) + 0.5_ki * C(3) * coeffs%c3(4, 2)
+ ! [0, 1, 1] <-- [0, 0, 1, 1]
+ cprime%c2(1,2) = cprime%c2(1,2) + 0.5_ki * C(0) * coeffs%c2(1, 6)
+ ! [0, 0, 1] <-- [0, 0, 1, 1]
+ cprime%c2(1,4) = cprime%c2(1,4) + 0.5_ki * C(1) * coeffs%c2(1, 6)
+ ! [0, 2, 2] <-- [0, 0, 2, 2]
+ cprime%c2(2,2) = cprime%c2(2,2) + 0.5_ki * C(0) * coeffs%c2(2, 6)
+ ! [0, 0, 2] <-- [0, 0, 2, 2]
+ cprime%c2(2,4) = cprime%c2(2,4) + 0.5_ki * C(2) * coeffs%c2(2, 6)
+ ! [0, 3, 3] <-- [0, 0, 3, 3]
+ cprime%c2(3,2) = cprime%c2(3,2) + 0.5_ki * C(0) * coeffs%c2(3, 6)
+ ! [0, 0, 3] <-- [0, 0, 3, 3]
+ cprime%c2(3,4) = cprime%c2(3,4) + 0.5_ki * C(3) * coeffs%c2(3, 6)
+ ! [1, 2, 2] <-- [1, 1, 2, 2]
+ cprime%c2(4,2) = cprime%c2(4,2) + 0.5_ki * C(1) * coeffs%c2(4, 6)
+ ! [1, 1, 2] <-- [1, 1, 2, 2]
+ cprime%c2(4,4) = cprime%c2(4,4) + 0.5_ki * C(2) * coeffs%c2(4, 6)
+ ! [1, 3, 3] <-- [1, 1, 3, 3]
+ cprime%c2(5,2) = cprime%c2(5,2) + 0.5_ki * C(1) * coeffs%c2(5, 6)
+ ! [1, 1, 3] <-- [1, 1, 3, 3]
+ cprime%c2(5,4) = cprime%c2(5,4) + 0.5_ki * C(3) * coeffs%c2(5, 6)
+ ! [2, 3, 3] <-- [2, 2, 3, 3]
+ cprime%c2(6,2) = cprime%c2(6,2) + 0.5_ki * C(2) * coeffs%c2(6, 6)
+ ! [2, 2, 3] <-- [2, 2, 3, 3]
+ cprime%c2(6,4) = cprime%c2(6,4) + 0.5_ki * C(3) * coeffs%c2(6, 6)
+ ! [0, 0, 0] <-- [0, 0, 0, 0]
+ cprime%c1(1,3) = cprime%c1(1,3) + C(0) * coeffs%c1(1, 4)
+ ! [1, 1, 1] <-- [1, 1, 1, 1]
+ cprime%c1(2,3) = cprime%c1(2,3) + C(1) * coeffs%c1(2, 4)
+ ! [2, 2, 2] <-- [2, 2, 2, 2]
+ cprime%c1(3,3) = cprime%c1(3,3) + C(2) * coeffs%c1(3, 4)
+ ! [3, 3, 3] <-- [3, 3, 3, 3]
+ cprime%c1(4,3) = cprime%c1(4,3) + C(3) * coeffs%c1(4, 4)
+ ! [0, 0, 1, 1] <-- [0, 0, 0, 1, 1]
+ cprime%c2(1,5) = 3.0_ki/5.0_ki * C(0) * coeffs%c2(1, 9)
+ ! [0, 0, 0, 1] <-- [0, 0, 0, 1, 1]
+ cprime%c2(1,6) = 2.0_ki/5.0_ki * C(1) * coeffs%c2(1, 9)
+ ! [0, 0, 2, 2] <-- [0, 0, 0, 2, 2]
+ cprime%c2(2,5) = 3.0_ki/5.0_ki * C(0) * coeffs%c2(2, 9)
+ ! [0, 0, 0, 2] <-- [0, 0, 0, 2, 2]
+ cprime%c2(2,6) = 2.0_ki/5.0_ki * C(2) * coeffs%c2(2, 9)
+ ! [0, 0, 3, 3] <-- [0, 0, 0, 3, 3]
+ cprime%c2(3,5) = 3.0_ki/5.0_ki * C(0) * coeffs%c2(3, 9)
+ ! [0, 0, 0, 3] <-- [0, 0, 0, 3, 3]
+ cprime%c2(3,6) = 2.0_ki/5.0_ki * C(3) * coeffs%c2(3, 9)
+ ! [1, 1, 2, 2] <-- [1, 1, 1, 2, 2]
+ cprime%c2(4,5) = 3.0_ki/5.0_ki * C(1) * coeffs%c2(4, 9)
+ ! [1, 1, 1, 2] <-- [1, 1, 1, 2, 2]
+ cprime%c2(4,6) = 2.0_ki/5.0_ki * C(2) * coeffs%c2(4, 9)
+ ! [1, 1, 3, 3] <-- [1, 1, 1, 3, 3]
+ cprime%c2(5,5) = 3.0_ki/5.0_ki * C(1) * coeffs%c2(5, 9)
+ ! [1, 1, 1, 3] <-- [1, 1, 1, 3, 3]
+ cprime%c2(5,6) = 2.0_ki/5.0_ki * C(3) * coeffs%c2(5, 9)
+ ! [2, 2, 3, 3] <-- [2, 2, 2, 3, 3]
+ cprime%c2(6,5) = 3.0_ki/5.0_ki * C(2) * coeffs%c2(6, 9)
+ ! [2, 2, 2, 3] <-- [2, 2, 2, 3, 3]
+ cprime%c2(6,6) = 2.0_ki/5.0_ki * C(3) * coeffs%c2(6, 9)
+ ! [0, 0, 1, 2] <-- [0, 0, 0, 1, 2]
+ cprime%c3(1,4) = 3.0_ki/5.0_ki * C(0) * coeffs%c3(1, 10)
+ ! [0, 0, 0, 2] <-- [0, 0, 0, 1, 2]
+ cprime%c2(2,6) = cprime%c2(2,6) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(1, 10)
+ ! [0, 0, 0, 1] <-- [0, 0, 0, 1, 2]
+ cprime%c2(1,6) = cprime%c2(1,6) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(1, 10)
+ ! [0, 0, 1, 3] <-- [0, 0, 0, 1, 3]
+ cprime%c3(2,4) = 3.0_ki/5.0_ki * C(0) * coeffs%c3(2, 10)
+ ! [0, 0, 0, 3] <-- [0, 0, 0, 1, 3]
+ cprime%c2(3,6) = cprime%c2(3,6) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(2, 10)
+ ! [0, 0, 0, 1] <-- [0, 0, 0, 1, 3]
+ cprime%c2(1,6) = cprime%c2(1,6) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(2, 10)
+ ! [0, 0, 2, 3] <-- [0, 0, 0, 2, 3]
+ cprime%c3(3,4) = 3.0_ki/5.0_ki * C(0) * coeffs%c3(3, 10)
+ ! [0, 0, 0, 3] <-- [0, 0, 0, 2, 3]
+ cprime%c2(3,6) = cprime%c2(3,6) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(3, 10)
+ ! [0, 0, 0, 2] <-- [0, 0, 0, 2, 3]
+ cprime%c2(2,6) = cprime%c2(2,6) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(3, 10)
+ ! [1, 1, 2, 3] <-- [1, 1, 1, 2, 3]
+ cprime%c3(4,4) = 3.0_ki/5.0_ki * C(1) * coeffs%c3(4, 10)
+ ! [1, 1, 1, 3] <-- [1, 1, 1, 2, 3]
+ cprime%c2(5,6) = cprime%c2(5,6) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(4, 10)
+ ! [1, 1, 1, 2] <-- [1, 1, 1, 2, 3]
+ cprime%c2(4,6) = cprime%c2(4,6) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(4, 10)
+ ! [1, 2, 3, 3] <-- [0, 1, 2, 3, 3]
+ cprime%c3(4,2) = 1.0_ki/5.0_ki * C(0) * coeffs%c4(1, 2)
+ ! [0, 2, 3, 3] <-- [0, 1, 2, 3, 3]
+ cprime%c3(3,2) = 1.0_ki/5.0_ki * C(1) * coeffs%c4(1, 2)
+ ! [0, 1, 3, 3] <-- [0, 1, 2, 3, 3]
+ cprime%c3(2,2) = 1.0_ki/5.0_ki * C(2) * coeffs%c4(1, 2)
+ ! [0, 1, 2, 3] <-- [0, 1, 2, 3, 3]
+ cprime%c4(1,1) = 2.0_ki/5.0_ki * C(3) * coeffs%c4(1, 2)
+ ! [1, 2, 2, 2] <-- [0, 1, 2, 2, 2]
+ cprime%c2(4,3) = 1.0_ki/5.0_ki * C(0) * coeffs%c3(1, 3)
+ ! [0, 2, 2, 2] <-- [0, 1, 2, 2, 2]
+ cprime%c2(2,3) = 1.0_ki/5.0_ki * C(1) * coeffs%c3(1, 3)
+ ! [0, 1, 2, 2] <-- [0, 1, 2, 2, 2]
+ cprime%c3(1,2) = 3.0_ki/5.0_ki * C(2) * coeffs%c3(1, 3)
+ ! [1, 3, 3, 3] <-- [0, 1, 3, 3, 3]
+ cprime%c2(5,3) = 1.0_ki/5.0_ki * C(0) * coeffs%c3(2, 3)
+ ! [0, 3, 3, 3] <-- [0, 1, 3, 3, 3]
+ cprime%c2(3,3) = 1.0_ki/5.0_ki * C(1) * coeffs%c3(2, 3)
+ ! [0, 1, 3, 3] <-- [0, 1, 3, 3, 3]
+ cprime%c3(2,2) = cprime%c3(2,2) + 3.0_ki/5.0_ki * C(3) * coeffs%c3(2, 3)
+ ! [2, 3, 3, 3] <-- [0, 2, 3, 3, 3]
+ cprime%c2(6,3) = 1.0_ki/5.0_ki * C(0) * coeffs%c3(3, 3)
+ ! [0, 3, 3, 3] <-- [0, 2, 3, 3, 3]
+ cprime%c2(3,3) = cprime%c2(3,3) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(3, 3)
+ ! [0, 2, 3, 3] <-- [0, 2, 3, 3, 3]
+ cprime%c3(3,2) = cprime%c3(3,2) + 3.0_ki/5.0_ki * C(3) * coeffs%c3(3, 3)
+ ! [2, 3, 3, 3] <-- [1, 2, 3, 3, 3]
+ cprime%c2(6,3) = cprime%c2(6,3) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(4, 3)
+ ! [1, 3, 3, 3] <-- [1, 2, 3, 3, 3]
+ cprime%c2(5,3) = cprime%c2(5,3) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(4, 3)
+ ! [1, 2, 3, 3] <-- [1, 2, 3, 3, 3]
+ cprime%c3(4,2) = cprime%c3(4,2) + 3.0_ki/5.0_ki * C(3) * coeffs%c3(4, 3)
+ ! [0, 1, 2, 3] <-- [0, 0, 1, 2, 3]
+ cprime%c4(1,1) = cprime%c4(1,1) + 2.0_ki/5.0_ki * C(0) * coeffs%c4(1, 5)
+ ! [0, 0, 2, 3] <-- [0, 0, 1, 2, 3]
+ cprime%c3(3,4) = cprime%c3(3,4) + 1.0_ki/5.0_ki * C(1) * coeffs%c4(1, 5)
+ ! [0, 0, 1, 3] <-- [0, 0, 1, 2, 3]
+ cprime%c3(2,4) = cprime%c3(2,4) + 1.0_ki/5.0_ki * C(2) * coeffs%c4(1, 5)
+ ! [0, 0, 1, 2] <-- [0, 0, 1, 2, 3]
+ cprime%c3(1,4) = cprime%c3(1,4) + 1.0_ki/5.0_ki * C(3) * coeffs%c4(1, 5)
+ ! [1, 2, 2, 3] <-- [0, 1, 2, 2, 3]
+ cprime%c3(4,3) = 1.0_ki/5.0_ki * C(0) * coeffs%c4(1, 3)
+ ! [0, 2, 2, 3] <-- [0, 1, 2, 2, 3]
+ cprime%c3(3,3) = 1.0_ki/5.0_ki * C(1) * coeffs%c4(1, 3)
+ ! [0, 1, 2, 3] <-- [0, 1, 2, 2, 3]
+ cprime%c4(1,1) = cprime%c4(1,1) + 2.0_ki/5.0_ki * C(2) * coeffs%c4(1, 3)
+ ! [0, 1, 2, 2] <-- [0, 1, 2, 2, 3]
+ cprime%c3(1,2) = cprime%c3(1,2) + 1.0_ki/5.0_ki * C(3) * coeffs%c4(1, 3)
+ ! [1, 1, 1, 2] <-- [0, 1, 1, 1, 2]
+ cprime%c2(4,6) = cprime%c2(4,6) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(1, 6)
+ ! [0, 1, 1, 2] <-- [0, 1, 1, 1, 2]
+ cprime%c3(1,3) = 3.0_ki/5.0_ki * C(1) * coeffs%c3(1, 6)
+ ! [0, 1, 1, 1] <-- [0, 1, 1, 1, 2]
+ cprime%c2(1,3) = 1.0_ki/5.0_ki * C(2) * coeffs%c3(1, 6)
+ ! [1, 1, 1, 3] <-- [0, 1, 1, 1, 3]
+ cprime%c2(5,6) = cprime%c2(5,6) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(2, 6)
+ ! [0, 1, 1, 3] <-- [0, 1, 1, 1, 3]
+ cprime%c3(2,3) = 3.0_ki/5.0_ki * C(1) * coeffs%c3(2, 6)
+ ! [0, 1, 1, 1] <-- [0, 1, 1, 1, 3]
+ cprime%c2(1,3) = cprime%c2(1,3) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(2, 6)
+ ! [2, 2, 2, 3] <-- [0, 2, 2, 2, 3]
+ cprime%c2(6,6) = cprime%c2(6,6) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(3, 6)
+ ! [0, 2, 2, 3] <-- [0, 2, 2, 2, 3]
+ cprime%c3(3,3) = cprime%c3(3,3) + 3.0_ki/5.0_ki * C(2) * coeffs%c3(3, 6)
+ ! [0, 2, 2, 2] <-- [0, 2, 2, 2, 3]
+ cprime%c2(2,3) = cprime%c2(2,3) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(3, 6)
+ ! [2, 2, 2, 3] <-- [1, 2, 2, 2, 3]
+ cprime%c2(6,6) = cprime%c2(6,6) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(4, 6)
+ ! [1, 2, 2, 3] <-- [1, 2, 2, 2, 3]
+ cprime%c3(4,3) = cprime%c3(4,3) + 3.0_ki/5.0_ki * C(2) * coeffs%c3(4, 6)
+ ! [1, 2, 2, 2] <-- [1, 2, 2, 2, 3]
+ cprime%c2(4,3) = cprime%c2(4,3) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(4, 6)
+ ! [1, 1, 1, 1] <-- [0, 1, 1, 1, 1]
+ cprime%c1(2,4) = 1.0_ki/5.0_ki * C(0) * coeffs%c2(1, 4)
+ ! [0, 1, 1, 1] <-- [0, 1, 1, 1, 1]
+ cprime%c2(1,3) = cprime%c2(1,3) + 4.0_ki/5.0_ki * C(1) * coeffs%c2(1, 4)
+ ! [2, 2, 2, 2] <-- [0, 2, 2, 2, 2]
+ cprime%c1(3,4) = 1.0_ki/5.0_ki * C(0) * coeffs%c2(2, 4)
+ ! [0, 2, 2, 2] <-- [0, 2, 2, 2, 2]
+ cprime%c2(2,3) = cprime%c2(2,3) + 4.0_ki/5.0_ki * C(2) * coeffs%c2(2, 4)
+ ! [3, 3, 3, 3] <-- [0, 3, 3, 3, 3]
+ cprime%c1(4,4) = 1.0_ki/5.0_ki * C(0) * coeffs%c2(3, 4)
+ ! [0, 3, 3, 3] <-- [0, 3, 3, 3, 3]
+ cprime%c2(3,3) = cprime%c2(3,3) + 4.0_ki/5.0_ki * C(3) * coeffs%c2(3, 4)
+ ! [2, 2, 2, 2] <-- [1, 2, 2, 2, 2]
+ cprime%c1(3,4) = cprime%c1(3,4) + 1.0_ki/5.0_ki * C(1) * coeffs%c2(4, 4)
+ ! [1, 2, 2, 2] <-- [1, 2, 2, 2, 2]
+ cprime%c2(4,3) = cprime%c2(4,3) + 4.0_ki/5.0_ki * C(2) * coeffs%c2(4, 4)
+ ! [3, 3, 3, 3] <-- [1, 3, 3, 3, 3]
+ cprime%c1(4,4) = cprime%c1(4,4) + 1.0_ki/5.0_ki * C(1) * coeffs%c2(5, 4)
+ ! [1, 3, 3, 3] <-- [1, 3, 3, 3, 3]
+ cprime%c2(5,3) = cprime%c2(5,3) + 4.0_ki/5.0_ki * C(3) * coeffs%c2(5, 4)
+ ! [3, 3, 3, 3] <-- [2, 3, 3, 3, 3]
+ cprime%c1(4,4) = cprime%c1(4,4) + 1.0_ki/5.0_ki * C(2) * coeffs%c2(6, 4)
+ ! [2, 3, 3, 3] <-- [2, 3, 3, 3, 3]
+ cprime%c2(6,3) = cprime%c2(6,3) + 4.0_ki/5.0_ki * C(3) * coeffs%c2(6, 4)
+ ! [1, 1, 2, 2] <-- [0, 1, 1, 2, 2]
+ cprime%c2(4,5) = cprime%c2(4,5) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(1, 5)
+ ! [0, 1, 2, 2] <-- [0, 1, 1, 2, 2]
+ cprime%c3(1,2) = cprime%c3(1,2) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(1, 5)
+ ! [0, 1, 1, 2] <-- [0, 1, 1, 2, 2]
+ cprime%c3(1,3) = cprime%c3(1,3) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(1, 5)
+ ! [1, 1, 3, 3] <-- [0, 1, 1, 3, 3]
+ cprime%c2(5,5) = cprime%c2(5,5) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(2, 5)
+ ! [0, 1, 3, 3] <-- [0, 1, 1, 3, 3]
+ cprime%c3(2,2) = cprime%c3(2,2) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(2, 5)
+ ! [0, 1, 1, 3] <-- [0, 1, 1, 3, 3]
+ cprime%c3(2,3) = cprime%c3(2,3) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(2, 5)
+ ! [2, 2, 3, 3] <-- [0, 2, 2, 3, 3]
+ cprime%c2(6,5) = cprime%c2(6,5) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(3, 5)
+ ! [0, 2, 3, 3] <-- [0, 2, 2, 3, 3]
+ cprime%c3(3,2) = cprime%c3(3,2) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(3, 5)
+ ! [0, 2, 2, 3] <-- [0, 2, 2, 3, 3]
+ cprime%c3(3,3) = cprime%c3(3,3) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(3, 5)
+ ! [2, 2, 3, 3] <-- [1, 2, 2, 3, 3]
+ cprime%c2(6,5) = cprime%c2(6,5) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(4, 5)
+ ! [1, 2, 3, 3] <-- [1, 2, 2, 3, 3]
+ cprime%c3(4,2) = cprime%c3(4,2) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(4, 5)
+ ! [1, 2, 2, 3] <-- [1, 2, 2, 3, 3]
+ cprime%c3(4,3) = cprime%c3(4,3) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(4, 5)
+ ! [0, 0, 0, 0] <-- [0, 0, 0, 0, 0]
+ cprime%c1(1,4) = C(0) * coeffs%c1(1, 5)
+ ! [1, 1, 1, 1] <-- [1, 1, 1, 1, 1]
+ cprime%c1(2,4) = cprime%c1(2,4) + C(1) * coeffs%c1(2, 5)
+ ! [2, 2, 2, 2] <-- [2, 2, 2, 2, 2]
+ cprime%c1(3,4) = cprime%c1(3,4) + C(2) * coeffs%c1(3, 5)
+ ! [3, 3, 3, 3] <-- [3, 3, 3, 3, 3]
+ cprime%c1(4,4) = cprime%c1(4,4) + C(3) * coeffs%c1(4, 5)
+ ! [0, 1, 1, 1] <-- [0, 0, 1, 1, 1]
+ cprime%c2(1,3) = cprime%c2(1,3) + 2.0_ki/5.0_ki * C(0) * coeffs%c2(1, 7)
+ ! [0, 0, 1, 1] <-- [0, 0, 1, 1, 1]
+ cprime%c2(1,5) = cprime%c2(1,5) + 3.0_ki/5.0_ki * C(1) * coeffs%c2(1, 7)
+ ! [0, 2, 2, 2] <-- [0, 0, 2, 2, 2]
+ cprime%c2(2,3) = cprime%c2(2,3) + 2.0_ki/5.0_ki * C(0) * coeffs%c2(2, 7)
+ ! [0, 0, 2, 2] <-- [0, 0, 2, 2, 2]
+ cprime%c2(2,5) = cprime%c2(2,5) + 3.0_ki/5.0_ki * C(2) * coeffs%c2(2, 7)
+ ! [0, 3, 3, 3] <-- [0, 0, 3, 3, 3]
+ cprime%c2(3,3) = cprime%c2(3,3) + 2.0_ki/5.0_ki * C(0) * coeffs%c2(3, 7)
+ ! [0, 0, 3, 3] <-- [0, 0, 3, 3, 3]
+ cprime%c2(3,5) = cprime%c2(3,5) + 3.0_ki/5.0_ki * C(3) * coeffs%c2(3, 7)
+ ! [1, 2, 2, 2] <-- [1, 1, 2, 2, 2]
+ cprime%c2(4,3) = cprime%c2(4,3) + 2.0_ki/5.0_ki * C(1) * coeffs%c2(4, 7)
+ ! [1, 1, 2, 2] <-- [1, 1, 2, 2, 2]
+ cprime%c2(4,5) = cprime%c2(4,5) + 3.0_ki/5.0_ki * C(2) * coeffs%c2(4, 7)
+ ! [1, 3, 3, 3] <-- [1, 1, 3, 3, 3]
+ cprime%c2(5,3) = cprime%c2(5,3) + 2.0_ki/5.0_ki * C(1) * coeffs%c2(5, 7)
+ ! [1, 1, 3, 3] <-- [1, 1, 3, 3, 3]
+ cprime%c2(5,5) = cprime%c2(5,5) + 3.0_ki/5.0_ki * C(3) * coeffs%c2(5, 7)
+ ! [2, 3, 3, 3] <-- [2, 2, 3, 3, 3]
+ cprime%c2(6,3) = cprime%c2(6,3) + 2.0_ki/5.0_ki * C(2) * coeffs%c2(6, 7)
+ ! [2, 2, 3, 3] <-- [2, 2, 3, 3, 3]
+ cprime%c2(6,5) = cprime%c2(6,5) + 3.0_ki/5.0_ki * C(3) * coeffs%c2(6, 7)
+ ! [0, 1, 2, 2] <-- [0, 0, 1, 2, 2]
+ cprime%c3(1,2) = cprime%c3(1,2) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(1, 8)
+ ! [0, 0, 2, 2] <-- [0, 0, 1, 2, 2]
+ cprime%c2(2,5) = cprime%c2(2,5) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(1, 8)
+ ! [0, 0, 1, 2] <-- [0, 0, 1, 2, 2]
+ cprime%c3(1,4) = cprime%c3(1,4) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(1, 8)
+ ! [0, 1, 3, 3] <-- [0, 0, 1, 3, 3]
+ cprime%c3(2,2) = cprime%c3(2,2) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(2, 8)
+ ! [0, 0, 3, 3] <-- [0, 0, 1, 3, 3]
+ cprime%c2(3,5) = cprime%c2(3,5) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(2, 8)
+ ! [0, 0, 1, 3] <-- [0, 0, 1, 3, 3]
+ cprime%c3(2,4) = cprime%c3(2,4) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(2, 8)
+ ! [0, 2, 3, 3] <-- [0, 0, 2, 3, 3]
+ cprime%c3(3,2) = cprime%c3(3,2) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(3, 8)
+ ! [0, 0, 3, 3] <-- [0, 0, 2, 3, 3]
+ cprime%c2(3,5) = cprime%c2(3,5) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(3, 8)
+ ! [0, 0, 2, 3] <-- [0, 0, 2, 3, 3]
+ cprime%c3(3,4) = cprime%c3(3,4) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(3, 8)
+ ! [1, 2, 3, 3] <-- [1, 1, 2, 3, 3]
+ cprime%c3(4,2) = cprime%c3(4,2) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(4, 8)
+ ! [1, 1, 3, 3] <-- [1, 1, 2, 3, 3]
+ cprime%c2(5,5) = cprime%c2(5,5) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(4, 8)
+ ! [1, 1, 2, 3] <-- [1, 1, 2, 3, 3]
+ cprime%c3(4,4) = cprime%c3(4,4) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(4, 8)
+ ! [0, 0, 0, 1] <-- [0, 0, 0, 0, 1]
+ cprime%c2(1,6) = cprime%c2(1,6) + 4.0_ki/5.0_ki * C(0) * coeffs%c2(1, 10)
+ ! [0, 0, 0, 0] <-- [0, 0, 0, 0, 1]
+ cprime%c1(1,4) = cprime%c1(1,4) + 1.0_ki/5.0_ki * C(1) * coeffs%c2(1, 10)
+ ! [0, 0, 0, 2] <-- [0, 0, 0, 0, 2]
+ cprime%c2(2,6) = cprime%c2(2,6) + 4.0_ki/5.0_ki * C(0) * coeffs%c2(2, 10)
+ ! [0, 0, 0, 0] <-- [0, 0, 0, 0, 2]
+ cprime%c1(1,4) = cprime%c1(1,4) + 1.0_ki/5.0_ki * C(2) * coeffs%c2(2, 10)
+ ! [0, 0, 0, 3] <-- [0, 0, 0, 0, 3]
+ cprime%c2(3,6) = cprime%c2(3,6) + 4.0_ki/5.0_ki * C(0) * coeffs%c2(3, 10)
+ ! [0, 0, 0, 0] <-- [0, 0, 0, 0, 3]
+ cprime%c1(1,4) = cprime%c1(1,4) + 1.0_ki/5.0_ki * C(3) * coeffs%c2(3, 10)
+ ! [1, 1, 1, 2] <-- [1, 1, 1, 1, 2]
+ cprime%c2(4,6) = cprime%c2(4,6) + 4.0_ki/5.0_ki * C(1) * coeffs%c2(4, 10)
+ ! [1, 1, 1, 1] <-- [1, 1, 1, 1, 2]
+ cprime%c1(2,4) = cprime%c1(2,4) + 1.0_ki/5.0_ki * C(2) * coeffs%c2(4, 10)
+ ! [1, 1, 1, 3] <-- [1, 1, 1, 1, 3]
+ cprime%c2(5,6) = cprime%c2(5,6) + 4.0_ki/5.0_ki * C(1) * coeffs%c2(5, 10)
+ ! [1, 1, 1, 1] <-- [1, 1, 1, 1, 3]
+ cprime%c1(2,4) = cprime%c1(2,4) + 1.0_ki/5.0_ki * C(3) * coeffs%c2(5, 10)
+ ! [2, 2, 2, 3] <-- [2, 2, 2, 2, 3]
+ cprime%c2(6,6) = cprime%c2(6,6) + 4.0_ki/5.0_ki * C(2) * coeffs%c2(6, 10)
+ ! [2, 2, 2, 2] <-- [2, 2, 2, 2, 3]
+ cprime%c1(3,4) = cprime%c1(3,4) + 1.0_ki/5.0_ki * C(3) * coeffs%c2(6, 10)
+ ! [0, 1, 1, 2] <-- [0, 0, 1, 1, 2]
+ cprime%c3(1,3) = cprime%c3(1,3) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(1, 9)
+ ! [0, 0, 1, 2] <-- [0, 0, 1, 1, 2]
+ cprime%c3(1,4) = cprime%c3(1,4) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(1, 9)
+ ! [0, 0, 1, 1] <-- [0, 0, 1, 1, 2]
+ cprime%c2(1,5) = cprime%c2(1,5) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(1, 9)
+ ! [0, 1, 1, 3] <-- [0, 0, 1, 1, 3]
+ cprime%c3(2,3) = cprime%c3(2,3) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(2, 9)
+ ! [0, 0, 1, 3] <-- [0, 0, 1, 1, 3]
+ cprime%c3(2,4) = cprime%c3(2,4) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(2, 9)
+ ! [0, 0, 1, 1] <-- [0, 0, 1, 1, 3]
+ cprime%c2(1,5) = cprime%c2(1,5) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(2, 9)
+ ! [0, 2, 2, 3] <-- [0, 0, 2, 2, 3]
+ cprime%c3(3,3) = cprime%c3(3,3) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(3, 9)
+ ! [0, 0, 2, 3] <-- [0, 0, 2, 2, 3]
+ cprime%c3(3,4) = cprime%c3(3,4) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(3, 9)
+ ! [0, 0, 2, 2] <-- [0, 0, 2, 2, 3]
+ cprime%c2(2,5) = cprime%c2(2,5) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(3, 9)
+ ! [1, 2, 2, 3] <-- [1, 1, 2, 2, 3]
+ cprime%c3(4,3) = cprime%c3(4,3) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(4, 9)
+ ! [1, 1, 2, 3] <-- [1, 1, 2, 2, 3]
+ cprime%c3(4,4) = cprime%c3(4,4) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(4, 9)
+ ! [1, 1, 2, 2] <-- [1, 1, 2, 2, 3]
+ cprime%c2(4,5) = cprime%c2(4,5) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(4, 9)
+ ! [1, 1, 2, 3] <-- [0, 1, 1, 2, 3]
+ cprime%c3(4,4) = cprime%c3(4,4) + 1.0_ki/5.0_ki * C(0) * coeffs%c4(1, 4)
+ ! [0, 1, 2, 3] <-- [0, 1, 1, 2, 3]
+ cprime%c4(1,1) = cprime%c4(1,1) + 2.0_ki/5.0_ki * C(1) * coeffs%c4(1, 4)
+ ! [0, 1, 1, 3] <-- [0, 1, 1, 2, 3]
+ cprime%c3(2,3) = cprime%c3(2,3) + 1.0_ki/5.0_ki * C(2) * coeffs%c4(1, 4)
+ ! [0, 1, 1, 2] <-- [0, 1, 1, 2, 3]
+ cprime%c3(1,3) = cprime%c3(1,3) + 1.0_ki/5.0_ki * C(3) * coeffs%c4(1, 4)
+ amp = amp - contract5_4(cprime, momenta, new_set)
+ end do
+end function contract6_5
+!****f* src/interface/tens_comb/contract6_6
+! NAME
+!
+! Function contract6_6
+!
+! USAGE
+!
+! amp = contract6_6(coeffs, momenta, b_set)
+!
+! DESCRIPTION
+!
+! Contracts the 6-point rank 6 tensor integral
+! with its coefficients.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_6)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+! * b_set -- the set of pinched propagators as integer number (bit-set)
+!
+! RETURN VALUE
+!
+! The result of contracting the tensor integral with its coefficient.
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+function contract6_6(coeffs, momenta, b_set) result(amp)
+ ! generated by: write_function_contract
+ implicit none
+ type(coeff_type_6), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in) :: momenta
+ integer, intent(in) :: b_set
+ type(form_factor) :: amp
+ ! generated by: write_contract_split
+ complex(ki), dimension(0:3) :: C
+ type(coeff_type_5) :: cprime
+ integer :: i, pnch, new_set
+ integer, dimension(1) :: pnch_set
+ integer, dimension(6) :: unpinched
+ unpinched = unpackb(pminus(b_ref, b_set), 6)
+ amp = coeffs%c0 * a60(b_set)
+ do pnch=1,6
+ ! Eq. (54) in hep-ph/0504267
+ C(:) = 0.0_ki
+ do i=1,6
+ C(:) = C(:) + inv_s(unpinched(pnch),unpinched(i),b_set) * &
+ & momenta(unpinched(i),:)
+ end do
+ ! Eq. (63) in hep-ph/0504267
+ pnch_set(1) = pnch
+ new_set = punion(packb(pnch_set),b_set)
+ ! [] <-- [0]
+ cprime%c0 = C(0) * coeffs%c1(1, 1)
+ ! [] <-- [1]
+ cprime%c0 = cprime%c0 + C(1) * coeffs%c1(2, 1)
+ ! [] <-- [2]
+ cprime%c0 = cprime%c0 + C(2) * coeffs%c1(3, 1)
+ ! [] <-- [3]
+ cprime%c0 = cprime%c0 + C(3) * coeffs%c1(4, 1)
+ ! [0] <-- [0, 0]
+ cprime%c1(1,1) = C(0) * coeffs%c1(1, 2)
+ ! [1] <-- [1, 1]
+ cprime%c1(2,1) = C(1) * coeffs%c1(2, 2)
+ ! [2] <-- [2, 2]
+ cprime%c1(3,1) = C(2) * coeffs%c1(3, 2)
+ ! [3] <-- [3, 3]
+ cprime%c1(4,1) = C(3) * coeffs%c1(4, 2)
+ ! [1] <-- [0, 1]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(0) * coeffs%c2(1, 1)
+ ! [0] <-- [0, 1]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(1) * coeffs%c2(1, 1)
+ ! [2] <-- [0, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(0) * coeffs%c2(2, 1)
+ ! [0] <-- [0, 2]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(2) * coeffs%c2(2, 1)
+ ! [3] <-- [0, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(0) * coeffs%c2(3, 1)
+ ! [0] <-- [0, 3]
+ cprime%c1(1,1) = cprime%c1(1,1) + 0.5_ki * C(3) * coeffs%c2(3, 1)
+ ! [2] <-- [1, 2]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(1) * coeffs%c2(4, 1)
+ ! [1] <-- [1, 2]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(2) * coeffs%c2(4, 1)
+ ! [3] <-- [1, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(1) * coeffs%c2(5, 1)
+ ! [1] <-- [1, 3]
+ cprime%c1(2,1) = cprime%c1(2,1) + 0.5_ki * C(3) * coeffs%c2(5, 1)
+ ! [3] <-- [2, 3]
+ cprime%c1(4,1) = cprime%c1(4,1) + 0.5_ki * C(2) * coeffs%c2(6, 1)
+ ! [2] <-- [2, 3]
+ cprime%c1(3,1) = cprime%c1(3,1) + 0.5_ki * C(3) * coeffs%c2(6, 1)
+ ! [1, 1] <-- [0, 1, 1]
+ cprime%c1(2,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(1, 2)
+ ! [0, 1] <-- [0, 1, 1]
+ cprime%c2(1,1) = 2.0_ki/3.0_ki * C(1) * coeffs%c2(1, 2)
+ ! [2, 2] <-- [0, 2, 2]
+ cprime%c1(3,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(2, 2)
+ ! [0, 2] <-- [0, 2, 2]
+ cprime%c2(2,1) = 2.0_ki/3.0_ki * C(2) * coeffs%c2(2, 2)
+ ! [3, 3] <-- [0, 3, 3]
+ cprime%c1(4,2) = 1.0_ki/3.0_ki * C(0) * coeffs%c2(3, 2)
+ ! [0, 3] <-- [0, 3, 3]
+ cprime%c2(3,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(3, 2)
+ ! [2, 2] <-- [1, 2, 2]
+ cprime%c1(3,2) = cprime%c1(3,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(4, 2)
+ ! [1, 2] <-- [1, 2, 2]
+ cprime%c2(4,1) = 2.0_ki/3.0_ki * C(2) * coeffs%c2(4, 2)
+ ! [3, 3] <-- [1, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(5, 2)
+ ! [1, 3] <-- [1, 3, 3]
+ cprime%c2(5,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(5, 2)
+ ! [3, 3] <-- [2, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(6, 2)
+ ! [2, 3] <-- [2, 3, 3]
+ cprime%c2(6,1) = 2.0_ki/3.0_ki * C(3) * coeffs%c2(6, 2)
+ ! [1, 2] <-- [0, 1, 2]
+ cprime%c2(4,1) = cprime%c2(4,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(1, 1)
+ ! [0, 2] <-- [0, 1, 2]
+ cprime%c2(2,1) = cprime%c2(2,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(1, 1)
+ ! [0, 1] <-- [0, 1, 2]
+ cprime%c2(1,1) = cprime%c2(1,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(1, 1)
+ ! [1, 3] <-- [0, 1, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(2, 1)
+ ! [0, 3] <-- [0, 1, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(2, 1)
+ ! [0, 1] <-- [0, 1, 3]
+ cprime%c2(1,1) = cprime%c2(1,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(2, 1)
+ ! [2, 3] <-- [0, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(3, 1)
+ ! [0, 3] <-- [0, 2, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(3, 1)
+ ! [0, 2] <-- [0, 2, 3]
+ cprime%c2(2,1) = cprime%c2(2,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(3, 1)
+ ! [2, 3] <-- [1, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(4, 1)
+ ! [1, 3] <-- [1, 2, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(4, 1)
+ ! [1, 2] <-- [1, 2, 3]
+ cprime%c2(4,1) = cprime%c2(4,1) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(4, 1)
+ ! [0, 0] <-- [0, 0, 0]
+ cprime%c1(1,2) = C(0) * coeffs%c1(1, 3)
+ ! [1, 1] <-- [1, 1, 1]
+ cprime%c1(2,2) = cprime%c1(2,2) + C(1) * coeffs%c1(2, 3)
+ ! [2, 2] <-- [2, 2, 2]
+ cprime%c1(3,2) = cprime%c1(3,2) + C(2) * coeffs%c1(3, 3)
+ ! [3, 3] <-- [3, 3, 3]
+ cprime%c1(4,2) = cprime%c1(4,2) + C(3) * coeffs%c1(4, 3)
+ ! [0, 1] <-- [0, 0, 1]
+ cprime%c2(1,1) = cprime%c2(1,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(1, 6)
+ ! [0, 0] <-- [0, 0, 1]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(1, 6)
+ ! [0, 2] <-- [0, 0, 2]
+ cprime%c2(2,1) = cprime%c2(2,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(2, 6)
+ ! [0, 0] <-- [0, 0, 2]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(2, 6)
+ ! [0, 3] <-- [0, 0, 3]
+ cprime%c2(3,1) = cprime%c2(3,1) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(3, 6)
+ ! [0, 0] <-- [0, 0, 3]
+ cprime%c1(1,2) = cprime%c1(1,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(3, 6)
+ ! [1, 2] <-- [1, 1, 2]
+ cprime%c2(4,1) = cprime%c2(4,1) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(4, 6)
+ ! [1, 1] <-- [1, 1, 2]
+ cprime%c1(2,2) = cprime%c1(2,2) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(4, 6)
+ ! [1, 3] <-- [1, 1, 3]
+ cprime%c2(5,1) = cprime%c2(5,1) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(5, 6)
+ ! [1, 1] <-- [1, 1, 3]
+ cprime%c1(2,2) = cprime%c1(2,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(5, 6)
+ ! [2, 3] <-- [2, 2, 3]
+ cprime%c2(6,1) = cprime%c2(6,1) + 2.0_ki/3.0_ki * C(2) * coeffs%c2(6, 6)
+ ! [2, 2] <-- [2, 2, 3]
+ cprime%c1(3,2) = cprime%c1(3,2) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(6, 6)
+ ! [1, 1, 2] <-- [0, 1, 1, 2]
+ cprime%c2(4,5) = 0.25_ki * C(0) * coeffs%c3(1, 5)
+ ! [0, 1, 2] <-- [0, 1, 1, 2]
+ cprime%c3(1,1) = 0.5_ki * C(1) * coeffs%c3(1, 5)
+ ! [0, 1, 1] <-- [0, 1, 1, 2]
+ cprime%c2(1,2) = 0.25_ki * C(2) * coeffs%c3(1, 5)
+ ! [1, 1, 3] <-- [0, 1, 1, 3]
+ cprime%c2(5,5) = 0.25_ki * C(0) * coeffs%c3(2, 5)
+ ! [0, 1, 3] <-- [0, 1, 1, 3]
+ cprime%c3(2,1) = 0.5_ki * C(1) * coeffs%c3(2, 5)
+ ! [0, 1, 1] <-- [0, 1, 1, 3]
+ cprime%c2(1,2) = cprime%c2(1,2) + 0.25_ki * C(3) * coeffs%c3(2, 5)
+ ! [2, 2, 3] <-- [0, 2, 2, 3]
+ cprime%c2(6,5) = 0.25_ki * C(0) * coeffs%c3(3, 5)
+ ! [0, 2, 3] <-- [0, 2, 2, 3]
+ cprime%c3(3,1) = 0.5_ki * C(2) * coeffs%c3(3, 5)
+ ! [0, 2, 2] <-- [0, 2, 2, 3]
+ cprime%c2(2,2) = 0.25_ki * C(3) * coeffs%c3(3, 5)
+ ! [2, 2, 3] <-- [1, 2, 2, 3]
+ cprime%c2(6,5) = cprime%c2(6,5) + 0.25_ki * C(1) * coeffs%c3(4, 5)
+ ! [1, 2, 3] <-- [1, 2, 2, 3]
+ cprime%c3(4,1) = 0.5_ki * C(2) * coeffs%c3(4, 5)
+ ! [1, 2, 2] <-- [1, 2, 2, 3]
+ cprime%c2(4,2) = 0.25_ki * C(3) * coeffs%c3(4, 5)
+ ! [1, 1, 1] <-- [0, 1, 1, 1]
+ cprime%c1(2,3) = 0.25_ki * C(0) * coeffs%c2(1, 3)
+ ! [0, 1, 1] <-- [0, 1, 1, 1]
+ cprime%c2(1,2) = cprime%c2(1,2) + 3.0_ki/4.0_ki * C(1) * coeffs%c2(1, 3)
+ ! [2, 2, 2] <-- [0, 2, 2, 2]
+ cprime%c1(3,3) = 0.25_ki * C(0) * coeffs%c2(2, 3)
+ ! [0, 2, 2] <-- [0, 2, 2, 2]
+ cprime%c2(2,2) = cprime%c2(2,2) + 3.0_ki/4.0_ki * C(2) * coeffs%c2(2, 3)
+ ! [3, 3, 3] <-- [0, 3, 3, 3]
+ cprime%c1(4,3) = 0.25_ki * C(0) * coeffs%c2(3, 3)
+ ! [0, 3, 3] <-- [0, 3, 3, 3]
+ cprime%c2(3,2) = 3.0_ki/4.0_ki * C(3) * coeffs%c2(3, 3)
+ ! [2, 2, 2] <-- [1, 2, 2, 2]
+ cprime%c1(3,3) = cprime%c1(3,3) + 0.25_ki * C(1) * coeffs%c2(4, 3)
+ ! [1, 2, 2] <-- [1, 2, 2, 2]
+ cprime%c2(4,2) = cprime%c2(4,2) + 3.0_ki/4.0_ki * C(2) * coeffs%c2(4, 3)
+ ! [3, 3, 3] <-- [1, 3, 3, 3]
+ cprime%c1(4,3) = cprime%c1(4,3) + 0.25_ki * C(1) * coeffs%c2(5, 3)
+ ! [1, 3, 3] <-- [1, 3, 3, 3]
+ cprime%c2(5,2) = 3.0_ki/4.0_ki * C(3) * coeffs%c2(5, 3)
+ ! [3, 3, 3] <-- [2, 3, 3, 3]
+ cprime%c1(4,3) = cprime%c1(4,3) + 0.25_ki * C(2) * coeffs%c2(6, 3)
+ ! [2, 3, 3] <-- [2, 3, 3, 3]
+ cprime%c2(6,2) = 3.0_ki/4.0_ki * C(3) * coeffs%c2(6, 3)
+ ! [0, 1, 2] <-- [0, 0, 1, 2]
+ cprime%c3(1,1) = cprime%c3(1,1) + 0.5_ki * C(0) * coeffs%c3(1, 11)
+ ! [0, 0, 2] <-- [0, 0, 1, 2]
+ cprime%c2(2,5) = 0.25_ki * C(1) * coeffs%c3(1, 11)
+ ! [0, 0, 1] <-- [0, 0, 1, 2]
+ cprime%c2(1,5) = 0.25_ki * C(2) * coeffs%c3(1, 11)
+ ! [0, 1, 3] <-- [0, 0, 1, 3]
+ cprime%c3(2,1) = cprime%c3(2,1) + 0.5_ki * C(0) * coeffs%c3(2, 11)
+ ! [0, 0, 3] <-- [0, 0, 1, 3]
+ cprime%c2(3,5) = 0.25_ki * C(1) * coeffs%c3(2, 11)
+ ! [0, 0, 1] <-- [0, 0, 1, 3]
+ cprime%c2(1,5) = cprime%c2(1,5) + 0.25_ki * C(3) * coeffs%c3(2, 11)
+ ! [0, 2, 3] <-- [0, 0, 2, 3]
+ cprime%c3(3,1) = cprime%c3(3,1) + 0.5_ki * C(0) * coeffs%c3(3, 11)
+ ! [0, 0, 3] <-- [0, 0, 2, 3]
+ cprime%c2(3,5) = cprime%c2(3,5) + 0.25_ki * C(2) * coeffs%c3(3, 11)
+ ! [0, 0, 2] <-- [0, 0, 2, 3]
+ cprime%c2(2,5) = cprime%c2(2,5) + 0.25_ki * C(3) * coeffs%c3(3, 11)
+ ! [1, 2, 3] <-- [1, 1, 2, 3]
+ cprime%c3(4,1) = cprime%c3(4,1) + 0.5_ki * C(1) * coeffs%c3(4, 11)
+ ! [1, 1, 3] <-- [1, 1, 2, 3]
+ cprime%c2(5,5) = cprime%c2(5,5) + 0.25_ki * C(2) * coeffs%c3(4, 11)
+ ! [1, 1, 2] <-- [1, 1, 2, 3]
+ cprime%c2(4,5) = cprime%c2(4,5) + 0.25_ki * C(3) * coeffs%c3(4, 11)
+ ! [0, 0, 1] <-- [0, 0, 0, 1]
+ cprime%c2(1,5) = cprime%c2(1,5) + 3.0_ki/4.0_ki * C(0) * coeffs%c2(1, 10)
+ ! [0, 0, 0] <-- [0, 0, 0, 1]
+ cprime%c1(1,3) = 0.25_ki * C(1) * coeffs%c2(1, 10)
+ ! [0, 0, 2] <-- [0, 0, 0, 2]
+ cprime%c2(2,5) = cprime%c2(2,5) + 3.0_ki/4.0_ki * C(0) * coeffs%c2(2, 10)
+ ! [0, 0, 0] <-- [0, 0, 0, 2]
+ cprime%c1(1,3) = cprime%c1(1,3) + 0.25_ki * C(2) * coeffs%c2(2, 10)
+ ! [0, 0, 3] <-- [0, 0, 0, 3]
+ cprime%c2(3,5) = cprime%c2(3,5) + 3.0_ki/4.0_ki * C(0) * coeffs%c2(3, 10)
+ ! [0, 0, 0] <-- [0, 0, 0, 3]
+ cprime%c1(1,3) = cprime%c1(1,3) + 0.25_ki * C(3) * coeffs%c2(3, 10)
+ ! [1, 1, 2] <-- [1, 1, 1, 2]
+ cprime%c2(4,5) = cprime%c2(4,5) + 3.0_ki/4.0_ki * C(1) * coeffs%c2(4, 10)
+ ! [1, 1, 1] <-- [1, 1, 1, 2]
+ cprime%c1(2,3) = cprime%c1(2,3) + 0.25_ki * C(2) * coeffs%c2(4, 10)
+ ! [1, 1, 3] <-- [1, 1, 1, 3]
+ cprime%c2(5,5) = cprime%c2(5,5) + 3.0_ki/4.0_ki * C(1) * coeffs%c2(5, 10)
+ ! [1, 1, 1] <-- [1, 1, 1, 3]
+ cprime%c1(2,3) = cprime%c1(2,3) + 0.25_ki * C(3) * coeffs%c2(5, 10)
+ ! [2, 2, 3] <-- [2, 2, 2, 3]
+ cprime%c2(6,5) = cprime%c2(6,5) + 3.0_ki/4.0_ki * C(2) * coeffs%c2(6, 10)
+ ! [2, 2, 2] <-- [2, 2, 2, 3]
+ cprime%c1(3,3) = cprime%c1(3,3) + 0.25_ki * C(3) * coeffs%c2(6, 10)
+ ! [1, 2, 3] <-- [0, 1, 2, 3]
+ cprime%c3(4,1) = cprime%c3(4,1) + 0.25_ki * C(0) * coeffs%c4(1, 1)
+ ! [0, 2, 3] <-- [0, 1, 2, 3]
+ cprime%c3(3,1) = cprime%c3(3,1) + 0.25_ki * C(1) * coeffs%c4(1, 1)
+ ! [0, 1, 3] <-- [0, 1, 2, 3]
+ cprime%c3(2,1) = cprime%c3(2,1) + 0.25_ki * C(2) * coeffs%c4(1, 1)
+ ! [0, 1, 2] <-- [0, 1, 2, 3]
+ cprime%c3(1,1) = cprime%c3(1,1) + 0.25_ki * C(3) * coeffs%c4(1, 1)
+ ! [1, 2, 2] <-- [0, 1, 2, 2]
+ cprime%c2(4,2) = cprime%c2(4,2) + 0.25_ki * C(0) * coeffs%c3(1, 2)
+ ! [0, 2, 2] <-- [0, 1, 2, 2]
+ cprime%c2(2,2) = cprime%c2(2,2) + 0.25_ki * C(1) * coeffs%c3(1, 2)
+ ! [0, 1, 2] <-- [0, 1, 2, 2]
+ cprime%c3(1,1) = cprime%c3(1,1) + 0.5_ki * C(2) * coeffs%c3(1, 2)
+ ! [1, 3, 3] <-- [0, 1, 3, 3]
+ cprime%c2(5,2) = cprime%c2(5,2) + 0.25_ki * C(0) * coeffs%c3(2, 2)
+ ! [0, 3, 3] <-- [0, 1, 3, 3]
+ cprime%c2(3,2) = cprime%c2(3,2) + 0.25_ki * C(1) * coeffs%c3(2, 2)
+ ! [0, 1, 3] <-- [0, 1, 3, 3]
+ cprime%c3(2,1) = cprime%c3(2,1) + 0.5_ki * C(3) * coeffs%c3(2, 2)
+ ! [2, 3, 3] <-- [0, 2, 3, 3]
+ cprime%c2(6,2) = cprime%c2(6,2) + 0.25_ki * C(0) * coeffs%c3(3, 2)
+ ! [0, 3, 3] <-- [0, 2, 3, 3]
+ cprime%c2(3,2) = cprime%c2(3,2) + 0.25_ki * C(2) * coeffs%c3(3, 2)
+ ! [0, 2, 3] <-- [0, 2, 3, 3]
+ cprime%c3(3,1) = cprime%c3(3,1) + 0.5_ki * C(3) * coeffs%c3(3, 2)
+ ! [2, 3, 3] <-- [1, 2, 3, 3]
+ cprime%c2(6,2) = cprime%c2(6,2) + 0.25_ki * C(1) * coeffs%c3(4, 2)
+ ! [1, 3, 3] <-- [1, 2, 3, 3]
+ cprime%c2(5,2) = cprime%c2(5,2) + 0.25_ki * C(2) * coeffs%c3(4, 2)
+ ! [1, 2, 3] <-- [1, 2, 3, 3]
+ cprime%c3(4,1) = cprime%c3(4,1) + 0.5_ki * C(3) * coeffs%c3(4, 2)
+ ! [0, 1, 1] <-- [0, 0, 1, 1]
+ cprime%c2(1,2) = cprime%c2(1,2) + 0.5_ki * C(0) * coeffs%c2(1, 7)
+ ! [0, 0, 1] <-- [0, 0, 1, 1]
+ cprime%c2(1,5) = cprime%c2(1,5) + 0.5_ki * C(1) * coeffs%c2(1, 7)
+ ! [0, 2, 2] <-- [0, 0, 2, 2]
+ cprime%c2(2,2) = cprime%c2(2,2) + 0.5_ki * C(0) * coeffs%c2(2, 7)
+ ! [0, 0, 2] <-- [0, 0, 2, 2]
+ cprime%c2(2,5) = cprime%c2(2,5) + 0.5_ki * C(2) * coeffs%c2(2, 7)
+ ! [0, 3, 3] <-- [0, 0, 3, 3]
+ cprime%c2(3,2) = cprime%c2(3,2) + 0.5_ki * C(0) * coeffs%c2(3, 7)
+ ! [0, 0, 3] <-- [0, 0, 3, 3]
+ cprime%c2(3,5) = cprime%c2(3,5) + 0.5_ki * C(3) * coeffs%c2(3, 7)
+ ! [1, 2, 2] <-- [1, 1, 2, 2]
+ cprime%c2(4,2) = cprime%c2(4,2) + 0.5_ki * C(1) * coeffs%c2(4, 7)
+ ! [1, 1, 2] <-- [1, 1, 2, 2]
+ cprime%c2(4,5) = cprime%c2(4,5) + 0.5_ki * C(2) * coeffs%c2(4, 7)
+ ! [1, 3, 3] <-- [1, 1, 3, 3]
+ cprime%c2(5,2) = cprime%c2(5,2) + 0.5_ki * C(1) * coeffs%c2(5, 7)
+ ! [1, 1, 3] <-- [1, 1, 3, 3]
+ cprime%c2(5,5) = cprime%c2(5,5) + 0.5_ki * C(3) * coeffs%c2(5, 7)
+ ! [2, 3, 3] <-- [2, 2, 3, 3]
+ cprime%c2(6,2) = cprime%c2(6,2) + 0.5_ki * C(2) * coeffs%c2(6, 7)
+ ! [2, 2, 3] <-- [2, 2, 3, 3]
+ cprime%c2(6,5) = cprime%c2(6,5) + 0.5_ki * C(3) * coeffs%c2(6, 7)
+ ! [0, 0, 0] <-- [0, 0, 0, 0]
+ cprime%c1(1,3) = cprime%c1(1,3) + C(0) * coeffs%c1(1, 4)
+ ! [1, 1, 1] <-- [1, 1, 1, 1]
+ cprime%c1(2,3) = cprime%c1(2,3) + C(1) * coeffs%c1(2, 4)
+ ! [2, 2, 2] <-- [2, 2, 2, 2]
+ cprime%c1(3,3) = cprime%c1(3,3) + C(2) * coeffs%c1(3, 4)
+ ! [3, 3, 3] <-- [3, 3, 3, 3]
+ cprime%c1(4,3) = cprime%c1(4,3) + C(3) * coeffs%c1(4, 4)
+ ! [0, 0, 1, 1] <-- [0, 0, 0, 1, 1]
+ cprime%c2(1,6) = 3.0_ki/5.0_ki * C(0) * coeffs%c2(1, 11)
+ ! [0, 0, 0, 1] <-- [0, 0, 0, 1, 1]
+ cprime%c2(1,8) = 2.0_ki/5.0_ki * C(1) * coeffs%c2(1, 11)
+ ! [0, 0, 2, 2] <-- [0, 0, 0, 2, 2]
+ cprime%c2(2,6) = 3.0_ki/5.0_ki * C(0) * coeffs%c2(2, 11)
+ ! [0, 0, 0, 2] <-- [0, 0, 0, 2, 2]
+ cprime%c2(2,8) = 2.0_ki/5.0_ki * C(2) * coeffs%c2(2, 11)
+ ! [0, 0, 3, 3] <-- [0, 0, 0, 3, 3]
+ cprime%c2(3,6) = 3.0_ki/5.0_ki * C(0) * coeffs%c2(3, 11)
+ ! [0, 0, 0, 3] <-- [0, 0, 0, 3, 3]
+ cprime%c2(3,8) = 2.0_ki/5.0_ki * C(3) * coeffs%c2(3, 11)
+ ! [1, 1, 2, 2] <-- [1, 1, 1, 2, 2]
+ cprime%c2(4,6) = 3.0_ki/5.0_ki * C(1) * coeffs%c2(4, 11)
+ ! [1, 1, 1, 2] <-- [1, 1, 1, 2, 2]
+ cprime%c2(4,8) = 2.0_ki/5.0_ki * C(2) * coeffs%c2(4, 11)
+ ! [1, 1, 3, 3] <-- [1, 1, 1, 3, 3]
+ cprime%c2(5,6) = 3.0_ki/5.0_ki * C(1) * coeffs%c2(5, 11)
+ ! [1, 1, 1, 3] <-- [1, 1, 1, 3, 3]
+ cprime%c2(5,8) = 2.0_ki/5.0_ki * C(3) * coeffs%c2(5, 11)
+ ! [2, 2, 3, 3] <-- [2, 2, 2, 3, 3]
+ cprime%c2(6,6) = 3.0_ki/5.0_ki * C(2) * coeffs%c2(6, 11)
+ ! [2, 2, 2, 3] <-- [2, 2, 2, 3, 3]
+ cprime%c2(6,8) = 2.0_ki/5.0_ki * C(3) * coeffs%c2(6, 11)
+ ! [0, 0, 1, 2] <-- [0, 0, 0, 1, 2]
+ cprime%c3(1,7) = 3.0_ki/5.0_ki * C(0) * coeffs%c3(1, 17)
+ ! [0, 0, 0, 2] <-- [0, 0, 0, 1, 2]
+ cprime%c2(2,8) = cprime%c2(2,8) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(1, 17)
+ ! [0, 0, 0, 1] <-- [0, 0, 0, 1, 2]
+ cprime%c2(1,8) = cprime%c2(1,8) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(1, 17)
+ ! [0, 0, 1, 3] <-- [0, 0, 0, 1, 3]
+ cprime%c3(2,7) = 3.0_ki/5.0_ki * C(0) * coeffs%c3(2, 17)
+ ! [0, 0, 0, 3] <-- [0, 0, 0, 1, 3]
+ cprime%c2(3,8) = cprime%c2(3,8) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(2, 17)
+ ! [0, 0, 0, 1] <-- [0, 0, 0, 1, 3]
+ cprime%c2(1,8) = cprime%c2(1,8) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(2, 17)
+ ! [0, 0, 2, 3] <-- [0, 0, 0, 2, 3]
+ cprime%c3(3,7) = 3.0_ki/5.0_ki * C(0) * coeffs%c3(3, 17)
+ ! [0, 0, 0, 3] <-- [0, 0, 0, 2, 3]
+ cprime%c2(3,8) = cprime%c2(3,8) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(3, 17)
+ ! [0, 0, 0, 2] <-- [0, 0, 0, 2, 3]
+ cprime%c2(2,8) = cprime%c2(2,8) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(3, 17)
+ ! [1, 1, 2, 3] <-- [1, 1, 1, 2, 3]
+ cprime%c3(4,7) = 3.0_ki/5.0_ki * C(1) * coeffs%c3(4, 17)
+ ! [1, 1, 1, 3] <-- [1, 1, 1, 2, 3]
+ cprime%c2(5,8) = cprime%c2(5,8) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(4, 17)
+ ! [1, 1, 1, 2] <-- [1, 1, 1, 2, 3]
+ cprime%c2(4,8) = cprime%c2(4,8) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(4, 17)
+ ! [1, 2, 3, 3] <-- [0, 1, 2, 3, 3]
+ cprime%c3(4,2) = 1.0_ki/5.0_ki * C(0) * coeffs%c4(1, 2)
+ ! [0, 2, 3, 3] <-- [0, 1, 2, 3, 3]
+ cprime%c3(3,2) = 1.0_ki/5.0_ki * C(1) * coeffs%c4(1, 2)
+ ! [0, 1, 3, 3] <-- [0, 1, 2, 3, 3]
+ cprime%c3(2,2) = 1.0_ki/5.0_ki * C(2) * coeffs%c4(1, 2)
+ ! [0, 1, 2, 3] <-- [0, 1, 2, 3, 3]
+ cprime%c4(1,1) = 2.0_ki/5.0_ki * C(3) * coeffs%c4(1, 2)
+ ! [1, 2, 2, 2] <-- [0, 1, 2, 2, 2]
+ cprime%c2(4,3) = 1.0_ki/5.0_ki * C(0) * coeffs%c3(1, 3)
+ ! [0, 2, 2, 2] <-- [0, 1, 2, 2, 2]
+ cprime%c2(2,3) = 1.0_ki/5.0_ki * C(1) * coeffs%c3(1, 3)
+ ! [0, 1, 2, 2] <-- [0, 1, 2, 2, 2]
+ cprime%c3(1,2) = 3.0_ki/5.0_ki * C(2) * coeffs%c3(1, 3)
+ ! [1, 3, 3, 3] <-- [0, 1, 3, 3, 3]
+ cprime%c2(5,3) = 1.0_ki/5.0_ki * C(0) * coeffs%c3(2, 3)
+ ! [0, 3, 3, 3] <-- [0, 1, 3, 3, 3]
+ cprime%c2(3,3) = 1.0_ki/5.0_ki * C(1) * coeffs%c3(2, 3)
+ ! [0, 1, 3, 3] <-- [0, 1, 3, 3, 3]
+ cprime%c3(2,2) = cprime%c3(2,2) + 3.0_ki/5.0_ki * C(3) * coeffs%c3(2, 3)
+ ! [2, 3, 3, 3] <-- [0, 2, 3, 3, 3]
+ cprime%c2(6,3) = 1.0_ki/5.0_ki * C(0) * coeffs%c3(3, 3)
+ ! [0, 3, 3, 3] <-- [0, 2, 3, 3, 3]
+ cprime%c2(3,3) = cprime%c2(3,3) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(3, 3)
+ ! [0, 2, 3, 3] <-- [0, 2, 3, 3, 3]
+ cprime%c3(3,2) = cprime%c3(3,2) + 3.0_ki/5.0_ki * C(3) * coeffs%c3(3, 3)
+ ! [2, 3, 3, 3] <-- [1, 2, 3, 3, 3]
+ cprime%c2(6,3) = cprime%c2(6,3) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(4, 3)
+ ! [1, 3, 3, 3] <-- [1, 2, 3, 3, 3]
+ cprime%c2(5,3) = cprime%c2(5,3) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(4, 3)
+ ! [1, 2, 3, 3] <-- [1, 2, 3, 3, 3]
+ cprime%c3(4,2) = cprime%c3(4,2) + 3.0_ki/5.0_ki * C(3) * coeffs%c3(4, 3)
+ ! [0, 1, 2, 3] <-- [0, 0, 1, 2, 3]
+ cprime%c4(1,1) = cprime%c4(1,1) + 2.0_ki/5.0_ki * C(0) * coeffs%c4(1, 11)
+ ! [0, 0, 2, 3] <-- [0, 0, 1, 2, 3]
+ cprime%c3(3,7) = cprime%c3(3,7) + 1.0_ki/5.0_ki * C(1) * coeffs%c4(1, 11)
+ ! [0, 0, 1, 3] <-- [0, 0, 1, 2, 3]
+ cprime%c3(2,7) = cprime%c3(2,7) + 1.0_ki/5.0_ki * C(2) * coeffs%c4(1, 11)
+ ! [0, 0, 1, 2] <-- [0, 0, 1, 2, 3]
+ cprime%c3(1,7) = cprime%c3(1,7) + 1.0_ki/5.0_ki * C(3) * coeffs%c4(1, 11)
+ ! [1, 2, 2, 3] <-- [0, 1, 2, 2, 3]
+ cprime%c3(4,4) = 1.0_ki/5.0_ki * C(0) * coeffs%c4(1, 4)
+ ! [0, 2, 2, 3] <-- [0, 1, 2, 2, 3]
+ cprime%c3(3,4) = 1.0_ki/5.0_ki * C(1) * coeffs%c4(1, 4)
+ ! [0, 1, 2, 3] <-- [0, 1, 2, 2, 3]
+ cprime%c4(1,1) = cprime%c4(1,1) + 2.0_ki/5.0_ki * C(2) * coeffs%c4(1, 4)
+ ! [0, 1, 2, 2] <-- [0, 1, 2, 2, 3]
+ cprime%c3(1,2) = cprime%c3(1,2) + 1.0_ki/5.0_ki * C(3) * coeffs%c4(1, 4)
+ ! [1, 1, 1, 2] <-- [0, 1, 1, 1, 2]
+ cprime%c2(4,8) = cprime%c2(4,8) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(1, 8)
+ ! [0, 1, 1, 2] <-- [0, 1, 1, 1, 2]
+ cprime%c3(1,4) = 3.0_ki/5.0_ki * C(1) * coeffs%c3(1, 8)
+ ! [0, 1, 1, 1] <-- [0, 1, 1, 1, 2]
+ cprime%c2(1,3) = 1.0_ki/5.0_ki * C(2) * coeffs%c3(1, 8)
+ ! [1, 1, 1, 3] <-- [0, 1, 1, 1, 3]
+ cprime%c2(5,8) = cprime%c2(5,8) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(2, 8)
+ ! [0, 1, 1, 3] <-- [0, 1, 1, 1, 3]
+ cprime%c3(2,4) = 3.0_ki/5.0_ki * C(1) * coeffs%c3(2, 8)
+ ! [0, 1, 1, 1] <-- [0, 1, 1, 1, 3]
+ cprime%c2(1,3) = cprime%c2(1,3) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(2, 8)
+ ! [2, 2, 2, 3] <-- [0, 2, 2, 2, 3]
+ cprime%c2(6,8) = cprime%c2(6,8) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(3, 8)
+ ! [0, 2, 2, 3] <-- [0, 2, 2, 2, 3]
+ cprime%c3(3,4) = cprime%c3(3,4) + 3.0_ki/5.0_ki * C(2) * coeffs%c3(3, 8)
+ ! [0, 2, 2, 2] <-- [0, 2, 2, 2, 3]
+ cprime%c2(2,3) = cprime%c2(2,3) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(3, 8)
+ ! [2, 2, 2, 3] <-- [1, 2, 2, 2, 3]
+ cprime%c2(6,8) = cprime%c2(6,8) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(4, 8)
+ ! [1, 2, 2, 3] <-- [1, 2, 2, 2, 3]
+ cprime%c3(4,4) = cprime%c3(4,4) + 3.0_ki/5.0_ki * C(2) * coeffs%c3(4, 8)
+ ! [1, 2, 2, 2] <-- [1, 2, 2, 2, 3]
+ cprime%c2(4,3) = cprime%c2(4,3) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(4, 8)
+ ! [1, 1, 1, 1] <-- [0, 1, 1, 1, 1]
+ cprime%c1(2,4) = 1.0_ki/5.0_ki * C(0) * coeffs%c2(1, 4)
+ ! [0, 1, 1, 1] <-- [0, 1, 1, 1, 1]
+ cprime%c2(1,3) = cprime%c2(1,3) + 4.0_ki/5.0_ki * C(1) * coeffs%c2(1, 4)
+ ! [2, 2, 2, 2] <-- [0, 2, 2, 2, 2]
+ cprime%c1(3,4) = 1.0_ki/5.0_ki * C(0) * coeffs%c2(2, 4)
+ ! [0, 2, 2, 2] <-- [0, 2, 2, 2, 2]
+ cprime%c2(2,3) = cprime%c2(2,3) + 4.0_ki/5.0_ki * C(2) * coeffs%c2(2, 4)
+ ! [3, 3, 3, 3] <-- [0, 3, 3, 3, 3]
+ cprime%c1(4,4) = 1.0_ki/5.0_ki * C(0) * coeffs%c2(3, 4)
+ ! [0, 3, 3, 3] <-- [0, 3, 3, 3, 3]
+ cprime%c2(3,3) = cprime%c2(3,3) + 4.0_ki/5.0_ki * C(3) * coeffs%c2(3, 4)
+ ! [2, 2, 2, 2] <-- [1, 2, 2, 2, 2]
+ cprime%c1(3,4) = cprime%c1(3,4) + 1.0_ki/5.0_ki * C(1) * coeffs%c2(4, 4)
+ ! [1, 2, 2, 2] <-- [1, 2, 2, 2, 2]
+ cprime%c2(4,3) = cprime%c2(4,3) + 4.0_ki/5.0_ki * C(2) * coeffs%c2(4, 4)
+ ! [3, 3, 3, 3] <-- [1, 3, 3, 3, 3]
+ cprime%c1(4,4) = cprime%c1(4,4) + 1.0_ki/5.0_ki * C(1) * coeffs%c2(5, 4)
+ ! [1, 3, 3, 3] <-- [1, 3, 3, 3, 3]
+ cprime%c2(5,3) = cprime%c2(5,3) + 4.0_ki/5.0_ki * C(3) * coeffs%c2(5, 4)
+ ! [3, 3, 3, 3] <-- [2, 3, 3, 3, 3]
+ cprime%c1(4,4) = cprime%c1(4,4) + 1.0_ki/5.0_ki * C(2) * coeffs%c2(6, 4)
+ ! [2, 3, 3, 3] <-- [2, 3, 3, 3, 3]
+ cprime%c2(6,3) = cprime%c2(6,3) + 4.0_ki/5.0_ki * C(3) * coeffs%c2(6, 4)
+ ! [1, 1, 2, 2] <-- [0, 1, 1, 2, 2]
+ cprime%c2(4,6) = cprime%c2(4,6) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(1, 6)
+ ! [0, 1, 2, 2] <-- [0, 1, 1, 2, 2]
+ cprime%c3(1,2) = cprime%c3(1,2) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(1, 6)
+ ! [0, 1, 1, 2] <-- [0, 1, 1, 2, 2]
+ cprime%c3(1,4) = cprime%c3(1,4) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(1, 6)
+ ! [1, 1, 3, 3] <-- [0, 1, 1, 3, 3]
+ cprime%c2(5,6) = cprime%c2(5,6) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(2, 6)
+ ! [0, 1, 3, 3] <-- [0, 1, 1, 3, 3]
+ cprime%c3(2,2) = cprime%c3(2,2) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(2, 6)
+ ! [0, 1, 1, 3] <-- [0, 1, 1, 3, 3]
+ cprime%c3(2,4) = cprime%c3(2,4) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(2, 6)
+ ! [2, 2, 3, 3] <-- [0, 2, 2, 3, 3]
+ cprime%c2(6,6) = cprime%c2(6,6) + 1.0_ki/5.0_ki * C(0) * coeffs%c3(3, 6)
+ ! [0, 2, 3, 3] <-- [0, 2, 2, 3, 3]
+ cprime%c3(3,2) = cprime%c3(3,2) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(3, 6)
+ ! [0, 2, 2, 3] <-- [0, 2, 2, 3, 3]
+ cprime%c3(3,4) = cprime%c3(3,4) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(3, 6)
+ ! [2, 2, 3, 3] <-- [1, 2, 2, 3, 3]
+ cprime%c2(6,6) = cprime%c2(6,6) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(4, 6)
+ ! [1, 2, 3, 3] <-- [1, 2, 2, 3, 3]
+ cprime%c3(4,2) = cprime%c3(4,2) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(4, 6)
+ ! [1, 2, 2, 3] <-- [1, 2, 2, 3, 3]
+ cprime%c3(4,4) = cprime%c3(4,4) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(4, 6)
+ ! [0, 0, 0, 0] <-- [0, 0, 0, 0, 0]
+ cprime%c1(1,4) = C(0) * coeffs%c1(1, 5)
+ ! [1, 1, 1, 1] <-- [1, 1, 1, 1, 1]
+ cprime%c1(2,4) = cprime%c1(2,4) + C(1) * coeffs%c1(2, 5)
+ ! [2, 2, 2, 2] <-- [2, 2, 2, 2, 2]
+ cprime%c1(3,4) = cprime%c1(3,4) + C(2) * coeffs%c1(3, 5)
+ ! [3, 3, 3, 3] <-- [3, 3, 3, 3, 3]
+ cprime%c1(4,4) = cprime%c1(4,4) + C(3) * coeffs%c1(4, 5)
+ ! [0, 1, 1, 1] <-- [0, 0, 1, 1, 1]
+ cprime%c2(1,3) = cprime%c2(1,3) + 2.0_ki/5.0_ki * C(0) * coeffs%c2(1, 8)
+ ! [0, 0, 1, 1] <-- [0, 0, 1, 1, 1]
+ cprime%c2(1,6) = cprime%c2(1,6) + 3.0_ki/5.0_ki * C(1) * coeffs%c2(1, 8)
+ ! [0, 2, 2, 2] <-- [0, 0, 2, 2, 2]
+ cprime%c2(2,3) = cprime%c2(2,3) + 2.0_ki/5.0_ki * C(0) * coeffs%c2(2, 8)
+ ! [0, 0, 2, 2] <-- [0, 0, 2, 2, 2]
+ cprime%c2(2,6) = cprime%c2(2,6) + 3.0_ki/5.0_ki * C(2) * coeffs%c2(2, 8)
+ ! [0, 3, 3, 3] <-- [0, 0, 3, 3, 3]
+ cprime%c2(3,3) = cprime%c2(3,3) + 2.0_ki/5.0_ki * C(0) * coeffs%c2(3, 8)
+ ! [0, 0, 3, 3] <-- [0, 0, 3, 3, 3]
+ cprime%c2(3,6) = cprime%c2(3,6) + 3.0_ki/5.0_ki * C(3) * coeffs%c2(3, 8)
+ ! [1, 2, 2, 2] <-- [1, 1, 2, 2, 2]
+ cprime%c2(4,3) = cprime%c2(4,3) + 2.0_ki/5.0_ki * C(1) * coeffs%c2(4, 8)
+ ! [1, 1, 2, 2] <-- [1, 1, 2, 2, 2]
+ cprime%c2(4,6) = cprime%c2(4,6) + 3.0_ki/5.0_ki * C(2) * coeffs%c2(4, 8)
+ ! [1, 3, 3, 3] <-- [1, 1, 3, 3, 3]
+ cprime%c2(5,3) = cprime%c2(5,3) + 2.0_ki/5.0_ki * C(1) * coeffs%c2(5, 8)
+ ! [1, 1, 3, 3] <-- [1, 1, 3, 3, 3]
+ cprime%c2(5,6) = cprime%c2(5,6) + 3.0_ki/5.0_ki * C(3) * coeffs%c2(5, 8)
+ ! [2, 3, 3, 3] <-- [2, 2, 3, 3, 3]
+ cprime%c2(6,3) = cprime%c2(6,3) + 2.0_ki/5.0_ki * C(2) * coeffs%c2(6, 8)
+ ! [2, 2, 3, 3] <-- [2, 2, 3, 3, 3]
+ cprime%c2(6,6) = cprime%c2(6,6) + 3.0_ki/5.0_ki * C(3) * coeffs%c2(6, 8)
+ ! [0, 1, 2, 2] <-- [0, 0, 1, 2, 2]
+ cprime%c3(1,2) = cprime%c3(1,2) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(1, 12)
+ ! [0, 0, 2, 2] <-- [0, 0, 1, 2, 2]
+ cprime%c2(2,6) = cprime%c2(2,6) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(1, 12)
+ ! [0, 0, 1, 2] <-- [0, 0, 1, 2, 2]
+ cprime%c3(1,7) = cprime%c3(1,7) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(1, 12)
+ ! [0, 1, 3, 3] <-- [0, 0, 1, 3, 3]
+ cprime%c3(2,2) = cprime%c3(2,2) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(2, 12)
+ ! [0, 0, 3, 3] <-- [0, 0, 1, 3, 3]
+ cprime%c2(3,6) = cprime%c2(3,6) + 1.0_ki/5.0_ki * C(1) * coeffs%c3(2, 12)
+ ! [0, 0, 1, 3] <-- [0, 0, 1, 3, 3]
+ cprime%c3(2,7) = cprime%c3(2,7) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(2, 12)
+ ! [0, 2, 3, 3] <-- [0, 0, 2, 3, 3]
+ cprime%c3(3,2) = cprime%c3(3,2) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(3, 12)
+ ! [0, 0, 3, 3] <-- [0, 0, 2, 3, 3]
+ cprime%c2(3,6) = cprime%c2(3,6) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(3, 12)
+ ! [0, 0, 2, 3] <-- [0, 0, 2, 3, 3]
+ cprime%c3(3,7) = cprime%c3(3,7) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(3, 12)
+ ! [1, 2, 3, 3] <-- [1, 1, 2, 3, 3]
+ cprime%c3(4,2) = cprime%c3(4,2) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(4, 12)
+ ! [1, 1, 3, 3] <-- [1, 1, 2, 3, 3]
+ cprime%c2(5,6) = cprime%c2(5,6) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(4, 12)
+ ! [1, 1, 2, 3] <-- [1, 1, 2, 3, 3]
+ cprime%c3(4,7) = cprime%c3(4,7) + 2.0_ki/5.0_ki * C(3) * coeffs%c3(4, 12)
+ ! [0, 0, 0, 1] <-- [0, 0, 0, 0, 1]
+ cprime%c2(1,8) = cprime%c2(1,8) + 4.0_ki/5.0_ki * C(0) * coeffs%c2(1, 13)
+ ! [0, 0, 0, 0] <-- [0, 0, 0, 0, 1]
+ cprime%c1(1,4) = cprime%c1(1,4) + 1.0_ki/5.0_ki * C(1) * coeffs%c2(1, 13)
+ ! [0, 0, 0, 2] <-- [0, 0, 0, 0, 2]
+ cprime%c2(2,8) = cprime%c2(2,8) + 4.0_ki/5.0_ki * C(0) * coeffs%c2(2, 13)
+ ! [0, 0, 0, 0] <-- [0, 0, 0, 0, 2]
+ cprime%c1(1,4) = cprime%c1(1,4) + 1.0_ki/5.0_ki * C(2) * coeffs%c2(2, 13)
+ ! [0, 0, 0, 3] <-- [0, 0, 0, 0, 3]
+ cprime%c2(3,8) = cprime%c2(3,8) + 4.0_ki/5.0_ki * C(0) * coeffs%c2(3, 13)
+ ! [0, 0, 0, 0] <-- [0, 0, 0, 0, 3]
+ cprime%c1(1,4) = cprime%c1(1,4) + 1.0_ki/5.0_ki * C(3) * coeffs%c2(3, 13)
+ ! [1, 1, 1, 2] <-- [1, 1, 1, 1, 2]
+ cprime%c2(4,8) = cprime%c2(4,8) + 4.0_ki/5.0_ki * C(1) * coeffs%c2(4, 13)
+ ! [1, 1, 1, 1] <-- [1, 1, 1, 1, 2]
+ cprime%c1(2,4) = cprime%c1(2,4) + 1.0_ki/5.0_ki * C(2) * coeffs%c2(4, 13)
+ ! [1, 1, 1, 3] <-- [1, 1, 1, 1, 3]
+ cprime%c2(5,8) = cprime%c2(5,8) + 4.0_ki/5.0_ki * C(1) * coeffs%c2(5, 13)
+ ! [1, 1, 1, 1] <-- [1, 1, 1, 1, 3]
+ cprime%c1(2,4) = cprime%c1(2,4) + 1.0_ki/5.0_ki * C(3) * coeffs%c2(5, 13)
+ ! [2, 2, 2, 3] <-- [2, 2, 2, 2, 3]
+ cprime%c2(6,8) = cprime%c2(6,8) + 4.0_ki/5.0_ki * C(2) * coeffs%c2(6, 13)
+ ! [2, 2, 2, 2] <-- [2, 2, 2, 2, 3]
+ cprime%c1(3,4) = cprime%c1(3,4) + 1.0_ki/5.0_ki * C(3) * coeffs%c2(6, 13)
+ ! [0, 1, 1, 2] <-- [0, 0, 1, 1, 2]
+ cprime%c3(1,4) = cprime%c3(1,4) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(1, 14)
+ ! [0, 0, 1, 2] <-- [0, 0, 1, 1, 2]
+ cprime%c3(1,7) = cprime%c3(1,7) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(1, 14)
+ ! [0, 0, 1, 1] <-- [0, 0, 1, 1, 2]
+ cprime%c2(1,6) = cprime%c2(1,6) + 1.0_ki/5.0_ki * C(2) * coeffs%c3(1, 14)
+ ! [0, 1, 1, 3] <-- [0, 0, 1, 1, 3]
+ cprime%c3(2,4) = cprime%c3(2,4) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(2, 14)
+ ! [0, 0, 1, 3] <-- [0, 0, 1, 1, 3]
+ cprime%c3(2,7) = cprime%c3(2,7) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(2, 14)
+ ! [0, 0, 1, 1] <-- [0, 0, 1, 1, 3]
+ cprime%c2(1,6) = cprime%c2(1,6) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(2, 14)
+ ! [0, 2, 2, 3] <-- [0, 0, 2, 2, 3]
+ cprime%c3(3,4) = cprime%c3(3,4) + 2.0_ki/5.0_ki * C(0) * coeffs%c3(3, 14)
+ ! [0, 0, 2, 3] <-- [0, 0, 2, 2, 3]
+ cprime%c3(3,7) = cprime%c3(3,7) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(3, 14)
+ ! [0, 0, 2, 2] <-- [0, 0, 2, 2, 3]
+ cprime%c2(2,6) = cprime%c2(2,6) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(3, 14)
+ ! [1, 2, 2, 3] <-- [1, 1, 2, 2, 3]
+ cprime%c3(4,4) = cprime%c3(4,4) + 2.0_ki/5.0_ki * C(1) * coeffs%c3(4, 14)
+ ! [1, 1, 2, 3] <-- [1, 1, 2, 2, 3]
+ cprime%c3(4,7) = cprime%c3(4,7) + 2.0_ki/5.0_ki * C(2) * coeffs%c3(4, 14)
+ ! [1, 1, 2, 2] <-- [1, 1, 2, 2, 3]
+ cprime%c2(4,6) = cprime%c2(4,6) + 1.0_ki/5.0_ki * C(3) * coeffs%c3(4, 14)
+ ! [1, 1, 2, 3] <-- [0, 1, 1, 2, 3]
+ cprime%c3(4,7) = cprime%c3(4,7) + 1.0_ki/5.0_ki * C(0) * coeffs%c4(1, 7)
+ ! [0, 1, 2, 3] <-- [0, 1, 1, 2, 3]
+ cprime%c4(1,1) = cprime%c4(1,1) + 2.0_ki/5.0_ki * C(1) * coeffs%c4(1, 7)
+ ! [0, 1, 1, 3] <-- [0, 1, 1, 2, 3]
+ cprime%c3(2,4) = cprime%c3(2,4) + 1.0_ki/5.0_ki * C(2) * coeffs%c4(1, 7)
+ ! [0, 1, 1, 2] <-- [0, 1, 1, 2, 3]
+ cprime%c3(1,4) = cprime%c3(1,4) + 1.0_ki/5.0_ki * C(3) * coeffs%c4(1, 7)
+ ! [0, 1, 1, 2, 3] <-- [0, 0, 1, 1, 2, 3]
+ cprime%c4(1,4) = 1.0_ki/3.0_ki * C(0) * coeffs%c4(1, 14)
+ ! [0, 0, 1, 2, 3] <-- [0, 0, 1, 1, 2, 3]
+ cprime%c4(1,5) = 1.0_ki/3.0_ki * C(1) * coeffs%c4(1, 14)
+ ! [0, 0, 1, 1, 3] <-- [0, 0, 1, 1, 2, 3]
+ cprime%c3(2,9) = 1.0_ki/6.0_ki * C(2) * coeffs%c4(1, 14)
+ ! [0, 0, 1, 1, 2] <-- [0, 0, 1, 1, 2, 3]
+ cprime%c3(1,9) = 1.0_ki/6.0_ki * C(3) * coeffs%c4(1, 14)
+ ! [1, 1, 1, 2, 2] <-- [0, 1, 1, 1, 2, 2]
+ cprime%c2(4,9) = 1.0_ki/6.0_ki * C(0) * coeffs%c3(1, 9)
+ ! [0, 1, 1, 2, 2] <-- [0, 1, 1, 1, 2, 2]
+ cprime%c3(1,5) = 0.5_ki * C(1) * coeffs%c3(1, 9)
+ ! [0, 1, 1, 1, 2] <-- [0, 1, 1, 1, 2, 2]
+ cprime%c3(1,6) = 1.0_ki/3.0_ki * C(2) * coeffs%c3(1, 9)
+ ! [1, 1, 1, 3, 3] <-- [0, 1, 1, 1, 3, 3]
+ cprime%c2(5,9) = 1.0_ki/6.0_ki * C(0) * coeffs%c3(2, 9)
+ ! [0, 1, 1, 3, 3] <-- [0, 1, 1, 1, 3, 3]
+ cprime%c3(2,5) = 0.5_ki * C(1) * coeffs%c3(2, 9)
+ ! [0, 1, 1, 1, 3] <-- [0, 1, 1, 1, 3, 3]
+ cprime%c3(2,6) = 1.0_ki/3.0_ki * C(3) * coeffs%c3(2, 9)
+ ! [2, 2, 2, 3, 3] <-- [0, 2, 2, 2, 3, 3]
+ cprime%c2(6,9) = 1.0_ki/6.0_ki * C(0) * coeffs%c3(3, 9)
+ ! [0, 2, 2, 3, 3] <-- [0, 2, 2, 2, 3, 3]
+ cprime%c3(3,5) = 0.5_ki * C(2) * coeffs%c3(3, 9)
+ ! [0, 2, 2, 2, 3] <-- [0, 2, 2, 2, 3, 3]
+ cprime%c3(3,6) = 1.0_ki/3.0_ki * C(3) * coeffs%c3(3, 9)
+ ! [2, 2, 2, 3, 3] <-- [1, 2, 2, 2, 3, 3]
+ cprime%c2(6,9) = cprime%c2(6,9) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(4, 9)
+ ! [1, 2, 2, 3, 3] <-- [1, 2, 2, 2, 3, 3]
+ cprime%c3(4,5) = 0.5_ki * C(2) * coeffs%c3(4, 9)
+ ! [1, 2, 2, 2, 3] <-- [1, 2, 2, 2, 3, 3]
+ cprime%c3(4,6) = 1.0_ki/3.0_ki * C(3) * coeffs%c3(4, 9)
+ ! [1, 2, 2, 2, 3] <-- [0, 1, 2, 2, 2, 3]
+ cprime%c3(4,6) = cprime%c3(4,6) + 1.0_ki/6.0_ki * C(0) * coeffs%c4(1, 6)
+ ! [0, 2, 2, 2, 3] <-- [0, 1, 2, 2, 2, 3]
+ cprime%c3(3,6) = cprime%c3(3,6) + 1.0_ki/6.0_ki * C(1) * coeffs%c4(1, 6)
+ ! [0, 1, 2, 2, 3] <-- [0, 1, 2, 2, 2, 3]
+ cprime%c4(1,3) = 0.5_ki * C(2) * coeffs%c4(1, 6)
+ ! [0, 1, 2, 2, 2] <-- [0, 1, 2, 2, 2, 3]
+ cprime%c3(1,3) = 1.0_ki/6.0_ki * C(3) * coeffs%c4(1, 6)
+ ! [0, 0, 0, 0, 1] <-- [0, 0, 0, 0, 0, 1]
+ cprime%c2(1,10) = 5.0_ki/6.0_ki * C(0) * coeffs%c2(1, 15)
+ ! [0, 0, 0, 0, 0] <-- [0, 0, 0, 0, 0, 1]
+ cprime%c1(1,5) = 1.0_ki/6.0_ki * C(1) * coeffs%c2(1, 15)
+ ! [0, 0, 0, 0, 2] <-- [0, 0, 0, 0, 0, 2]
+ cprime%c2(2,10) = 5.0_ki/6.0_ki * C(0) * coeffs%c2(2, 15)
+ ! [0, 0, 0, 0, 0] <-- [0, 0, 0, 0, 0, 2]
+ cprime%c1(1,5) = cprime%c1(1,5) + 1.0_ki/6.0_ki * C(2) * coeffs%c2(2, 15)
+ ! [0, 0, 0, 0, 3] <-- [0, 0, 0, 0, 0, 3]
+ cprime%c2(3,10) = 5.0_ki/6.0_ki * C(0) * coeffs%c2(3, 15)
+ ! [0, 0, 0, 0, 0] <-- [0, 0, 0, 0, 0, 3]
+ cprime%c1(1,5) = cprime%c1(1,5) + 1.0_ki/6.0_ki * C(3) * coeffs%c2(3, 15)
+ ! [1, 1, 1, 1, 2] <-- [1, 1, 1, 1, 1, 2]
+ cprime%c2(4,10) = 5.0_ki/6.0_ki * C(1) * coeffs%c2(4, 15)
+ ! [1, 1, 1, 1, 1] <-- [1, 1, 1, 1, 1, 2]
+ cprime%c1(2,5) = 1.0_ki/6.0_ki * C(2) * coeffs%c2(4, 15)
+ ! [1, 1, 1, 1, 3] <-- [1, 1, 1, 1, 1, 3]
+ cprime%c2(5,10) = 5.0_ki/6.0_ki * C(1) * coeffs%c2(5, 15)
+ ! [1, 1, 1, 1, 1] <-- [1, 1, 1, 1, 1, 3]
+ cprime%c1(2,5) = cprime%c1(2,5) + 1.0_ki/6.0_ki * C(3) * coeffs%c2(5, 15)
+ ! [2, 2, 2, 2, 3] <-- [2, 2, 2, 2, 2, 3]
+ cprime%c2(6,10) = 5.0_ki/6.0_ki * C(2) * coeffs%c2(6, 15)
+ ! [2, 2, 2, 2, 2] <-- [2, 2, 2, 2, 2, 3]
+ cprime%c1(3,5) = 1.0_ki/6.0_ki * C(3) * coeffs%c2(6, 15)
+ ! [0, 1, 1, 1, 2] <-- [0, 0, 1, 1, 1, 2]
+ cprime%c3(1,6) = cprime%c3(1,6) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(1, 16)
+ ! [0, 0, 1, 1, 2] <-- [0, 0, 1, 1, 1, 2]
+ cprime%c3(1,9) = cprime%c3(1,9) + 0.5_ki * C(1) * coeffs%c3(1, 16)
+ ! [0, 0, 1, 1, 1] <-- [0, 0, 1, 1, 1, 2]
+ cprime%c2(1,7) = 1.0_ki/6.0_ki * C(2) * coeffs%c3(1, 16)
+ ! [0, 1, 1, 1, 3] <-- [0, 0, 1, 1, 1, 3]
+ cprime%c3(2,6) = cprime%c3(2,6) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(2, 16)
+ ! [0, 0, 1, 1, 3] <-- [0, 0, 1, 1, 1, 3]
+ cprime%c3(2,9) = cprime%c3(2,9) + 0.5_ki * C(1) * coeffs%c3(2, 16)
+ ! [0, 0, 1, 1, 1] <-- [0, 0, 1, 1, 1, 3]
+ cprime%c2(1,7) = cprime%c2(1,7) + 1.0_ki/6.0_ki * C(3) * coeffs%c3(2, 16)
+ ! [0, 2, 2, 2, 3] <-- [0, 0, 2, 2, 2, 3]
+ cprime%c3(3,6) = cprime%c3(3,6) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(3, 16)
+ ! [0, 0, 2, 2, 3] <-- [0, 0, 2, 2, 2, 3]
+ cprime%c3(3,9) = 0.5_ki * C(2) * coeffs%c3(3, 16)
+ ! [0, 0, 2, 2, 2] <-- [0, 0, 2, 2, 2, 3]
+ cprime%c2(2,7) = 1.0_ki/6.0_ki * C(3) * coeffs%c3(3, 16)
+ ! [1, 2, 2, 2, 3] <-- [1, 1, 2, 2, 2, 3]
+ cprime%c3(4,6) = cprime%c3(4,6) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(4, 16)
+ ! [1, 1, 2, 2, 3] <-- [1, 1, 2, 2, 2, 3]
+ cprime%c3(4,9) = 0.5_ki * C(2) * coeffs%c3(4, 16)
+ ! [1, 1, 2, 2, 2] <-- [1, 1, 2, 2, 2, 3]
+ cprime%c2(4,7) = 1.0_ki/6.0_ki * C(3) * coeffs%c3(4, 16)
+ ! [1, 2, 2, 3, 3] <-- [0, 1, 2, 2, 3, 3]
+ cprime%c3(4,5) = cprime%c3(4,5) + 1.0_ki/6.0_ki * C(0) * coeffs%c4(1, 5)
+ ! [0, 2, 2, 3, 3] <-- [0, 1, 2, 2, 3, 3]
+ cprime%c3(3,5) = cprime%c3(3,5) + 1.0_ki/6.0_ki * C(1) * coeffs%c4(1, 5)
+ ! [0, 1, 2, 3, 3] <-- [0, 1, 2, 2, 3, 3]
+ cprime%c4(1,2) = 1.0_ki/3.0_ki * C(2) * coeffs%c4(1, 5)
+ ! [0, 1, 2, 2, 3] <-- [0, 1, 2, 2, 3, 3]
+ cprime%c4(1,3) = cprime%c4(1,3) + 1.0_ki/3.0_ki * C(3) * coeffs%c4(1, 5)
+ ! [0, 1, 2, 2, 3] <-- [0, 0, 1, 2, 2, 3]
+ cprime%c4(1,3) = cprime%c4(1,3) + 1.0_ki/3.0_ki * C(0) * coeffs%c4(1, 13)
+ ! [0, 0, 2, 2, 3] <-- [0, 0, 1, 2, 2, 3]
+ cprime%c3(3,9) = cprime%c3(3,9) + 1.0_ki/6.0_ki * C(1) * coeffs%c4(1, 13)
+ ! [0, 0, 1, 2, 3] <-- [0, 0, 1, 2, 2, 3]
+ cprime%c4(1,5) = cprime%c4(1,5) + 1.0_ki/3.0_ki * C(2) * coeffs%c4(1, 13)
+ ! [0, 0, 1, 2, 2] <-- [0, 0, 1, 2, 2, 3]
+ cprime%c3(1,8) = 1.0_ki/6.0_ki * C(3) * coeffs%c4(1, 13)
+ ! [0, 0, 1, 1, 1] <-- [0, 0, 0, 1, 1, 1]
+ cprime%c2(1,7) = cprime%c2(1,7) + 0.5_ki * C(0) * coeffs%c2(1, 12)
+ ! [0, 0, 0, 1, 1] <-- [0, 0, 0, 1, 1, 1]
+ cprime%c2(1,9) = 0.5_ki * C(1) * coeffs%c2(1, 12)
+ ! [0, 0, 2, 2, 2] <-- [0, 0, 0, 2, 2, 2]
+ cprime%c2(2,7) = cprime%c2(2,7) + 0.5_ki * C(0) * coeffs%c2(2, 12)
+ ! [0, 0, 0, 2, 2] <-- [0, 0, 0, 2, 2, 2]
+ cprime%c2(2,9) = 0.5_ki * C(2) * coeffs%c2(2, 12)
+ ! [0, 0, 3, 3, 3] <-- [0, 0, 0, 3, 3, 3]
+ cprime%c2(3,7) = 0.5_ki * C(0) * coeffs%c2(3, 12)
+ ! [0, 0, 0, 3, 3] <-- [0, 0, 0, 3, 3, 3]
+ cprime%c2(3,9) = 0.5_ki * C(3) * coeffs%c2(3, 12)
+ ! [1, 1, 2, 2, 2] <-- [1, 1, 1, 2, 2, 2]
+ cprime%c2(4,7) = cprime%c2(4,7) + 0.5_ki * C(1) * coeffs%c2(4, 12)
+ ! [1, 1, 1, 2, 2] <-- [1, 1, 1, 2, 2, 2]
+ cprime%c2(4,9) = cprime%c2(4,9) + 0.5_ki * C(2) * coeffs%c2(4, 12)
+ ! [1, 1, 3, 3, 3] <-- [1, 1, 1, 3, 3, 3]
+ cprime%c2(5,7) = 0.5_ki * C(1) * coeffs%c2(5, 12)
+ ! [1, 1, 1, 3, 3] <-- [1, 1, 1, 3, 3, 3]
+ cprime%c2(5,9) = cprime%c2(5,9) + 0.5_ki * C(3) * coeffs%c2(5, 12)
+ ! [2, 2, 3, 3, 3] <-- [2, 2, 2, 3, 3, 3]
+ cprime%c2(6,7) = 0.5_ki * C(2) * coeffs%c2(6, 12)
+ ! [2, 2, 2, 3, 3] <-- [2, 2, 2, 3, 3, 3]
+ cprime%c2(6,9) = cprime%c2(6,9) + 0.5_ki * C(3) * coeffs%c2(6, 12)
+ ! [1, 1, 1, 1, 2] <-- [0, 1, 1, 1, 1, 2]
+ cprime%c2(4,10) = cprime%c2(4,10) + 1.0_ki/6.0_ki * C(0) * coeffs%c3(1, 10)
+ ! [0, 1, 1, 1, 2] <-- [0, 1, 1, 1, 1, 2]
+ cprime%c3(1,6) = cprime%c3(1,6) + 2.0_ki/3.0_ki * C(1) * coeffs%c3(1, 10)
+ ! [0, 1, 1, 1, 1] <-- [0, 1, 1, 1, 1, 2]
+ cprime%c2(1,4) = 1.0_ki/6.0_ki * C(2) * coeffs%c3(1, 10)
+ ! [1, 1, 1, 1, 3] <-- [0, 1, 1, 1, 1, 3]
+ cprime%c2(5,10) = cprime%c2(5,10) + 1.0_ki/6.0_ki * C(0) * coeffs%c3(2, 10)
+ ! [0, 1, 1, 1, 3] <-- [0, 1, 1, 1, 1, 3]
+ cprime%c3(2,6) = cprime%c3(2,6) + 2.0_ki/3.0_ki * C(1) * coeffs%c3(2, 10)
+ ! [0, 1, 1, 1, 1] <-- [0, 1, 1, 1, 1, 3]
+ cprime%c2(1,4) = cprime%c2(1,4) + 1.0_ki/6.0_ki * C(3) * coeffs%c3(2, 10)
+ ! [2, 2, 2, 2, 3] <-- [0, 2, 2, 2, 2, 3]
+ cprime%c2(6,10) = cprime%c2(6,10) + 1.0_ki/6.0_ki * C(0) * coeffs%c3(3, 10)
+ ! [0, 2, 2, 2, 3] <-- [0, 2, 2, 2, 2, 3]
+ cprime%c3(3,6) = cprime%c3(3,6) + 2.0_ki/3.0_ki * C(2) * coeffs%c3(3, 10)
+ ! [0, 2, 2, 2, 2] <-- [0, 2, 2, 2, 2, 3]
+ cprime%c2(2,4) = 1.0_ki/6.0_ki * C(3) * coeffs%c3(3, 10)
+ ! [2, 2, 2, 2, 3] <-- [1, 2, 2, 2, 2, 3]
+ cprime%c2(6,10) = cprime%c2(6,10) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(4, 10)
+ ! [1, 2, 2, 2, 3] <-- [1, 2, 2, 2, 2, 3]
+ cprime%c3(4,6) = cprime%c3(4,6) + 2.0_ki/3.0_ki * C(2) * coeffs%c3(4, 10)
+ ! [1, 2, 2, 2, 2] <-- [1, 2, 2, 2, 2, 3]
+ cprime%c2(4,4) = 1.0_ki/6.0_ki * C(3) * coeffs%c3(4, 10)
+ ! [1, 1, 2, 2, 3] <-- [0, 1, 1, 2, 2, 3]
+ cprime%c3(4,9) = cprime%c3(4,9) + 1.0_ki/6.0_ki * C(0) * coeffs%c4(1, 9)
+ ! [0, 1, 2, 2, 3] <-- [0, 1, 1, 2, 2, 3]
+ cprime%c4(1,3) = cprime%c4(1,3) + 1.0_ki/3.0_ki * C(1) * coeffs%c4(1, 9)
+ ! [0, 1, 1, 2, 3] <-- [0, 1, 1, 2, 2, 3]
+ cprime%c4(1,4) = cprime%c4(1,4) + 1.0_ki/3.0_ki * C(2) * coeffs%c4(1, 9)
+ ! [0, 1, 1, 2, 2] <-- [0, 1, 1, 2, 2, 3]
+ cprime%c3(1,5) = cprime%c3(1,5) + 1.0_ki/6.0_ki * C(3) * coeffs%c4(1, 9)
+ ! [0, 0, 1, 2, 3] <-- [0, 0, 0, 1, 2, 3]
+ cprime%c4(1,5) = cprime%c4(1,5) + 0.5_ki * C(0) * coeffs%c4(1, 15)
+ ! [0, 0, 0, 2, 3] <-- [0, 0, 0, 1, 2, 3]
+ cprime%c3(3,10) = 1.0_ki/6.0_ki * C(1) * coeffs%c4(1, 15)
+ ! [0, 0, 0, 1, 3] <-- [0, 0, 0, 1, 2, 3]
+ cprime%c3(2,10) = 1.0_ki/6.0_ki * C(2) * coeffs%c4(1, 15)
+ ! [0, 0, 0, 1, 2] <-- [0, 0, 0, 1, 2, 3]
+ cprime%c3(1,10) = 1.0_ki/6.0_ki * C(3) * coeffs%c4(1, 15)
+ ! [1, 1, 1, 1, 1] <-- [0, 1, 1, 1, 1, 1]
+ cprime%c1(2,5) = cprime%c1(2,5) + 1.0_ki/6.0_ki * C(0) * coeffs%c2(1, 5)
+ ! [0, 1, 1, 1, 1] <-- [0, 1, 1, 1, 1, 1]
+ cprime%c2(1,4) = cprime%c2(1,4) + 5.0_ki/6.0_ki * C(1) * coeffs%c2(1, 5)
+ ! [2, 2, 2, 2, 2] <-- [0, 2, 2, 2, 2, 2]
+ cprime%c1(3,5) = cprime%c1(3,5) + 1.0_ki/6.0_ki * C(0) * coeffs%c2(2, 5)
+ ! [0, 2, 2, 2, 2] <-- [0, 2, 2, 2, 2, 2]
+ cprime%c2(2,4) = cprime%c2(2,4) + 5.0_ki/6.0_ki * C(2) * coeffs%c2(2, 5)
+ ! [3, 3, 3, 3, 3] <-- [0, 3, 3, 3, 3, 3]
+ cprime%c1(4,5) = 1.0_ki/6.0_ki * C(0) * coeffs%c2(3, 5)
+ ! [0, 3, 3, 3, 3] <-- [0, 3, 3, 3, 3, 3]
+ cprime%c2(3,4) = 5.0_ki/6.0_ki * C(3) * coeffs%c2(3, 5)
+ ! [2, 2, 2, 2, 2] <-- [1, 2, 2, 2, 2, 2]
+ cprime%c1(3,5) = cprime%c1(3,5) + 1.0_ki/6.0_ki * C(1) * coeffs%c2(4, 5)
+ ! [1, 2, 2, 2, 2] <-- [1, 2, 2, 2, 2, 2]
+ cprime%c2(4,4) = cprime%c2(4,4) + 5.0_ki/6.0_ki * C(2) * coeffs%c2(4, 5)
+ ! [3, 3, 3, 3, 3] <-- [1, 3, 3, 3, 3, 3]
+ cprime%c1(4,5) = cprime%c1(4,5) + 1.0_ki/6.0_ki * C(1) * coeffs%c2(5, 5)
+ ! [1, 3, 3, 3, 3] <-- [1, 3, 3, 3, 3, 3]
+ cprime%c2(5,4) = 5.0_ki/6.0_ki * C(3) * coeffs%c2(5, 5)
+ ! [3, 3, 3, 3, 3] <-- [2, 3, 3, 3, 3, 3]
+ cprime%c1(4,5) = cprime%c1(4,5) + 1.0_ki/6.0_ki * C(2) * coeffs%c2(6, 5)
+ ! [2, 3, 3, 3, 3] <-- [2, 3, 3, 3, 3, 3]
+ cprime%c2(6,4) = 5.0_ki/6.0_ki * C(3) * coeffs%c2(6, 5)
+ ! [0, 1, 2, 3, 3] <-- [0, 0, 1, 2, 3, 3]
+ cprime%c4(1,2) = cprime%c4(1,2) + 1.0_ki/3.0_ki * C(0) * coeffs%c4(1, 12)
+ ! [0, 0, 2, 3, 3] <-- [0, 0, 1, 2, 3, 3]
+ cprime%c3(3,8) = 1.0_ki/6.0_ki * C(1) * coeffs%c4(1, 12)
+ ! [0, 0, 1, 3, 3] <-- [0, 0, 1, 2, 3, 3]
+ cprime%c3(2,8) = 1.0_ki/6.0_ki * C(2) * coeffs%c4(1, 12)
+ ! [0, 0, 1, 2, 3] <-- [0, 0, 1, 2, 3, 3]
+ cprime%c4(1,5) = cprime%c4(1,5) + 1.0_ki/3.0_ki * C(3) * coeffs%c4(1, 12)
+ ! [0, 0, 1, 2, 2] <-- [0, 0, 0, 1, 2, 2]
+ cprime%c3(1,8) = cprime%c3(1,8) + 0.5_ki * C(0) * coeffs%c3(1, 18)
+ ! [0, 0, 0, 2, 2] <-- [0, 0, 0, 1, 2, 2]
+ cprime%c2(2,9) = cprime%c2(2,9) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(1, 18)
+ ! [0, 0, 0, 1, 2] <-- [0, 0, 0, 1, 2, 2]
+ cprime%c3(1,10) = cprime%c3(1,10) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(1, 18)
+ ! [0, 0, 1, 3, 3] <-- [0, 0, 0, 1, 3, 3]
+ cprime%c3(2,8) = cprime%c3(2,8) + 0.5_ki * C(0) * coeffs%c3(2, 18)
+ ! [0, 0, 0, 3, 3] <-- [0, 0, 0, 1, 3, 3]
+ cprime%c2(3,9) = cprime%c2(3,9) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(2, 18)
+ ! [0, 0, 0, 1, 3] <-- [0, 0, 0, 1, 3, 3]
+ cprime%c3(2,10) = cprime%c3(2,10) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(2, 18)
+ ! [0, 0, 2, 3, 3] <-- [0, 0, 0, 2, 3, 3]
+ cprime%c3(3,8) = cprime%c3(3,8) + 0.5_ki * C(0) * coeffs%c3(3, 18)
+ ! [0, 0, 0, 3, 3] <-- [0, 0, 0, 2, 3, 3]
+ cprime%c2(3,9) = cprime%c2(3,9) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(3, 18)
+ ! [0, 0, 0, 2, 3] <-- [0, 0, 0, 2, 3, 3]
+ cprime%c3(3,10) = cprime%c3(3,10) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(3, 18)
+ ! [1, 1, 2, 3, 3] <-- [1, 1, 1, 2, 3, 3]
+ cprime%c3(4,8) = 0.5_ki * C(1) * coeffs%c3(4, 18)
+ ! [1, 1, 1, 3, 3] <-- [1, 1, 1, 2, 3, 3]
+ cprime%c2(5,9) = cprime%c2(5,9) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(4, 18)
+ ! [1, 1, 1, 2, 3] <-- [1, 1, 1, 2, 3, 3]
+ cprime%c3(4,10) = 1.0_ki/3.0_ki * C(3) * coeffs%c3(4, 18)
+ ! [1, 1, 2, 3, 3] <-- [0, 1, 1, 2, 3, 3]
+ cprime%c3(4,8) = cprime%c3(4,8) + 1.0_ki/6.0_ki * C(0) * coeffs%c4(1, 8)
+ ! [0, 1, 2, 3, 3] <-- [0, 1, 1, 2, 3, 3]
+ cprime%c4(1,2) = cprime%c4(1,2) + 1.0_ki/3.0_ki * C(1) * coeffs%c4(1, 8)
+ ! [0, 1, 1, 3, 3] <-- [0, 1, 1, 2, 3, 3]
+ cprime%c3(2,5) = cprime%c3(2,5) + 1.0_ki/6.0_ki * C(2) * coeffs%c4(1, 8)
+ ! [0, 1, 1, 2, 3] <-- [0, 1, 1, 2, 3, 3]
+ cprime%c4(1,4) = cprime%c4(1,4) + 1.0_ki/3.0_ki * C(3) * coeffs%c4(1, 8)
+ ! [0, 0, 1, 1, 2] <-- [0, 0, 0, 1, 1, 2]
+ cprime%c3(1,9) = cprime%c3(1,9) + 0.5_ki * C(0) * coeffs%c3(1, 19)
+ ! [0, 0, 0, 1, 2] <-- [0, 0, 0, 1, 1, 2]
+ cprime%c3(1,10) = cprime%c3(1,10) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(1, 19)
+ ! [0, 0, 0, 1, 1] <-- [0, 0, 0, 1, 1, 2]
+ cprime%c2(1,9) = cprime%c2(1,9) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(1, 19)
+ ! [0, 0, 1, 1, 3] <-- [0, 0, 0, 1, 1, 3]
+ cprime%c3(2,9) = cprime%c3(2,9) + 0.5_ki * C(0) * coeffs%c3(2, 19)
+ ! [0, 0, 0, 1, 3] <-- [0, 0, 0, 1, 1, 3]
+ cprime%c3(2,10) = cprime%c3(2,10) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(2, 19)
+ ! [0, 0, 0, 1, 1] <-- [0, 0, 0, 1, 1, 3]
+ cprime%c2(1,9) = cprime%c2(1,9) + 1.0_ki/6.0_ki * C(3) * coeffs%c3(2, 19)
+ ! [0, 0, 2, 2, 3] <-- [0, 0, 0, 2, 2, 3]
+ cprime%c3(3,9) = cprime%c3(3,9) + 0.5_ki * C(0) * coeffs%c3(3, 19)
+ ! [0, 0, 0, 2, 3] <-- [0, 0, 0, 2, 2, 3]
+ cprime%c3(3,10) = cprime%c3(3,10) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(3, 19)
+ ! [0, 0, 0, 2, 2] <-- [0, 0, 0, 2, 2, 3]
+ cprime%c2(2,9) = cprime%c2(2,9) + 1.0_ki/6.0_ki * C(3) * coeffs%c3(3, 19)
+ ! [1, 1, 2, 2, 3] <-- [1, 1, 1, 2, 2, 3]
+ cprime%c3(4,9) = cprime%c3(4,9) + 0.5_ki * C(1) * coeffs%c3(4, 19)
+ ! [1, 1, 1, 2, 3] <-- [1, 1, 1, 2, 2, 3]
+ cprime%c3(4,10) = cprime%c3(4,10) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(4, 19)
+ ! [1, 1, 1, 2, 2] <-- [1, 1, 1, 2, 2, 3]
+ cprime%c2(4,9) = cprime%c2(4,9) + 1.0_ki/6.0_ki * C(3) * coeffs%c3(4, 19)
+ ! [1, 1, 2, 2, 2] <-- [0, 1, 1, 2, 2, 2]
+ cprime%c2(4,7) = cprime%c2(4,7) + 1.0_ki/6.0_ki * C(0) * coeffs%c3(1, 7)
+ ! [0, 1, 2, 2, 2] <-- [0, 1, 1, 2, 2, 2]
+ cprime%c3(1,3) = cprime%c3(1,3) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(1, 7)
+ ! [0, 1, 1, 2, 2] <-- [0, 1, 1, 2, 2, 2]
+ cprime%c3(1,5) = cprime%c3(1,5) + 0.5_ki * C(2) * coeffs%c3(1, 7)
+ ! [1, 1, 3, 3, 3] <-- [0, 1, 1, 3, 3, 3]
+ cprime%c2(5,7) = cprime%c2(5,7) + 1.0_ki/6.0_ki * C(0) * coeffs%c3(2, 7)
+ ! [0, 1, 3, 3, 3] <-- [0, 1, 1, 3, 3, 3]
+ cprime%c3(2,3) = 1.0_ki/3.0_ki * C(1) * coeffs%c3(2, 7)
+ ! [0, 1, 1, 3, 3] <-- [0, 1, 1, 3, 3, 3]
+ cprime%c3(2,5) = cprime%c3(2,5) + 0.5_ki * C(3) * coeffs%c3(2, 7)
+ ! [2, 2, 3, 3, 3] <-- [0, 2, 2, 3, 3, 3]
+ cprime%c2(6,7) = cprime%c2(6,7) + 1.0_ki/6.0_ki * C(0) * coeffs%c3(3, 7)
+ ! [0, 2, 3, 3, 3] <-- [0, 2, 2, 3, 3, 3]
+ cprime%c3(3,3) = 1.0_ki/3.0_ki * C(2) * coeffs%c3(3, 7)
+ ! [0, 2, 2, 3, 3] <-- [0, 2, 2, 3, 3, 3]
+ cprime%c3(3,5) = cprime%c3(3,5) + 0.5_ki * C(3) * coeffs%c3(3, 7)
+ ! [2, 2, 3, 3, 3] <-- [1, 2, 2, 3, 3, 3]
+ cprime%c2(6,7) = cprime%c2(6,7) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(4, 7)
+ ! [1, 2, 3, 3, 3] <-- [1, 2, 2, 3, 3, 3]
+ cprime%c3(4,3) = 1.0_ki/3.0_ki * C(2) * coeffs%c3(4, 7)
+ ! [1, 2, 2, 3, 3] <-- [1, 2, 2, 3, 3, 3]
+ cprime%c3(4,5) = cprime%c3(4,5) + 0.5_ki * C(3) * coeffs%c3(4, 7)
+ ! [0, 0, 0, 1, 2] <-- [0, 0, 0, 0, 1, 2]
+ cprime%c3(1,10) = cprime%c3(1,10) + 2.0_ki/3.0_ki * C(0) * coeffs%c3(1, 20)
+ ! [0, 0, 0, 0, 2] <-- [0, 0, 0, 0, 1, 2]
+ cprime%c2(2,10) = cprime%c2(2,10) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(1, 20)
+ ! [0, 0, 0, 0, 1] <-- [0, 0, 0, 0, 1, 2]
+ cprime%c2(1,10) = cprime%c2(1,10) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(1, 20)
+ ! [0, 0, 0, 1, 3] <-- [0, 0, 0, 0, 1, 3]
+ cprime%c3(2,10) = cprime%c3(2,10) + 2.0_ki/3.0_ki * C(0) * coeffs%c3(2, 20)
+ ! [0, 0, 0, 0, 3] <-- [0, 0, 0, 0, 1, 3]
+ cprime%c2(3,10) = cprime%c2(3,10) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(2, 20)
+ ! [0, 0, 0, 0, 1] <-- [0, 0, 0, 0, 1, 3]
+ cprime%c2(1,10) = cprime%c2(1,10) + 1.0_ki/6.0_ki * C(3) * coeffs%c3(2, 20)
+ ! [0, 0, 0, 2, 3] <-- [0, 0, 0, 0, 2, 3]
+ cprime%c3(3,10) = cprime%c3(3,10) + 2.0_ki/3.0_ki * C(0) * coeffs%c3(3, 20)
+ ! [0, 0, 0, 0, 3] <-- [0, 0, 0, 0, 2, 3]
+ cprime%c2(3,10) = cprime%c2(3,10) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(3, 20)
+ ! [0, 0, 0, 0, 2] <-- [0, 0, 0, 0, 2, 3]
+ cprime%c2(2,10) = cprime%c2(2,10) + 1.0_ki/6.0_ki * C(3) * coeffs%c3(3, 20)
+ ! [1, 1, 1, 2, 3] <-- [1, 1, 1, 1, 2, 3]
+ cprime%c3(4,10) = cprime%c3(4,10) + 2.0_ki/3.0_ki * C(1) * coeffs%c3(4, 20)
+ ! [1, 1, 1, 1, 3] <-- [1, 1, 1, 1, 2, 3]
+ cprime%c2(5,10) = cprime%c2(5,10) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(4, 20)
+ ! [1, 1, 1, 1, 2] <-- [1, 1, 1, 1, 2, 3]
+ cprime%c2(4,10) = cprime%c2(4,10) + 1.0_ki/6.0_ki * C(3) * coeffs%c3(4, 20)
+ ! [1, 1, 1, 2, 3] <-- [0, 1, 1, 1, 2, 3]
+ cprime%c3(4,10) = cprime%c3(4,10) + 1.0_ki/6.0_ki * C(0) * coeffs%c4(1, 10)
+ ! [0, 1, 1, 2, 3] <-- [0, 1, 1, 1, 2, 3]
+ cprime%c4(1,4) = cprime%c4(1,4) + 0.5_ki * C(1) * coeffs%c4(1, 10)
+ ! [0, 1, 1, 1, 3] <-- [0, 1, 1, 1, 2, 3]
+ cprime%c3(2,6) = cprime%c3(2,6) + 1.0_ki/6.0_ki * C(2) * coeffs%c4(1, 10)
+ ! [0, 1, 1, 1, 2] <-- [0, 1, 1, 1, 2, 3]
+ cprime%c3(1,6) = cprime%c3(1,6) + 1.0_ki/6.0_ki * C(3) * coeffs%c4(1, 10)
+ ! [0, 0, 0, 1, 1] <-- [0, 0, 0, 0, 1, 1]
+ cprime%c2(1,9) = cprime%c2(1,9) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(1, 14)
+ ! [0, 0, 0, 0, 1] <-- [0, 0, 0, 0, 1, 1]
+ cprime%c2(1,10) = cprime%c2(1,10) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(1, 14)
+ ! [0, 0, 0, 2, 2] <-- [0, 0, 0, 0, 2, 2]
+ cprime%c2(2,9) = cprime%c2(2,9) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(2, 14)
+ ! [0, 0, 0, 0, 2] <-- [0, 0, 0, 0, 2, 2]
+ cprime%c2(2,10) = cprime%c2(2,10) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(2, 14)
+ ! [0, 0, 0, 3, 3] <-- [0, 0, 0, 0, 3, 3]
+ cprime%c2(3,9) = cprime%c2(3,9) + 2.0_ki/3.0_ki * C(0) * coeffs%c2(3, 14)
+ ! [0, 0, 0, 0, 3] <-- [0, 0, 0, 0, 3, 3]
+ cprime%c2(3,10) = cprime%c2(3,10) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(3, 14)
+ ! [1, 1, 1, 2, 2] <-- [1, 1, 1, 1, 2, 2]
+ cprime%c2(4,9) = cprime%c2(4,9) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(4, 14)
+ ! [1, 1, 1, 1, 2] <-- [1, 1, 1, 1, 2, 2]
+ cprime%c2(4,10) = cprime%c2(4,10) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(4, 14)
+ ! [1, 1, 1, 3, 3] <-- [1, 1, 1, 1, 3, 3]
+ cprime%c2(5,9) = cprime%c2(5,9) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(5, 14)
+ ! [1, 1, 1, 1, 3] <-- [1, 1, 1, 1, 3, 3]
+ cprime%c2(5,10) = cprime%c2(5,10) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(5, 14)
+ ! [2, 2, 2, 3, 3] <-- [2, 2, 2, 2, 3, 3]
+ cprime%c2(6,9) = cprime%c2(6,9) + 2.0_ki/3.0_ki * C(2) * coeffs%c2(6, 14)
+ ! [2, 2, 2, 2, 3] <-- [2, 2, 2, 2, 3, 3]
+ cprime%c2(6,10) = cprime%c2(6,10) + 1.0_ki/3.0_ki * C(3) * coeffs%c2(6, 14)
+ ! [0, 1, 2, 2, 2] <-- [0, 0, 1, 2, 2, 2]
+ cprime%c3(1,3) = cprime%c3(1,3) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(1, 13)
+ ! [0, 0, 2, 2, 2] <-- [0, 0, 1, 2, 2, 2]
+ cprime%c2(2,7) = cprime%c2(2,7) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(1, 13)
+ ! [0, 0, 1, 2, 2] <-- [0, 0, 1, 2, 2, 2]
+ cprime%c3(1,8) = cprime%c3(1,8) + 0.5_ki * C(2) * coeffs%c3(1, 13)
+ ! [0, 1, 3, 3, 3] <-- [0, 0, 1, 3, 3, 3]
+ cprime%c3(2,3) = cprime%c3(2,3) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(2, 13)
+ ! [0, 0, 3, 3, 3] <-- [0, 0, 1, 3, 3, 3]
+ cprime%c2(3,7) = cprime%c2(3,7) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(2, 13)
+ ! [0, 0, 1, 3, 3] <-- [0, 0, 1, 3, 3, 3]
+ cprime%c3(2,8) = cprime%c3(2,8) + 0.5_ki * C(3) * coeffs%c3(2, 13)
+ ! [0, 2, 3, 3, 3] <-- [0, 0, 2, 3, 3, 3]
+ cprime%c3(3,3) = cprime%c3(3,3) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(3, 13)
+ ! [0, 0, 3, 3, 3] <-- [0, 0, 2, 3, 3, 3]
+ cprime%c2(3,7) = cprime%c2(3,7) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(3, 13)
+ ! [0, 0, 2, 3, 3] <-- [0, 0, 2, 3, 3, 3]
+ cprime%c3(3,8) = cprime%c3(3,8) + 0.5_ki * C(3) * coeffs%c3(3, 13)
+ ! [1, 2, 3, 3, 3] <-- [1, 1, 2, 3, 3, 3]
+ cprime%c3(4,3) = cprime%c3(4,3) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(4, 13)
+ ! [1, 1, 3, 3, 3] <-- [1, 1, 2, 3, 3, 3]
+ cprime%c2(5,7) = cprime%c2(5,7) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(4, 13)
+ ! [1, 1, 2, 3, 3] <-- [1, 1, 2, 3, 3, 3]
+ cprime%c3(4,8) = cprime%c3(4,8) + 0.5_ki * C(3) * coeffs%c3(4, 13)
+ ! [1, 2, 3, 3, 3] <-- [0, 1, 2, 3, 3, 3]
+ cprime%c3(4,3) = cprime%c3(4,3) + 1.0_ki/6.0_ki * C(0) * coeffs%c4(1, 3)
+ ! [0, 2, 3, 3, 3] <-- [0, 1, 2, 3, 3, 3]
+ cprime%c3(3,3) = cprime%c3(3,3) + 1.0_ki/6.0_ki * C(1) * coeffs%c4(1, 3)
+ ! [0, 1, 3, 3, 3] <-- [0, 1, 2, 3, 3, 3]
+ cprime%c3(2,3) = cprime%c3(2,3) + 1.0_ki/6.0_ki * C(2) * coeffs%c4(1, 3)
+ ! [0, 1, 2, 3, 3] <-- [0, 1, 2, 3, 3, 3]
+ cprime%c4(1,2) = cprime%c4(1,2) + 0.5_ki * C(3) * coeffs%c4(1, 3)
+ ! [0, 1, 1, 2, 2] <-- [0, 0, 1, 1, 2, 2]
+ cprime%c3(1,5) = cprime%c3(1,5) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(1, 15)
+ ! [0, 0, 1, 2, 2] <-- [0, 0, 1, 1, 2, 2]
+ cprime%c3(1,8) = cprime%c3(1,8) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(1, 15)
+ ! [0, 0, 1, 1, 2] <-- [0, 0, 1, 1, 2, 2]
+ cprime%c3(1,9) = cprime%c3(1,9) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(1, 15)
+ ! [0, 1, 1, 3, 3] <-- [0, 0, 1, 1, 3, 3]
+ cprime%c3(2,5) = cprime%c3(2,5) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(2, 15)
+ ! [0, 0, 1, 3, 3] <-- [0, 0, 1, 1, 3, 3]
+ cprime%c3(2,8) = cprime%c3(2,8) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(2, 15)
+ ! [0, 0, 1, 1, 3] <-- [0, 0, 1, 1, 3, 3]
+ cprime%c3(2,9) = cprime%c3(2,9) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(2, 15)
+ ! [0, 2, 2, 3, 3] <-- [0, 0, 2, 2, 3, 3]
+ cprime%c3(3,5) = cprime%c3(3,5) + 1.0_ki/3.0_ki * C(0) * coeffs%c3(3, 15)
+ ! [0, 0, 2, 3, 3] <-- [0, 0, 2, 2, 3, 3]
+ cprime%c3(3,8) = cprime%c3(3,8) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(3, 15)
+ ! [0, 0, 2, 2, 3] <-- [0, 0, 2, 2, 3, 3]
+ cprime%c3(3,9) = cprime%c3(3,9) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(3, 15)
+ ! [1, 2, 2, 3, 3] <-- [1, 1, 2, 2, 3, 3]
+ cprime%c3(4,5) = cprime%c3(4,5) + 1.0_ki/3.0_ki * C(1) * coeffs%c3(4, 15)
+ ! [1, 1, 2, 3, 3] <-- [1, 1, 2, 2, 3, 3]
+ cprime%c3(4,8) = cprime%c3(4,8) + 1.0_ki/3.0_ki * C(2) * coeffs%c3(4, 15)
+ ! [1, 1, 2, 2, 3] <-- [1, 1, 2, 2, 3, 3]
+ cprime%c3(4,9) = cprime%c3(4,9) + 1.0_ki/3.0_ki * C(3) * coeffs%c3(4, 15)
+ ! [0, 1, 1, 1, 1] <-- [0, 0, 1, 1, 1, 1]
+ cprime%c2(1,4) = cprime%c2(1,4) + 1.0_ki/3.0_ki * C(0) * coeffs%c2(1, 9)
+ ! [0, 0, 1, 1, 1] <-- [0, 0, 1, 1, 1, 1]
+ cprime%c2(1,7) = cprime%c2(1,7) + 2.0_ki/3.0_ki * C(1) * coeffs%c2(1, 9)
+ ! [0, 2, 2, 2, 2] <-- [0, 0, 2, 2, 2, 2]
+ cprime%c2(2,4) = cprime%c2(2,4) + 1.0_ki/3.0_ki * C(0) * coeffs%c2(2, 9)
+ ! [0, 0, 2, 2, 2] <-- [0, 0, 2, 2, 2, 2]
+ cprime%c2(2,7) = cprime%c2(2,7) + 2.0_ki/3.0_ki * C(2) * coeffs%c2(2, 9)
+ ! [0, 3, 3, 3, 3] <-- [0, 0, 3, 3, 3, 3]
+ cprime%c2(3,4) = cprime%c2(3,4) + 1.0_ki/3.0_ki * C(0) * coeffs%c2(3, 9)
+ ! [0, 0, 3, 3, 3] <-- [0, 0, 3, 3, 3, 3]
+ cprime%c2(3,7) = cprime%c2(3,7) + 2.0_ki/3.0_ki * C(3) * coeffs%c2(3, 9)
+ ! [1, 2, 2, 2, 2] <-- [1, 1, 2, 2, 2, 2]
+ cprime%c2(4,4) = cprime%c2(4,4) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(4, 9)
+ ! [1, 1, 2, 2, 2] <-- [1, 1, 2, 2, 2, 2]
+ cprime%c2(4,7) = cprime%c2(4,7) + 2.0_ki/3.0_ki * C(2) * coeffs%c2(4, 9)
+ ! [1, 3, 3, 3, 3] <-- [1, 1, 3, 3, 3, 3]
+ cprime%c2(5,4) = cprime%c2(5,4) + 1.0_ki/3.0_ki * C(1) * coeffs%c2(5, 9)
+ ! [1, 1, 3, 3, 3] <-- [1, 1, 3, 3, 3, 3]
+ cprime%c2(5,7) = cprime%c2(5,7) + 2.0_ki/3.0_ki * C(3) * coeffs%c2(5, 9)
+ ! [2, 3, 3, 3, 3] <-- [2, 2, 3, 3, 3, 3]
+ cprime%c2(6,4) = cprime%c2(6,4) + 1.0_ki/3.0_ki * C(2) * coeffs%c2(6, 9)
+ ! [2, 2, 3, 3, 3] <-- [2, 2, 3, 3, 3, 3]
+ cprime%c2(6,7) = cprime%c2(6,7) + 2.0_ki/3.0_ki * C(3) * coeffs%c2(6, 9)
+ ! [0, 0, 0, 0, 0] <-- [0, 0, 0, 0, 0, 0]
+ cprime%c1(1,5) = cprime%c1(1,5) + C(0) * coeffs%c1(1, 6)
+ ! [1, 1, 1, 1, 1] <-- [1, 1, 1, 1, 1, 1]
+ cprime%c1(2,5) = cprime%c1(2,5) + C(1) * coeffs%c1(2, 6)
+ ! [2, 2, 2, 2, 2] <-- [2, 2, 2, 2, 2, 2]
+ cprime%c1(3,5) = cprime%c1(3,5) + C(2) * coeffs%c1(3, 6)
+ ! [3, 3, 3, 3, 3] <-- [3, 3, 3, 3, 3, 3]
+ cprime%c1(4,5) = cprime%c1(4,5) + C(3) * coeffs%c1(4, 6)
+ ! [1, 2, 2, 2, 2] <-- [0, 1, 2, 2, 2, 2]
+ cprime%c2(4,4) = cprime%c2(4,4) + 1.0_ki/6.0_ki * C(0) * coeffs%c3(1, 4)
+ ! [0, 2, 2, 2, 2] <-- [0, 1, 2, 2, 2, 2]
+ cprime%c2(2,4) = cprime%c2(2,4) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(1, 4)
+ ! [0, 1, 2, 2, 2] <-- [0, 1, 2, 2, 2, 2]
+ cprime%c3(1,3) = cprime%c3(1,3) + 2.0_ki/3.0_ki * C(2) * coeffs%c3(1, 4)
+ ! [1, 3, 3, 3, 3] <-- [0, 1, 3, 3, 3, 3]
+ cprime%c2(5,4) = cprime%c2(5,4) + 1.0_ki/6.0_ki * C(0) * coeffs%c3(2, 4)
+ ! [0, 3, 3, 3, 3] <-- [0, 1, 3, 3, 3, 3]
+ cprime%c2(3,4) = cprime%c2(3,4) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(2, 4)
+ ! [0, 1, 3, 3, 3] <-- [0, 1, 3, 3, 3, 3]
+ cprime%c3(2,3) = cprime%c3(2,3) + 2.0_ki/3.0_ki * C(3) * coeffs%c3(2, 4)
+ ! [2, 3, 3, 3, 3] <-- [0, 2, 3, 3, 3, 3]
+ cprime%c2(6,4) = cprime%c2(6,4) + 1.0_ki/6.0_ki * C(0) * coeffs%c3(3, 4)
+ ! [0, 3, 3, 3, 3] <-- [0, 2, 3, 3, 3, 3]
+ cprime%c2(3,4) = cprime%c2(3,4) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(3, 4)
+ ! [0, 2, 3, 3, 3] <-- [0, 2, 3, 3, 3, 3]
+ cprime%c3(3,3) = cprime%c3(3,3) + 2.0_ki/3.0_ki * C(3) * coeffs%c3(3, 4)
+ ! [2, 3, 3, 3, 3] <-- [1, 2, 3, 3, 3, 3]
+ cprime%c2(6,4) = cprime%c2(6,4) + 1.0_ki/6.0_ki * C(1) * coeffs%c3(4, 4)
+ ! [1, 3, 3, 3, 3] <-- [1, 2, 3, 3, 3, 3]
+ cprime%c2(5,4) = cprime%c2(5,4) + 1.0_ki/6.0_ki * C(2) * coeffs%c3(4, 4)
+ ! [1, 2, 3, 3, 3] <-- [1, 2, 3, 3, 3, 3]
+ cprime%c3(4,3) = cprime%c3(4,3) + 2.0_ki/3.0_ki * C(3) * coeffs%c3(4, 4)
+ amp = amp - contract5_5(cprime, momenta, new_set)
+ end do
+end function contract6_6
+!****f* src/interface/tens_comb/contract_a_tensor_1
+! NAME
+!
+! Function contract_a_tensor_1
+!
+! USAGE
+!
+! ans = contract_a_tensor_1(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an A-type tensor
+! of rank 1 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_1)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_a_tensor_1(coeffs, momenta) result(res)
+ ! generated by: write_function_a_tensor_contract
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(1)
+ acc = momenta(1,0)
+ res = acc * coeffs%c1(1,1)
+ acc = momenta(1,1)
+ res = res + acc * coeffs%c1(2,1)
+ acc = momenta(1,2)
+ res = res + acc * coeffs%c1(3,1)
+ acc = momenta(1,3)
+ res = res + acc * coeffs%c1(4,1)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_a_tensor_1
+!****f* src/interface/tens_comb/contract_a_tensor_2
+! NAME
+!
+! Function contract_a_tensor_2
+!
+! USAGE
+!
+! ans = contract_a_tensor_2(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an A-type tensor
+! of rank 2 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_2)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_a_tensor_2(coeffs, momenta) result(res)
+ ! generated by: write_function_a_tensor_contract
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(1)
+ acc = momenta(1,0)
+ res = acc * coeffs%c1(1,1)
+ acc = momenta(1,1)
+ res = res + acc * coeffs%c1(2,1)
+ acc = momenta(1,2)
+ res = res + acc * coeffs%c1(3,1)
+ acc = momenta(1,3)
+ res = res + acc * coeffs%c1(4,1)
+ case(2)
+ acc = momenta(1,0)*momenta(2,0)
+ res = acc * coeffs%c1(1,2)
+ acc = momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c1(2,2)
+ acc = momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c1(3,2)
+ acc = momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c1(4,2)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(1,1)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(2,1)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(3,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(4,1)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(5,1)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(6,1)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_a_tensor_2
+!****f* src/interface/tens_comb/contract_b_tensor_2
+! NAME
+!
+! Function contract_b_tensor_2
+!
+! USAGE
+!
+! ans = contract_b_tensor_2(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an B-type tensor
+! of rank 2 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_2)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_b_tensor_2(coeffs, momenta) result(res)
+ ! generated by: write_function_b_tensor_contract
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(0)
+ res = coeffs%c1(1,2)
+ res = res - coeffs%c1(2,2)
+ res = res - coeffs%c1(3,2)
+ res = res - coeffs%c1(4,2)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_b_tensor_2
+!****f* src/interface/tens_comb/contract_a_tensor_3
+! NAME
+!
+! Function contract_a_tensor_3
+!
+! USAGE
+!
+! ans = contract_a_tensor_3(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an A-type tensor
+! of rank 3 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_3)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_a_tensor_3(coeffs, momenta) result(res)
+ ! generated by: write_function_a_tensor_contract
+ implicit none
+ type(coeff_type_3), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ real(ki) :: reg0
+ real(ki) :: reg1
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(1)
+ acc = momenta(1,0)
+ res = acc * coeffs%c1(1,1)
+ acc = momenta(1,1)
+ res = res + acc * coeffs%c1(2,1)
+ acc = momenta(1,2)
+ res = res + acc * coeffs%c1(3,1)
+ acc = momenta(1,3)
+ res = res + acc * coeffs%c1(4,1)
+ case(2)
+ acc = momenta(1,0)*momenta(2,0)
+ res = acc * coeffs%c1(1,2)
+ acc = momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c1(2,2)
+ acc = momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c1(3,2)
+ acc = momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c1(4,2)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(1,1)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(2,1)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(3,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(4,1)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(5,1)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(6,1)
+ case(3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = acc * coeffs%c2(1,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,2)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,2)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,2)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,2)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(1,1)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(2,1)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(3,1)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(4,1)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,0)
+ res = res + acc * coeffs%c1(1,3)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)
+ res = res + acc * coeffs%c1(2,3)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)
+ res = res + acc * coeffs%c1(3,3)
+ acc = momenta(1,3)*momenta(2,3)*momenta(3,3)
+ res = res + acc * coeffs%c1(4,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(1,3)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,3)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,3)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_a_tensor_3
+!****f* src/interface/tens_comb/contract_b_tensor_3
+! NAME
+!
+! Function contract_b_tensor_3
+!
+! USAGE
+!
+! ans = contract_b_tensor_3(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an B-type tensor
+! of rank 3 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_3)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_b_tensor_3(coeffs, momenta) result(res)
+ ! generated by: write_function_b_tensor_contract
+ implicit none
+ type(coeff_type_3), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(0)
+ res = coeffs%c1(1,2)
+ res = res - coeffs%c1(2,2)
+ res = res - coeffs%c1(3,2)
+ res = res - coeffs%c1(4,2)
+ case(1)
+ acc = -momenta(1,0)
+ res = acc * coeffs%c2(1,2)
+ acc = -momenta(1,0)
+ res = res + acc * coeffs%c2(2,2)
+ acc = -momenta(1,0)
+ res = res + acc * coeffs%c2(3,2)
+ acc = -momenta(1,1)
+ res = res + acc * coeffs%c2(4,2)
+ acc = -momenta(1,1)
+ res = res + acc * coeffs%c2(5,2)
+ acc = -momenta(1,2)
+ res = res + acc * coeffs%c2(6,2)
+ acc = 3*momenta(1,0)
+ res = res + acc * coeffs%c1(1,3)
+ acc = -3*momenta(1,1)
+ res = res + acc * coeffs%c1(2,3)
+ acc = -3*momenta(1,2)
+ res = res + acc * coeffs%c1(3,3)
+ acc = -3*momenta(1,3)
+ res = res + acc * coeffs%c1(4,3)
+ acc = momenta(1,1)
+ res = res + acc * coeffs%c2(1,3)
+ acc = momenta(1,2)
+ res = res + acc * coeffs%c2(2,3)
+ acc = momenta(1,3)
+ res = res + acc * coeffs%c2(3,3)
+ acc = -momenta(1,2)
+ res = res + acc * coeffs%c2(4,3)
+ acc = -momenta(1,3)
+ res = res + acc * coeffs%c2(5,3)
+ acc = -momenta(1,3)
+ res = res + acc * coeffs%c2(6,3)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_b_tensor_3
+!****f* src/interface/tens_comb/contract_a_tensor_4
+! NAME
+!
+! Function contract_a_tensor_4
+!
+! USAGE
+!
+! ans = contract_a_tensor_4(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an A-type tensor
+! of rank 4 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_4)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_a_tensor_4(coeffs, momenta) result(res)
+ ! generated by: write_function_a_tensor_contract
+ implicit none
+ type(coeff_type_4), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ real(ki) :: reg4
+ real(ki) :: reg5
+ real(ki) :: reg2
+ real(ki) :: reg3
+ real(ki) :: reg0
+ real(ki) :: reg1
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(1)
+ acc = momenta(1,0)
+ res = acc * coeffs%c1(1,1)
+ acc = momenta(1,1)
+ res = res + acc * coeffs%c1(2,1)
+ acc = momenta(1,2)
+ res = res + acc * coeffs%c1(3,1)
+ acc = momenta(1,3)
+ res = res + acc * coeffs%c1(4,1)
+ case(2)
+ acc = momenta(1,0)*momenta(2,0)
+ res = acc * coeffs%c1(1,2)
+ acc = momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c1(2,2)
+ acc = momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c1(3,2)
+ acc = momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c1(4,2)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(1,1)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(2,1)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(3,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(4,1)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(5,1)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(6,1)
+ case(3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = acc * coeffs%c2(1,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,2)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,2)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,2)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,2)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(1,1)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(2,1)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(3,1)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(4,1)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,0)
+ res = res + acc * coeffs%c1(1,3)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)
+ res = res + acc * coeffs%c1(2,3)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)
+ res = res + acc * coeffs%c1(3,3)
+ acc = momenta(1,3)*momenta(2,3)*momenta(3,3)
+ res = res + acc * coeffs%c1(4,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(1,4)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,4)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,4)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,4)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,4)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,4)
+ case(4)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg2 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(3,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = acc * coeffs%c3(1,3)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(2,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,0)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(3,3)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg1 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,0)*momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(1,3)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(2,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,0)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(3,3)*momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(3,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(4,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,3)*momenta(3,3)*momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(5,3)
+ acc = momenta(2,2)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,2)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,2)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,2)*momenta(2,3)*momenta(3,3)*momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(6,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg2 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(4,2)
+ acc = acc + momenta(3,2)*momenta(4,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(1,4)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(2,4)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,0)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(4,0)
+ acc = momenta(3,2)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,2)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(3,4)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ acc = acc * momenta(3,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(2,1)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(4,4)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,1)*momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(1,6)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg1 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)*momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(2,6)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,3)*momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(3,6)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg1 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,2)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)*momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(4,6)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg1 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,3)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(5,6)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(6,6)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg2 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg4 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(2,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg5
+ acc = acc + reg4
+ acc = acc * momenta(1,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 24.0_ki
+ res = res + acc * coeffs%c4(1,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg2 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,1)
+ acc = acc + momenta(3,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(1,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,1)
+ acc = acc + momenta(1,1)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(2,2)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,0)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(3,2)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg1 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg2
+ acc = acc * momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(1,5)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg2
+ acc = acc * momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(2,5)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg2 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,3)
+ acc = acc + reg2
+ acc = acc * momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(3,5)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg2
+ acc = acc * momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(4,5)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg1 = acc * momenta(3,1)
+ acc = momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)
+ acc = acc + reg2
+ acc = acc * momenta(1,1)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(5,5)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,2)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg2
+ acc = acc * momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(6,5)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,0)*momenta(4,0)
+ res = res + acc * coeffs%c1(1,4)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)*momenta(4,1)
+ res = res + acc * coeffs%c1(2,4)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,2)
+ res = res + acc * coeffs%c1(3,4)
+ acc = momenta(1,3)*momenta(2,3)*momenta(3,3)*momenta(4,3)
+ res = res + acc * coeffs%c1(4,4)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_a_tensor_4
+!****f* src/interface/tens_comb/contract_b_tensor_4
+! NAME
+!
+! Function contract_b_tensor_4
+!
+! USAGE
+!
+! ans = contract_b_tensor_4(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an B-type tensor
+! of rank 4 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_4)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_b_tensor_4(coeffs, momenta) result(res)
+ ! generated by: write_function_b_tensor_contract
+ implicit none
+ type(coeff_type_4), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(0)
+ res = coeffs%c1(1,2)
+ res = res - coeffs%c1(2,2)
+ res = res - coeffs%c1(3,2)
+ res = res - coeffs%c1(4,2)
+ case(1)
+ acc = -momenta(1,0)
+ res = acc * coeffs%c2(1,2)
+ acc = -momenta(1,0)
+ res = res + acc * coeffs%c2(2,2)
+ acc = -momenta(1,0)
+ res = res + acc * coeffs%c2(3,2)
+ acc = -momenta(1,1)
+ res = res + acc * coeffs%c2(4,2)
+ acc = -momenta(1,1)
+ res = res + acc * coeffs%c2(5,2)
+ acc = -momenta(1,2)
+ res = res + acc * coeffs%c2(6,2)
+ acc = 3*momenta(1,0)
+ res = res + acc * coeffs%c1(1,3)
+ acc = -3*momenta(1,1)
+ res = res + acc * coeffs%c1(2,3)
+ acc = -3*momenta(1,2)
+ res = res + acc * coeffs%c1(3,3)
+ acc = -3*momenta(1,3)
+ res = res + acc * coeffs%c1(4,3)
+ acc = momenta(1,1)
+ res = res + acc * coeffs%c2(1,4)
+ acc = momenta(1,2)
+ res = res + acc * coeffs%c2(2,4)
+ acc = momenta(1,3)
+ res = res + acc * coeffs%c2(3,4)
+ acc = -momenta(1,2)
+ res = res + acc * coeffs%c2(4,4)
+ acc = -momenta(1,3)
+ res = res + acc * coeffs%c2(5,4)
+ acc = -momenta(1,3)
+ res = res + acc * coeffs%c2(6,4)
+ case(2)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = acc * coeffs%c3(1,3)
+ acc = -momenta(1,0)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(2,3)
+ acc = -momenta(1,0)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(3,3)
+ acc = -momenta(1,1)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(4,3)
+ acc = -3*momenta(1,0)*momenta(2,1)
+ acc = acc - 3*momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(1,3)
+ acc = -3*momenta(1,0)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(2,3)
+ acc = -3*momenta(1,0)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(3,3)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(4,3)
+ acc = -3*momenta(1,1)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(5,3)
+ acc = -3*momenta(1,2)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(6,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(1,4)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(2,4)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(3,4)
+ acc = -momenta(1,2)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(4,4)
+ acc = 3*momenta(1,0)*momenta(2,1)
+ acc = acc + 3*momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(1,6)
+ acc = 3*momenta(1,0)*momenta(2,2)
+ acc = acc + 3*momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(2,6)
+ acc = 3*momenta(1,0)*momenta(2,3)
+ acc = acc + 3*momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(3,6)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(4,6)
+ acc = -3*momenta(1,1)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(5,6)
+ acc = -3*momenta(1,2)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(6,6)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(1,2)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(2,2)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(3,2)
+ acc = -momenta(1,1)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(4,2)
+ acc = momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c2(1,5)
+ acc = momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c2(2,5)
+ acc = momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c2(3,5)
+ acc = -momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c2(4,5)
+ acc = -momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c2(5,5)
+ acc = -momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c2(6,5)
+ acc = -momenta(1,0)*momenta(2,0)
+ res = res + acc * coeffs%c2(1,5)
+ acc = -momenta(1,0)*momenta(2,0)
+ res = res + acc * coeffs%c2(2,5)
+ acc = -momenta(1,0)*momenta(2,0)
+ res = res + acc * coeffs%c2(3,5)
+ acc = -momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c2(4,5)
+ acc = -momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c2(5,5)
+ acc = -momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c2(6,5)
+ acc = 6*momenta(1,0)*momenta(2,0)
+ res = res + acc * coeffs%c1(1,4)
+ acc = -6*momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c1(2,4)
+ acc = -6*momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c1(3,4)
+ acc = -6*momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c1(4,4)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_b_tensor_4
+!****f* src/interface/tens_comb/contract_c_tensor_4
+! NAME
+!
+! Function contract_c_tensor_4
+!
+! USAGE
+!
+! ans = contract_c_tensor_4(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an C-type tensor
+! of rank 4 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_4)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_c_tensor_4(coeffs, momenta) result(res)
+ ! generated by: write_function_c_tensor_contract
+ implicit none
+ type(coeff_type_4), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(0)
+ res = -coeffs%c2(1,5)
+ res = res - coeffs%c2(2,5)
+ res = res - coeffs%c2(3,5)
+ res = res + coeffs%c2(4,5)
+ res = res + coeffs%c2(5,5)
+ res = res + coeffs%c2(6,5)
+ acc = 3
+ res = res + acc * coeffs%c1(1,4)
+ acc = 3
+ res = res + acc * coeffs%c1(2,4)
+ acc = 3
+ res = res + acc * coeffs%c1(3,4)
+ acc = 3
+ res = res + acc * coeffs%c1(4,4)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_c_tensor_4
+!****f* src/interface/tens_comb/contract_a_tensor_5
+! NAME
+!
+! Function contract_a_tensor_5
+!
+! USAGE
+!
+! ans = contract_a_tensor_5(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an A-type tensor
+! of rank 5 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_5)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_a_tensor_5(coeffs, momenta) result(res)
+ ! generated by: write_function_a_tensor_contract
+ implicit none
+ type(coeff_type_5), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ real(ki) :: reg6
+ real(ki) :: reg4
+ real(ki) :: reg5
+ real(ki) :: reg2
+ real(ki) :: reg3
+ real(ki) :: reg0
+ real(ki) :: reg1
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(1)
+ acc = momenta(1,0)
+ res = acc * coeffs%c1(1,1)
+ acc = momenta(1,1)
+ res = res + acc * coeffs%c1(2,1)
+ acc = momenta(1,2)
+ res = res + acc * coeffs%c1(3,1)
+ acc = momenta(1,3)
+ res = res + acc * coeffs%c1(4,1)
+ case(2)
+ acc = momenta(1,0)*momenta(2,0)
+ res = acc * coeffs%c1(1,2)
+ acc = momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c1(2,2)
+ acc = momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c1(3,2)
+ acc = momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c1(4,2)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(1,1)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(2,1)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(3,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(4,1)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(5,1)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(6,1)
+ case(3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = acc * coeffs%c2(1,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,2)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,2)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,2)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,2)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(1,1)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(2,1)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(3,1)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(4,1)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,0)
+ res = res + acc * coeffs%c1(1,3)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)
+ res = res + acc * coeffs%c1(2,3)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)
+ res = res + acc * coeffs%c1(3,3)
+ acc = momenta(1,3)*momenta(2,3)*momenta(3,3)
+ res = res + acc * coeffs%c1(4,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(1,5)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,5)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,5)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,5)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,5)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,5)
+ case(4)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg2 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(3,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = acc * coeffs%c3(1,4)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(2,4)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,0)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(3,4)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(4,4)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg1 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,0)*momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(1,3)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(2,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,0)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(3,3)*momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(3,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(4,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,3)*momenta(3,3)*momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(5,3)
+ acc = momenta(2,2)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,2)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,2)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,2)*momenta(2,3)*momenta(3,3)*momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(6,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg2 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(4,2)
+ acc = acc + momenta(3,2)*momenta(4,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(1,7)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(2,7)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,0)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(4,0)
+ acc = momenta(3,2)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,2)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(3,7)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ acc = acc * momenta(3,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(2,1)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(4,7)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,1)*momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(1,8)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg1 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)*momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(2,8)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,3)*momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(3,8)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg1 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,2)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)*momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(4,8)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg1 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,3)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(5,8)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 4.0_ki
+ res = res + acc * coeffs%c2(6,8)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg2 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg4 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(2,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg5
+ acc = acc + reg4
+ acc = acc * momenta(1,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 24.0_ki
+ res = res + acc * coeffs%c4(1,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg2 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,1)
+ acc = acc + momenta(3,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(1,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,1)
+ acc = acc + momenta(1,1)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(2,2)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,0)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(3,2)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ reg1 = acc * momenta(4,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 12.0_ki
+ res = res + acc * coeffs%c3(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg1 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg2
+ acc = acc * momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(1,6)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg2
+ acc = acc * momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(2,6)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg2 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,3)
+ acc = acc + reg2
+ acc = acc * momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(3,6)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg2
+ acc = acc * momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(4,6)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg1 = acc * momenta(3,1)
+ acc = momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)
+ acc = acc + reg2
+ acc = acc * momenta(1,1)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(5,6)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,2)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg2
+ acc = acc * momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c2(6,6)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,0)*momenta(4,0)
+ res = res + acc * coeffs%c1(1,4)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)*momenta(4,1)
+ res = res + acc * coeffs%c1(2,4)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,2)
+ res = res + acc * coeffs%c1(3,4)
+ acc = momenta(1,3)*momenta(2,3)*momenta(3,3)*momenta(4,3)
+ res = res + acc * coeffs%c1(4,4)
+ case(5)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg2 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg3
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,1)*momenta(4,0)
+ acc = acc + reg2
+ acc = acc * momenta(5,1)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = acc * coeffs%c2(1,9)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg3
+ acc = acc * momenta(4,0)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)*momenta(4,0)
+ acc = acc + reg2
+ acc = acc * momenta(5,2)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(2,9)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg2 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(4,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg3 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,3)
+ acc = acc + reg3
+ acc = acc * momenta(3,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg3 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,3)*momenta(4,0)
+ acc = acc + reg2
+ acc = acc * momenta(5,3)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(3,9)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg3
+ acc = acc * momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg3 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,2)*momenta(4,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)*momenta(4,1)
+ acc = acc + reg2
+ acc = acc * momenta(5,2)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(4,9)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg2 = acc * momenta(3,1)
+ acc = momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(1,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)
+ acc = acc + reg3
+ acc = acc * momenta(1,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg3 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,3)*momenta(4,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg2
+ acc = acc * momenta(5,3)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(5,9)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(2,2)*momenta(3,3)*momenta(5,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(1,3)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,2)*momenta(5,3)
+ acc = acc + reg3
+ acc = acc * momenta(1,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg3 = acc * momenta(5,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(5,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)*momenta(5,2)
+ acc = acc + reg2
+ acc = acc * momenta(4,3)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(6,9)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg3 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(4,2)
+ acc = acc + momenta(3,2)*momenta(4,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,0)
+ acc = momenta(4,1)*momenta(5,2)
+ acc = acc + momenta(4,2)*momenta(5,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(3,1)*momenta(5,2)
+ acc = acc + momenta(3,2)*momenta(5,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc * momenta(4,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(1,10)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg2 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg3 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc * momenta(5,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,0)
+ acc = momenta(4,1)*momenta(5,3)
+ acc = acc + momenta(4,3)*momenta(5,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(3,1)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc * momenta(4,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(2,10)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg2 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,0)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,0)
+ acc = momenta(3,2)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,2)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,0)
+ acc = momenta(4,2)*momenta(5,3)
+ acc = acc + momenta(4,3)*momenta(5,2)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(3,2)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,2)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc * momenta(4,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(3,10)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg2 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ acc = acc * momenta(3,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(2,1)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(2,1)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(3,2)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,2)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc * momenta(2,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(4,10)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ reg2 = acc * momenta(5,0)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ reg3 = acc * momenta(5,1)
+ acc = momenta(2,0)*momenta(3,1)
+ acc = acc + momenta(2,1)*momenta(3,0)
+ acc = acc * momenta(5,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(4,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg4 = acc * momenta(5,1)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(5,3)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(5,2)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ reg5 = acc * momenta(5,0)
+ acc = momenta(3,0)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,0)
+ reg6 = acc * momenta(5,1)
+ acc = momenta(3,0)*momenta(4,1)
+ acc = acc + momenta(3,1)*momenta(4,0)
+ acc = acc * momenta(5,3)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(2,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg5 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(5,1)
+ acc = acc + momenta(1,1)*momenta(5,0)
+ reg5 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg6 = acc * momenta(5,2)
+ acc = momenta(4,0)*momenta(5,1)
+ acc = acc + momenta(4,1)*momenta(5,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg5 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ reg5 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,0)
+ reg6 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(3,1)
+ acc = acc + momenta(1,1)*momenta(3,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(3,1)
+ acc = acc + momenta(1,1)*momenta(3,0)
+ reg5 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg6 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,1)
+ acc = acc + momenta(3,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 60.0_ki
+ res = res + acc * coeffs%c4(1,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(5,2)
+ acc = momenta(3,0)*momenta(5,1)
+ acc = acc + momenta(3,1)*momenta(5,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg3 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(5,2)
+ acc = momenta(4,0)*momenta(5,1)
+ acc = acc + momenta(4,1)*momenta(5,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,1)
+ acc = acc + momenta(3,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc * momenta(5,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(1,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg2 = acc * momenta(5,0)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg3 = acc * momenta(5,1)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(5,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,1)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,1)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,3)
+ acc = momenta(3,0)*momenta(4,1)
+ acc = acc + momenta(3,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(5,1)
+ acc = acc + momenta(1,1)*momenta(5,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,1)
+ acc = acc + momenta(1,1)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(2,3)
+ acc = momenta(2,0)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,0)
+ reg2 = acc * momenta(4,2)
+ acc = momenta(2,0)*momenta(5,2)
+ acc = acc + momenta(2,2)*momenta(5,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ acc = acc * momenta(4,0)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,0)
+ acc = acc * momenta(3,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,3)
+ acc = momenta(3,0)*momenta(4,2)
+ acc = acc + momenta(3,2)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(5,2)
+ acc = acc + momenta(1,2)*momenta(5,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(3,3)
+ acc = momenta(2,1)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,1)
+ reg2 = acc * momenta(4,2)
+ acc = momenta(2,1)*momenta(5,2)
+ acc = acc + momenta(2,2)*momenta(5,1)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ acc = acc * momenta(4,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,1)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,1)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,3)
+ acc = momenta(3,1)*momenta(4,2)
+ acc = acc + momenta(3,2)*momenta(4,1)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(5,2)
+ acc = acc + momenta(1,2)*momenta(5,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(4,3)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(4,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg3 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(2,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg5 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg6 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(1,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg3 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,0)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg5 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(5,3)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg5 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg6 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,2)*momenta(3,3)
+ acc = acc + momenta(1,3)*momenta(3,2)
+ reg4 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ reg5 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(3,3)
+ acc = acc + momenta(1,3)*momenta(3,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(2,0)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg5 = acc * momenta(5,1)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg6 = acc * momenta(5,3)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(1,0)
+ acc = acc + reg3
+ reg2 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,1)
+ reg5 = acc * momenta(4,2)
+ acc = momenta(4,1)*momenta(5,3)
+ acc = acc + momenta(4,3)*momenta(5,1)
+ reg6 = acc * momenta(3,2)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 60.0_ki
+ res = res + acc * coeffs%c4(1,5)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg2 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,0)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg5 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg5 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg6 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg4 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg5 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(4,1)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg5 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg6 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(4,0)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(2,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg5 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg6 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(1,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(5,2)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ reg5 = acc * momenta(5,0)
+ acc = momenta(3,0)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,0)
+ reg6 = acc * momenta(5,1)
+ acc = momenta(3,0)*momenta(4,1)
+ acc = acc + momenta(3,1)*momenta(4,0)
+ acc = acc * momenta(5,3)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 60.0_ki
+ res = res + acc * coeffs%c4(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg3 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(3,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(5,2)
+ acc = acc + momenta(2,2)*momenta(5,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(3,0)*momenta(5,2)
+ acc = acc + momenta(3,2)*momenta(5,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc * momenta(2,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(1,6)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg2 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(5,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(3,0)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc * momenta(2,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(2,6)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg2 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(5,2)
+ acc = momenta(3,0)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,0)
+ acc = acc + reg3
+ reg2 = acc * momenta(5,2)
+ acc = momenta(4,0)*momenta(5,3)
+ acc = acc + momenta(4,3)*momenta(5,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc * momenta(5,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(3,6)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg2 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(5,2)
+ acc = momenta(3,1)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,1)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(5,2)
+ acc = momenta(4,1)*momenta(5,3)
+ acc = acc + momenta(4,3)*momenta(5,1)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc * momenta(5,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 20.0_ki
+ res = res + acc * coeffs%c3(4,6)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg2 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,0)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)*momenta(4,1)*momenta(5,0)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(1,4)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(5,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(5,0)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)*momenta(5,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,0)*momenta(5,2)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(2,4)
+ acc = momenta(2,0)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,0)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(2,3)*momenta(4,0)*momenta(5,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,0)*momenta(4,3)*momenta(5,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(3,3)*momenta(4,3)*momenta(5,3)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(3,4)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(5,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(5,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)*momenta(5,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,1)*momenta(5,2)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(4,4)
+ acc = momenta(2,1)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,1)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(2,3)*momenta(4,1)*momenta(5,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)*momenta(5,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,3)*momenta(3,3)*momenta(4,3)*momenta(5,3)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(5,4)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg2 = acc * momenta(4,3)
+ acc = momenta(2,3)*momenta(4,2)*momenta(5,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,2)*momenta(4,3)*momenta(5,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,2)*momenta(2,3)*momenta(3,3)*momenta(4,3)*momenta(5,3)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(6,4)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,1)
+ acc = momenta(3,0)*momenta(5,2)
+ acc = acc + momenta(3,2)*momenta(5,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(2,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,2)
+ acc = momenta(3,0)*momenta(5,1)
+ acc = acc + momenta(3,1)*momenta(5,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(4,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg5 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg5
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc * momenta(4,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(1,5)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,1)
+ acc = acc + momenta(1,1)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg3 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg4
+ reg3 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg4 = acc * momenta(3,1)
+ acc = momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(1,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)
+ acc = acc + reg5
+ acc = acc * momenta(1,1)
+ acc = acc + reg3
+ acc = acc * momenta(5,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(2,5)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg2 = acc * momenta(5,0)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(3,2)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,2)
+ acc = acc * momenta(2,0)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(5,2)
+ acc = acc + momenta(1,2)*momenta(5,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,2)
+ acc = momenta(3,0)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(4,3)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(2,2)*momenta(3,3)*momenta(5,2)
+ acc = acc + reg4
+ reg3 = acc * momenta(1,3)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,2)*momenta(5,3)
+ acc = acc + reg5
+ acc = acc * momenta(1,2)
+ acc = acc + reg3
+ acc = acc * momenta(4,0)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(3,5)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg2 = acc * momenta(5,1)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(5,2)
+ acc = acc + momenta(1,2)*momenta(5,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(5,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg3 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(3,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(3,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,2)
+ acc = momenta(3,1)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,1)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(4,3)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(2,2)*momenta(3,3)*momenta(5,2)
+ acc = acc + reg4
+ reg3 = acc * momenta(1,3)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,2)*momenta(5,3)
+ acc = acc + reg5
+ acc = acc * momenta(1,2)
+ acc = acc + reg3
+ acc = acc * momenta(4,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(4,5)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,0)*momenta(4,0)*momenta(5,0)
+ res = res + acc * coeffs%c1(1,5)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)*momenta(4,1)*momenta(5,1)
+ res = res + acc * coeffs%c1(2,5)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,2)*momenta(5,2)
+ res = res + acc * coeffs%c1(3,5)
+ acc = momenta(1,3)*momenta(2,3)*momenta(3,3)*momenta(4,3)*momenta(5,3)
+ res = res + acc * coeffs%c1(4,5)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg2 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg3
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg3 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,0)*momenta(4,1)
+ acc = acc + reg2
+ acc = acc * momenta(5,0)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(1,7)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg2
+ reg1 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg3
+ acc = acc * momenta(5,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(5,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(5,0)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)*momenta(5,2)
+ acc = acc + reg2
+ acc = acc * momenta(4,0)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(2,7)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,0)*momenta(4,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(5,0)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(3,3)*momenta(4,0)
+ acc = acc + reg3
+ acc = acc * momenta(5,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(2,0)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(2,3)*momenta(4,0)*momenta(5,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,0)*momenta(4,3)*momenta(5,3)
+ acc = acc + reg2
+ acc = acc * momenta(1,0)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(3,7)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg3
+ acc = acc * momenta(5,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(5,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)*momenta(5,2)
+ acc = acc + reg2
+ acc = acc * momenta(4,1)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(4,7)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(5,1)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg3 = acc * momenta(3,1)
+ acc = momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg3
+ acc = acc * momenta(5,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(2,1)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,1)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(2,3)*momenta(4,1)*momenta(5,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)*momenta(5,3)
+ acc = acc + reg2
+ acc = acc * momenta(1,1)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(5,7)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,2)*momenta(5,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(4,2)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(2,2)*momenta(3,3)*momenta(5,2)
+ acc = acc + reg3
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ reg0 = acc * momenta(1,3)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(2,3)*momenta(4,2)*momenta(5,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,2)*momenta(4,3)*momenta(5,3)
+ acc = acc + reg2
+ acc = acc * momenta(1,2)
+ acc = acc + reg0
+ acc = acc / 10.0_ki
+ res = res + acc * coeffs%c2(6,7)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,0)
+ acc = momenta(3,1)*momenta(5,2)
+ acc = acc + momenta(3,2)*momenta(5,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,2)
+ acc = momenta(3,0)*momenta(5,1)
+ acc = acc + momenta(3,1)*momenta(5,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg5 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg5
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc * momenta(4,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(1,8)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,1)
+ acc = acc + momenta(1,1)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg3 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg4 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(4,3)
+ acc = acc + reg4
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg5 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,3)
+ acc = acc + reg5
+ acc = acc * momenta(3,3)
+ acc = acc + reg3
+ acc = acc * momenta(5,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(2,8)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ reg2 = acc * momenta(4,2)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,0)
+ acc = acc * momenta(2,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,0)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg3 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,0)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg4
+ reg3 = acc * momenta(4,0)
+ acc = momenta(3,2)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,2)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ reg4 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,3)*momenta(4,3)
+ acc = acc + reg4
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg5 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,3)
+ acc = acc + reg5
+ acc = acc * momenta(3,3)
+ acc = acc + reg3
+ acc = acc * momenta(5,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(3,8)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ reg2 = acc * momenta(4,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(2,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc * momenta(4,3)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg3 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,1)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ acc = acc * momenta(3,3)
+ acc = acc + reg4
+ reg3 = acc * momenta(2,1)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg4 = acc * momenta(3,1)
+ acc = momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(1,3)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(2,3)*momenta(3,1)*momenta(4,3)
+ acc = acc + reg5
+ acc = acc * momenta(1,1)
+ acc = acc + reg3
+ acc = acc * momenta(5,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(4,8)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,1)*momenta(4,0)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,0)*momenta(4,0)*momenta(5,1)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(1,10)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg2 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,2)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)*momenta(4,0)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,0)*momenta(4,0)*momenta(5,2)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(2,10)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg2 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,3)*momenta(4,0)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,0)*momenta(4,0)*momenta(5,3)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(3,10)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg2 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,2)*momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)*momenta(4,1)*momenta(5,2)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(4,10)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg2 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,3)*momenta(4,1)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,3)*momenta(4,1)
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)*momenta(4,1)*momenta(5,3)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(5,10)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg2 = acc * momenta(5,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(5,3)
+ acc = acc + reg2
+ reg1 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)*momenta(5,2)
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)*momenta(4,3)*momenta(5,2)
+ acc = acc + reg0
+ acc = acc / 5.0_ki
+ res = res + acc * coeffs%c2(6,10)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg2 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg3 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,2)
+ acc = acc + momenta(1,2)*momenta(4,1)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(3,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg4 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(4,2)
+ acc = acc + momenta(3,2)*momenta(4,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg4 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg5 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg5
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ acc = acc * momenta(5,2)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(1,9)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg2 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg3
+ reg2 = acc * momenta(2,1)
+ acc = momenta(2,0)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,0)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg3 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(4,0)
+ acc = momenta(3,1)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,1)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,1)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg4 = acc * momenta(2,1)
+ acc = momenta(1,1)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg5 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(4,1)
+ acc = acc + reg5
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ acc = acc * momenta(5,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(2,9)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ reg3 = acc * momenta(3,2)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,0)
+ acc = momenta(3,2)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,2)
+ acc = acc * momenta(1,0)
+ acc = acc * momenta(2,0)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(5,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,2)
+ acc = momenta(3,0)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,0)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(4,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,0)
+ reg5 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg5
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(3,9)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg2 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg3 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ reg2 = acc * momenta(3,1)
+ acc = momenta(3,2)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,2)
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(2,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(4,2)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg3 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(5,3)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc * momenta(5,2)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(3,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(3,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,2)
+ acc = momenta(3,1)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,1)
+ acc = acc * momenta(1,2)
+ acc = acc * momenta(2,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(4,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg4
+ reg3 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg5 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg5
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc * momenta(4,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 30.0_ki
+ res = res + acc * coeffs%c3(4,9)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg2 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg3 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(4,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg3 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(3,2)
+ acc = momenta(1,1)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,1)
+ reg4 = acc * momenta(3,0)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg5 = acc * momenta(3,3)
+ acc = momenta(1,0)*momenta(4,3)
+ acc = acc + momenta(1,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(2,2)
+ acc = momenta(2,1)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,1)
+ reg5 = acc * momenta(3,0)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg6 = acc * momenta(3,3)
+ acc = momenta(2,0)*momenta(4,3)
+ acc = acc + momenta(2,3)*momenta(4,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(1,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ reg0 = acc * momenta(5,1)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg3 = acc * momenta(4,2)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg4 = acc * momenta(4,3)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc * momenta(4,1)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc * momenta(5,0)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg4 = acc * momenta(4,2)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ reg5 = acc * momenta(2,2)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ acc = acc * momenta(1,2)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(5,3)
+ acc = momenta(2,0)*momenta(4,1)
+ acc = acc + momenta(2,1)*momenta(4,0)
+ reg5 = acc * momenta(1,3)
+ acc = momenta(1,0)*momenta(2,1)
+ acc = acc + momenta(1,1)*momenta(2,0)
+ reg6 = acc * momenta(4,3)
+ acc = momenta(1,0)*momenta(4,1)
+ acc = acc + momenta(1,1)*momenta(4,0)
+ acc = acc * momenta(2,3)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(5,2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc * momenta(3,1)
+ acc = momenta(1,2)*momenta(3,3)
+ acc = acc + momenta(1,3)*momenta(3,2)
+ reg4 = acc * momenta(5,0)
+ acc = momenta(1,2)*momenta(5,3)
+ acc = acc + momenta(1,3)*momenta(5,2)
+ reg5 = acc * momenta(3,0)
+ acc = momenta(3,2)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,2)
+ acc = acc * momenta(1,0)
+ acc = acc + reg5
+ acc = acc + reg4
+ reg3 = acc * momenta(4,1)
+ acc = momenta(3,0)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,0)
+ reg5 = acc * momenta(4,2)
+ acc = momenta(4,0)*momenta(5,3)
+ acc = acc + momenta(4,3)*momenta(5,0)
+ reg6 = acc * momenta(3,2)
+ acc = momenta(3,0)*momenta(4,3)
+ acc = acc + momenta(3,3)*momenta(4,0)
+ acc = acc * momenta(5,2)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(1,1)
+ acc = acc + reg3
+ reg2 = acc * momenta(2,1)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg5 = acc * momenta(5,0)
+ acc = momenta(2,2)*momenta(5,3)
+ acc = acc + momenta(2,3)*momenta(5,2)
+ reg6 = acc * momenta(3,0)
+ acc = momenta(3,2)*momenta(5,3)
+ acc = acc + momenta(3,3)*momenta(5,2)
+ acc = acc * momenta(2,0)
+ acc = acc + reg6
+ acc = acc + reg5
+ acc = acc * momenta(1,1)
+ acc = acc * momenta(4,1)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 60.0_ki
+ res = res + acc * coeffs%c4(1,4)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_a_tensor_5
+!****f* src/interface/tens_comb/contract_b_tensor_5
+! NAME
+!
+! Function contract_b_tensor_5
+!
+! USAGE
+!
+! ans = contract_b_tensor_5(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an B-type tensor
+! of rank 5 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_5)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_b_tensor_5(coeffs, momenta) result(res)
+ ! generated by: write_function_b_tensor_contract
+ implicit none
+ type(coeff_type_5), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ real(ki) :: reg0
+ real(ki) :: reg1
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(0)
+ res = coeffs%c1(1,2)
+ res = res - coeffs%c1(2,2)
+ res = res - coeffs%c1(3,2)
+ res = res - coeffs%c1(4,2)
+ case(1)
+ acc = -momenta(1,0)
+ res = acc * coeffs%c2(1,2)
+ acc = -momenta(1,0)
+ res = res + acc * coeffs%c2(2,2)
+ acc = -momenta(1,0)
+ res = res + acc * coeffs%c2(3,2)
+ acc = -momenta(1,1)
+ res = res + acc * coeffs%c2(4,2)
+ acc = -momenta(1,1)
+ res = res + acc * coeffs%c2(5,2)
+ acc = -momenta(1,2)
+ res = res + acc * coeffs%c2(6,2)
+ acc = 3*momenta(1,0)
+ res = res + acc * coeffs%c1(1,3)
+ acc = -3*momenta(1,1)
+ res = res + acc * coeffs%c1(2,3)
+ acc = -3*momenta(1,2)
+ res = res + acc * coeffs%c1(3,3)
+ acc = -3*momenta(1,3)
+ res = res + acc * coeffs%c1(4,3)
+ acc = momenta(1,1)
+ res = res + acc * coeffs%c2(1,5)
+ acc = momenta(1,2)
+ res = res + acc * coeffs%c2(2,5)
+ acc = momenta(1,3)
+ res = res + acc * coeffs%c2(3,5)
+ acc = -momenta(1,2)
+ res = res + acc * coeffs%c2(4,5)
+ acc = -momenta(1,3)
+ res = res + acc * coeffs%c2(5,5)
+ acc = -momenta(1,3)
+ res = res + acc * coeffs%c2(6,5)
+ case(2)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = acc * coeffs%c3(1,4)
+ acc = -momenta(1,0)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(2,4)
+ acc = -momenta(1,0)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(3,4)
+ acc = -momenta(1,1)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(4,4)
+ acc = -3*momenta(1,0)*momenta(2,1)
+ acc = acc - 3*momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(1,3)
+ acc = -3*momenta(1,0)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(2,3)
+ acc = -3*momenta(1,0)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(3,3)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(4,3)
+ acc = -3*momenta(1,1)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(5,3)
+ acc = -3*momenta(1,2)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(6,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(1,7)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(2,7)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(3,7)
+ acc = -momenta(1,2)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(4,7)
+ acc = 3*momenta(1,0)*momenta(2,1)
+ acc = acc + 3*momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(1,8)
+ acc = 3*momenta(1,0)*momenta(2,2)
+ acc = acc + 3*momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(2,8)
+ acc = 3*momenta(1,0)*momenta(2,3)
+ acc = acc + 3*momenta(1,3)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(3,8)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(4,8)
+ acc = -3*momenta(1,1)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(5,8)
+ acc = -3*momenta(1,2)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,2)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c2(6,8)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(1,2)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(2,2)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(3,2)
+ acc = -momenta(1,1)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,1)
+ acc = acc / 2.0_ki
+ res = res + acc * coeffs%c3(4,2)
+ acc = momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c2(1,6)
+ acc = momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c2(2,6)
+ acc = momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c2(3,6)
+ acc = -momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c2(4,6)
+ acc = -momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c2(5,6)
+ acc = -momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c2(6,6)
+ acc = -momenta(1,0)*momenta(2,0)
+ res = res + acc * coeffs%c2(1,6)
+ acc = -momenta(1,0)*momenta(2,0)
+ res = res + acc * coeffs%c2(2,6)
+ acc = -momenta(1,0)*momenta(2,0)
+ res = res + acc * coeffs%c2(3,6)
+ acc = -momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c2(4,6)
+ acc = -momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c2(5,6)
+ acc = -momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c2(6,6)
+ acc = 6*momenta(1,0)*momenta(2,0)
+ res = res + acc * coeffs%c1(1,4)
+ acc = -6*momenta(1,1)*momenta(2,1)
+ res = res + acc * coeffs%c1(2,4)
+ acc = -6*momenta(1,2)*momenta(2,2)
+ res = res + acc * coeffs%c1(3,4)
+ acc = -6*momenta(1,3)*momenta(2,3)
+ res = res + acc * coeffs%c1(4,4)
+ case(3)
+ acc = 3*momenta(1,0)*momenta(2,1)
+ acc = acc + 3*momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,1)
+ acc = 3*momenta(1,1)*momenta(2,1)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = acc * coeffs%c2(1,9)
+ acc = 3*momenta(1,0)*momenta(2,2)
+ acc = acc + 3*momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,2)
+ acc = 3*momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,9)
+ acc = 3*momenta(2,0)*momenta(3,3)
+ acc = acc + 3*momenta(2,3)*momenta(3,0)
+ reg0 = acc * momenta(1,3)
+ acc = 3*momenta(1,0)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,9)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,2)
+ acc = -3*momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,9)
+ acc = -3*momenta(2,1)*momenta(3,3)
+ acc = acc - 3*momenta(2,3)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = -3*momenta(1,1)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,9)
+ acc = -3*momenta(2,2)*momenta(3,3)
+ acc = acc - 3*momenta(2,3)*momenta(3,2)
+ reg0 = acc * momenta(1,3)
+ acc = -3*momenta(1,2)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,9)
+ acc = -momenta(1,0)*momenta(2,0)*momenta(3,0)
+ res = res + acc * coeffs%c2(1,9)
+ acc = -momenta(1,0)*momenta(2,0)*momenta(3,0)
+ res = res + acc * coeffs%c2(2,9)
+ acc = -momenta(1,0)*momenta(2,0)*momenta(3,0)
+ res = res + acc * coeffs%c2(3,9)
+ acc = -momenta(1,1)*momenta(2,1)*momenta(3,1)
+ res = res + acc * coeffs%c2(4,9)
+ acc = -momenta(1,1)*momenta(2,1)*momenta(3,1)
+ res = res + acc * coeffs%c2(5,9)
+ acc = -momenta(1,2)*momenta(2,2)*momenta(3,2)
+ res = res + acc * coeffs%c2(6,9)
+ acc = 3*momenta(1,1)*momenta(2,2)
+ acc = acc + 3*momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = 3*momenta(1,0)*momenta(2,1)
+ acc = acc + 3*momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = 3*momenta(1,0)*momenta(2,2)
+ acc = acc + 3*momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(1,10)
+ acc = 3*momenta(1,1)*momenta(2,3)
+ acc = acc + 3*momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = 3*momenta(1,0)*momenta(2,1)
+ acc = acc + 3*momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,3)
+ acc = 3*momenta(1,0)*momenta(2,3)
+ acc = acc + 3*momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(2,10)
+ acc = 3*momenta(1,2)*momenta(2,3)
+ acc = acc + 3*momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,0)
+ acc = 3*momenta(1,0)*momenta(2,3)
+ acc = acc + 3*momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = 3*momenta(1,0)*momenta(2,2)
+ acc = acc + 3*momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(3,10)
+ acc = -3*momenta(2,1)*momenta(3,2)
+ acc = acc - 3*momenta(2,2)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,3)
+ acc = -3*momenta(1,1)*momenta(3,2)
+ acc = acc - 3*momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(4,10)
+ acc = -momenta(1,1)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c4(1,2)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = -3*momenta(1,0)*momenta(2,1)
+ acc = acc - 3*momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = -3*momenta(1,0)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(1,3)
+ acc = -3*momenta(1,1)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = -3*momenta(1,0)*momenta(2,1)
+ acc = acc - 3*momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,3)
+ acc = -3*momenta(1,0)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(2,3)
+ acc = -3*momenta(1,2)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,0)
+ acc = -3*momenta(1,0)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = -3*momenta(1,0)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(3,3)
+ acc = -3*momenta(2,1)*momenta(3,2)
+ acc = acc - 3*momenta(2,2)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,3)
+ acc = -3*momenta(1,1)*momenta(3,2)
+ acc = acc - 3*momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(4,3)
+ acc = momenta(2,1)*momenta(3,2)
+ acc = acc + momenta(2,2)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,3)
+ acc = momenta(1,1)*momenta(3,2)
+ acc = acc + momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c4(1,5)
+ acc = -momenta(1,1)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,3)
+ acc = -momenta(1,0)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c4(1,3)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = -3*momenta(1,0)*momenta(2,1)
+ acc = acc - 3*momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = -3*momenta(1,0)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(1,6)
+ acc = -3*momenta(1,1)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,0)
+ acc = -3*momenta(1,0)*momenta(2,1)
+ acc = acc - 3*momenta(1,1)*momenta(2,0)
+ reg1 = acc * momenta(3,3)
+ acc = -3*momenta(1,0)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,0)
+ acc = acc * momenta(3,1)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(2,6)
+ acc = -3*momenta(1,2)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,0)
+ acc = -3*momenta(1,0)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = -3*momenta(1,0)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(3,6)
+ acc = -3*momenta(2,1)*momenta(3,2)
+ acc = acc - 3*momenta(2,2)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ reg1 = acc * momenta(3,3)
+ acc = -3*momenta(1,1)*momenta(3,2)
+ acc = acc - 3*momenta(1,2)*momenta(3,1)
+ acc = acc * momenta(2,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c3(4,6)
+ acc = -6*momenta(1,0)*momenta(2,1)
+ acc = acc - 6*momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,1)
+ acc = -6*momenta(1,1)*momenta(2,1)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(1,4)
+ acc = -6*momenta(1,0)*momenta(2,2)
+ acc = acc - 6*momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,2)
+ acc = -6*momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,4)
+ acc = -6*momenta(2,0)*momenta(3,3)
+ acc = acc - 6*momenta(2,3)*momenta(3,0)
+ reg0 = acc * momenta(1,3)
+ acc = -6*momenta(1,0)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,4)
+ acc = -6*momenta(1,1)*momenta(2,2)
+ acc = acc - 6*momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,2)
+ acc = -6*momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,4)
+ acc = -6*momenta(2,1)*momenta(3,3)
+ acc = acc - 6*momenta(2,3)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = -6*momenta(1,1)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,4)
+ acc = -6*momenta(2,2)*momenta(3,3)
+ acc = acc - 6*momenta(2,3)*momenta(3,2)
+ reg0 = acc * momenta(1,3)
+ acc = -6*momenta(1,2)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,4)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,2)
+ acc = -momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(1,5)
+ acc = -momenta(2,0)*momenta(3,3)
+ acc = acc - momenta(2,3)*momenta(3,0)
+ reg0 = acc * momenta(1,3)
+ acc = -momenta(1,0)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(2,5)
+ acc = -momenta(2,0)*momenta(3,3)
+ acc = acc - momenta(2,3)*momenta(3,0)
+ reg0 = acc * momenta(1,3)
+ acc = -momenta(1,0)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(3,5)
+ acc = -momenta(2,1)*momenta(3,3)
+ acc = acc - momenta(2,3)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = -momenta(1,1)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(4,5)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,1)
+ acc = -momenta(1,1)*momenta(2,1)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(1,5)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,1)
+ acc = -momenta(1,1)*momenta(2,1)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(2,5)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,2)
+ acc = -momenta(1,2)*momenta(2,2)*momenta(3,0)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(3,5)
+ acc = -momenta(1,1)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,2)
+ acc = -momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(4,5)
+ acc = 10*momenta(1,0)*momenta(2,0)*momenta(3,0)
+ res = res + acc * coeffs%c1(1,5)
+ acc = -10*momenta(1,1)*momenta(2,1)*momenta(3,1)
+ res = res + acc * coeffs%c1(2,5)
+ acc = -10*momenta(1,2)*momenta(2,2)*momenta(3,2)
+ res = res + acc * coeffs%c1(3,5)
+ acc = -10*momenta(1,3)*momenta(2,3)*momenta(3,3)
+ res = res + acc * coeffs%c1(4,5)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,1)
+ res = res + acc * coeffs%c2(1,7)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,2)
+ res = res + acc * coeffs%c2(2,7)
+ acc = momenta(1,3)*momenta(2,3)*momenta(3,3)
+ res = res + acc * coeffs%c2(3,7)
+ acc = -momenta(1,2)*momenta(2,2)*momenta(3,2)
+ res = res + acc * coeffs%c2(4,7)
+ acc = -momenta(1,3)*momenta(2,3)*momenta(3,3)
+ res = res + acc * coeffs%c2(5,7)
+ acc = -momenta(1,3)*momenta(2,3)*momenta(3,3)
+ res = res + acc * coeffs%c2(6,7)
+ acc = -3*momenta(1,0)*momenta(2,1)
+ acc = acc - 3*momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = -3*momenta(1,0)*momenta(2,0)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(1,7)
+ acc = -3*momenta(1,0)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = -3*momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,7)
+ acc = -3*momenta(1,0)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = -3*momenta(1,0)*momenta(2,0)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,7)
+ acc = -3*momenta(1,1)*momenta(2,2)
+ acc = acc - 3*momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = -3*momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,7)
+ acc = -3*momenta(1,1)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = -3*momenta(1,1)*momenta(2,1)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,7)
+ acc = -3*momenta(1,2)*momenta(2,3)
+ acc = acc - 3*momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,2)
+ acc = -3*momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,7)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(1,8)
+ acc = momenta(2,1)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,1)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,1)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(2,8)
+ acc = momenta(2,2)*momenta(3,3)
+ acc = acc + momenta(2,3)*momenta(3,2)
+ reg0 = acc * momenta(1,3)
+ acc = momenta(1,2)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(3,8)
+ acc = -momenta(2,2)*momenta(3,3)
+ acc = acc - momenta(2,3)*momenta(3,2)
+ reg0 = acc * momenta(1,3)
+ acc = -momenta(1,2)*momenta(2,3)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(4,8)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = -momenta(1,0)*momenta(2,0)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(1,8)
+ acc = -momenta(1,0)*momenta(2,1)
+ acc = acc - momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = -momenta(1,0)*momenta(2,0)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(2,8)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = -momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(3,8)
+ acc = -momenta(1,1)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = -momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(4,8)
+ acc = 6*momenta(1,0)*momenta(2,1)
+ acc = acc + 6*momenta(1,1)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = 6*momenta(1,0)*momenta(2,0)*momenta(3,1)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(1,10)
+ acc = 6*momenta(1,0)*momenta(2,2)
+ acc = acc + 6*momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = 6*momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(2,10)
+ acc = 6*momenta(1,0)*momenta(2,3)
+ acc = acc + 6*momenta(1,3)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = 6*momenta(1,0)*momenta(2,0)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(3,10)
+ acc = -6*momenta(1,1)*momenta(2,2)
+ acc = acc - 6*momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = -6*momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(4,10)
+ acc = -6*momenta(1,1)*momenta(2,3)
+ acc = acc - 6*momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = -6*momenta(1,1)*momenta(2,1)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(5,10)
+ acc = -6*momenta(1,2)*momenta(2,3)
+ acc = acc - 6*momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,2)
+ acc = -6*momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c2(6,10)
+ acc = momenta(1,1)*momenta(2,2)
+ acc = acc + momenta(1,2)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(1,9)
+ acc = momenta(1,1)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = momenta(1,1)*momenta(2,1)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(2,9)
+ acc = momenta(1,2)*momenta(2,3)
+ acc = acc + momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,2)
+ acc = momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(3,9)
+ acc = -momenta(1,2)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,2)
+ acc = -momenta(1,2)*momenta(2,2)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(4,9)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = -momenta(1,0)*momenta(2,0)*momenta(3,2)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(1,9)
+ acc = -momenta(1,0)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = -momenta(1,0)*momenta(2,0)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(2,9)
+ acc = -momenta(1,0)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,0)
+ reg0 = acc * momenta(3,0)
+ acc = -momenta(1,0)*momenta(2,0)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(3,9)
+ acc = -momenta(1,1)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,1)
+ reg0 = acc * momenta(3,1)
+ acc = -momenta(1,1)*momenta(2,1)*momenta(3,3)
+ acc = acc + reg0
+ acc = acc / 3.0_ki
+ res = res + acc * coeffs%c3(4,9)
+ acc = -momenta(1,2)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,2)
+ reg0 = acc * momenta(3,0)
+ acc = -momenta(1,0)*momenta(2,3)
+ acc = acc - momenta(1,3)*momenta(2,0)
+ reg1 = acc * momenta(3,2)
+ acc = -momenta(1,0)*momenta(2,2)
+ acc = acc - momenta(1,2)*momenta(2,0)
+ acc = acc * momenta(3,3)
+ acc = acc + reg1
+ acc = acc + reg0
+ acc = acc / 6.0_ki
+ res = res + acc * coeffs%c4(1,4)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_b_tensor_5
+!****f* src/interface/tens_comb/contract_c_tensor_5
+! NAME
+!
+! Function contract_c_tensor_5
+!
+! USAGE
+!
+! ans = contract_c_tensor_5(coeffs, momenta)
+!
+! DESCRIPTION
+!
+! Contracts the a set of coefficients with an C-type tensor
+! of rank 5 constructed from a given set of momenta.
+!
+! INPUTS
+!
+! * coeffs -- coefficients of type(coeff_type_5)
+! * momenta -- real array of dimension(:,3) containing the
+! momenta r_i of the loop propagators
+!
+! RETURN VALUE
+!
+! The result of the contraction which is a complex number
+!
+! SIDE EFFECTS
+!
+! None
+!
+! EXAMPLE
+!
+!
+!*****
+pure function contract_c_tensor_5(coeffs, momenta) result(res)
+ ! generated by: write_function_c_tensor_contract
+ implicit none
+ type(coeff_type_5), intent(in) :: coeffs
+ real(ki), dimension(:,0:), intent(in), optional :: momenta
+ complex(ki) :: res
+ integer :: rk
+ real(ki) :: acc
+ if (present(momenta)) then
+ rk = size(momenta, 1)
+ else
+ rk = 0
+ end if
+ select case(rk)
+ case(0)
+ res = -coeffs%c2(1,6)
+ res = res - coeffs%c2(2,6)
+ res = res - coeffs%c2(3,6)
+ res = res + coeffs%c2(4,6)
+ res = res + coeffs%c2(5,6)
+ res = res + coeffs%c2(6,6)
+ acc = 3
+ res = res + acc * coeffs%c1(1,4)
+ acc = 3
+ res = res + acc * coeffs%c1(2,4)
+ acc = 3
+ res = res + acc * coeffs%c1(3,4)
+ acc = 3
+ res = res + acc * coeffs%c1(4,4)
+ case(1)
+ acc = -3*momenta(1,0)
+ res = acc * coeffs%c2(1,9)
+ acc = -3*momenta(1,0)
+ res = res + acc * coeffs%c2(2,9)
+ acc = -3*momenta(1,0)
+ res = res + acc * coeffs%c2(3,9)
+ acc = 3*momenta(1,1)
+ res = res + acc * coeffs%c2(4,9)
+ acc = 3*momenta(1,1)
+ res = res + acc * coeffs%c2(5,9)
+ acc = 3*momenta(1,2)
+ res = res + acc * coeffs%c2(6,9)
+ acc = 3*momenta(1,0)
+ res = res + acc * coeffs%c2(1,4)
+ acc = 3*momenta(1,0)
+ res = res + acc * coeffs%c2(2,4)
+ acc = 3*momenta(1,0)
+ res = res + acc * coeffs%c2(3,4)
+ acc = 3*momenta(1,1)
+ res = res + acc * coeffs%c2(4,4)
+ acc = 3*momenta(1,1)
+ res = res + acc * coeffs%c2(5,4)
+ acc = 3*momenta(1,2)
+ res = res + acc * coeffs%c2(6,4)
+ acc = momenta(1,0)
+ res = res + acc * coeffs%c3(1,5)
+ acc = momenta(1,0)
+ res = res + acc * coeffs%c3(2,5)
+ acc = momenta(1,0)
+ res = res + acc * coeffs%c3(3,5)
+ acc = momenta(1,1)
+ res = res + acc * coeffs%c3(4,5)
+ acc = 15*momenta(1,0)
+ res = res + acc * coeffs%c1(1,5)
+ acc = 15*momenta(1,1)
+ res = res + acc * coeffs%c1(2,5)
+ acc = 15*momenta(1,2)
+ res = res + acc * coeffs%c1(3,5)
+ acc = 15*momenta(1,3)
+ res = res + acc * coeffs%c1(4,5)
+ acc = -3*momenta(1,1)
+ res = res + acc * coeffs%c2(1,7)
+ acc = -3*momenta(1,2)
+ res = res + acc * coeffs%c2(2,7)
+ acc = -3*momenta(1,3)
+ res = res + acc * coeffs%c2(3,7)
+ acc = 3*momenta(1,2)
+ res = res + acc * coeffs%c2(4,7)
+ acc = 3*momenta(1,3)
+ res = res + acc * coeffs%c2(5,7)
+ acc = 3*momenta(1,3)
+ res = res + acc * coeffs%c2(6,7)
+ acc = -momenta(1,1)
+ res = res + acc * coeffs%c3(1,8)
+ acc = -momenta(1,1)
+ res = res + acc * coeffs%c3(2,8)
+ acc = -momenta(1,2)
+ res = res + acc * coeffs%c3(3,8)
+ acc = momenta(1,2)
+ res = res + acc * coeffs%c3(4,8)
+ acc = 3*momenta(1,1)
+ res = res + acc * coeffs%c2(1,10)
+ acc = 3*momenta(1,2)
+ res = res + acc * coeffs%c2(2,10)
+ acc = 3*momenta(1,3)
+ res = res + acc * coeffs%c2(3,10)
+ acc = 3*momenta(1,2)
+ res = res + acc * coeffs%c2(4,10)
+ acc = 3*momenta(1,3)
+ res = res + acc * coeffs%c2(5,10)
+ acc = 3*momenta(1,3)
+ res = res + acc * coeffs%c2(6,10)
+ acc = -momenta(1,2)
+ res = res + acc * coeffs%c3(1,9)
+ acc = -momenta(1,3)
+ res = res + acc * coeffs%c3(2,9)
+ acc = -momenta(1,3)
+ res = res + acc * coeffs%c3(3,9)
+ acc = momenta(1,3)
+ res = res + acc * coeffs%c3(4,9)
+ case default
+ res = 0.0_ki
+ end select
+end function contract_c_tensor_5
+end module tens_comb
diff --git a/golem95c-1.2.1/interface/tens_rec.f90 b/golem95c-1.2.1/interface/tens_rec.f90
new file mode 100644
index 0000000..1cbd805
--- /dev/null
+++ b/golem95c-1.2.1/interface/tens_rec.f90
@@ -0,0 +1,6177 @@
+!****h* src/interface/tens_rec
+! NAME
+!
+! Module tens_rec
+!
+! USAGE
+!
+! use tens_rec
+!
+! DESCRIPTION
+!
+! This module offers the possibility of reconstructing the tensor
+! coefficients that have to be contracted with tensor integrals in
+! order to reproduce a diagram, which has been specified by a set
+! of denominators and a numerator N(q, mu^2). This module is typically
+! used in connection with the module tens_comb.
+!
+! Please, note that this module is generated by a script and should not
+! be modified manually. In order to make changes to this module rerun
+! the Python script
+!
+! tool/tens_rec/tens.py
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+!
+!*****
+module tens_rec
+use precision_golem, only: ki
+implicit none
+private :: ki
+real(ki), dimension(0:3), parameter, private :: null_vec = &
+ & (/0.0_ki,0.0_ki,0.0_ki,0.0_ki/)
+real(ki), dimension(1,1), parameter, private :: mat1_1 = &
+& reshape((/&
+&1.0_ki/3.0_ki/),&
+& (/1,1/), order=(/2,1/))
+real(ki), dimension(1,1), parameter, private :: q1_1 = &
+& reshape((/&
+&3.0_ki/),&
+& (/1,1/), order=(/2,1/))
+real(ki), dimension(2,2), parameter, private :: mat2_1 = &
+& reshape((/&
+&5.0_ki/6.0_ki,-3.0_ki/10.0_ki,-1.0_ki/6.0_ki,1.0_ki/10.0_ki/),&
+& (/2,2/), order=(/2,1/))
+real(ki), dimension(2,1), parameter, private :: q2_1 = &
+& reshape((/&
+&3.0_ki,5.0_ki/),&
+& (/2,1/), order=(/2,1/))
+real(ki), dimension(1,1), parameter, private :: mat2_2 = &
+& reshape((/&
+&1.0_ki/9.0_ki/),&
+& (/1,1/), order=(/2,1/))
+real(ki), dimension(1,2), parameter, private :: q2_2 = &
+& reshape((/&
+&3.0_ki,3.0_ki/),&
+& (/1,2/), order=(/2,1/))
+real(ki), dimension(3,3), parameter, private :: mat3_1 = &
+& reshape((/&
+&35.0_ki/24.0_ki,-21.0_ki/20.0_ki,15.0_ki/56.0_ki,-1.0_ki/2.0_ki,1.0_ki/2.0_ki, &
+&-1.0_ki/7.0_ki,1.0_ki/24.0_ki,-1.0_ki/20.0_ki,1.0_ki/56.0_ki/),&
+& (/3,3/), order=(/2,1/))
+real(ki), dimension(3,1), parameter, private :: q3_1 = &
+& reshape((/&
+&3.0_ki,5.0_ki,7.0_ki/),&
+& (/3,1/), order=(/2,1/))
+real(ki), dimension(3,3), parameter, private :: mat3_2 = &
+& reshape((/&
+&4.0_ki/9.0_ki,-1.0_ki/10.0_ki,-1.0_ki/10.0_ki,-1.0_ki/18.0_ki,1.0_ki/30.0_ki, &
+&0.0_ki,-1.0_ki/18.0_ki,0.0_ki,1.0_ki/30.0_ki/),&
+& (/3,3/), order=(/2,1/))
+real(ki), dimension(3,2), parameter, private :: q3_2 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,5.0_ki,5.0_ki,3.0_ki/),&
+& (/3,2/), order=(/2,1/))
+real(ki), dimension(1,1), parameter, private :: mat3_3 = &
+& reshape((/&
+&1.0_ki/27.0_ki/),&
+& (/1,1/), order=(/2,1/))
+real(ki), dimension(1,3), parameter, private :: q3_3 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki/),&
+& (/1,3/), order=(/2,1/))
+real(ki), dimension(4,4), parameter, private :: mat4_1 = &
+& reshape((/&
+&385.0_ki/192.0_ki,-77.0_ki/40.0_ki,165.0_ki/224.0_ki,-35.0_ki/704.0_ki, &
+&-167.0_ki/192.0_ki,131.0_ki/120.0_ki,-103.0_ki/224.0_ki,71.0_ki/2112.0_ki, &
+&23.0_ki/192.0_ki,-7.0_ki/40.0_ki,19.0_ki/224.0_ki,-5.0_ki/704.0_ki, &
+&-1.0_ki/192.0_ki,1.0_ki/120.0_ki,-1.0_ki/224.0_ki,1.0_ki/2112.0_ki/),&
+& (/4,4/), order=(/2,1/))
+real(ki), dimension(4,1), parameter, private :: q4_1 = &
+& reshape((/&
+&3.0_ki,5.0_ki,7.0_ki,11.0_ki/),&
+& (/4,1/), order=(/2,1/))
+real(ki), dimension(6,6), parameter, private :: mat4_2 = &
+& reshape((/&
+&10.0_ki/9.0_ki,-1.0_ki/2.0_ki,5.0_ki/56.0_ki,-1.0_ki/2.0_ki,9.0_ki/100.0_ki, &
+&5.0_ki/56.0_ki,-1.0_ki/4.0_ki,13.0_ki/60.0_ki,-1.0_ki/21.0_ki,1.0_ki/20.0_ki, &
+&-3.0_ki/100.0_ki,0.0_ki,1.0_ki/72.0_ki,-1.0_ki/60.0_ki,1.0_ki/168.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,-1.0_ki/4.0_ki,1.0_ki/20.0_ki,0.0_ki,13.0_ki/60.0_ki, &
+&-3.0_ki/100.0_ki,-1.0_ki/21.0_ki,1.0_ki/36.0_ki,-1.0_ki/60.0_ki,0.0_ki, &
+&-1.0_ki/60.0_ki,1.0_ki/100.0_ki,0.0_ki,1.0_ki/72.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/60.0_ki,0.0_ki,1.0_ki/168.0_ki/),&
+& (/6,6/), order=(/2,1/))
+real(ki), dimension(6,2), parameter, private :: q4_2 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,7.0_ki,5.0_ki,3.0_ki,5.0_ki,5.0_ki,7.0_ki, &
+&3.0_ki/),&
+& (/6,2/), order=(/2,1/))
+real(ki), dimension(4,4), parameter, private :: mat4_3 = &
+& reshape((/&
+&11.0_ki/54.0_ki,-1.0_ki/30.0_ki,-1.0_ki/30.0_ki,-1.0_ki/30.0_ki, &
+&-1.0_ki/54.0_ki,1.0_ki/90.0_ki,0.0_ki,0.0_ki,-1.0_ki/54.0_ki,0.0_ki, &
+&1.0_ki/90.0_ki,0.0_ki,-1.0_ki/54.0_ki,0.0_ki,0.0_ki,1.0_ki/90.0_ki/),&
+& (/4,4/), order=(/2,1/))
+real(ki), dimension(4,3), parameter, private :: q4_3 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,5.0_ki,3.0_ki,5.0_ki,3.0_ki, &
+&3.0_ki/),&
+& (/4,3/), order=(/2,1/))
+real(ki), dimension(1,1), parameter, private :: mat4_4 = &
+& reshape((/&
+&1.0_ki/81.0_ki/),&
+& (/1,1/), order=(/2,1/))
+real(ki), dimension(1,4), parameter, private :: q4_4 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,3.0_ki/),&
+& (/1,4/), order=(/2,1/))
+real(ki), dimension(5,5), parameter, private :: mat5_1 = &
+& reshape((/&
+&1001.0_ki/384.0_ki,-1001.0_ki/320.0_ki,715.0_ki/448.0_ki,-455.0_ki/1408.0_ki, &
+&77.0_ki/832.0_ki,-213.0_ki/160.0_ki,967.0_ki/480.0_ki,-47.0_ki/42.0_ki, &
+&257.0_ki/1056.0_ki,-443.0_ki/6240.0_ki,233.0_ki/960.0_ki,-101.0_ki/240.0_ki, &
+&25.0_ki/96.0_ki,-133.0_ki/2112.0_ki,59.0_ki/3120.0_ki,-3.0_ki/160.0_ki, &
+&17.0_ki/480.0_ki,-1.0_ki/42.0_ki,7.0_ki/1056.0_ki,-1.0_ki/480.0_ki, &
+&1.0_ki/1920.0_ki,-1.0_ki/960.0_ki,1.0_ki/1344.0_ki,-1.0_ki/4224.0_ki, &
+&1.0_ki/12480.0_ki/),&
+& (/5,5/), order=(/2,1/))
+real(ki), dimension(5,1), parameter, private :: q5_1 = &
+& reshape((/&
+&3.0_ki,5.0_ki,7.0_ki,11.0_ki,13.0_ki/),&
+& (/5,1/), order=(/2,1/))
+real(ki), dimension(10,10), parameter, private :: mat5_2 = &
+& reshape((/&
+&605.0_ki/288.0_ki,-65.0_ki/48.0_ki,85.0_ki/224.0_ki,-35.0_ki/2112.0_ki, &
+&-65.0_ki/48.0_ki,27.0_ki/50.0_ki,-9.0_ki/112.0_ki,85.0_ki/224.0_ki, &
+&-9.0_ki/112.0_ki,-35.0_ki/2112.0_ki,-371.0_ki/576.0_ki,487.0_ki/720.0_ki, &
+&-151.0_ki/672.0_ki,71.0_ki/6336.0_ki,11.0_ki/40.0_ki,-9.0_ki/40.0_ki, &
+&3.0_ki/70.0_ki,-5.0_ki/112.0_ki,3.0_ki/112.0_ki,0.0_ki,35.0_ki/576.0_ki, &
+&-1.0_ki/12.0_ki,25.0_ki/672.0_ki,-5.0_ki/2112.0_ki,-1.0_ki/80.0_ki, &
+&3.0_ki/200.0_ki,-3.0_ki/560.0_ki,0.0_ki,0.0_ki,0.0_ki,-1.0_ki/576.0_ki, &
+&1.0_ki/360.0_ki,-1.0_ki/672.0_ki,1.0_ki/6336.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,-371.0_ki/576.0_ki,11.0_ki/40.0_ki,-5.0_ki/112.0_ki,0.0_ki, &
+&487.0_ki/720.0_ki,-9.0_ki/40.0_ki,3.0_ki/112.0_ki,-151.0_ki/672.0_ki, &
+&3.0_ki/70.0_ki,71.0_ki/6336.0_ki,5.0_ki/36.0_ki,-7.0_ki/60.0_ki, &
+&1.0_ki/42.0_ki,0.0_ki,-7.0_ki/60.0_ki,9.0_ki/100.0_ki,-1.0_ki/70.0_ki, &
+&1.0_ki/42.0_ki,-1.0_ki/70.0_ki,0.0_ki,-1.0_ki/144.0_ki,1.0_ki/120.0_ki, &
+&-1.0_ki/336.0_ki,0.0_ki,1.0_ki/240.0_ki,-1.0_ki/200.0_ki,1.0_ki/560.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,35.0_ki/576.0_ki,-1.0_ki/80.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/12.0_ki,3.0_ki/200.0_ki,0.0_ki,25.0_ki/672.0_ki,-3.0_ki/560.0_ki, &
+&-5.0_ki/2112.0_ki,-1.0_ki/144.0_ki,1.0_ki/240.0_ki,0.0_ki,0.0_ki, &
+&1.0_ki/120.0_ki,-1.0_ki/200.0_ki,0.0_ki,-1.0_ki/336.0_ki,1.0_ki/560.0_ki, &
+&0.0_ki,-1.0_ki/576.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/360.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/672.0_ki,0.0_ki,1.0_ki/6336.0_ki/),&
+& (/10,10/), order=(/2,1/))
+real(ki), dimension(10,2), parameter, private :: q5_2 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,7.0_ki,3.0_ki,11.0_ki,5.0_ki,3.0_ki,5.0_ki, &
+&5.0_ki,5.0_ki,7.0_ki,7.0_ki,3.0_ki,7.0_ki,5.0_ki,11.0_ki,3.0_ki/),&
+& (/10,2/), order=(/2,1/))
+real(ki), dimension(10,10), parameter, private :: mat5_3 = &
+& reshape((/&
+&143.0_ki/216.0_ki,-13.0_ki/60.0_ki,5.0_ki/168.0_ki,-13.0_ki/60.0_ki, &
+&3.0_ki/100.0_ki,5.0_ki/168.0_ki,-13.0_ki/60.0_ki,3.0_ki/100.0_ki, &
+&3.0_ki/100.0_ki,5.0_ki/168.0_ki,-1.0_ki/9.0_ki,4.0_ki/45.0_ki,-1.0_ki/63.0_ki, &
+&1.0_ki/60.0_ki,-1.0_ki/100.0_ki,0.0_ki,1.0_ki/60.0_ki,-1.0_ki/100.0_ki,0.0_ki, &
+&0.0_ki,1.0_ki/216.0_ki,-1.0_ki/180.0_ki,1.0_ki/504.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,-1.0_ki/9.0_ki,1.0_ki/60.0_ki,0.0_ki, &
+&4.0_ki/45.0_ki,-1.0_ki/100.0_ki,-1.0_ki/63.0_ki,1.0_ki/60.0_ki,0.0_ki, &
+&-1.0_ki/100.0_ki,0.0_ki,1.0_ki/108.0_ki,-1.0_ki/180.0_ki,0.0_ki, &
+&-1.0_ki/180.0_ki,1.0_ki/300.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&1.0_ki/216.0_ki,0.0_ki,0.0_ki,-1.0_ki/180.0_ki,0.0_ki,1.0_ki/504.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,-1.0_ki/9.0_ki,1.0_ki/60.0_ki,0.0_ki,1.0_ki/60.0_ki, &
+&0.0_ki,0.0_ki,4.0_ki/45.0_ki,-1.0_ki/100.0_ki,-1.0_ki/100.0_ki, &
+&-1.0_ki/63.0_ki,1.0_ki/108.0_ki,-1.0_ki/180.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/180.0_ki,1.0_ki/300.0_ki,0.0_ki,0.0_ki,1.0_ki/108.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/180.0_ki,0.0_ki,0.0_ki,-1.0_ki/180.0_ki,0.0_ki,1.0_ki/300.0_ki,0.0_ki, &
+&1.0_ki/216.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,-1.0_ki/180.0_ki,0.0_ki, &
+&0.0_ki,1.0_ki/504.0_ki/),&
+& (/10,10/), order=(/2,1/))
+real(ki), dimension(10,3), parameter, private :: q5_3 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,7.0_ki,3.0_ki,5.0_ki, &
+&3.0_ki,3.0_ki,5.0_ki,5.0_ki,3.0_ki,7.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,5.0_ki, &
+&3.0_ki,5.0_ki,5.0_ki,5.0_ki,3.0_ki,7.0_ki,3.0_ki,3.0_ki/),&
+& (/10,3/), order=(/2,1/))
+real(ki), dimension(5,5), parameter, private :: mat5_4 = &
+& reshape((/&
+&7.0_ki/81.0_ki,-1.0_ki/90.0_ki,-1.0_ki/90.0_ki,-1.0_ki/90.0_ki, &
+&-1.0_ki/90.0_ki,-1.0_ki/162.0_ki,1.0_ki/270.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/162.0_ki,0.0_ki,1.0_ki/270.0_ki,0.0_ki,0.0_ki,-1.0_ki/162.0_ki,0.0_ki, &
+&0.0_ki,1.0_ki/270.0_ki,0.0_ki,-1.0_ki/162.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&1.0_ki/270.0_ki/),&
+& (/5,5/), order=(/2,1/))
+real(ki), dimension(5,4), parameter, private :: q5_4 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,3.0_ki,3.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,5.0_ki, &
+&3.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,3.0_ki/),&
+& (/5,4/), order=(/2,1/))
+real(ki), dimension(6,6), parameter, private :: mat6_1 = &
+& reshape((/&
+&2431.0_ki/768.0_ki,-17017.0_ki/3840.0_ki,2431.0_ki/896.0_ki, &
+&-7735.0_ki/8448.0_ki,1309.0_ki/3328.0_ki,-143.0_ki/6528.0_ki, &
+&-48457.0_ki/26880.0_ki,35881.0_ki/11520.0_ki,-3959.0_ki/1920.0_ki, &
+&18841.0_ki/25344.0_ki,-16217.0_ki/49920.0_ki,12673.0_ki/685440.0_ki, &
+&5239.0_ki/13440.0_ki,-489.0_ki/640.0_ki,3727.0_ki/6720.0_ki, &
+&-925.0_ki/4224.0_ki,2449.0_ki/24960.0_ki,-659.0_ki/114240.0_ki, &
+&-77.0_ki/1920.0_ki,491.0_ki/5760.0_ki,-149.0_ki/2240.0_ki,371.0_ki/12672.0_ki, &
+&-113.0_ki/8320.0_ki,41.0_ki/48960.0_ki,53.0_ki/26880.0_ki,-17.0_ki/3840.0_ki, &
+&7.0_ki/1920.0_ki,-5.0_ki/2816.0_ki,43.0_ki/49920.0_ki,-13.0_ki/228480.0_ki, &
+&-1.0_ki/26880.0_ki,1.0_ki/11520.0_ki,-1.0_ki/13440.0_ki,1.0_ki/25344.0_ki, &
+&-1.0_ki/49920.0_ki,1.0_ki/685440.0_ki/),&
+& (/6,6/), order=(/2,1/))
+real(ki), dimension(6,1), parameter, private :: q6_1 = &
+& reshape((/&
+&3.0_ki,5.0_ki,7.0_ki,11.0_ki,13.0_ki,17.0_ki/),&
+& (/6,1/), order=(/2,1/))
+real(ki), dimension(15,15), parameter, private :: mat6_2 = &
+& reshape((/&
+&1981.0_ki/576.0_ki,-1085.0_ki/384.0_ki,205.0_ki/192.0_ki,-35.0_ki/264.0_ki, &
+&77.0_ki/2496.0_ki,-1085.0_ki/384.0_ki,651.0_ki/400.0_ki,-27.0_ki/64.0_ki, &
+&21.0_ki/1408.0_ki,205.0_ki/192.0_ki,-27.0_ki/64.0_ki,225.0_ki/3136.0_ki, &
+&-35.0_ki/264.0_ki,21.0_ki/1408.0_ki,77.0_ki/2496.0_ki,-1231.0_ki/960.0_ki, &
+&9127.0_ki/5760.0_ki,-2791.0_ki/4032.0_ki,1241.0_ki/12672.0_ki, &
+&-443.0_ki/18720.0_ki,1501.0_ki/1920.0_ki,-79.0_ki/100.0_ki,549.0_ki/2240.0_ki, &
+&-71.0_ki/7040.0_ki,-95.0_ki/448.0_ki,81.0_ki/448.0_ki,-15.0_ki/392.0_ki, &
+&35.0_ki/4224.0_ki,-7.0_ki/1408.0_ki,0.0_ki,961.0_ki/5760.0_ki, &
+&-373.0_ki/1440.0_ki,283.0_ki/2016.0_ki,-311.0_ki/12672.0_ki,59.0_ki/9360.0_ki, &
+&-43.0_ki/640.0_ki,9.0_ki/100.0_ki,-87.0_ki/2240.0_ki,3.0_ki/1408.0_ki, &
+&5.0_ki/448.0_ki,-3.0_ki/224.0_ki,15.0_ki/3136.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-17.0_ki/1920.0_ki,23.0_ki/1440.0_ki,-41.0_ki/4032.0_ki,31.0_ki/12672.0_ki, &
+&-1.0_ki/1440.0_ki,1.0_ki/640.0_ki,-1.0_ki/400.0_ki,3.0_ki/2240.0_ki, &
+&-1.0_ki/7040.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/5760.0_ki, &
+&-1.0_ki/2880.0_ki,1.0_ki/4032.0_ki,-1.0_ki/12672.0_ki,1.0_ki/37440.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1231.0_ki/960.0_ki,1501.0_ki/1920.0_ki,-95.0_ki/448.0_ki,35.0_ki/4224.0_ki, &
+&0.0_ki,9127.0_ki/5760.0_ki,-79.0_ki/100.0_ki,81.0_ki/448.0_ki, &
+&-7.0_ki/1408.0_ki,-2791.0_ki/4032.0_ki,549.0_ki/2240.0_ki,-15.0_ki/392.0_ki, &
+&1241.0_ki/12672.0_ki,-71.0_ki/7040.0_ki,-443.0_ki/18720.0_ki, &
+&215.0_ki/576.0_ki,-2221.0_ki/5760.0_ki,167.0_ki/1344.0_ki,-71.0_ki/12672.0_ki, &
+&0.0_ki,-2221.0_ki/5760.0_ki,221.0_ki/600.0_ki,-33.0_ki/320.0_ki, &
+&71.0_ki/21120.0_ki,167.0_ki/1344.0_ki,-33.0_ki/320.0_ki,1.0_ki/49.0_ki, &
+&-71.0_ki/12672.0_ki,71.0_ki/21120.0_ki,0.0_ki,-13.0_ki/384.0_ki, &
+&11.0_ki/240.0_ki,-9.0_ki/448.0_ki,5.0_ki/4224.0_ki,0.0_ki,11.0_ki/384.0_ki, &
+&-3.0_ki/80.0_ki,1.0_ki/64.0_ki,-1.0_ki/1408.0_ki,-1.0_ki/168.0_ki, &
+&1.0_ki/140.0_ki,-1.0_ki/392.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/1152.0_ki, &
+&-1.0_ki/720.0_ki,1.0_ki/1344.0_ki,-1.0_ki/12672.0_ki,0.0_ki,-1.0_ki/1920.0_ki, &
+&1.0_ki/1200.0_ki,-1.0_ki/2240.0_ki,1.0_ki/21120.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,961.0_ki/5760.0_ki,-43.0_ki/640.0_ki,5.0_ki/448.0_ki, &
+&0.0_ki,0.0_ki,-373.0_ki/1440.0_ki,9.0_ki/100.0_ki,-3.0_ki/224.0_ki,0.0_ki, &
+&283.0_ki/2016.0_ki,-87.0_ki/2240.0_ki,15.0_ki/3136.0_ki,-311.0_ki/12672.0_ki, &
+&3.0_ki/1408.0_ki,59.0_ki/9360.0_ki,-13.0_ki/384.0_ki,11.0_ki/384.0_ki, &
+&-1.0_ki/168.0_ki,0.0_ki,0.0_ki,11.0_ki/240.0_ki,-3.0_ki/80.0_ki, &
+&1.0_ki/140.0_ki,0.0_ki,-9.0_ki/448.0_ki,1.0_ki/64.0_ki,-1.0_ki/392.0_ki, &
+&5.0_ki/4224.0_ki,-1.0_ki/1408.0_ki,0.0_ki,1.0_ki/576.0_ki,-1.0_ki/480.0_ki, &
+&1.0_ki/1344.0_ki,0.0_ki,0.0_ki,-1.0_ki/480.0_ki,1.0_ki/400.0_ki, &
+&-1.0_ki/1120.0_ki,0.0_ki,1.0_ki/1344.0_ki,-1.0_ki/1120.0_ki,1.0_ki/3136.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,-17.0_ki/1920.0_ki,1.0_ki/640.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&23.0_ki/1440.0_ki,-1.0_ki/400.0_ki,0.0_ki,0.0_ki,-41.0_ki/4032.0_ki, &
+&3.0_ki/2240.0_ki,0.0_ki,31.0_ki/12672.0_ki,-1.0_ki/7040.0_ki, &
+&-1.0_ki/1440.0_ki,1.0_ki/1152.0_ki,-1.0_ki/1920.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/720.0_ki,1.0_ki/1200.0_ki,0.0_ki,0.0_ki,1.0_ki/1344.0_ki, &
+&-1.0_ki/2240.0_ki,0.0_ki,-1.0_ki/12672.0_ki,1.0_ki/21120.0_ki,0.0_ki, &
+&1.0_ki/5760.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,-1.0_ki/2880.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,1.0_ki/4032.0_ki,0.0_ki,0.0_ki,-1.0_ki/12672.0_ki,0.0_ki, &
+&1.0_ki/37440.0_ki/),&
+& (/15,15/), order=(/2,1/))
+real(ki), dimension(15,2), parameter, private :: q6_2 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,7.0_ki,3.0_ki,11.0_ki,3.0_ki,13.0_ki, &
+&5.0_ki,3.0_ki,5.0_ki,5.0_ki,5.0_ki,7.0_ki,5.0_ki,11.0_ki,7.0_ki,3.0_ki,7.0_ki, &
+&5.0_ki,7.0_ki,7.0_ki,11.0_ki,3.0_ki,11.0_ki,5.0_ki,13.0_ki,3.0_ki/),&
+& (/15,2/), order=(/2,1/))
+real(ki), dimension(20,20), parameter, private :: mat6_3 = &
+& reshape((/&
+&2755.0_ki/1728.0_ki,-55.0_ki/72.0_ki,115.0_ki/672.0_ki,-35.0_ki/6336.0_ki, &
+&-55.0_ki/72.0_ki,9.0_ki/40.0_ki,-3.0_ki/112.0_ki,115.0_ki/672.0_ki, &
+&-3.0_ki/112.0_ki,-35.0_ki/6336.0_ki,-55.0_ki/72.0_ki,9.0_ki/40.0_ki, &
+&-3.0_ki/112.0_ki,9.0_ki/40.0_ki,-27.0_ki/1000.0_ki,-3.0_ki/112.0_ki, &
+&115.0_ki/672.0_ki,-3.0_ki/112.0_ki,-3.0_ki/112.0_ki,-35.0_ki/6336.0_ki, &
+&-647.0_ki/1728.0_ki,383.0_ki/1080.0_ki,-199.0_ki/2016.0_ki,71.0_ki/19008.0_ki, &
+&7.0_ki/60.0_ki,-9.0_ki/100.0_ki,1.0_ki/70.0_ki,-5.0_ki/336.0_ki, &
+&1.0_ki/112.0_ki,0.0_ki,7.0_ki/60.0_ki,-9.0_ki/100.0_ki,1.0_ki/70.0_ki, &
+&-3.0_ki/200.0_ki,9.0_ki/1000.0_ki,0.0_ki,-5.0_ki/336.0_ki,1.0_ki/112.0_ki, &
+&0.0_ki,0.0_ki,47.0_ki/1728.0_ki,-13.0_ki/360.0_ki,31.0_ki/2016.0_ki, &
+&-5.0_ki/6336.0_ki,-1.0_ki/240.0_ki,1.0_ki/200.0_ki,-1.0_ki/560.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,-1.0_ki/240.0_ki,1.0_ki/200.0_ki,-1.0_ki/560.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,-1.0_ki/1728.0_ki,1.0_ki/1080.0_ki, &
+&-1.0_ki/2016.0_ki,1.0_ki/19008.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-647.0_ki/1728.0_ki,7.0_ki/60.0_ki,-5.0_ki/336.0_ki,0.0_ki,383.0_ki/1080.0_ki, &
+&-9.0_ki/100.0_ki,1.0_ki/112.0_ki,-199.0_ki/2016.0_ki,1.0_ki/70.0_ki, &
+&71.0_ki/19008.0_ki,7.0_ki/60.0_ki,-3.0_ki/200.0_ki,0.0_ki,-9.0_ki/100.0_ki, &
+&9.0_ki/1000.0_ki,1.0_ki/70.0_ki,-5.0_ki/336.0_ki,0.0_ki,1.0_ki/112.0_ki, &
+&0.0_ki,13.0_ki/216.0_ki,-17.0_ki/360.0_ki,1.0_ki/126.0_ki,0.0_ki, &
+&-17.0_ki/360.0_ki,7.0_ki/200.0_ki,-1.0_ki/210.0_ki,1.0_ki/126.0_ki, &
+&-1.0_ki/210.0_ki,0.0_ki,-1.0_ki/120.0_ki,1.0_ki/200.0_ki,0.0_ki, &
+&1.0_ki/200.0_ki,-3.0_ki/1000.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/432.0_ki,1.0_ki/360.0_ki,-1.0_ki/1008.0_ki,0.0_ki,1.0_ki/720.0_ki, &
+&-1.0_ki/600.0_ki,1.0_ki/1680.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,47.0_ki/1728.0_ki, &
+&-1.0_ki/240.0_ki,0.0_ki,0.0_ki,-13.0_ki/360.0_ki,1.0_ki/200.0_ki,0.0_ki, &
+&31.0_ki/2016.0_ki,-1.0_ki/560.0_ki,-5.0_ki/6336.0_ki,-1.0_ki/240.0_ki,0.0_ki, &
+&0.0_ki,1.0_ki/200.0_ki,0.0_ki,-1.0_ki/560.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/432.0_ki,1.0_ki/720.0_ki,0.0_ki,0.0_ki,1.0_ki/360.0_ki, &
+&-1.0_ki/600.0_ki,0.0_ki,-1.0_ki/1008.0_ki,1.0_ki/1680.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/1728.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/1080.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/2016.0_ki,0.0_ki,1.0_ki/19008.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,-647.0_ki/1728.0_ki,7.0_ki/60.0_ki, &
+&-5.0_ki/336.0_ki,0.0_ki,7.0_ki/60.0_ki,-3.0_ki/200.0_ki,0.0_ki, &
+&-5.0_ki/336.0_ki,0.0_ki,0.0_ki,383.0_ki/1080.0_ki,-9.0_ki/100.0_ki, &
+&1.0_ki/112.0_ki,-9.0_ki/100.0_ki,9.0_ki/1000.0_ki,1.0_ki/112.0_ki, &
+&-199.0_ki/2016.0_ki,1.0_ki/70.0_ki,1.0_ki/70.0_ki,71.0_ki/19008.0_ki, &
+&13.0_ki/216.0_ki,-17.0_ki/360.0_ki,1.0_ki/126.0_ki,0.0_ki,-1.0_ki/120.0_ki, &
+&1.0_ki/200.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,-17.0_ki/360.0_ki,7.0_ki/200.0_ki, &
+&-1.0_ki/210.0_ki,1.0_ki/200.0_ki,-3.0_ki/1000.0_ki,0.0_ki,1.0_ki/126.0_ki, &
+&-1.0_ki/210.0_ki,0.0_ki,0.0_ki,-1.0_ki/432.0_ki,1.0_ki/360.0_ki, &
+&-1.0_ki/1008.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&1.0_ki/720.0_ki,-1.0_ki/600.0_ki,1.0_ki/1680.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,13.0_ki/216.0_ki,-1.0_ki/120.0_ki,0.0_ki,0.0_ki, &
+&-17.0_ki/360.0_ki,1.0_ki/200.0_ki,0.0_ki,1.0_ki/126.0_ki,0.0_ki,0.0_ki, &
+&-17.0_ki/360.0_ki,1.0_ki/200.0_ki,0.0_ki,7.0_ki/200.0_ki,-3.0_ki/1000.0_ki, &
+&-1.0_ki/210.0_ki,1.0_ki/126.0_ki,0.0_ki,-1.0_ki/210.0_ki,0.0_ki, &
+&-1.0_ki/216.0_ki,1.0_ki/360.0_ki,0.0_ki,0.0_ki,1.0_ki/360.0_ki, &
+&-1.0_ki/600.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/360.0_ki,-1.0_ki/600.0_ki, &
+&0.0_ki,-1.0_ki/600.0_ki,1.0_ki/1000.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/432.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/360.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/1008.0_ki,0.0_ki,0.0_ki,1.0_ki/720.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/600.0_ki,0.0_ki,1.0_ki/1680.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&47.0_ki/1728.0_ki,-1.0_ki/240.0_ki,0.0_ki,0.0_ki,-1.0_ki/240.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,-13.0_ki/360.0_ki,1.0_ki/200.0_ki,0.0_ki, &
+&1.0_ki/200.0_ki,0.0_ki,0.0_ki,31.0_ki/2016.0_ki,-1.0_ki/560.0_ki, &
+&-1.0_ki/560.0_ki,-5.0_ki/6336.0_ki,-1.0_ki/432.0_ki,1.0_ki/720.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/360.0_ki, &
+&-1.0_ki/600.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,-1.0_ki/1008.0_ki, &
+&1.0_ki/1680.0_ki,0.0_ki,0.0_ki,-1.0_ki/432.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&1.0_ki/720.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/360.0_ki,0.0_ki, &
+&0.0_ki,-1.0_ki/600.0_ki,0.0_ki,0.0_ki,-1.0_ki/1008.0_ki,0.0_ki, &
+&1.0_ki/1680.0_ki,0.0_ki,-1.0_ki/1728.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/1080.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,-1.0_ki/2016.0_ki,0.0_ki,0.0_ki,1.0_ki/19008.0_ki/),&
+& (/20,20/), order=(/2,1/))
+real(ki), dimension(20,3), parameter, private :: q6_3 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,7.0_ki,3.0_ki,3.0_ki, &
+&11.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,5.0_ki,5.0_ki,3.0_ki,5.0_ki,7.0_ki,3.0_ki, &
+&7.0_ki,3.0_ki,3.0_ki,7.0_ki,5.0_ki,3.0_ki,11.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki, &
+&5.0_ki,3.0_ki,5.0_ki,5.0_ki,3.0_ki,7.0_ki,5.0_ki,5.0_ki,3.0_ki,5.0_ki,5.0_ki, &
+&5.0_ki,5.0_ki,7.0_ki,3.0_ki,7.0_ki,3.0_ki,3.0_ki,7.0_ki,3.0_ki,5.0_ki,7.0_ki, &
+&5.0_ki,3.0_ki,11.0_ki,3.0_ki,3.0_ki/),&
+& (/20,3/), order=(/2,1/))
+real(ki), dimension(15,15), parameter, private :: mat6_4 = &
+& reshape((/&
+&28.0_ki/81.0_ki,-4.0_ki/45.0_ki,5.0_ki/504.0_ki,-4.0_ki/45.0_ki, &
+&1.0_ki/100.0_ki,5.0_ki/504.0_ki,-4.0_ki/45.0_ki,1.0_ki/100.0_ki, &
+&1.0_ki/100.0_ki,5.0_ki/504.0_ki,-4.0_ki/45.0_ki,1.0_ki/100.0_ki, &
+&1.0_ki/100.0_ki,1.0_ki/100.0_ki,5.0_ki/504.0_ki,-5.0_ki/108.0_ki, &
+&19.0_ki/540.0_ki,-1.0_ki/189.0_ki,1.0_ki/180.0_ki,-1.0_ki/300.0_ki,0.0_ki, &
+&1.0_ki/180.0_ki,-1.0_ki/300.0_ki,0.0_ki,0.0_ki,1.0_ki/180.0_ki, &
+&-1.0_ki/300.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/648.0_ki,-1.0_ki/540.0_ki, &
+&1.0_ki/1512.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,-5.0_ki/108.0_ki,1.0_ki/180.0_ki,0.0_ki, &
+&19.0_ki/540.0_ki,-1.0_ki/300.0_ki,-1.0_ki/189.0_ki,1.0_ki/180.0_ki,0.0_ki, &
+&-1.0_ki/300.0_ki,0.0_ki,1.0_ki/180.0_ki,0.0_ki,-1.0_ki/300.0_ki,0.0_ki,0.0_ki, &
+&1.0_ki/324.0_ki,-1.0_ki/540.0_ki,0.0_ki,-1.0_ki/540.0_ki,1.0_ki/900.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&1.0_ki/648.0_ki,0.0_ki,0.0_ki,-1.0_ki/540.0_ki,0.0_ki,1.0_ki/1512.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,-5.0_ki/108.0_ki, &
+&1.0_ki/180.0_ki,0.0_ki,1.0_ki/180.0_ki,0.0_ki,0.0_ki,19.0_ki/540.0_ki, &
+&-1.0_ki/300.0_ki,-1.0_ki/300.0_ki,-1.0_ki/189.0_ki,1.0_ki/180.0_ki,0.0_ki, &
+&0.0_ki,-1.0_ki/300.0_ki,0.0_ki,1.0_ki/324.0_ki,-1.0_ki/540.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,-1.0_ki/540.0_ki,1.0_ki/900.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,1.0_ki/324.0_ki,0.0_ki,0.0_ki,-1.0_ki/540.0_ki,0.0_ki, &
+&0.0_ki,-1.0_ki/540.0_ki,0.0_ki,1.0_ki/900.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,1.0_ki/648.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/540.0_ki,0.0_ki,0.0_ki,1.0_ki/1512.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&0.0_ki,-5.0_ki/108.0_ki,1.0_ki/180.0_ki,0.0_ki,1.0_ki/180.0_ki,0.0_ki,0.0_ki, &
+&1.0_ki/180.0_ki,0.0_ki,0.0_ki,0.0_ki,19.0_ki/540.0_ki,-1.0_ki/300.0_ki, &
+&-1.0_ki/300.0_ki,-1.0_ki/300.0_ki,-1.0_ki/189.0_ki,1.0_ki/324.0_ki, &
+&-1.0_ki/540.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/540.0_ki,1.0_ki/900.0_ki,0.0_ki,0.0_ki,0.0_ki,1.0_ki/324.0_ki,0.0_ki, &
+&0.0_ki,-1.0_ki/540.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/540.0_ki,0.0_ki,1.0_ki/900.0_ki,0.0_ki,0.0_ki,1.0_ki/324.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,-1.0_ki/540.0_ki,0.0_ki,0.0_ki,0.0_ki, &
+&-1.0_ki/540.0_ki,0.0_ki,0.0_ki,1.0_ki/900.0_ki,0.0_ki,1.0_ki/648.0_ki,0.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,0.0_ki,-1.0_ki/540.0_ki, &
+&0.0_ki,0.0_ki,0.0_ki,1.0_ki/1512.0_ki/),&
+& (/15,15/), order=(/2,1/))
+real(ki), dimension(15,4), parameter, private :: q6_4 = &
+& reshape((/&
+&3.0_ki,3.0_ki,3.0_ki,3.0_ki,3.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,3.0_ki, &
+&7.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,3.0_ki,5.0_ki,5.0_ki,3.0_ki,3.0_ki, &
+&7.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,5.0_ki,3.0_ki, &
+&5.0_ki,5.0_ki,3.0_ki,3.0_ki,7.0_ki,3.0_ki,3.0_ki,5.0_ki,3.0_ki,3.0_ki,3.0_ki, &
+&5.0_ki,3.0_ki,3.0_ki,5.0_ki,5.0_ki,3.0_ki,5.0_ki,3.0_ki,5.0_ki,5.0_ki,3.0_ki, &
+&3.0_ki,7.0_ki,3.0_ki,3.0_ki,3.0_ki/),&
+& (/15,4/), order=(/2,1/))
+!****t* src/interface/tens_rec/coeff_type_1
+!
+! NAME
+!
+! Type coeff_type_1
+!
+! DESCRIPTION
+!
+! Holds the coefficients of a mixed rank tensor integral with maximum
+! tensor rank 1.
+!
+! ENTRIES
+!
+! * c0, ..., c1 -- coefficients of terms with 0,...,1
+! first index selects non-zero components of q
+! second index selects a specific monomial
+!
+!*****
+type coeff_type_1
+ complex(ki) :: c0
+ complex(ki), dimension(4,1) :: c1
+end type coeff_type_1
+!****t* src/interface/tens_rec/coeff_type_2
+!
+! NAME
+!
+! Type coeff_type_2
+!
+! DESCRIPTION
+!
+! Holds the coefficients of a mixed rank tensor integral with maximum
+! tensor rank 2.
+!
+! ENTRIES
+!
+! * c0, ..., c2 -- coefficients of terms with 0,...,2
+! first index selects non-zero components of q
+! second index selects a specific monomial
+!
+!*****
+type coeff_type_2
+ complex(ki) :: c0
+ complex(ki), dimension(4,2) :: c1
+ complex(ki), dimension(6,1) :: c2
+end type coeff_type_2
+!****t* src/interface/tens_rec/coeff_type_3
+!
+! NAME
+!
+! Type coeff_type_3
+!
+! DESCRIPTION
+!
+! Holds the coefficients of a mixed rank tensor integral with maximum
+! tensor rank 3.
+!
+! ENTRIES
+!
+! * c0, ..., c3 -- coefficients of terms with 0,...,3
+! first index selects non-zero components of q
+! second index selects a specific monomial
+!
+!*****
+type coeff_type_3
+ complex(ki) :: c0
+ complex(ki), dimension(4,3) :: c1
+ complex(ki), dimension(6,3) :: c2
+ complex(ki), dimension(4,1) :: c3
+end type coeff_type_3
+!****t* src/interface/tens_rec/coeff_type_4
+!
+! NAME
+!
+! Type coeff_type_4
+!
+! DESCRIPTION
+!
+! Holds the coefficients of a mixed rank tensor integral with maximum
+! tensor rank 4.
+!
+! ENTRIES
+!
+! * c0, ..., c4 -- coefficients of terms with 0,...,4
+! first index selects non-zero components of q
+! second index selects a specific monomial
+!
+!*****
+type coeff_type_4
+ complex(ki) :: c0
+ complex(ki), dimension(4,4) :: c1
+ complex(ki), dimension(6,6) :: c2
+ complex(ki), dimension(4,4) :: c3
+ complex(ki), dimension(1,1) :: c4
+end type coeff_type_4
+!****t* src/interface/tens_rec/coeff_type_5
+!
+! NAME
+!
+! Type coeff_type_5
+!
+! DESCRIPTION
+!
+! Holds the coefficients of a mixed rank tensor integral with maximum
+! tensor rank 5.
+!
+! ENTRIES
+!
+! * c0, ..., c4 -- coefficients of terms with 0,...,4
+! first index selects non-zero components of q
+! second index selects a specific monomial
+!
+!*****
+type coeff_type_5
+ complex(ki) :: c0
+ complex(ki), dimension(4,5) :: c1
+ complex(ki), dimension(6,10) :: c2
+ complex(ki), dimension(4,10) :: c3
+ complex(ki), dimension(1,5) :: c4
+end type coeff_type_5
+!****t* src/interface/tens_rec/coeff_type_6
+!
+! NAME
+!
+! Type coeff_type_6
+!
+! DESCRIPTION
+!
+! Holds the coefficients of a mixed rank tensor integral with maximum
+! tensor rank 6.
+!
+! ENTRIES
+!
+! * c0, ..., c4 -- coefficients of terms with 0,...,4
+! first index selects non-zero components of q
+! second index selects a specific monomial
+!
+!*****
+type coeff_type_6
+ complex(ki) :: c0
+ complex(ki), dimension(4,6) :: c1
+ complex(ki), dimension(6,15) :: c2
+ complex(ki), dimension(4,20) :: c3
+ complex(ki), dimension(1,15) :: c4
+end type coeff_type_6
+interface print_coeffs
+ module procedure print_coeffs_1
+ module procedure print_coeffs_2
+ module procedure print_coeffs_3
+ module procedure print_coeffs_4
+ module procedure print_coeffs_5
+ module procedure print_coeffs_6
+end interface
+contains
+!****f* src/interface/tens_rec/solve1_1
+! NAME
+!
+! Subroutine solve1_1
+!
+! USAGE
+!
+! call solve1_1(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q1_1.
+! The matrix mat1_1 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_1 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve1_1(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(1), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_1), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_3), intent(in), optional :: coeffs2
+ complex(ki), dimension(1) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ if (present(coeffs2)) then
+ do i=1,1
+ Q(indices(1)) = q1_1(i,1)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval1(Q, coeffs, 0) &
+ & - tenseval3(Q, coeffs2, 1)
+ end do
+ else
+ do i=1,1
+ Q(indices(1)) = q1_1(i,1)
+ xnum(i) = numeval(Q, mu2) - tenseval1(Q, coeffs, 0)
+ end do
+ end if
+ coeffs%c1(idx,:) = matmul(mat1_1,xnum)
+end subroutine solve1_1
+!****f* src/interface/tens_rec/tenseval1_1
+! NAME
+!
+! Function tenseval1_1
+!
+! USAGE
+!
+! result = tenseval1_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(1) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval1_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(1), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval1_1
+ real(ki) :: q0
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(1)*q0
+ tenseval1_1 = acc
+end function tenseval1_1
+!****f* src/interface/tens_rec/ctenseval1_1
+! NAME
+!
+! Function ctenseval1_1
+!
+! USAGE
+!
+! result = ctenseval1_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(1) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval1_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(1), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval1_1
+ complex(ki) :: q0
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(1)*q0
+ ctenseval1_1 = acc
+end function ctenseval1_1
+!****f* src/interface/tens_rec/solve1
+! NAME
+!
+! Subroutine solve1
+!
+! USAGE
+!
+! call solve1(numeval, mu2, coeffs, coeffs2)
+!
+! DESCRIPTION
+!
+! Determines the tensor coefficients of a numerator for a fixed value
+! of mu^2 with maximum rank 1
+!
+! INPUTS
+!
+! * numeval -- function representing the numerator of the problem
+! * mu2 -- fixed value of mu^2 for which the numerator is evaluated
+! * coeffs -- a record of type coeff_type_1 used to store the result
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve1(numeval, mu2, coeffs, coeffs2)
+ ! generated by: write_subroutine_glob_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ real(ki), intent(in) :: mu2
+ type(coeff_type_1), intent(inout) :: coeffs
+ type(coeff_type_3), intent(in), optional :: coeffs2
+ if (present(coeffs2)) then
+ coeffs%c0 = numeval(null_vec, mu2) - coeffs2%c0
+ call solve1_1(numeval, (/0/), mu2, coeffs, 1, coeffs2)
+ call solve1_1(numeval, (/1/), mu2, coeffs, 2, coeffs2)
+ call solve1_1(numeval, (/2/), mu2, coeffs, 3, coeffs2)
+ call solve1_1(numeval, (/3/), mu2, coeffs, 4, coeffs2)
+ else
+ coeffs%c0 = numeval((/0.0_ki,0.0_ki,0.0_ki,0.0_ki/), mu2)
+ call solve1_1(numeval, (/0/), mu2, coeffs, 1)
+ call solve1_1(numeval, (/1/), mu2, coeffs, 2)
+ call solve1_1(numeval, (/2/), mu2, coeffs, 3)
+ call solve1_1(numeval, (/3/), mu2, coeffs, 4)
+ end if
+end subroutine solve1
+!****f* src/interface/tens_rec/tenseval1
+! NAME
+!
+! Function tenseval1
+!
+! USAGE
+!
+! result = tenseval1(Q, coeffs, max_k)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_1
+! * max_k -- optional integer argument limiting the the reconstruction
+! to a subset of terms with no more than max_k components of q
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval1(Q, coeffs, max_k)
+ ! generated by: write_function_glob_recon
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_1), intent(in) :: coeffs
+ integer, intent(in), optional :: max_k
+ complex(ki) :: tenseval1
+ integer :: maxk
+ if (present(max_k)) then
+ maxk = max_k
+ else
+ maxk = 1
+ end if
+ tenseval1 = coeffs%c0
+ if (1 .le. maxk) then
+ tenseval1 = tenseval1 + tenseval1_1(Q, (/0/), coeffs%c1(1,:))
+ tenseval1 = tenseval1 + tenseval1_1(Q, (/1/), coeffs%c1(2,:))
+ tenseval1 = tenseval1 + tenseval1_1(Q, (/2/), coeffs%c1(3,:))
+ tenseval1 = tenseval1 + tenseval1_1(Q, (/3/), coeffs%c1(4,:))
+ end if
+end function tenseval1
+!****f* src/interface/tens_rec/ctenseval1
+! NAME
+!
+! Function ctenseval1
+!
+! USAGE
+!
+! result = ctenseval1(Q, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_1
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval1(Q, coeffs)
+ ! generated by: write_function_glob_recon_complex
+ implicit none
+ complex(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_1), intent(in) :: coeffs
+ complex(ki) :: ctenseval1
+ ctenseval1 = coeffs%c0
+ ctenseval1 = ctenseval1 + ctenseval1_1(Q, (/0/), coeffs%c1(1,:))
+ ctenseval1 = ctenseval1 + ctenseval1_1(Q, (/1/), coeffs%c1(2,:))
+ ctenseval1 = ctenseval1 + ctenseval1_1(Q, (/2/), coeffs%c1(3,:))
+ ctenseval1 = ctenseval1 + ctenseval1_1(Q, (/3/), coeffs%c1(4,:))
+end function ctenseval1
+!****f* src/interface/tens_rec/print_coeffs_1
+! NAME
+!
+! Subroutine print_coeffs_1
+!
+! Visible through public interface print_coeffs
+!
+! USAGE
+!
+! call print_coeffs(coeffs,unit=6)
+!
+! DESCRIPTION
+!
+! Prints the coefficients of a numerator of maximum rank 1
+! in human readable form.
+!
+! INPUTS
+!
+! * coeffs -- a record of type coeff_type_1
+! * unit -- number of an open file, defaults to stdout (unit=6)
+!
+! SIDE EFFECTS
+!
+! Prints to the given file
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine print_coeffs_1(coeffs, unit)
+ ! generated by: write_print_coeffs
+ implicit none
+ type(coeff_type_1), intent(in) :: coeffs
+ integer, intent(in), optional :: unit
+ integer :: ch
+ if (present(unit)) then
+ ch = unit
+ else
+ ch = 6
+ end if
+ write(ch,'(A4,G24.16,1x,G24.16,A1)') ' (', coeffs%c0, ')'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(1,1), ')*q(0)'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(2,1), ')*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(3,1), ')*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(4,1), ')*q(3)'
+end subroutine print_coeffs_1
+!****f* src/interface/tens_rec/reconstruct1
+! NAME
+!
+! Subroutine reconstruct1
+!
+! USAGE
+!
+! call reconstruct1(numeval, cm0)
+!
+! DESCRIPTION
+!
+! Reconstructs all coefficients of a tensor integral of maximum rank 1,
+! including the coefficients in front of mu2 and mu2^2.
+!
+! In the given case the rank is too low in order to allow for mu2 pieces.
+!
+!
+! INPUTS
+!
+! * numeval -- the numerator function
+! * cm0 -- coefficients of type coeff_type_1, representing the
+! numerator
+!
+! SIDE EFFECTS
+!
+! Writes results to cm0.
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine reconstruct1(numeval, cm0)
+ ! generated by: write_subroutine_reconstruct_dummy
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ type(coeff_type_1), intent(out) :: cm0
+ call solve1(numeval, 0.0_ki, cm0)
+end subroutine reconstruct1
+!****f* src/interface/tens_rec/solve2_1
+! NAME
+!
+! Subroutine solve2_1
+!
+! USAGE
+!
+! call solve2_1(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q2_1.
+! The matrix mat2_1 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_2 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve2_1(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(1), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_2), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_4), intent(in), optional :: coeffs2
+ complex(ki), dimension(2) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ if (present(coeffs2)) then
+ do i=1,2
+ Q(indices(1)) = q2_1(i,1)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval2(Q, coeffs, 0) &
+ & - tenseval4(Q, coeffs2, 1)
+ end do
+ else
+ do i=1,2
+ Q(indices(1)) = q2_1(i,1)
+ xnum(i) = numeval(Q, mu2) - tenseval2(Q, coeffs, 0)
+ end do
+ end if
+ coeffs%c1(idx,:) = matmul(mat2_1,xnum)
+end subroutine solve2_1
+!****f* src/interface/tens_rec/tenseval2_1
+! NAME
+!
+! Function tenseval2_1
+!
+! USAGE
+!
+! result = tenseval2_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(2) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval2_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(2), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval2_1
+ real(ki) :: q0
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(1) + coeffs(2)*q0
+ acc = acc*q0
+ tenseval2_1 = acc
+end function tenseval2_1
+!****f* src/interface/tens_rec/ctenseval2_1
+! NAME
+!
+! Function ctenseval2_1
+!
+! USAGE
+!
+! result = ctenseval2_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(2) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval2_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(2), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval2_1
+ complex(ki) :: q0
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(1) + coeffs(2)*q0
+ acc = acc*q0
+ ctenseval2_1 = acc
+end function ctenseval2_1
+!****f* src/interface/tens_rec/solve2_2
+! NAME
+!
+! Subroutine solve2_2
+!
+! USAGE
+!
+! call solve2_2(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q2_2.
+! The matrix mat2_2 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_2 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve2_2(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(2), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_2), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_4), intent(in), optional :: coeffs2
+ complex(ki), dimension(1) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ if (present(coeffs2)) then
+ do i=1,1
+ Q(indices(1)) = q2_2(i,1)
+ Q(indices(2)) = q2_2(i,2)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval2(Q, coeffs, 1) &
+ & - tenseval4(Q, coeffs2, 2)
+ end do
+ else
+ do i=1,1
+ Q(indices(1)) = q2_2(i,1)
+ Q(indices(2)) = q2_2(i,2)
+ xnum(i) = numeval(Q, mu2) - tenseval2(Q, coeffs, 1)
+ end do
+ end if
+ coeffs%c2(idx,:) = matmul(mat2_2,xnum)
+end subroutine solve2_2
+!****f* src/interface/tens_rec/tenseval2_2
+! NAME
+!
+! Function tenseval2_2
+!
+! USAGE
+!
+! result = tenseval2_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(1) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval2_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(1), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval2_2
+ real(ki) :: q0
+ real(ki) :: q1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(1)*q0*q1
+ tenseval2_2 = acc
+end function tenseval2_2
+!****f* src/interface/tens_rec/ctenseval2_2
+! NAME
+!
+! Function ctenseval2_2
+!
+! USAGE
+!
+! result = ctenseval2_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(1) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval2_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(1), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval2_2
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(1)*q0*q1
+ ctenseval2_2 = acc
+end function ctenseval2_2
+!****f* src/interface/tens_rec/solve2
+! NAME
+!
+! Subroutine solve2
+!
+! USAGE
+!
+! call solve2(numeval, mu2, coeffs, coeffs2)
+!
+! DESCRIPTION
+!
+! Determines the tensor coefficients of a numerator for a fixed value
+! of mu^2 with maximum rank 2
+!
+! INPUTS
+!
+! * numeval -- function representing the numerator of the problem
+! * mu2 -- fixed value of mu^2 for which the numerator is evaluated
+! * coeffs -- a record of type coeff_type_2 used to store the result
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve2(numeval, mu2, coeffs, coeffs2)
+ ! generated by: write_subroutine_glob_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ real(ki), intent(in) :: mu2
+ type(coeff_type_2), intent(inout) :: coeffs
+ type(coeff_type_4), intent(in), optional :: coeffs2
+ if (present(coeffs2)) then
+ coeffs%c0 = numeval(null_vec, mu2) - coeffs2%c0
+ call solve2_1(numeval, (/0/), mu2, coeffs, 1, coeffs2)
+ call solve2_1(numeval, (/1/), mu2, coeffs, 2, coeffs2)
+ call solve2_1(numeval, (/2/), mu2, coeffs, 3, coeffs2)
+ call solve2_1(numeval, (/3/), mu2, coeffs, 4, coeffs2)
+ call solve2_2(numeval, (/0,1/), mu2, coeffs, 1, coeffs2)
+ call solve2_2(numeval, (/0,2/), mu2, coeffs, 2, coeffs2)
+ call solve2_2(numeval, (/0,3/), mu2, coeffs, 3, coeffs2)
+ call solve2_2(numeval, (/1,2/), mu2, coeffs, 4, coeffs2)
+ call solve2_2(numeval, (/1,3/), mu2, coeffs, 5, coeffs2)
+ call solve2_2(numeval, (/2,3/), mu2, coeffs, 6, coeffs2)
+ else
+ coeffs%c0 = numeval((/0.0_ki,0.0_ki,0.0_ki,0.0_ki/), mu2)
+ call solve2_1(numeval, (/0/), mu2, coeffs, 1)
+ call solve2_1(numeval, (/1/), mu2, coeffs, 2)
+ call solve2_1(numeval, (/2/), mu2, coeffs, 3)
+ call solve2_1(numeval, (/3/), mu2, coeffs, 4)
+ call solve2_2(numeval, (/0,1/), mu2, coeffs, 1)
+ call solve2_2(numeval, (/0,2/), mu2, coeffs, 2)
+ call solve2_2(numeval, (/0,3/), mu2, coeffs, 3)
+ call solve2_2(numeval, (/1,2/), mu2, coeffs, 4)
+ call solve2_2(numeval, (/1,3/), mu2, coeffs, 5)
+ call solve2_2(numeval, (/2,3/), mu2, coeffs, 6)
+ end if
+end subroutine solve2
+!****f* src/interface/tens_rec/tenseval2
+! NAME
+!
+! Function tenseval2
+!
+! USAGE
+!
+! result = tenseval2(Q, coeffs, max_k)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_2
+! * max_k -- optional integer argument limiting the the reconstruction
+! to a subset of terms with no more than max_k components of q
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval2(Q, coeffs, max_k)
+ ! generated by: write_function_glob_recon
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_2), intent(in) :: coeffs
+ integer, intent(in), optional :: max_k
+ complex(ki) :: tenseval2
+ integer :: maxk
+ if (present(max_k)) then
+ maxk = max_k
+ else
+ maxk = 2
+ end if
+ tenseval2 = coeffs%c0
+ if (1 .le. maxk) then
+ tenseval2 = tenseval2 + tenseval2_1(Q, (/0/), coeffs%c1(1,:))
+ tenseval2 = tenseval2 + tenseval2_1(Q, (/1/), coeffs%c1(2,:))
+ tenseval2 = tenseval2 + tenseval2_1(Q, (/2/), coeffs%c1(3,:))
+ tenseval2 = tenseval2 + tenseval2_1(Q, (/3/), coeffs%c1(4,:))
+ end if
+ if (2 .le. maxk) then
+ tenseval2 = tenseval2 + tenseval2_2(Q, (/0,1/), coeffs%c2(1,:))
+ tenseval2 = tenseval2 + tenseval2_2(Q, (/0,2/), coeffs%c2(2,:))
+ tenseval2 = tenseval2 + tenseval2_2(Q, (/0,3/), coeffs%c2(3,:))
+ tenseval2 = tenseval2 + tenseval2_2(Q, (/1,2/), coeffs%c2(4,:))
+ tenseval2 = tenseval2 + tenseval2_2(Q, (/1,3/), coeffs%c2(5,:))
+ tenseval2 = tenseval2 + tenseval2_2(Q, (/2,3/), coeffs%c2(6,:))
+ end if
+end function tenseval2
+!****f* src/interface/tens_rec/ctenseval2
+! NAME
+!
+! Function ctenseval2
+!
+! USAGE
+!
+! result = ctenseval2(Q, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_2
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval2(Q, coeffs)
+ ! generated by: write_function_glob_recon_complex
+ implicit none
+ complex(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_2), intent(in) :: coeffs
+ complex(ki) :: ctenseval2
+ ctenseval2 = coeffs%c0
+ ctenseval2 = ctenseval2 + ctenseval2_1(Q, (/0/), coeffs%c1(1,:))
+ ctenseval2 = ctenseval2 + ctenseval2_1(Q, (/1/), coeffs%c1(2,:))
+ ctenseval2 = ctenseval2 + ctenseval2_1(Q, (/2/), coeffs%c1(3,:))
+ ctenseval2 = ctenseval2 + ctenseval2_1(Q, (/3/), coeffs%c1(4,:))
+ ctenseval2 = ctenseval2 + ctenseval2_2(Q, (/0,1/), coeffs%c2(1,:))
+ ctenseval2 = ctenseval2 + ctenseval2_2(Q, (/0,2/), coeffs%c2(2,:))
+ ctenseval2 = ctenseval2 + ctenseval2_2(Q, (/0,3/), coeffs%c2(3,:))
+ ctenseval2 = ctenseval2 + ctenseval2_2(Q, (/1,2/), coeffs%c2(4,:))
+ ctenseval2 = ctenseval2 + ctenseval2_2(Q, (/1,3/), coeffs%c2(5,:))
+ ctenseval2 = ctenseval2 + ctenseval2_2(Q, (/2,3/), coeffs%c2(6,:))
+end function ctenseval2
+!****f* src/interface/tens_rec/print_coeffs_2
+! NAME
+!
+! Subroutine print_coeffs_2
+!
+! Visible through public interface print_coeffs
+!
+! USAGE
+!
+! call print_coeffs(coeffs,unit=6)
+!
+! DESCRIPTION
+!
+! Prints the coefficients of a numerator of maximum rank 2
+! in human readable form.
+!
+! INPUTS
+!
+! * coeffs -- a record of type coeff_type_2
+! * unit -- number of an open file, defaults to stdout (unit=6)
+!
+! SIDE EFFECTS
+!
+! Prints to the given file
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine print_coeffs_2(coeffs, unit)
+ ! generated by: write_print_coeffs
+ implicit none
+ type(coeff_type_2), intent(in) :: coeffs
+ integer, intent(in), optional :: unit
+ integer :: ch
+ if (present(unit)) then
+ ch = unit
+ else
+ ch = 6
+ end if
+ write(ch,'(A4,G24.16,1x,G24.16,A1)') ' (', coeffs%c0, ')'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(1,1), ')*q(0)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,2), ')*q(0)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(2,1), ')*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,2), ')*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(3,1), ')*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,2), ')*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(4,1), ')*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,2), ')*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(1,1), ')*q(0)*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(2,1), ')*q(0)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(3,1), ')*q(0)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(4,1), ')*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(5,1), ')*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(6,1), ')*q(2)*q(3)'
+end subroutine print_coeffs_2
+!****f* src/interface/tens_rec/reconstruct2
+! NAME
+!
+! Subroutine reconstruct2
+!
+! USAGE
+!
+! call reconstruct2(numeval, cm0, cm1, cm2)
+!
+! DESCRIPTION
+!
+! Reconstructs all coefficients of a tensor integral of maximum rank 2,
+! including the coefficients in front of mu2 and mu2^2.
+!
+! INPUTS
+!
+! * numeval -- the numerator function
+! * cm0 -- coefficients of type coeff_type_2, representing the
+! numerator at mu2=0
+! * cm1 -- coefficients of type complex(ki), representing the
+! tensor in front of mu2 [optional]
+! * cm2 -- coefficients of type complex(ki), representing the
+! tensor in front of mu2^2 [optional]
+!
+! SIDE EFFECTS
+!
+! Writes results to cm0, cm1 and cm2 (if present). If cm1 and cm2 are omitted
+! only N(q,0) is evaluated. If cm2 is omitted it is assumed that the numerator
+! is at most linear in mu2.
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine reconstruct2(numeval, cm0, cm1, cm2)
+ ! generated by: write_subroutine_reconstruct
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ type(coeff_type_2), intent(out) :: cm0
+ complex(ki), intent(out), optional :: cm1
+ complex(ki), intent(out), optional :: cm2
+ complex(ki) :: ca, cb
+ call solve2(numeval, 0.0_ki, cm0)
+ if (present(cm1)) then
+ if (present(cm2)) then
+ ca = numeval(null_vec, +1.0_ki) - cm0%c0
+ cb = numeval(null_vec, -1.0_ki) - cm0%c0
+ cm1= 0.5_ki * (ca - cb)
+ cm2= 0.5_ki * (ca + cb)
+ else
+ cm1 = numeval(null_vec, +1.0_ki) - cm0%c0
+ end if
+ end if
+end subroutine reconstruct2
+!****f* src/interface/tens_rec/solve3_1
+! NAME
+!
+! Subroutine solve3_1
+!
+! USAGE
+!
+! call solve3_1(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q3_1.
+! The matrix mat3_1 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_3 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve3_1(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(1), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_3), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_5), intent(in), optional :: coeffs2
+ complex(ki), dimension(3) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ if (present(coeffs2)) then
+ do i=1,3
+ Q(indices(1)) = q3_1(i,1)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval3(Q, coeffs, 0) &
+ & - tenseval5(Q, coeffs2, 1)
+ end do
+ else
+ do i=1,3
+ Q(indices(1)) = q3_1(i,1)
+ xnum(i) = numeval(Q, mu2) - tenseval3(Q, coeffs, 0)
+ end do
+ end if
+ coeffs%c1(idx,:) = matmul(mat3_1,xnum)
+end subroutine solve3_1
+!****f* src/interface/tens_rec/tenseval3_1
+! NAME
+!
+! Function tenseval3_1
+!
+! USAGE
+!
+! result = tenseval3_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(3) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval3_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(3), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval3_1
+ real(ki) :: q0
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(2) + coeffs(3)*q0
+ reg1 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg1
+ acc = acc*q0
+ tenseval3_1 = acc
+end function tenseval3_1
+!****f* src/interface/tens_rec/ctenseval3_1
+! NAME
+!
+! Function ctenseval3_1
+!
+! USAGE
+!
+! result = ctenseval3_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(3) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval3_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(3), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval3_1
+ complex(ki) :: q0
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(2) + coeffs(3)*q0
+ reg1 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg1
+ acc = acc*q0
+ ctenseval3_1 = acc
+end function ctenseval3_1
+!****f* src/interface/tens_rec/solve3_2
+! NAME
+!
+! Subroutine solve3_2
+!
+! USAGE
+!
+! call solve3_2(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q3_2.
+! The matrix mat3_2 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_3 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve3_2(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(2), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_3), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_5), intent(in), optional :: coeffs2
+ complex(ki), dimension(3) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ if (present(coeffs2)) then
+ do i=1,3
+ Q(indices(1)) = q3_2(i,1)
+ Q(indices(2)) = q3_2(i,2)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval3(Q, coeffs, 1) &
+ & - tenseval5(Q, coeffs2, 2)
+ end do
+ else
+ do i=1,3
+ Q(indices(1)) = q3_2(i,1)
+ Q(indices(2)) = q3_2(i,2)
+ xnum(i) = numeval(Q, mu2) - tenseval3(Q, coeffs, 1)
+ end do
+ end if
+ coeffs%c2(idx,:) = matmul(mat3_2,xnum)
+end subroutine solve3_2
+!****f* src/interface/tens_rec/tenseval3_2
+! NAME
+!
+! Function tenseval3_2
+!
+! USAGE
+!
+! result = tenseval3_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(3) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval3_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(3), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval3_2
+ real(ki) :: q0
+ real(ki) :: q1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(2)*q1 + coeffs(3)*q0 + coeffs(1)
+ acc = acc*q0*q1
+ tenseval3_2 = acc
+end function tenseval3_2
+!****f* src/interface/tens_rec/ctenseval3_2
+! NAME
+!
+! Function ctenseval3_2
+!
+! USAGE
+!
+! result = ctenseval3_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(3) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval3_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(3), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval3_2
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(2)*q1 + coeffs(3)*q0 + coeffs(1)
+ acc = acc*q0*q1
+ ctenseval3_2 = acc
+end function ctenseval3_2
+!****f* src/interface/tens_rec/solve3_3
+! NAME
+!
+! Subroutine solve3_3
+!
+! USAGE
+!
+! call solve3_3(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q3_3.
+! The matrix mat3_3 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_3 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve3_3(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(3), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_3), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_5), intent(in), optional :: coeffs2
+ complex(ki), dimension(1) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ if (present(coeffs2)) then
+ do i=1,1
+ Q(indices(1)) = q3_3(i,1)
+ Q(indices(2)) = q3_3(i,2)
+ Q(indices(3)) = q3_3(i,3)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval3(Q, coeffs, 2) &
+ & - tenseval5(Q, coeffs2, 3)
+ end do
+ else
+ do i=1,1
+ Q(indices(1)) = q3_3(i,1)
+ Q(indices(2)) = q3_3(i,2)
+ Q(indices(3)) = q3_3(i,3)
+ xnum(i) = numeval(Q, mu2) - tenseval3(Q, coeffs, 2)
+ end do
+ end if
+ coeffs%c3(idx,:) = matmul(mat3_3,xnum)
+end subroutine solve3_3
+!****f* src/interface/tens_rec/tenseval3_3
+! NAME
+!
+! Function tenseval3_3
+!
+! USAGE
+!
+! result = tenseval3_3(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 3 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(3): the set of non-zero indices.
+! * coeffs -- an array of dimension(1) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 3 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval3_3(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(3), intent(in) :: indices
+ complex(ki), dimension(1), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval3_3
+ real(ki) :: q0
+ real(ki) :: q1
+ real(ki) :: q2
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ acc = coeffs(1)*q0*q1*q2
+ tenseval3_3 = acc
+end function tenseval3_3
+!****f* src/interface/tens_rec/ctenseval3_3
+! NAME
+!
+! Function ctenseval3_3
+!
+! USAGE
+!
+! result = ctenseval3_3(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 3 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(3): the set of non-zero indices.
+! * coeffs -- an array of dimension(1) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 3 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval3_3(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(3), intent(in) :: indices
+ complex(ki), dimension(1), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval3_3
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: q2
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ acc = coeffs(1)*q0*q1*q2
+ ctenseval3_3 = acc
+end function ctenseval3_3
+!****f* src/interface/tens_rec/solve3
+! NAME
+!
+! Subroutine solve3
+!
+! USAGE
+!
+! call solve3(numeval, mu2, coeffs, coeffs2)
+!
+! DESCRIPTION
+!
+! Determines the tensor coefficients of a numerator for a fixed value
+! of mu^2 with maximum rank 3
+!
+! INPUTS
+!
+! * numeval -- function representing the numerator of the problem
+! * mu2 -- fixed value of mu^2 for which the numerator is evaluated
+! * coeffs -- a record of type coeff_type_3 used to store the result
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve3(numeval, mu2, coeffs, coeffs2)
+ ! generated by: write_subroutine_glob_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ real(ki), intent(in) :: mu2
+ type(coeff_type_3), intent(inout) :: coeffs
+ type(coeff_type_5), intent(in), optional :: coeffs2
+ if (present(coeffs2)) then
+ coeffs%c0 = numeval(null_vec, mu2) - coeffs2%c0
+ call solve3_1(numeval, (/0/), mu2, coeffs, 1, coeffs2)
+ call solve3_1(numeval, (/1/), mu2, coeffs, 2, coeffs2)
+ call solve3_1(numeval, (/2/), mu2, coeffs, 3, coeffs2)
+ call solve3_1(numeval, (/3/), mu2, coeffs, 4, coeffs2)
+ call solve3_2(numeval, (/0,1/), mu2, coeffs, 1, coeffs2)
+ call solve3_2(numeval, (/0,2/), mu2, coeffs, 2, coeffs2)
+ call solve3_2(numeval, (/0,3/), mu2, coeffs, 3, coeffs2)
+ call solve3_2(numeval, (/1,2/), mu2, coeffs, 4, coeffs2)
+ call solve3_2(numeval, (/1,3/), mu2, coeffs, 5, coeffs2)
+ call solve3_2(numeval, (/2,3/), mu2, coeffs, 6, coeffs2)
+ call solve3_3(numeval, (/0,1,2/), mu2, coeffs, 1, coeffs2)
+ call solve3_3(numeval, (/0,1,3/), mu2, coeffs, 2, coeffs2)
+ call solve3_3(numeval, (/0,2,3/), mu2, coeffs, 3, coeffs2)
+ call solve3_3(numeval, (/1,2,3/), mu2, coeffs, 4, coeffs2)
+ else
+ coeffs%c0 = numeval((/0.0_ki,0.0_ki,0.0_ki,0.0_ki/), mu2)
+ call solve3_1(numeval, (/0/), mu2, coeffs, 1)
+ call solve3_1(numeval, (/1/), mu2, coeffs, 2)
+ call solve3_1(numeval, (/2/), mu2, coeffs, 3)
+ call solve3_1(numeval, (/3/), mu2, coeffs, 4)
+ call solve3_2(numeval, (/0,1/), mu2, coeffs, 1)
+ call solve3_2(numeval, (/0,2/), mu2, coeffs, 2)
+ call solve3_2(numeval, (/0,3/), mu2, coeffs, 3)
+ call solve3_2(numeval, (/1,2/), mu2, coeffs, 4)
+ call solve3_2(numeval, (/1,3/), mu2, coeffs, 5)
+ call solve3_2(numeval, (/2,3/), mu2, coeffs, 6)
+ call solve3_3(numeval, (/0,1,2/), mu2, coeffs, 1)
+ call solve3_3(numeval, (/0,1,3/), mu2, coeffs, 2)
+ call solve3_3(numeval, (/0,2,3/), mu2, coeffs, 3)
+ call solve3_3(numeval, (/1,2,3/), mu2, coeffs, 4)
+ end if
+end subroutine solve3
+!****f* src/interface/tens_rec/tenseval3
+! NAME
+!
+! Function tenseval3
+!
+! USAGE
+!
+! result = tenseval3(Q, coeffs, max_k)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_3
+! * max_k -- optional integer argument limiting the the reconstruction
+! to a subset of terms with no more than max_k components of q
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval3(Q, coeffs, max_k)
+ ! generated by: write_function_glob_recon
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_3), intent(in) :: coeffs
+ integer, intent(in), optional :: max_k
+ complex(ki) :: tenseval3
+ integer :: maxk
+ if (present(max_k)) then
+ maxk = max_k
+ else
+ maxk = 3
+ end if
+ tenseval3 = coeffs%c0
+ if (1 .le. maxk) then
+ tenseval3 = tenseval3 + tenseval3_1(Q, (/0/), coeffs%c1(1,:))
+ tenseval3 = tenseval3 + tenseval3_1(Q, (/1/), coeffs%c1(2,:))
+ tenseval3 = tenseval3 + tenseval3_1(Q, (/2/), coeffs%c1(3,:))
+ tenseval3 = tenseval3 + tenseval3_1(Q, (/3/), coeffs%c1(4,:))
+ end if
+ if (2 .le. maxk) then
+ tenseval3 = tenseval3 + tenseval3_2(Q, (/0,1/), coeffs%c2(1,:))
+ tenseval3 = tenseval3 + tenseval3_2(Q, (/0,2/), coeffs%c2(2,:))
+ tenseval3 = tenseval3 + tenseval3_2(Q, (/0,3/), coeffs%c2(3,:))
+ tenseval3 = tenseval3 + tenseval3_2(Q, (/1,2/), coeffs%c2(4,:))
+ tenseval3 = tenseval3 + tenseval3_2(Q, (/1,3/), coeffs%c2(5,:))
+ tenseval3 = tenseval3 + tenseval3_2(Q, (/2,3/), coeffs%c2(6,:))
+ end if
+ if (3 .le. maxk) then
+ tenseval3 = tenseval3 + tenseval3_3(Q, (/0,1,2/), coeffs%c3(1,:))
+ tenseval3 = tenseval3 + tenseval3_3(Q, (/0,1,3/), coeffs%c3(2,:))
+ tenseval3 = tenseval3 + tenseval3_3(Q, (/0,2,3/), coeffs%c3(3,:))
+ tenseval3 = tenseval3 + tenseval3_3(Q, (/1,2,3/), coeffs%c3(4,:))
+ end if
+end function tenseval3
+!****f* src/interface/tens_rec/ctenseval3
+! NAME
+!
+! Function ctenseval3
+!
+! USAGE
+!
+! result = ctenseval3(Q, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_3
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval3(Q, coeffs)
+ ! generated by: write_function_glob_recon_complex
+ implicit none
+ complex(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_3), intent(in) :: coeffs
+ complex(ki) :: ctenseval3
+ ctenseval3 = coeffs%c0
+ ctenseval3 = ctenseval3 + ctenseval3_1(Q, (/0/), coeffs%c1(1,:))
+ ctenseval3 = ctenseval3 + ctenseval3_1(Q, (/1/), coeffs%c1(2,:))
+ ctenseval3 = ctenseval3 + ctenseval3_1(Q, (/2/), coeffs%c1(3,:))
+ ctenseval3 = ctenseval3 + ctenseval3_1(Q, (/3/), coeffs%c1(4,:))
+ ctenseval3 = ctenseval3 + ctenseval3_2(Q, (/0,1/), coeffs%c2(1,:))
+ ctenseval3 = ctenseval3 + ctenseval3_2(Q, (/0,2/), coeffs%c2(2,:))
+ ctenseval3 = ctenseval3 + ctenseval3_2(Q, (/0,3/), coeffs%c2(3,:))
+ ctenseval3 = ctenseval3 + ctenseval3_2(Q, (/1,2/), coeffs%c2(4,:))
+ ctenseval3 = ctenseval3 + ctenseval3_2(Q, (/1,3/), coeffs%c2(5,:))
+ ctenseval3 = ctenseval3 + ctenseval3_2(Q, (/2,3/), coeffs%c2(6,:))
+ ctenseval3 = ctenseval3 + ctenseval3_3(Q, (/0,1,2/), coeffs%c3(1,:))
+ ctenseval3 = ctenseval3 + ctenseval3_3(Q, (/0,1,3/), coeffs%c3(2,:))
+ ctenseval3 = ctenseval3 + ctenseval3_3(Q, (/0,2,3/), coeffs%c3(3,:))
+ ctenseval3 = ctenseval3 + ctenseval3_3(Q, (/1,2,3/), coeffs%c3(4,:))
+end function ctenseval3
+!****f* src/interface/tens_rec/print_coeffs_3
+! NAME
+!
+! Subroutine print_coeffs_3
+!
+! Visible through public interface print_coeffs
+!
+! USAGE
+!
+! call print_coeffs(coeffs,unit=6)
+!
+! DESCRIPTION
+!
+! Prints the coefficients of a numerator of maximum rank 3
+! in human readable form.
+!
+! INPUTS
+!
+! * coeffs -- a record of type coeff_type_3
+! * unit -- number of an open file, defaults to stdout (unit=6)
+!
+! SIDE EFFECTS
+!
+! Prints to the given file
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine print_coeffs_3(coeffs, unit)
+ ! generated by: write_print_coeffs
+ implicit none
+ type(coeff_type_3), intent(in) :: coeffs
+ integer, intent(in), optional :: unit
+ integer :: ch
+ if (present(unit)) then
+ ch = unit
+ else
+ ch = 6
+ end if
+ write(ch,'(A4,G24.16,1x,G24.16,A1)') ' (', coeffs%c0, ')'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(1,1), ')*q(0)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,2), ')*q(0)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,3), ')*q(0)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(2,1), ')*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,2), ')*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,3), ')*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(3,1), ')*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,2), ')*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,3), ')*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(4,1), ')*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,2), ')*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,3), ')*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(1,1), ')*q(0)*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,2), ')*q(0)*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,3), ')*q(0)^2*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(2,1), ')*q(0)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,2), ')*q(0)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,3), ')*q(0)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(3,1), ')*q(0)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,2), ')*q(0)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,3), ')*q(0)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(4,1), ')*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,2), ')*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,3), ')*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(5,1), ')*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,2), ')*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,3), ')*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(6,1), ')*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,2), ')*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,3), ')*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(1,1), ')*q(0)*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(2,1), ')*q(0)*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(3,1), ')*q(0)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(4,1), ')*q(1)*q(2)*q(3)'
+end subroutine print_coeffs_3
+!****f* src/interface/tens_rec/reconstruct3
+! NAME
+!
+! Subroutine reconstruct3
+!
+! USAGE
+!
+! call reconstruct3(numeval, cm0, cm1, cm2)
+!
+! DESCRIPTION
+!
+! Reconstructs all coefficients of a tensor integral of maximum rank 3,
+! including the coefficients in front of mu2 and mu2^2.
+!
+! INPUTS
+!
+! * numeval -- the numerator function
+! * cm0 -- coefficients of type coeff_type_3, representing the
+! numerator at mu2=0
+! * cm1 -- coefficients of type type(coeff_type_1), representing the
+! tensor in front of mu2 [optional]
+! * cm2 -- coefficients of type type(coeff_type_1), representing the
+! tensor in front of mu2^2 [optional]
+!
+! SIDE EFFECTS
+!
+! Writes results to cm0, cm1 and cm2 (if present). If cm1 and cm2 are omitted
+! only N(q,0) is evaluated. If cm2 is omitted it is assumed that the numerator
+! is at most linear in mu2.
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine reconstruct3(numeval, cm0, cm1, cm2)
+ ! generated by: write_subroutine_reconstruct
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ type(coeff_type_3), intent(out) :: cm0
+ type(coeff_type_1), intent(out), optional :: cm1
+ type(coeff_type_1), intent(out), optional :: cm2
+ type(coeff_type_1) :: ca, cb
+ call solve3(numeval, 0.0_ki, cm0)
+ if (present(cm1)) then
+ if (present(cm2)) then
+ call solve1(numeval, +1.0_ki, ca, cm0)
+ call solve1(numeval, -1.0_ki, cb, cm0)
+ cm1%c0= 0.5_ki * (ca%c0 - cb%c0)
+ cm2%c0= 0.5_ki * (ca%c0 + cb%c0)
+ cm1%c1 = 0.5_ki * (ca%c1 - cb%c1)
+ cm2%c1 = 0.5_ki * (ca%c1 + cb%c1)
+ else
+ call solve1(numeval, +1.0_ki, cm1, cm0)
+ end if
+ end if
+end subroutine reconstruct3
+!****f* src/interface/tens_rec/solve4_1
+! NAME
+!
+! Subroutine solve4_1
+!
+! USAGE
+!
+! call solve4_1(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q4_1.
+! The matrix mat4_1 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_4 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve4_1(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(1), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_4), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_6), intent(in), optional :: coeffs2
+ complex(ki), dimension(4) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ if (present(coeffs2)) then
+ do i=1,4
+ Q(indices(1)) = q4_1(i,1)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval4(Q, coeffs, 0) &
+ & - tenseval6(Q, coeffs2, 1)
+ end do
+ else
+ do i=1,4
+ Q(indices(1)) = q4_1(i,1)
+ xnum(i) = numeval(Q, mu2) - tenseval4(Q, coeffs, 0)
+ end do
+ end if
+ coeffs%c1(idx,:) = matmul(mat4_1,xnum)
+end subroutine solve4_1
+!****f* src/interface/tens_rec/tenseval4_1
+! NAME
+!
+! Function tenseval4_1
+!
+! USAGE
+!
+! result = tenseval4_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(4) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval4_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(4), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval4_1
+ real(ki) :: q0
+ complex(ki) :: reg2
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(3) + coeffs(4)*q0
+ reg2 = acc*q0
+ acc = coeffs(2)
+ acc = acc + reg2
+ reg1 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg1
+ acc = acc*q0
+ tenseval4_1 = acc
+end function tenseval4_1
+!****f* src/interface/tens_rec/ctenseval4_1
+! NAME
+!
+! Function ctenseval4_1
+!
+! USAGE
+!
+! result = ctenseval4_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(4) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval4_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(4), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval4_1
+ complex(ki) :: q0
+ complex(ki) :: reg2
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(3) + coeffs(4)*q0
+ reg2 = acc*q0
+ acc = coeffs(2)
+ acc = acc + reg2
+ reg1 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg1
+ acc = acc*q0
+ ctenseval4_1 = acc
+end function ctenseval4_1
+!****f* src/interface/tens_rec/solve4_2
+! NAME
+!
+! Subroutine solve4_2
+!
+! USAGE
+!
+! call solve4_2(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q4_2.
+! The matrix mat4_2 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_4 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve4_2(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(2), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_4), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_6), intent(in), optional :: coeffs2
+ complex(ki), dimension(6) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ if (present(coeffs2)) then
+ do i=1,6
+ Q(indices(1)) = q4_2(i,1)
+ Q(indices(2)) = q4_2(i,2)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval4(Q, coeffs, 1) &
+ & - tenseval6(Q, coeffs2, 2)
+ end do
+ else
+ do i=1,6
+ Q(indices(1)) = q4_2(i,1)
+ Q(indices(2)) = q4_2(i,2)
+ xnum(i) = numeval(Q, mu2) - tenseval4(Q, coeffs, 1)
+ end do
+ end if
+ coeffs%c2(idx,:) = matmul(mat4_2,xnum)
+end subroutine solve4_2
+!****f* src/interface/tens_rec/tenseval4_2
+! NAME
+!
+! Function tenseval4_2
+!
+! USAGE
+!
+! result = tenseval4_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(6) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval4_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(6), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval4_2
+ real(ki) :: q0
+ real(ki) :: q1
+ complex(ki) :: reg2
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(3)*q1 + coeffs(5)*q0 + coeffs(2)
+ reg1 = acc*q1
+ acc = coeffs(6)*q0 + coeffs(4)
+ reg2 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1
+ tenseval4_2 = acc
+end function tenseval4_2
+!****f* src/interface/tens_rec/ctenseval4_2
+! NAME
+!
+! Function ctenseval4_2
+!
+! USAGE
+!
+! result = ctenseval4_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(6) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval4_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(6), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval4_2
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: reg2
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(3)*q1 + coeffs(5)*q0 + coeffs(2)
+ reg1 = acc*q1
+ acc = coeffs(6)*q0 + coeffs(4)
+ reg2 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1
+ ctenseval4_2 = acc
+end function ctenseval4_2
+!****f* src/interface/tens_rec/solve4_3
+! NAME
+!
+! Subroutine solve4_3
+!
+! USAGE
+!
+! call solve4_3(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q4_3.
+! The matrix mat4_3 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_4 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve4_3(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(3), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_4), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_6), intent(in), optional :: coeffs2
+ complex(ki), dimension(4) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ if (present(coeffs2)) then
+ do i=1,4
+ Q(indices(1)) = q4_3(i,1)
+ Q(indices(2)) = q4_3(i,2)
+ Q(indices(3)) = q4_3(i,3)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval4(Q, coeffs, 2) &
+ & - tenseval6(Q, coeffs2, 3)
+ end do
+ else
+ do i=1,4
+ Q(indices(1)) = q4_3(i,1)
+ Q(indices(2)) = q4_3(i,2)
+ Q(indices(3)) = q4_3(i,3)
+ xnum(i) = numeval(Q, mu2) - tenseval4(Q, coeffs, 2)
+ end do
+ end if
+ coeffs%c3(idx,:) = matmul(mat4_3,xnum)
+end subroutine solve4_3
+!****f* src/interface/tens_rec/tenseval4_3
+! NAME
+!
+! Function tenseval4_3
+!
+! USAGE
+!
+! result = tenseval4_3(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 3 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(3): the set of non-zero indices.
+! * coeffs -- an array of dimension(4) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 3 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval4_3(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(3), intent(in) :: indices
+ complex(ki), dimension(4), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval4_3
+ real(ki) :: q0
+ real(ki) :: q1
+ real(ki) :: q2
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ acc = coeffs(4)*q0 + coeffs(3)*q1 + coeffs(1) + coeffs(2)*q2
+ acc = acc*q0*q1*q2
+ tenseval4_3 = acc
+end function tenseval4_3
+!****f* src/interface/tens_rec/ctenseval4_3
+! NAME
+!
+! Function ctenseval4_3
+!
+! USAGE
+!
+! result = ctenseval4_3(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 3 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(3): the set of non-zero indices.
+! * coeffs -- an array of dimension(4) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 3 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval4_3(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(3), intent(in) :: indices
+ complex(ki), dimension(4), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval4_3
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: q2
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ acc = coeffs(4)*q0 + coeffs(3)*q1 + coeffs(1) + coeffs(2)*q2
+ acc = acc*q0*q1*q2
+ ctenseval4_3 = acc
+end function ctenseval4_3
+!****f* src/interface/tens_rec/solve4_4
+! NAME
+!
+! Subroutine solve4_4
+!
+! USAGE
+!
+! call solve4_4(numeval, indices, mu2, coeffs, idx, coeffs2)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q4_4.
+! The matrix mat4_4 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_4 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve4_4(numeval, indices, mu2, coeffs, idx, coeffs2)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(4), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_4), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ type(coeff_type_6), intent(in), optional :: coeffs2
+ complex(ki), dimension(1) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ if (present(coeffs2)) then
+ do i=1,1
+ Q(indices(1)) = q4_4(i,1)
+ Q(indices(2)) = q4_4(i,2)
+ Q(indices(3)) = q4_4(i,3)
+ Q(indices(4)) = q4_4(i,4)
+ xnum(i) = numeval(Q, mu2) &
+ & - tenseval4(Q, coeffs, 3) &
+ & - tenseval6(Q, coeffs2, 4)
+ end do
+ else
+ do i=1,1
+ Q(indices(1)) = q4_4(i,1)
+ Q(indices(2)) = q4_4(i,2)
+ Q(indices(3)) = q4_4(i,3)
+ Q(indices(4)) = q4_4(i,4)
+ xnum(i) = numeval(Q, mu2) - tenseval4(Q, coeffs, 3)
+ end do
+ end if
+ coeffs%c4(idx,:) = matmul(mat4_4,xnum)
+end subroutine solve4_4
+!****f* src/interface/tens_rec/tenseval4_4
+! NAME
+!
+! Function tenseval4_4
+!
+! USAGE
+!
+! result = tenseval4_4(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 4 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(4): the set of non-zero indices.
+! * coeffs -- an array of dimension(1) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 4 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval4_4(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(4), intent(in) :: indices
+ complex(ki), dimension(1), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval4_4
+ real(ki) :: q0
+ real(ki) :: q1
+ real(ki) :: q2
+ real(ki) :: q3
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ q3 = Q(indices(4))
+ acc = coeffs(1)*q0*q1*q2*q3
+ tenseval4_4 = acc
+end function tenseval4_4
+!****f* src/interface/tens_rec/ctenseval4_4
+! NAME
+!
+! Function ctenseval4_4
+!
+! USAGE
+!
+! result = ctenseval4_4(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 4 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(4): the set of non-zero indices.
+! * coeffs -- an array of dimension(1) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 4 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval4_4(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(4), intent(in) :: indices
+ complex(ki), dimension(1), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval4_4
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: q2
+ complex(ki) :: q3
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ q3 = Q(indices(4))
+ acc = coeffs(1)*q0*q1*q2*q3
+ ctenseval4_4 = acc
+end function ctenseval4_4
+!****f* src/interface/tens_rec/solve4
+! NAME
+!
+! Subroutine solve4
+!
+! USAGE
+!
+! call solve4(numeval, mu2, coeffs, coeffs2)
+!
+! DESCRIPTION
+!
+! Determines the tensor coefficients of a numerator for a fixed value
+! of mu^2 with maximum rank 4
+!
+! INPUTS
+!
+! * numeval -- function representing the numerator of the problem
+! * mu2 -- fixed value of mu^2 for which the numerator is evaluated
+! * coeffs -- a record of type coeff_type_4 used to store the result
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve4(numeval, mu2, coeffs, coeffs2)
+ ! generated by: write_subroutine_glob_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ real(ki), intent(in) :: mu2
+ type(coeff_type_4), intent(inout) :: coeffs
+ type(coeff_type_6), intent(in), optional :: coeffs2
+ if (present(coeffs2)) then
+ coeffs%c0 = numeval(null_vec, mu2) - coeffs2%c0
+ call solve4_1(numeval, (/0/), mu2, coeffs, 1, coeffs2)
+ call solve4_1(numeval, (/1/), mu2, coeffs, 2, coeffs2)
+ call solve4_1(numeval, (/2/), mu2, coeffs, 3, coeffs2)
+ call solve4_1(numeval, (/3/), mu2, coeffs, 4, coeffs2)
+ call solve4_2(numeval, (/0,1/), mu2, coeffs, 1, coeffs2)
+ call solve4_2(numeval, (/0,2/), mu2, coeffs, 2, coeffs2)
+ call solve4_2(numeval, (/0,3/), mu2, coeffs, 3, coeffs2)
+ call solve4_2(numeval, (/1,2/), mu2, coeffs, 4, coeffs2)
+ call solve4_2(numeval, (/1,3/), mu2, coeffs, 5, coeffs2)
+ call solve4_2(numeval, (/2,3/), mu2, coeffs, 6, coeffs2)
+ call solve4_3(numeval, (/0,1,2/), mu2, coeffs, 1, coeffs2)
+ call solve4_3(numeval, (/0,1,3/), mu2, coeffs, 2, coeffs2)
+ call solve4_3(numeval, (/0,2,3/), mu2, coeffs, 3, coeffs2)
+ call solve4_3(numeval, (/1,2,3/), mu2, coeffs, 4, coeffs2)
+ call solve4_4(numeval, (/0,1,2,3/), mu2, coeffs, 1, coeffs2)
+ else
+ coeffs%c0 = numeval((/0.0_ki,0.0_ki,0.0_ki,0.0_ki/), mu2)
+ call solve4_1(numeval, (/0/), mu2, coeffs, 1)
+ call solve4_1(numeval, (/1/), mu2, coeffs, 2)
+ call solve4_1(numeval, (/2/), mu2, coeffs, 3)
+ call solve4_1(numeval, (/3/), mu2, coeffs, 4)
+ call solve4_2(numeval, (/0,1/), mu2, coeffs, 1)
+ call solve4_2(numeval, (/0,2/), mu2, coeffs, 2)
+ call solve4_2(numeval, (/0,3/), mu2, coeffs, 3)
+ call solve4_2(numeval, (/1,2/), mu2, coeffs, 4)
+ call solve4_2(numeval, (/1,3/), mu2, coeffs, 5)
+ call solve4_2(numeval, (/2,3/), mu2, coeffs, 6)
+ call solve4_3(numeval, (/0,1,2/), mu2, coeffs, 1)
+ call solve4_3(numeval, (/0,1,3/), mu2, coeffs, 2)
+ call solve4_3(numeval, (/0,2,3/), mu2, coeffs, 3)
+ call solve4_3(numeval, (/1,2,3/), mu2, coeffs, 4)
+ call solve4_4(numeval, (/0,1,2,3/), mu2, coeffs, 1)
+ end if
+end subroutine solve4
+!****f* src/interface/tens_rec/tenseval4
+! NAME
+!
+! Function tenseval4
+!
+! USAGE
+!
+! result = tenseval4(Q, coeffs, max_k)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_4
+! * max_k -- optional integer argument limiting the the reconstruction
+! to a subset of terms with no more than max_k components of q
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval4(Q, coeffs, max_k)
+ ! generated by: write_function_glob_recon
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_4), intent(in) :: coeffs
+ integer, intent(in), optional :: max_k
+ complex(ki) :: tenseval4
+ integer :: maxk
+ if (present(max_k)) then
+ maxk = max_k
+ else
+ maxk = 4
+ end if
+ tenseval4 = coeffs%c0
+ if (1 .le. maxk) then
+ tenseval4 = tenseval4 + tenseval4_1(Q, (/0/), coeffs%c1(1,:))
+ tenseval4 = tenseval4 + tenseval4_1(Q, (/1/), coeffs%c1(2,:))
+ tenseval4 = tenseval4 + tenseval4_1(Q, (/2/), coeffs%c1(3,:))
+ tenseval4 = tenseval4 + tenseval4_1(Q, (/3/), coeffs%c1(4,:))
+ end if
+ if (2 .le. maxk) then
+ tenseval4 = tenseval4 + tenseval4_2(Q, (/0,1/), coeffs%c2(1,:))
+ tenseval4 = tenseval4 + tenseval4_2(Q, (/0,2/), coeffs%c2(2,:))
+ tenseval4 = tenseval4 + tenseval4_2(Q, (/0,3/), coeffs%c2(3,:))
+ tenseval4 = tenseval4 + tenseval4_2(Q, (/1,2/), coeffs%c2(4,:))
+ tenseval4 = tenseval4 + tenseval4_2(Q, (/1,3/), coeffs%c2(5,:))
+ tenseval4 = tenseval4 + tenseval4_2(Q, (/2,3/), coeffs%c2(6,:))
+ end if
+ if (3 .le. maxk) then
+ tenseval4 = tenseval4 + tenseval4_3(Q, (/0,1,2/), coeffs%c3(1,:))
+ tenseval4 = tenseval4 + tenseval4_3(Q, (/0,1,3/), coeffs%c3(2,:))
+ tenseval4 = tenseval4 + tenseval4_3(Q, (/0,2,3/), coeffs%c3(3,:))
+ tenseval4 = tenseval4 + tenseval4_3(Q, (/1,2,3/), coeffs%c3(4,:))
+ end if
+ if (4 .le. maxk) then
+ tenseval4 = tenseval4 + tenseval4_4(Q, (/0,1,2,3/), coeffs%c4(1,:))
+ end if
+end function tenseval4
+!****f* src/interface/tens_rec/ctenseval4
+! NAME
+!
+! Function ctenseval4
+!
+! USAGE
+!
+! result = ctenseval4(Q, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_4
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval4(Q, coeffs)
+ ! generated by: write_function_glob_recon_complex
+ implicit none
+ complex(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_4), intent(in) :: coeffs
+ complex(ki) :: ctenseval4
+ ctenseval4 = coeffs%c0
+ ctenseval4 = ctenseval4 + ctenseval4_1(Q, (/0/), coeffs%c1(1,:))
+ ctenseval4 = ctenseval4 + ctenseval4_1(Q, (/1/), coeffs%c1(2,:))
+ ctenseval4 = ctenseval4 + ctenseval4_1(Q, (/2/), coeffs%c1(3,:))
+ ctenseval4 = ctenseval4 + ctenseval4_1(Q, (/3/), coeffs%c1(4,:))
+ ctenseval4 = ctenseval4 + ctenseval4_2(Q, (/0,1/), coeffs%c2(1,:))
+ ctenseval4 = ctenseval4 + ctenseval4_2(Q, (/0,2/), coeffs%c2(2,:))
+ ctenseval4 = ctenseval4 + ctenseval4_2(Q, (/0,3/), coeffs%c2(3,:))
+ ctenseval4 = ctenseval4 + ctenseval4_2(Q, (/1,2/), coeffs%c2(4,:))
+ ctenseval4 = ctenseval4 + ctenseval4_2(Q, (/1,3/), coeffs%c2(5,:))
+ ctenseval4 = ctenseval4 + ctenseval4_2(Q, (/2,3/), coeffs%c2(6,:))
+ ctenseval4 = ctenseval4 + ctenseval4_3(Q, (/0,1,2/), coeffs%c3(1,:))
+ ctenseval4 = ctenseval4 + ctenseval4_3(Q, (/0,1,3/), coeffs%c3(2,:))
+ ctenseval4 = ctenseval4 + ctenseval4_3(Q, (/0,2,3/), coeffs%c3(3,:))
+ ctenseval4 = ctenseval4 + ctenseval4_3(Q, (/1,2,3/), coeffs%c3(4,:))
+ ctenseval4 = ctenseval4 + ctenseval4_4(Q, (/0,1,2,3/), coeffs%c4(1,:))
+end function ctenseval4
+!****f* src/interface/tens_rec/print_coeffs_4
+! NAME
+!
+! Subroutine print_coeffs_4
+!
+! Visible through public interface print_coeffs
+!
+! USAGE
+!
+! call print_coeffs(coeffs,unit=6)
+!
+! DESCRIPTION
+!
+! Prints the coefficients of a numerator of maximum rank 4
+! in human readable form.
+!
+! INPUTS
+!
+! * coeffs -- a record of type coeff_type_4
+! * unit -- number of an open file, defaults to stdout (unit=6)
+!
+! SIDE EFFECTS
+!
+! Prints to the given file
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine print_coeffs_4(coeffs, unit)
+ ! generated by: write_print_coeffs
+ implicit none
+ type(coeff_type_4), intent(in) :: coeffs
+ integer, intent(in), optional :: unit
+ integer :: ch
+ if (present(unit)) then
+ ch = unit
+ else
+ ch = 6
+ end if
+ write(ch,'(A4,G24.16,1x,G24.16,A1)') ' (', coeffs%c0, ')'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(1,1), ')*q(0)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,2), ')*q(0)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,3), ')*q(0)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,4), ')*q(0)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(2,1), ')*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,2), ')*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,3), ')*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,4), ')*q(1)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(3,1), ')*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,2), ')*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,3), ')*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,4), ')*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(4,1), ')*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,2), ')*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,3), ')*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,4), ')*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(1,1), ')*q(0)*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,2), ')*q(0)*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,3), ')*q(0)*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,4), ')*q(0)^2*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,5), ')*q(0)^2*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,6), ')*q(0)^3*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(2,1), ')*q(0)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,2), ')*q(0)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,3), ')*q(0)*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,4), ')*q(0)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,5), ')*q(0)^2*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,6), ')*q(0)^3*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(3,1), ')*q(0)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,2), ')*q(0)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,3), ')*q(0)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,4), ')*q(0)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,5), ')*q(0)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,6), ')*q(0)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(4,1), ')*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,2), ')*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,3), ')*q(1)*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,4), ')*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,5), ')*q(1)^2*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,6), ')*q(1)^3*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(5,1), ')*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,2), ')*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,3), ')*q(1)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,4), ')*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,5), ')*q(1)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,6), ')*q(1)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(6,1), ')*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,2), ')*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,3), ')*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,4), ')*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,5), ')*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,6), ')*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(1,1), ')*q(0)*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,2), ')*q(0)*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,3), ')*q(0)*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,4), ')*q(0)^2*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(2,1), ')*q(0)*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,2), ')*q(0)*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,3), ')*q(0)*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,4), ')*q(0)^2*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(3,1), ')*q(0)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,2), ')*q(0)*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,3), ')*q(0)*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,4), ')*q(0)^2*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(4,1), ')*q(1)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,2), ')*q(1)*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,3), ')*q(1)*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,4), ')*q(1)^2*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A21)') ' + (', coeffs%c4(1,1), ')*q(0)*q(1)*q(2)*q(3)'
+end subroutine print_coeffs_4
+!****f* src/interface/tens_rec/reconstruct4
+! NAME
+!
+! Subroutine reconstruct4
+!
+! USAGE
+!
+! call reconstruct4(numeval, cm0, cm1, cm2)
+!
+! DESCRIPTION
+!
+! Reconstructs all coefficients of a tensor integral of maximum rank 4,
+! including the coefficients in front of mu2 and mu2^2.
+!
+! INPUTS
+!
+! * numeval -- the numerator function
+! * cm0 -- coefficients of type coeff_type_4, representing the
+! numerator at mu2=0
+! * cm1 -- coefficients of type type(coeff_type_2), representing the
+! tensor in front of mu2 [optional]
+! * cm2 -- coefficients of type type(coeff_type_2), representing the
+! tensor in front of mu2^2 [optional]
+!
+! SIDE EFFECTS
+!
+! Writes results to cm0, cm1 and cm2 (if present). If cm1 and cm2 are omitted
+! only N(q,0) is evaluated. If cm2 is omitted it is assumed that the numerator
+! is at most linear in mu2.
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine reconstruct4(numeval, cm0, cm1, cm2)
+ ! generated by: write_subroutine_reconstruct
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ type(coeff_type_4), intent(out) :: cm0
+ type(coeff_type_2), intent(out), optional :: cm1
+ type(coeff_type_2), intent(out), optional :: cm2
+ type(coeff_type_2) :: ca, cb
+ call solve4(numeval, 0.0_ki, cm0)
+ if (present(cm1)) then
+ if (present(cm2)) then
+ call solve2(numeval, +1.0_ki, ca, cm0)
+ call solve2(numeval, -1.0_ki, cb, cm0)
+ cm1%c0= 0.5_ki * (ca%c0 - cb%c0)
+ cm2%c0= 0.5_ki * (ca%c0 + cb%c0)
+ cm1%c1 = 0.5_ki * (ca%c1 - cb%c1)
+ cm2%c1 = 0.5_ki * (ca%c1 + cb%c1)
+ cm1%c2 = 0.5_ki * (ca%c2 - cb%c2)
+ cm2%c2 = 0.5_ki * (ca%c2 + cb%c2)
+ else
+ call solve2(numeval, +1.0_ki, cm1, cm0)
+ end if
+ end if
+end subroutine reconstruct4
+!****f* src/interface/tens_rec/solve5_1
+! NAME
+!
+! Subroutine solve5_1
+!
+! USAGE
+!
+! call solve5_1(numeval, indices, mu2, coeffs, idx)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q5_1.
+! The matrix mat5_1 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_5 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve5_1(numeval, indices, mu2, coeffs, idx)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(1), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_5), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ complex(ki), dimension(5) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ do i=1,5
+ Q(indices(1)) = q5_1(i,1)
+ xnum(i) = numeval(Q, mu2) - tenseval5(Q, coeffs, 0)
+ end do
+ coeffs%c1(idx,:) = matmul(mat5_1,xnum)
+end subroutine solve5_1
+!****f* src/interface/tens_rec/tenseval5_1
+! NAME
+!
+! Function tenseval5_1
+!
+! USAGE
+!
+! result = tenseval5_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(5) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval5_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(5), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval5_1
+ real(ki) :: q0
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(4) + coeffs(5)*q0
+ reg3 = acc*q0
+ acc = coeffs(3)
+ acc = acc + reg3
+ reg2 = acc*q0
+ acc = coeffs(2)
+ acc = acc + reg2
+ reg1 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg1
+ acc = acc*q0
+ tenseval5_1 = acc
+end function tenseval5_1
+!****f* src/interface/tens_rec/ctenseval5_1
+! NAME
+!
+! Function ctenseval5_1
+!
+! USAGE
+!
+! result = ctenseval5_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(5) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval5_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(5), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval5_1
+ complex(ki) :: q0
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(4) + coeffs(5)*q0
+ reg3 = acc*q0
+ acc = coeffs(3)
+ acc = acc + reg3
+ reg2 = acc*q0
+ acc = coeffs(2)
+ acc = acc + reg2
+ reg1 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg1
+ acc = acc*q0
+ ctenseval5_1 = acc
+end function ctenseval5_1
+!****f* src/interface/tens_rec/solve5_2
+! NAME
+!
+! Subroutine solve5_2
+!
+! USAGE
+!
+! call solve5_2(numeval, indices, mu2, coeffs, idx)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q5_2.
+! The matrix mat5_2 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_5 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve5_2(numeval, indices, mu2, coeffs, idx)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(2), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_5), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ complex(ki), dimension(10) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ do i=1,10
+ Q(indices(1)) = q5_2(i,1)
+ Q(indices(2)) = q5_2(i,2)
+ xnum(i) = numeval(Q, mu2) - tenseval5(Q, coeffs, 1)
+ end do
+ coeffs%c2(idx,:) = matmul(mat5_2,xnum)
+end subroutine solve5_2
+!****f* src/interface/tens_rec/tenseval5_2
+! NAME
+!
+! Function tenseval5_2
+!
+! USAGE
+!
+! result = tenseval5_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(10) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval5_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(10), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval5_2
+ real(ki) :: q0
+ real(ki) :: q1
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(7)*q1 + coeffs(9)*q0 + coeffs(6)
+ reg2 = acc*q0
+ acc = coeffs(4)*q1 + coeffs(3)
+ reg3 = acc*q1
+ acc = coeffs(2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc*q1
+ acc = coeffs(10)*q0 + coeffs(8)
+ reg3 = acc*q0
+ acc = coeffs(5)
+ acc = acc + reg3
+ reg2 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1
+ tenseval5_2 = acc
+end function tenseval5_2
+!****f* src/interface/tens_rec/ctenseval5_2
+! NAME
+!
+! Function ctenseval5_2
+!
+! USAGE
+!
+! result = ctenseval5_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(10) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval5_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(10), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval5_2
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(7)*q1 + coeffs(9)*q0 + coeffs(6)
+ reg2 = acc*q0
+ acc = coeffs(4)*q1 + coeffs(3)
+ reg3 = acc*q1
+ acc = coeffs(2)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc*q1
+ acc = coeffs(10)*q0 + coeffs(8)
+ reg3 = acc*q0
+ acc = coeffs(5)
+ acc = acc + reg3
+ reg2 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1
+ ctenseval5_2 = acc
+end function ctenseval5_2
+!****f* src/interface/tens_rec/solve5_3
+! NAME
+!
+! Subroutine solve5_3
+!
+! USAGE
+!
+! call solve5_3(numeval, indices, mu2, coeffs, idx)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q5_3.
+! The matrix mat5_3 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_5 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve5_3(numeval, indices, mu2, coeffs, idx)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(3), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_5), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ complex(ki), dimension(10) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ do i=1,10
+ Q(indices(1)) = q5_3(i,1)
+ Q(indices(2)) = q5_3(i,2)
+ Q(indices(3)) = q5_3(i,3)
+ xnum(i) = numeval(Q, mu2) - tenseval5(Q, coeffs, 2)
+ end do
+ coeffs%c3(idx,:) = matmul(mat5_3,xnum)
+end subroutine solve5_3
+!****f* src/interface/tens_rec/tenseval5_3
+! NAME
+!
+! Function tenseval5_3
+!
+! USAGE
+!
+! result = tenseval5_3(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 3 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(3): the set of non-zero indices.
+! * coeffs -- an array of dimension(10) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 3 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval5_3(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(3), intent(in) :: indices
+ complex(ki), dimension(10), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval5_3
+ real(ki) :: q0
+ real(ki) :: q1
+ real(ki) :: q2
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ acc = coeffs(10)*q0 + coeffs(9)*q1 + coeffs(7) + coeffs(8)*q2
+ reg1 = acc*q0
+ acc = coeffs(6)*q1 + coeffs(4) + coeffs(5)*q2
+ reg2 = acc*q1
+ acc = coeffs(2) + coeffs(3)*q2
+ reg3 = acc*q2
+ acc = coeffs(1)
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1*q2
+ tenseval5_3 = acc
+end function tenseval5_3
+!****f* src/interface/tens_rec/ctenseval5_3
+! NAME
+!
+! Function ctenseval5_3
+!
+! USAGE
+!
+! result = ctenseval5_3(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 3 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(3): the set of non-zero indices.
+! * coeffs -- an array of dimension(10) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 3 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval5_3(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(3), intent(in) :: indices
+ complex(ki), dimension(10), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval5_3
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: q2
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ acc = coeffs(10)*q0 + coeffs(9)*q1 + coeffs(7) + coeffs(8)*q2
+ reg1 = acc*q0
+ acc = coeffs(6)*q1 + coeffs(4) + coeffs(5)*q2
+ reg2 = acc*q1
+ acc = coeffs(2) + coeffs(3)*q2
+ reg3 = acc*q2
+ acc = coeffs(1)
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1*q2
+ ctenseval5_3 = acc
+end function ctenseval5_3
+!****f* src/interface/tens_rec/solve5_4
+! NAME
+!
+! Subroutine solve5_4
+!
+! USAGE
+!
+! call solve5_4(numeval, indices, mu2, coeffs, idx)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q5_4.
+! The matrix mat5_4 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_5 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve5_4(numeval, indices, mu2, coeffs, idx)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(4), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_5), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ complex(ki), dimension(5) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ do i=1,5
+ Q(indices(1)) = q5_4(i,1)
+ Q(indices(2)) = q5_4(i,2)
+ Q(indices(3)) = q5_4(i,3)
+ Q(indices(4)) = q5_4(i,4)
+ xnum(i) = numeval(Q, mu2) - tenseval5(Q, coeffs, 3)
+ end do
+ coeffs%c4(idx,:) = matmul(mat5_4,xnum)
+end subroutine solve5_4
+!****f* src/interface/tens_rec/tenseval5_4
+! NAME
+!
+! Function tenseval5_4
+!
+! USAGE
+!
+! result = tenseval5_4(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 4 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(4): the set of non-zero indices.
+! * coeffs -- an array of dimension(5) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 4 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval5_4(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(4), intent(in) :: indices
+ complex(ki), dimension(5), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval5_4
+ real(ki) :: q0
+ real(ki) :: q1
+ real(ki) :: q2
+ real(ki) :: q3
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ q3 = Q(indices(4))
+ acc = coeffs(2)*q3 + coeffs(1) + coeffs(5)*q0 + coeffs(3)*q2 + coeffs(4)*q1
+ acc = acc*q0*q1*q2*q3
+ tenseval5_4 = acc
+end function tenseval5_4
+!****f* src/interface/tens_rec/ctenseval5_4
+! NAME
+!
+! Function ctenseval5_4
+!
+! USAGE
+!
+! result = ctenseval5_4(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 4 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(4): the set of non-zero indices.
+! * coeffs -- an array of dimension(5) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 4 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval5_4(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(4), intent(in) :: indices
+ complex(ki), dimension(5), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval5_4
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: q2
+ complex(ki) :: q3
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ q3 = Q(indices(4))
+ acc = coeffs(2)*q3 + coeffs(1) + coeffs(5)*q0 + coeffs(3)*q2 + coeffs(4)*q1
+ acc = acc*q0*q1*q2*q3
+ ctenseval5_4 = acc
+end function ctenseval5_4
+!****f* src/interface/tens_rec/solve5
+! NAME
+!
+! Subroutine solve5
+!
+! USAGE
+!
+! call solve5(numeval, mu2, coeffs)
+!
+! DESCRIPTION
+!
+! Determines the tensor coefficients of a numerator for a fixed value
+! of mu^2 with maximum rank 5
+!
+! INPUTS
+!
+! * numeval -- function representing the numerator of the problem
+! * mu2 -- fixed value of mu^2 for which the numerator is evaluated
+! * coeffs -- a record of type coeff_type_5 used to store the result
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve5(numeval, mu2, coeffs)
+ ! generated by: write_subroutine_glob_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ real(ki), intent(in) :: mu2
+ type(coeff_type_5), intent(inout) :: coeffs
+ coeffs%c0 = numeval((/0.0_ki,0.0_ki,0.0_ki,0.0_ki/), mu2)
+ call solve5_1(numeval, (/0/), mu2, coeffs, 1)
+ call solve5_1(numeval, (/1/), mu2, coeffs, 2)
+ call solve5_1(numeval, (/2/), mu2, coeffs, 3)
+ call solve5_1(numeval, (/3/), mu2, coeffs, 4)
+ call solve5_2(numeval, (/0,1/), mu2, coeffs, 1)
+ call solve5_2(numeval, (/0,2/), mu2, coeffs, 2)
+ call solve5_2(numeval, (/0,3/), mu2, coeffs, 3)
+ call solve5_2(numeval, (/1,2/), mu2, coeffs, 4)
+ call solve5_2(numeval, (/1,3/), mu2, coeffs, 5)
+ call solve5_2(numeval, (/2,3/), mu2, coeffs, 6)
+ call solve5_3(numeval, (/0,1,2/), mu2, coeffs, 1)
+ call solve5_3(numeval, (/0,1,3/), mu2, coeffs, 2)
+ call solve5_3(numeval, (/0,2,3/), mu2, coeffs, 3)
+ call solve5_3(numeval, (/1,2,3/), mu2, coeffs, 4)
+ call solve5_4(numeval, (/0,1,2,3/), mu2, coeffs, 1)
+end subroutine solve5
+!****f* src/interface/tens_rec/tenseval5
+! NAME
+!
+! Function tenseval5
+!
+! USAGE
+!
+! result = tenseval5(Q, coeffs, max_k)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_5
+! * max_k -- optional integer argument limiting the the reconstruction
+! to a subset of terms with no more than max_k components of q
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval5(Q, coeffs, max_k)
+ ! generated by: write_function_glob_recon
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_5), intent(in) :: coeffs
+ integer, intent(in), optional :: max_k
+ complex(ki) :: tenseval5
+ integer :: maxk
+ if (present(max_k)) then
+ maxk = max_k
+ else
+ maxk = 4
+ end if
+ tenseval5 = coeffs%c0
+ if (1 .le. maxk) then
+ tenseval5 = tenseval5 + tenseval5_1(Q, (/0/), coeffs%c1(1,:))
+ tenseval5 = tenseval5 + tenseval5_1(Q, (/1/), coeffs%c1(2,:))
+ tenseval5 = tenseval5 + tenseval5_1(Q, (/2/), coeffs%c1(3,:))
+ tenseval5 = tenseval5 + tenseval5_1(Q, (/3/), coeffs%c1(4,:))
+ end if
+ if (2 .le. maxk) then
+ tenseval5 = tenseval5 + tenseval5_2(Q, (/0,1/), coeffs%c2(1,:))
+ tenseval5 = tenseval5 + tenseval5_2(Q, (/0,2/), coeffs%c2(2,:))
+ tenseval5 = tenseval5 + tenseval5_2(Q, (/0,3/), coeffs%c2(3,:))
+ tenseval5 = tenseval5 + tenseval5_2(Q, (/1,2/), coeffs%c2(4,:))
+ tenseval5 = tenseval5 + tenseval5_2(Q, (/1,3/), coeffs%c2(5,:))
+ tenseval5 = tenseval5 + tenseval5_2(Q, (/2,3/), coeffs%c2(6,:))
+ end if
+ if (3 .le. maxk) then
+ tenseval5 = tenseval5 + tenseval5_3(Q, (/0,1,2/), coeffs%c3(1,:))
+ tenseval5 = tenseval5 + tenseval5_3(Q, (/0,1,3/), coeffs%c3(2,:))
+ tenseval5 = tenseval5 + tenseval5_3(Q, (/0,2,3/), coeffs%c3(3,:))
+ tenseval5 = tenseval5 + tenseval5_3(Q, (/1,2,3/), coeffs%c3(4,:))
+ end if
+ if (4 .le. maxk) then
+ tenseval5 = tenseval5 + tenseval5_4(Q, (/0,1,2,3/), coeffs%c4(1,:))
+ end if
+end function tenseval5
+!****f* src/interface/tens_rec/ctenseval5
+! NAME
+!
+! Function ctenseval5
+!
+! USAGE
+!
+! result = ctenseval5(Q, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_5
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval5(Q, coeffs)
+ ! generated by: write_function_glob_recon_complex
+ implicit none
+ complex(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_5), intent(in) :: coeffs
+ complex(ki) :: ctenseval5
+ ctenseval5 = coeffs%c0
+ ctenseval5 = ctenseval5 + ctenseval5_1(Q, (/0/), coeffs%c1(1,:))
+ ctenseval5 = ctenseval5 + ctenseval5_1(Q, (/1/), coeffs%c1(2,:))
+ ctenseval5 = ctenseval5 + ctenseval5_1(Q, (/2/), coeffs%c1(3,:))
+ ctenseval5 = ctenseval5 + ctenseval5_1(Q, (/3/), coeffs%c1(4,:))
+ ctenseval5 = ctenseval5 + ctenseval5_2(Q, (/0,1/), coeffs%c2(1,:))
+ ctenseval5 = ctenseval5 + ctenseval5_2(Q, (/0,2/), coeffs%c2(2,:))
+ ctenseval5 = ctenseval5 + ctenseval5_2(Q, (/0,3/), coeffs%c2(3,:))
+ ctenseval5 = ctenseval5 + ctenseval5_2(Q, (/1,2/), coeffs%c2(4,:))
+ ctenseval5 = ctenseval5 + ctenseval5_2(Q, (/1,3/), coeffs%c2(5,:))
+ ctenseval5 = ctenseval5 + ctenseval5_2(Q, (/2,3/), coeffs%c2(6,:))
+ ctenseval5 = ctenseval5 + ctenseval5_3(Q, (/0,1,2/), coeffs%c3(1,:))
+ ctenseval5 = ctenseval5 + ctenseval5_3(Q, (/0,1,3/), coeffs%c3(2,:))
+ ctenseval5 = ctenseval5 + ctenseval5_3(Q, (/0,2,3/), coeffs%c3(3,:))
+ ctenseval5 = ctenseval5 + ctenseval5_3(Q, (/1,2,3/), coeffs%c3(4,:))
+ ctenseval5 = ctenseval5 + ctenseval5_4(Q, (/0,1,2,3/), coeffs%c4(1,:))
+end function ctenseval5
+!****f* src/interface/tens_rec/print_coeffs_5
+! NAME
+!
+! Subroutine print_coeffs_5
+!
+! Visible through public interface print_coeffs
+!
+! USAGE
+!
+! call print_coeffs(coeffs,unit=6)
+!
+! DESCRIPTION
+!
+! Prints the coefficients of a numerator of maximum rank 5
+! in human readable form.
+!
+! INPUTS
+!
+! * coeffs -- a record of type coeff_type_5
+! * unit -- number of an open file, defaults to stdout (unit=6)
+!
+! SIDE EFFECTS
+!
+! Prints to the given file
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine print_coeffs_5(coeffs, unit)
+ ! generated by: write_print_coeffs
+ implicit none
+ type(coeff_type_5), intent(in) :: coeffs
+ integer, intent(in), optional :: unit
+ integer :: ch
+ if (present(unit)) then
+ ch = unit
+ else
+ ch = 6
+ end if
+ write(ch,'(A4,G24.16,1x,G24.16,A1)') ' (', coeffs%c0, ')'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(1,1), ')*q(0)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,2), ')*q(0)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,3), ')*q(0)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,4), ')*q(0)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,5), ')*q(0)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(2,1), ')*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,2), ')*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,3), ')*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,4), ')*q(1)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,5), ')*q(1)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(3,1), ')*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,2), ')*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,3), ')*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,4), ')*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,5), ')*q(2)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(4,1), ')*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,2), ')*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,3), ')*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,4), ')*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,5), ')*q(3)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(1,1), ')*q(0)*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,2), ')*q(0)*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,3), ')*q(0)*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,4), ')*q(0)*q(1)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,5), ')*q(0)^2*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,6), ')*q(0)^2*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,7), ')*q(0)^2*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,8), ')*q(0)^3*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,9), ')*q(0)^3*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,10), ')*q(0)^4*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(2,1), ')*q(0)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,2), ')*q(0)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,3), ')*q(0)*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,4), ')*q(0)*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,5), ')*q(0)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,6), ')*q(0)^2*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,7), ')*q(0)^2*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,8), ')*q(0)^3*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,9), ')*q(0)^3*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,10), ')*q(0)^4*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(3,1), ')*q(0)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,2), ')*q(0)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,3), ')*q(0)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,4), ')*q(0)*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,5), ')*q(0)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,6), ')*q(0)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,7), ')*q(0)^2*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,8), ')*q(0)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,9), ')*q(0)^3*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,10), ')*q(0)^4*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(4,1), ')*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,2), ')*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,3), ')*q(1)*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,4), ')*q(1)*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,5), ')*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,6), ')*q(1)^2*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,7), ')*q(1)^2*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,8), ')*q(1)^3*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,9), ')*q(1)^3*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,10), ')*q(1)^4*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(5,1), ')*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,2), ')*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,3), ')*q(1)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,4), ')*q(1)*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,5), ')*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,6), ')*q(1)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,7), ')*q(1)^2*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,8), ')*q(1)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,9), ')*q(1)^3*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,10), ')*q(1)^4*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(6,1), ')*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,2), ')*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,3), ')*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,4), ')*q(2)*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,5), ')*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,6), ')*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,7), ')*q(2)^2*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,8), ')*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,9), ')*q(2)^3*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,10), ')*q(2)^4*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(1,1), ')*q(0)*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,2), ')*q(0)*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,3), ')*q(0)*q(1)*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,4), ')*q(0)*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,5), ')*q(0)*q(1)^2*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,6), ')*q(0)*q(1)^3*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,7), ')*q(0)^2*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,8), ')*q(0)^2*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,9), ')*q(0)^2*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,10), ')*q(0)^3*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(2,1), ')*q(0)*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,2), ')*q(0)*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,3), ')*q(0)*q(1)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,4), ')*q(0)*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,5), ')*q(0)*q(1)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,6), ')*q(0)*q(1)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,7), ')*q(0)^2*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,8), ')*q(0)^2*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,9), ')*q(0)^2*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,10), ')*q(0)^3*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(3,1), ')*q(0)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,2), ')*q(0)*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,3), ')*q(0)*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,4), ')*q(0)*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,5), ')*q(0)*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,6), ')*q(0)*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,7), ')*q(0)^2*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,8), ')*q(0)^2*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,9), ')*q(0)^2*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,10), ')*q(0)^3*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(4,1), ')*q(1)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,2), ')*q(1)*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,3), ')*q(1)*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,4), ')*q(1)*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,5), ')*q(1)*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,6), ')*q(1)*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,7), ')*q(1)^2*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,8), ')*q(1)^2*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,9), ')*q(1)^2*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,10), ')*q(1)^3*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A21)') ' + (', coeffs%c4(1,1), ')*q(0)*q(1)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,2), ')*q(0)*q(1)*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,3), ')*q(0)*q(1)*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,4), ')*q(0)*q(1)^2*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,5), ')*q(0)^2*q(1)*q(2)*q(3)'
+end subroutine print_coeffs_5
+!****f* src/interface/tens_rec/reconstruct5
+! NAME
+!
+! Subroutine reconstruct5
+!
+! USAGE
+!
+! call reconstruct5(numeval, cm0, cm1, cm2)
+!
+! DESCRIPTION
+!
+! Reconstructs all coefficients of a tensor integral of maximum rank 5,
+! including the coefficients in front of mu2 and mu2^2.
+!
+! INPUTS
+!
+! * numeval -- the numerator function
+! * cm0 -- coefficients of type coeff_type_5, representing the
+! numerator at mu2=0
+! * cm1 -- coefficients of type type(coeff_type_3), representing the
+! tensor in front of mu2 [optional]
+! * cm2 -- coefficients of type type(coeff_type_3), representing the
+! tensor in front of mu2^2 [optional]
+!
+! SIDE EFFECTS
+!
+! Writes results to cm0, cm1 and cm2 (if present). If cm1 and cm2 are omitted
+! only N(q,0) is evaluated. If cm2 is omitted it is assumed that the numerator
+! is at most linear in mu2.
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine reconstruct5(numeval, cm0, cm1, cm2)
+ ! generated by: write_subroutine_reconstruct
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ type(coeff_type_5), intent(out) :: cm0
+ type(coeff_type_3), intent(out), optional :: cm1
+ type(coeff_type_3), intent(out), optional :: cm2
+ type(coeff_type_3) :: ca, cb
+ call solve5(numeval, 0.0_ki, cm0)
+ if (present(cm1)) then
+ if (present(cm2)) then
+ call solve3(numeval, +1.0_ki, ca, cm0)
+ call solve3(numeval, -1.0_ki, cb, cm0)
+ cm1%c0= 0.5_ki * (ca%c0 - cb%c0)
+ cm2%c0= 0.5_ki * (ca%c0 + cb%c0)
+ cm1%c1 = 0.5_ki * (ca%c1 - cb%c1)
+ cm2%c1 = 0.5_ki * (ca%c1 + cb%c1)
+ cm1%c2 = 0.5_ki * (ca%c2 - cb%c2)
+ cm2%c2 = 0.5_ki * (ca%c2 + cb%c2)
+ cm1%c3 = 0.5_ki * (ca%c3 - cb%c3)
+ cm2%c3 = 0.5_ki * (ca%c3 + cb%c3)
+ else
+ call solve3(numeval, +1.0_ki, cm1, cm0)
+ end if
+ end if
+end subroutine reconstruct5
+!****f* src/interface/tens_rec/solve6_1
+! NAME
+!
+! Subroutine solve6_1
+!
+! USAGE
+!
+! call solve6_1(numeval, indices, mu2, coeffs, idx)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q6_1.
+! The matrix mat6_1 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_6 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve6_1(numeval, indices, mu2, coeffs, idx)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(1), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_6), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ complex(ki), dimension(6) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ do i=1,6
+ Q(indices(1)) = q6_1(i,1)
+ xnum(i) = numeval(Q, mu2) - tenseval6(Q, coeffs, 0)
+ end do
+ coeffs%c1(idx,:) = matmul(mat6_1,xnum)
+end subroutine solve6_1
+!****f* src/interface/tens_rec/tenseval6_1
+! NAME
+!
+! Function tenseval6_1
+!
+! USAGE
+!
+! result = tenseval6_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(6) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval6_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(6), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval6_1
+ real(ki) :: q0
+ complex(ki) :: reg4
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(5) + coeffs(6)*q0
+ reg4 = acc*q0
+ acc = coeffs(4)
+ acc = acc + reg4
+ reg3 = acc*q0
+ acc = coeffs(3)
+ acc = acc + reg3
+ reg2 = acc*q0
+ acc = coeffs(2)
+ acc = acc + reg2
+ reg1 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg1
+ acc = acc*q0
+ tenseval6_1 = acc
+end function tenseval6_1
+!****f* src/interface/tens_rec/ctenseval6_1
+! NAME
+!
+! Function ctenseval6_1
+!
+! USAGE
+!
+! result = ctenseval6_1(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 1 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(1): the set of non-zero indices.
+! * coeffs -- an array of dimension(6) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 1 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval6_1(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(1), intent(in) :: indices
+ complex(ki), dimension(6), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval6_1
+ complex(ki) :: q0
+ complex(ki) :: reg4
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ acc = coeffs(5) + coeffs(6)*q0
+ reg4 = acc*q0
+ acc = coeffs(4)
+ acc = acc + reg4
+ reg3 = acc*q0
+ acc = coeffs(3)
+ acc = acc + reg3
+ reg2 = acc*q0
+ acc = coeffs(2)
+ acc = acc + reg2
+ reg1 = acc*q0
+ acc = coeffs(1)
+ acc = acc + reg1
+ acc = acc*q0
+ ctenseval6_1 = acc
+end function ctenseval6_1
+!****f* src/interface/tens_rec/solve6_2
+! NAME
+!
+! Subroutine solve6_2
+!
+! USAGE
+!
+! call solve6_2(numeval, indices, mu2, coeffs, idx)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q6_2.
+! The matrix mat6_2 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_6 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve6_2(numeval, indices, mu2, coeffs, idx)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(2), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_6), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ complex(ki), dimension(15) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ do i=1,15
+ Q(indices(1)) = q6_2(i,1)
+ Q(indices(2)) = q6_2(i,2)
+ xnum(i) = numeval(Q, mu2) - tenseval6(Q, coeffs, 1)
+ end do
+ coeffs%c2(idx,:) = matmul(mat6_2,xnum)
+end subroutine solve6_2
+!****f* src/interface/tens_rec/tenseval6_2
+! NAME
+!
+! Function tenseval6_2
+!
+! USAGE
+!
+! result = tenseval6_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(15) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval6_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(15), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval6_2
+ real(ki) :: q0
+ real(ki) :: q1
+ complex(ki) :: reg4
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(12)*q1 + coeffs(14)*q0 + coeffs(11)
+ reg3 = acc*q0
+ acc = coeffs(9)*q1 + coeffs(8)
+ reg4 = acc*q1
+ acc = coeffs(7)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc*q1
+ acc = coeffs(15)*q0 + coeffs(13)
+ reg4 = acc*q0
+ acc = coeffs(10)
+ acc = acc + reg4
+ reg3 = acc*q0
+ acc = coeffs(6)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc*q0
+ acc = coeffs(5)*q1 + coeffs(4)
+ reg4 = acc*q1
+ acc = coeffs(3)
+ acc = acc + reg4
+ reg3 = acc*q1
+ acc = coeffs(2)
+ acc = acc + reg3
+ reg2 = acc*q1
+ acc = coeffs(1)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1
+ tenseval6_2 = acc
+end function tenseval6_2
+!****f* src/interface/tens_rec/ctenseval6_2
+! NAME
+!
+! Function ctenseval6_2
+!
+! USAGE
+!
+! result = ctenseval6_2(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 2 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(2): the set of non-zero indices.
+! * coeffs -- an array of dimension(15) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 2 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval6_2(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(2), intent(in) :: indices
+ complex(ki), dimension(15), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval6_2
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: reg4
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ acc = coeffs(12)*q1 + coeffs(14)*q0 + coeffs(11)
+ reg3 = acc*q0
+ acc = coeffs(9)*q1 + coeffs(8)
+ reg4 = acc*q1
+ acc = coeffs(7)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc*q1
+ acc = coeffs(15)*q0 + coeffs(13)
+ reg4 = acc*q0
+ acc = coeffs(10)
+ acc = acc + reg4
+ reg3 = acc*q0
+ acc = coeffs(6)
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc*q0
+ acc = coeffs(5)*q1 + coeffs(4)
+ reg4 = acc*q1
+ acc = coeffs(3)
+ acc = acc + reg4
+ reg3 = acc*q1
+ acc = coeffs(2)
+ acc = acc + reg3
+ reg2 = acc*q1
+ acc = coeffs(1)
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1
+ ctenseval6_2 = acc
+end function ctenseval6_2
+!****f* src/interface/tens_rec/solve6_3
+! NAME
+!
+! Subroutine solve6_3
+!
+! USAGE
+!
+! call solve6_3(numeval, indices, mu2, coeffs, idx)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q6_3.
+! The matrix mat6_3 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_6 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve6_3(numeval, indices, mu2, coeffs, idx)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(3), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_6), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ complex(ki), dimension(20) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ Q(:)=0.0_ki
+ do i=1,20
+ Q(indices(1)) = q6_3(i,1)
+ Q(indices(2)) = q6_3(i,2)
+ Q(indices(3)) = q6_3(i,3)
+ xnum(i) = numeval(Q, mu2) - tenseval6(Q, coeffs, 2)
+ end do
+ coeffs%c3(idx,:) = matmul(mat6_3,xnum)
+end subroutine solve6_3
+!****f* src/interface/tens_rec/tenseval6_3
+! NAME
+!
+! Function tenseval6_3
+!
+! USAGE
+!
+! result = tenseval6_3(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 3 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(3): the set of non-zero indices.
+! * coeffs -- an array of dimension(20) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 3 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval6_3(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(3), intent(in) :: indices
+ complex(ki), dimension(20), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval6_3
+ real(ki) :: q0
+ real(ki) :: q1
+ real(ki) :: q2
+ complex(ki) :: reg4
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ acc = coeffs(18)*q0 + coeffs(15)*q1 + coeffs(12) + coeffs(13)*q2
+ reg2 = acc*q0
+ acc = coeffs(9)*q1 + coeffs(6) + coeffs(7)*q2
+ reg3 = acc*q1
+ acc = coeffs(3) + coeffs(4)*q2
+ reg4 = acc*q2
+ acc = coeffs(2)
+ acc = acc + reg4
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc*q2
+ acc = coeffs(20)*q0 + coeffs(19)*q1 + coeffs(17)
+ reg3 = acc*q0
+ acc = coeffs(16)*q1 + coeffs(14)
+ reg4 = acc*q1
+ acc = coeffs(11)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc*q0
+ acc = coeffs(10)*q1 + coeffs(8)
+ reg4 = acc*q1
+ acc = coeffs(5)
+ acc = acc + reg4
+ reg3 = acc*q1
+ acc = coeffs(1)
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1*q2
+ tenseval6_3 = acc
+end function tenseval6_3
+!****f* src/interface/tens_rec/ctenseval6_3
+! NAME
+!
+! Function ctenseval6_3
+!
+! USAGE
+!
+! result = ctenseval6_3(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 3 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(3): the set of non-zero indices.
+! * coeffs -- an array of dimension(20) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 3 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval6_3(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(3), intent(in) :: indices
+ complex(ki), dimension(20), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval6_3
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: q2
+ complex(ki) :: reg4
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ acc = coeffs(18)*q0 + coeffs(15)*q1 + coeffs(12) + coeffs(13)*q2
+ reg2 = acc*q0
+ acc = coeffs(9)*q1 + coeffs(6) + coeffs(7)*q2
+ reg3 = acc*q1
+ acc = coeffs(3) + coeffs(4)*q2
+ reg4 = acc*q2
+ acc = coeffs(2)
+ acc = acc + reg4
+ acc = acc + reg3
+ acc = acc + reg2
+ reg1 = acc*q2
+ acc = coeffs(20)*q0 + coeffs(19)*q1 + coeffs(17)
+ reg3 = acc*q0
+ acc = coeffs(16)*q1 + coeffs(14)
+ reg4 = acc*q1
+ acc = coeffs(11)
+ acc = acc + reg4
+ acc = acc + reg3
+ reg2 = acc*q0
+ acc = coeffs(10)*q1 + coeffs(8)
+ reg4 = acc*q1
+ acc = coeffs(5)
+ acc = acc + reg4
+ reg3 = acc*q1
+ acc = coeffs(1)
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1*q2
+ ctenseval6_3 = acc
+end function ctenseval6_3
+!****f* src/interface/tens_rec/solve6_4
+! NAME
+!
+! Subroutine solve6_4
+!
+! USAGE
+!
+! call solve6_4(numeval, indices, mu2, coeffs, idx)
+!
+! DESCRIPTION
+!
+! This subroutine solves a system generated by substituting the
+! non-zero components of q in the numerator function numeval(q,mu2)
+! for the values given in the array q6_4.
+! The matrix mat6_4 is the inverse matrix of the left hand side
+! of the original system.
+!
+! INPUTS
+!
+! * numeval -- a function representing the numerator function
+! N(q, mu2) where q(0:3) is a real vector,
+! mu2 is a real number and the result of numeval is complex
+! * indices -- array of integers indicating the non-zero entries of q
+! * mu2 -- fixed value for mu2 passed to numeval
+! * coeffs -- coefficients of type coeff_type_6 to be solved for
+! * idx -- label indicating which entries in coeffs the given set
+! of indices corresponds to
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! No return value
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve6_4(numeval, indices, mu2, coeffs, idx)
+ ! generated by: write_subroutine_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ integer, dimension(4), intent(in) :: indices
+ real(ki), intent(in) :: mu2
+ type(coeff_type_6), intent(inout) :: coeffs
+ integer, intent(in) :: idx
+ complex(ki), dimension(15) :: xnum
+ real(ki), dimension(0:3) :: Q
+ integer :: i
+ do i=1,15
+ Q(indices(1)) = q6_4(i,1)
+ Q(indices(2)) = q6_4(i,2)
+ Q(indices(3)) = q6_4(i,3)
+ Q(indices(4)) = q6_4(i,4)
+ xnum(i) = numeval(Q, mu2) - tenseval6(Q, coeffs, 3)
+ end do
+ coeffs%c4(idx,:) = matmul(mat6_4,xnum)
+end subroutine solve6_4
+!****f* src/interface/tens_rec/tenseval6_4
+! NAME
+!
+! Function tenseval6_4
+!
+! USAGE
+!
+! result = tenseval6_4(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 4 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * indices -- array of dimension(4): the set of non-zero indices.
+! * coeffs -- an array of dimension(15) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 4 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval6_4(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(4), intent(in) :: indices
+ complex(ki), dimension(15), intent(in) :: coeffs
+ real(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: tenseval6_4
+ real(ki) :: q0
+ real(ki) :: q1
+ real(ki) :: q2
+ real(ki) :: q3
+ complex(ki) :: reg4
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ q3 = Q(indices(4))
+ acc = coeffs(12)*q3 + coeffs(11) + coeffs(15)*q0 + coeffs(14)*q1
+ acc = acc + coeffs(13)*q2
+ reg1 = acc*q0
+ acc = coeffs(8)*q3 + coeffs(7) + coeffs(10)*q1 + coeffs(9)*q2
+ reg2 = acc*q1
+ acc = coeffs(5)*q3 + coeffs(4) + coeffs(6)*q2
+ reg3 = acc*q2
+ acc = coeffs(3)*q3 + coeffs(2)
+ reg4 = acc*q3
+ acc = coeffs(1)
+ acc = acc + reg4
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1*q2*q3
+ tenseval6_4 = acc
+end function tenseval6_4
+!****f* src/interface/tens_rec/ctenseval6_4
+! NAME
+!
+! Function ctenseval6_4
+!
+! USAGE
+!
+! result = ctenseval6_4(Q, indices, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes the part of N(Q) from the coefficients where Q has exactly
+! 4 non-zero entries identified by the array indices.
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * indices -- array of dimension(4): the set of non-zero indices.
+! * coeffs -- an array of dimension(15) holding the coefficients.
+! as defined in the corresponding derived type.
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) coming from the terms where
+! exactly the 4 entries of q specified in indices are non-zero.
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval6_4(Q, indices, coeffs)
+ ! generated by: write_function_recon
+ implicit none
+ integer, dimension(4), intent(in) :: indices
+ complex(ki), dimension(15), intent(in) :: coeffs
+ complex(ki), dimension(0:3), intent(in) :: Q
+ complex(ki) :: ctenseval6_4
+ complex(ki) :: q0
+ complex(ki) :: q1
+ complex(ki) :: q2
+ complex(ki) :: q3
+ complex(ki) :: reg4
+ complex(ki) :: reg2
+ complex(ki) :: reg3
+ complex(ki) :: reg1
+ complex(ki) :: acc
+ q0 = Q(indices(1))
+ q1 = Q(indices(2))
+ q2 = Q(indices(3))
+ q3 = Q(indices(4))
+ acc = coeffs(12)*q3 + coeffs(11) + coeffs(15)*q0 + coeffs(14)*q1
+ acc = acc + coeffs(13)*q2
+ reg1 = acc*q0
+ acc = coeffs(8)*q3 + coeffs(7) + coeffs(10)*q1 + coeffs(9)*q2
+ reg2 = acc*q1
+ acc = coeffs(5)*q3 + coeffs(4) + coeffs(6)*q2
+ reg3 = acc*q2
+ acc = coeffs(3)*q3 + coeffs(2)
+ reg4 = acc*q3
+ acc = coeffs(1)
+ acc = acc + reg4
+ acc = acc + reg3
+ acc = acc + reg2
+ acc = acc + reg1
+ acc = acc*q0*q1*q2*q3
+ ctenseval6_4 = acc
+end function ctenseval6_4
+!****f* src/interface/tens_rec/solve6
+! NAME
+!
+! Subroutine solve6
+!
+! USAGE
+!
+! call solve6(numeval, mu2, coeffs)
+!
+! DESCRIPTION
+!
+! Determines the tensor coefficients of a numerator for a fixed value
+! of mu^2 with maximum rank 6
+!
+! INPUTS
+!
+! * numeval -- function representing the numerator of the problem
+! * mu2 -- fixed value of mu^2 for which the numerator is evaluated
+! * coeffs -- a record of type coeff_type_6 used to store the result
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine solve6(numeval, mu2, coeffs)
+ ! generated by: write_subroutine_glob_solve
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ real(ki), intent(in) :: mu2
+ type(coeff_type_6), intent(inout) :: coeffs
+ coeffs%c0 = numeval((/0.0_ki,0.0_ki,0.0_ki,0.0_ki/), mu2)
+ call solve6_1(numeval, (/0/), mu2, coeffs, 1)
+ call solve6_1(numeval, (/1/), mu2, coeffs, 2)
+ call solve6_1(numeval, (/2/), mu2, coeffs, 3)
+ call solve6_1(numeval, (/3/), mu2, coeffs, 4)
+ call solve6_2(numeval, (/0,1/), mu2, coeffs, 1)
+ call solve6_2(numeval, (/0,2/), mu2, coeffs, 2)
+ call solve6_2(numeval, (/0,3/), mu2, coeffs, 3)
+ call solve6_2(numeval, (/1,2/), mu2, coeffs, 4)
+ call solve6_2(numeval, (/1,3/), mu2, coeffs, 5)
+ call solve6_2(numeval, (/2,3/), mu2, coeffs, 6)
+ call solve6_3(numeval, (/0,1,2/), mu2, coeffs, 1)
+ call solve6_3(numeval, (/0,1,3/), mu2, coeffs, 2)
+ call solve6_3(numeval, (/0,2,3/), mu2, coeffs, 3)
+ call solve6_3(numeval, (/1,2,3/), mu2, coeffs, 4)
+ call solve6_4(numeval, (/0,1,2,3/), mu2, coeffs, 1)
+end subroutine solve6
+!****f* src/interface/tens_rec/tenseval6
+! NAME
+!
+! Function tenseval6
+!
+! USAGE
+!
+! result = tenseval6(Q, coeffs, max_k)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a real vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_6
+! * max_k -- optional integer argument limiting the the reconstruction
+! to a subset of terms with no more than max_k components of q
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function tenseval6(Q, coeffs, max_k)
+ ! generated by: write_function_glob_recon
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_6), intent(in) :: coeffs
+ integer, intent(in), optional :: max_k
+ complex(ki) :: tenseval6
+ integer :: maxk
+ if (present(max_k)) then
+ maxk = max_k
+ else
+ maxk = 4
+ end if
+ tenseval6 = coeffs%c0
+ if (1 .le. maxk) then
+ tenseval6 = tenseval6 + tenseval6_1(Q, (/0/), coeffs%c1(1,:))
+ tenseval6 = tenseval6 + tenseval6_1(Q, (/1/), coeffs%c1(2,:))
+ tenseval6 = tenseval6 + tenseval6_1(Q, (/2/), coeffs%c1(3,:))
+ tenseval6 = tenseval6 + tenseval6_1(Q, (/3/), coeffs%c1(4,:))
+ end if
+ if (2 .le. maxk) then
+ tenseval6 = tenseval6 + tenseval6_2(Q, (/0,1/), coeffs%c2(1,:))
+ tenseval6 = tenseval6 + tenseval6_2(Q, (/0,2/), coeffs%c2(2,:))
+ tenseval6 = tenseval6 + tenseval6_2(Q, (/0,3/), coeffs%c2(3,:))
+ tenseval6 = tenseval6 + tenseval6_2(Q, (/1,2/), coeffs%c2(4,:))
+ tenseval6 = tenseval6 + tenseval6_2(Q, (/1,3/), coeffs%c2(5,:))
+ tenseval6 = tenseval6 + tenseval6_2(Q, (/2,3/), coeffs%c2(6,:))
+ end if
+ if (3 .le. maxk) then
+ tenseval6 = tenseval6 + tenseval6_3(Q, (/0,1,2/), coeffs%c3(1,:))
+ tenseval6 = tenseval6 + tenseval6_3(Q, (/0,1,3/), coeffs%c3(2,:))
+ tenseval6 = tenseval6 + tenseval6_3(Q, (/0,2,3/), coeffs%c3(3,:))
+ tenseval6 = tenseval6 + tenseval6_3(Q, (/1,2,3/), coeffs%c3(4,:))
+ end if
+ if (4 .le. maxk) then
+ tenseval6 = tenseval6 + tenseval6_4(Q, (/0,1,2,3/), coeffs%c4(1,:))
+ end if
+end function tenseval6
+!****f* src/interface/tens_rec/ctenseval6
+! NAME
+!
+! Function ctenseval6
+!
+! USAGE
+!
+! result = ctenseval6(Q, coeffs)
+!
+! DESCRIPTION
+!
+! Recomputes N(Q) from a set of tensor coefficients
+!
+! INPUTS
+!
+! * Q -- a complex vector of dimension(0:3)
+! * coeffs -- a record of type coeff_type_6
+!
+! SIDE EFFECTS
+!
+! No side effect
+!
+! RETURN VALUE
+!
+! The value of the part of N(q) as reconstructed from the coefficients
+!
+! EXAMPLE
+!
+!
+!*****
+pure function ctenseval6(Q, coeffs)
+ ! generated by: write_function_glob_recon_complex
+ implicit none
+ complex(ki), dimension(0:3), intent(in) :: Q
+ type(coeff_type_6), intent(in) :: coeffs
+ complex(ki) :: ctenseval6
+ ctenseval6 = coeffs%c0
+ ctenseval6 = ctenseval6 + ctenseval6_1(Q, (/0/), coeffs%c1(1,:))
+ ctenseval6 = ctenseval6 + ctenseval6_1(Q, (/1/), coeffs%c1(2,:))
+ ctenseval6 = ctenseval6 + ctenseval6_1(Q, (/2/), coeffs%c1(3,:))
+ ctenseval6 = ctenseval6 + ctenseval6_1(Q, (/3/), coeffs%c1(4,:))
+ ctenseval6 = ctenseval6 + ctenseval6_2(Q, (/0,1/), coeffs%c2(1,:))
+ ctenseval6 = ctenseval6 + ctenseval6_2(Q, (/0,2/), coeffs%c2(2,:))
+ ctenseval6 = ctenseval6 + ctenseval6_2(Q, (/0,3/), coeffs%c2(3,:))
+ ctenseval6 = ctenseval6 + ctenseval6_2(Q, (/1,2/), coeffs%c2(4,:))
+ ctenseval6 = ctenseval6 + ctenseval6_2(Q, (/1,3/), coeffs%c2(5,:))
+ ctenseval6 = ctenseval6 + ctenseval6_2(Q, (/2,3/), coeffs%c2(6,:))
+ ctenseval6 = ctenseval6 + ctenseval6_3(Q, (/0,1,2/), coeffs%c3(1,:))
+ ctenseval6 = ctenseval6 + ctenseval6_3(Q, (/0,1,3/), coeffs%c3(2,:))
+ ctenseval6 = ctenseval6 + ctenseval6_3(Q, (/0,2,3/), coeffs%c3(3,:))
+ ctenseval6 = ctenseval6 + ctenseval6_3(Q, (/1,2,3/), coeffs%c3(4,:))
+ ctenseval6 = ctenseval6 + ctenseval6_4(Q, (/0,1,2,3/), coeffs%c4(1,:))
+end function ctenseval6
+!****f* src/interface/tens_rec/print_coeffs_6
+! NAME
+!
+! Subroutine print_coeffs_6
+!
+! Visible through public interface print_coeffs
+!
+! USAGE
+!
+! call print_coeffs(coeffs,unit=6)
+!
+! DESCRIPTION
+!
+! Prints the coefficients of a numerator of maximum rank 6
+! in human readable form.
+!
+! INPUTS
+!
+! * coeffs -- a record of type coeff_type_6
+! * unit -- number of an open file, defaults to stdout (unit=6)
+!
+! SIDE EFFECTS
+!
+! Prints to the given file
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine print_coeffs_6(coeffs, unit)
+ ! generated by: write_print_coeffs
+ implicit none
+ type(coeff_type_6), intent(in) :: coeffs
+ integer, intent(in), optional :: unit
+ integer :: ch
+ if (present(unit)) then
+ ch = unit
+ else
+ ch = 6
+ end if
+ write(ch,'(A4,G24.16,1x,G24.16,A1)') ' (', coeffs%c0, ')'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(1,1), ')*q(0)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,2), ')*q(0)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,3), ')*q(0)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,4), ')*q(0)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,5), ')*q(0)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(1,6), ')*q(0)^6'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(2,1), ')*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,2), ')*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,3), ')*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,4), ')*q(1)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,5), ')*q(1)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(2,6), ')*q(1)^6'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(3,1), ')*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,2), ')*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,3), ')*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,4), ')*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,5), ')*q(2)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(3,6), ')*q(2)^6'
+ write(ch,'(A4,G24.16,1x,G24.16,A6)') ' + (', coeffs%c1(4,1), ')*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,2), ')*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,3), ')*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,4), ')*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,5), ')*q(3)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A8)') ' + (', coeffs%c1(4,6), ')*q(3)^6'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(1,1), ')*q(0)*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,2), ')*q(0)*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,3), ')*q(0)*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,4), ')*q(0)*q(1)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,5), ')*q(0)*q(1)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,6), ')*q(0)^2*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,7), ')*q(0)^2*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,8), ')*q(0)^2*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,9), ')*q(0)^2*q(1)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,10), ')*q(0)^3*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,11), ')*q(0)^3*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,12), ')*q(0)^3*q(1)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,13), ')*q(0)^4*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(1,14), ')*q(0)^4*q(1)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(1,15), ')*q(0)^5*q(1)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(2,1), ')*q(0)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,2), ')*q(0)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,3), ')*q(0)*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,4), ')*q(0)*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,5), ')*q(0)*q(2)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,6), ')*q(0)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,7), ')*q(0)^2*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,8), ')*q(0)^2*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,9), ')*q(0)^2*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,10), ')*q(0)^3*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,11), ')*q(0)^3*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,12), ')*q(0)^3*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,13), ')*q(0)^4*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(2,14), ')*q(0)^4*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(2,15), ')*q(0)^5*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(3,1), ')*q(0)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,2), ')*q(0)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,3), ')*q(0)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,4), ')*q(0)*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,5), ')*q(0)*q(3)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,6), ')*q(0)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,7), ')*q(0)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,8), ')*q(0)^2*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,9), ')*q(0)^2*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,10), ')*q(0)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,11), ')*q(0)^3*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,12), ')*q(0)^3*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,13), ')*q(0)^4*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(3,14), ')*q(0)^4*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(3,15), ')*q(0)^5*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(4,1), ')*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,2), ')*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,3), ')*q(1)*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,4), ')*q(1)*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,5), ')*q(1)*q(2)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,6), ')*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,7), ')*q(1)^2*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,8), ')*q(1)^2*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,9), ')*q(1)^2*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,10), ')*q(1)^3*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,11), ')*q(1)^3*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,12), ')*q(1)^3*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,13), ')*q(1)^4*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(4,14), ')*q(1)^4*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(4,15), ')*q(1)^5*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(5,1), ')*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,2), ')*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,3), ')*q(1)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,4), ')*q(1)*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,5), ')*q(1)*q(3)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,6), ')*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,7), ')*q(1)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,8), ')*q(1)^2*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,9), ')*q(1)^2*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,10), ')*q(1)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,11), ')*q(1)^3*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,12), ')*q(1)^3*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,13), ')*q(1)^4*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(5,14), ')*q(1)^4*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(5,15), ')*q(1)^5*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A11)') ' + (', coeffs%c2(6,1), ')*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,2), ')*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,3), ')*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,4), ')*q(2)*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,5), ')*q(2)*q(3)^5'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,6), ')*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,7), ')*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,8), ')*q(2)^2*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,9), ')*q(2)^2*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,10), ')*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,11), ')*q(2)^3*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,12), ')*q(2)^3*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,13), ')*q(2)^4*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A15)') ' + (', coeffs%c2(6,14), ')*q(2)^4*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A13)') ' + (', coeffs%c2(6,15), ')*q(2)^5*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(1,1), ')*q(0)*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,2), ')*q(0)*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,3), ')*q(0)*q(1)*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,4), ')*q(0)*q(1)*q(2)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,5), ')*q(0)*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,6), ')*q(0)*q(1)^2*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,7), ')*q(0)*q(1)^2*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,8), ')*q(0)*q(1)^3*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,9), ')*q(0)*q(1)^3*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,10), ')*q(0)*q(1)^4*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,11), ')*q(0)^2*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,12), ')*q(0)^2*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,13), ')*q(0)^2*q(1)*q(2)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,14), ')*q(0)^2*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A22)') ' + (', coeffs%c3(1,15), ')*q(0)^2*q(1)^2*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,16), ')*q(0)^2*q(1)^3*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,17), ')*q(0)^3*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,18), ')*q(0)^3*q(1)*q(2)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(1,19), ')*q(0)^3*q(1)^2*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(1,20), ')*q(0)^4*q(1)*q(2)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(2,1), ')*q(0)*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,2), ')*q(0)*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,3), ')*q(0)*q(1)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,4), ')*q(0)*q(1)*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,5), ')*q(0)*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,6), ')*q(0)*q(1)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,7), ')*q(0)*q(1)^2*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,8), ')*q(0)*q(1)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,9), ')*q(0)*q(1)^3*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,10), ')*q(0)*q(1)^4*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,11), ')*q(0)^2*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,12), ')*q(0)^2*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,13), ')*q(0)^2*q(1)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,14), ')*q(0)^2*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A22)') ' + (', coeffs%c3(2,15), ')*q(0)^2*q(1)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,16), ')*q(0)^2*q(1)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,17), ')*q(0)^3*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,18), ')*q(0)^3*q(1)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(2,19), ')*q(0)^3*q(1)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(2,20), ')*q(0)^4*q(1)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(3,1), ')*q(0)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,2), ')*q(0)*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,3), ')*q(0)*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,4), ')*q(0)*q(2)*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,5), ')*q(0)*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,6), ')*q(0)*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,7), ')*q(0)*q(2)^2*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,8), ')*q(0)*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,9), ')*q(0)*q(2)^3*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,10), ')*q(0)*q(2)^4*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,11), ')*q(0)^2*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,12), ')*q(0)^2*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,13), ')*q(0)^2*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,14), ')*q(0)^2*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A22)') ' + (', coeffs%c3(3,15), ')*q(0)^2*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,16), ')*q(0)^2*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,17), ')*q(0)^3*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,18), ')*q(0)^3*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(3,19), ')*q(0)^3*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(3,20), ')*q(0)^4*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A16)') ' + (', coeffs%c3(4,1), ')*q(1)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,2), ')*q(1)*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,3), ')*q(1)*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,4), ')*q(1)*q(2)*q(3)^4'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,5), ')*q(1)*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,6), ')*q(1)*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,7), ')*q(1)*q(2)^2*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,8), ')*q(1)*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,9), ')*q(1)*q(2)^3*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,10), ')*q(1)*q(2)^4*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,11), ')*q(1)^2*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,12), ')*q(1)^2*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,13), ')*q(1)^2*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,14), ')*q(1)^2*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A22)') ' + (', coeffs%c3(4,15), ')*q(1)^2*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,16), ')*q(1)^2*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,17), ')*q(1)^3*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,18), ')*q(1)^3*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A20)') ' + (', coeffs%c3(4,19), ')*q(1)^3*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A18)') ' + (', coeffs%c3(4,20), ')*q(1)^4*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A21)') ' + (', coeffs%c4(1,1), ')*q(0)*q(1)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,2), ')*q(0)*q(1)*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,3), ')*q(0)*q(1)*q(2)*q(3)^3'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,4), ')*q(0)*q(1)*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A25)') ' + (', coeffs%c4(1,5), ')*q(0)*q(1)*q(2)^2*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,6), ')*q(0)*q(1)*q(2)^3*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,7), ')*q(0)*q(1)^2*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A25)') ' + (', coeffs%c4(1,8), ')*q(0)*q(1)^2*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A25)') ' + (', coeffs%c4(1,9), ')*q(0)*q(1)^2*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,10), ')*q(0)*q(1)^3*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,11), ')*q(0)^2*q(1)*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A25)') ' + (', coeffs%c4(1,12), ')*q(0)^2*q(1)*q(2)*q(3)^2'
+ write(ch,'(A4,G24.16,1x,G24.16,A25)') ' + (', coeffs%c4(1,13), ')*q(0)^2*q(1)*q(2)^2*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A25)') ' + (', coeffs%c4(1,14), ')*q(0)^2*q(1)^2*q(2)*q(3)'
+ write(ch,'(A4,G24.16,1x,G24.16,A23)') ' + (', coeffs%c4(1,15), ')*q(0)^3*q(1)*q(2)*q(3)'
+end subroutine print_coeffs_6
+!****f* src/interface/tens_rec/reconstruct6
+! NAME
+!
+! Subroutine reconstruct6
+!
+! USAGE
+!
+! call reconstruct6(numeval, cm0, cm1, cm2)
+!
+! DESCRIPTION
+!
+! Reconstructs all coefficients of a tensor integral of maximum rank 6,
+! including the coefficients in front of mu2 and mu2^2.
+!
+! INPUTS
+!
+! * numeval -- the numerator function
+! * cm0 -- coefficients of type coeff_type_6, representing the
+! numerator at mu2=0
+! * cm1 -- coefficients of type type(coeff_type_4), representing the
+! tensor in front of mu2 [optional]
+! * cm2 -- coefficients of type type(coeff_type_4), representing the
+! tensor in front of mu2^2 [optional]
+!
+! SIDE EFFECTS
+!
+! Writes results to cm0, cm1 and cm2 (if present). If cm1 and cm2 are omitted
+! only N(q,0) is evaluated. If cm2 is omitted it is assumed that the numerator
+! is at most linear in mu2.
+!
+! EXAMPLE
+!
+!
+!*****
+subroutine reconstruct6(numeval, cm0, cm1, cm2)
+ ! generated by: write_subroutine_reconstruct
+ implicit none
+ interface
+ function numeval(Q, mu2)
+ use precision_golem, only: ki
+ implicit none
+ real(ki), dimension(0:3), intent(in) :: Q
+ real(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+ type(coeff_type_6), intent(out) :: cm0
+ type(coeff_type_4), intent(out), optional :: cm1
+ type(coeff_type_4), intent(out), optional :: cm2
+ type(coeff_type_4) :: ca, cb
+ call solve6(numeval, 0.0_ki, cm0)
+ if (present(cm1)) then
+ if (present(cm2)) then
+ call solve4(numeval, +1.0_ki, ca, cm0)
+ call solve4(numeval, -1.0_ki, cb, cm0)
+ cm1%c0= 0.5_ki * (ca%c0 - cb%c0)
+ cm2%c0= 0.5_ki * (ca%c0 + cb%c0)
+ cm1%c1 = 0.5_ki * (ca%c1 - cb%c1)
+ cm2%c1 = 0.5_ki * (ca%c1 + cb%c1)
+ cm1%c2 = 0.5_ki * (ca%c2 - cb%c2)
+ cm2%c2 = 0.5_ki * (ca%c2 + cb%c2)
+ cm1%c3 = 0.5_ki * (ca%c3 - cb%c3)
+ cm2%c3 = 0.5_ki * (ca%c3 + cb%c3)
+ cm1%c4 = 0.5_ki * (ca%c4 - cb%c4)
+ cm2%c4 = 0.5_ki * (ca%c4 + cb%c4)
+ else
+ call solve4(numeval, +1.0_ki, cm1, cm0)
+ end if
+ end if
+end subroutine reconstruct6
+end module tens_rec
diff --git a/golem95c-1.2.1/interface/tensor_integrals.f90 b/golem95c-1.2.1/interface/tensor_integrals.f90
new file mode 100644
index 0000000..2ec980e
--- /dev/null
+++ b/golem95c-1.2.1/interface/tensor_integrals.f90
@@ -0,0 +1,1921 @@
+!
+!****h* src/interface/tensor_integrals
+! NAME
+!
+! Module tensor_integrals
+!
+! USAGE
+!
+! use tensor_integrals
+!
+! DESCRIPTION
+!
+! This module provides an interface which allows to compute
+! tensor integrals rather than form factors.
+!
+! OUTPUT
+!
+! This module exports the functions:
+! * init_smat -- initialize the s_smat from vectors and masses
+! * ti1 -- tensor tadpoles
+! * ti2 -- tensor bubbles
+! * ti3 -- tensor triangles
+! * ti4 -- tensor boxes
+! * ti5 -- tensor pentagons
+! * ti6 -- tensor hexagons
+!
+! USES
+!
+! precision_golem
+! form_factor_type
+! form_factor_1p
+! form_factor_2p
+! form_factor_3p
+! form_factor_4p
+! form_factor_5p
+! form_factor_6p
+! cache
+! matrice_s
+! spinor
+! array
+!
+!*****
+module tensor_integrals
+use precision_golem, only: ki
+use form_factor_type, only: form_factor, operator(*), operator(+)
+use form_factor_1p, only: a10
+use form_factor_2p, only: a20, a21, a22, b22
+use form_factor_3p, only: a30, a31, a32, a33, b32, b33
+use form_factor_4p, only: a40, a41, a42, a43, a44, b42, b43, b44, c44
+use form_factor_5p, only: a50, a51, a52, a53, a54, a55, b52, b53, b54, b55, &
+ & c54, c55
+use form_factor_6p, only: a60, a61, a62, a63, a64, a65, a66
+use cache, only: allocate_cache, clear_cache
+use matrice_s, only: set_ref, s_mat, allocation_s, deallocation_s, init_invs, &
+ & b_ref
+use spinor, only: scalar
+use array, only: packb, unpackb, pminus
+implicit none
+private
+
+private :: a10, a20, a21, a22, b22
+private :: a30, a31, a32, a33, b32, b33
+private :: a40, a41, a42, a43, a44, b42, b43, b44, c44
+private :: a50, a51, a52, a53, a54, a55, b52, b53, b54, b55, c54, c55
+private :: a60, a61, a62, a63, a64, a65, a66
+
+private :: ki, form_factor, allocate_cache, clear_cache, scalar
+private :: packb, unpackb, pminus
+private :: set_ref, s_mat, allocation_s, deallocation_s, init_invs, b_ref
+integer, dimension(0), target, private :: loc_s_null = 0
+
+private :: symmetric_A_coeff1
+private :: symmetric_A_coeff2
+private :: symmetric_A_coeff3
+private :: symmetric_A_coeff4
+private :: symmetric_A_coeff5
+private :: symmetric_A_coeff6
+private :: symmetric_B_coeff2
+private :: symmetric_B_coeff3
+private :: symmetric_B_coeff4
+private :: symmetric_B_coeff5
+private :: symmetric_C_coeff4
+private :: symmetric_C_coeff5
+
+interface symmetric_A_coeff
+ module procedure symmetric_A_coeff1
+ module procedure symmetric_A_coeff2
+ module procedure symmetric_A_coeff3
+ module procedure symmetric_A_coeff4
+ module procedure symmetric_A_coeff5
+ module procedure symmetric_A_coeff6
+end interface symmetric_A_coeff
+
+interface symmetric_B_coeff
+ module procedure symmetric_B_coeff2
+ module procedure symmetric_B_coeff3
+ module procedure symmetric_B_coeff4
+ module procedure symmetric_B_coeff5
+end interface symmetric_B_coeff
+
+interface symmetric_C_coeff
+ module procedure symmetric_C_coeff4
+ module procedure symmetric_C_coeff5
+end interface symmetric_C_coeff
+
+interface init_smat
+ module procedure init_smat1
+ module procedure init_smat2
+ module procedure init_smat3
+ module procedure init_smat4
+ module procedure init_smat5
+ module procedure init_smat6
+end interface init_smat
+
+interface ti1
+ module procedure ti1r0
+ module procedure ti1r1
+end interface ti1
+
+interface ti2
+ module procedure ti2r0
+ module procedure ti2r1
+ module procedure ti2r2
+end interface ti2
+
+interface ti3
+ module procedure ti3r0
+ module procedure ti3r1
+ module procedure ti3r2
+ module procedure ti3r3
+end interface ti3
+
+interface ti4
+ module procedure ti4r0
+ module procedure ti4r1
+ module procedure ti4r2
+ module procedure ti4r3
+ module procedure ti4r4
+end interface ti4
+
+interface ti5
+ module procedure ti5r0
+ module procedure ti5r1
+ module procedure ti5r2
+ module procedure ti5r3
+ module procedure ti5r4
+ module procedure ti5r5
+end interface ti5
+
+interface ti6
+ module procedure ti6r0
+ module procedure ti6r1
+ module procedure ti6r2
+ module procedure ti6r3
+ module procedure ti6r4
+ module procedure ti6r5
+ module procedure ti6r6
+end interface ti6
+
+private :: ti1r0, ti1r1
+private :: ti2r0, ti2r1, ti2r2
+private :: ti3r0, ti3r1, ti3r2, ti3r3
+private :: ti4r0, ti4r1, ti4r2, ti4r3, ti4r4
+private :: ti5r0, ti5r1, ti5r2, ti5r3, ti5r4, ti5r5
+private :: ti6r0, ti6r1, ti6r2, ti6r3, ti6r4, ti6r5, ti6r6
+
+integer, parameter, public :: use_existing_smat = 1
+integer, parameter, public :: keep_smat_on_exit = 2
+
+public :: ti1, ti2, ti3, ti4, ti5, ti6, init_smat, done_smat
+
+contains
+
+pure elemental function chop(val,prec)
+ implicit none
+ real(ki), intent(in) :: val
+ real(ki), optional, intent(in) :: prec
+ real(ki) :: chop
+
+ if (present(prec)) then
+ if (abs(val) .gt. prec) then
+ chop = val
+ else
+ chop = 0.0_ki
+ end if
+ else
+ if (abs(val) .gt. 1.0E+04_ki*epsilon(1.0_ki)) then
+ chop = val
+ else
+ chop = 0.0_ki
+ end if
+ end if
+end function chop
+
+!---#[ init_smat :
+subroutine init_smat1(m1sq)
+ implicit none
+ real(ki), intent(in) :: m1sq
+
+ call allocation_s(1)
+ set_ref = (/1/)
+ b_ref = packb(set_ref)
+ s_mat(1,1) = -m1sq-m1sq
+
+ call allocate_cache(1)
+
+ ! init_invs not needed for tadpoles
+end subroutine init_smat1
+
+subroutine init_smat2(r1,m1sq,m2sq)
+ implicit none
+ real(ki), dimension(4), intent(in) :: r1
+ real(ki), intent(in) :: m1sq,m2sq
+
+ call allocation_s(2)
+ set_ref = (/1,2/)
+ b_ref = packb(set_ref)
+ s_mat(1,1) = -m1sq-m1sq
+ s_mat(1,2) = chop(scalar(r1,r1)) - m1sq - m2sq
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -m2sq-m2sq
+
+ call allocate_cache(2)
+
+ ! init_invs not needed for bubbles
+end subroutine init_smat2
+
+subroutine init_smat3(r1,r2,m1sq,m2sq,m3sq)
+ implicit none
+ real(ki), dimension(4), intent(in) :: r1,r2
+ real(ki), intent(in) :: m1sq,m2sq,m3sq
+
+ real(ki), dimension(4) :: delt
+
+ call allocation_s(3)
+ set_ref = (/1,2,3/)
+ b_ref = packb(set_ref)
+ s_mat(1,1) = -m1sq-m1sq
+ delt = r1-r2
+ s_mat(1,2) = chop(scalar(delt,delt)) - m1sq - m2sq
+ delt = r1
+ s_mat(1,3) = chop(scalar(delt,delt)) - m1sq - m3sq
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -m2sq-m2sq
+ delt = r2
+ s_mat(2,3) = chop(scalar(delt,delt)) - m2sq - m3sq
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -m3sq-m3sq
+
+ call allocate_cache(3)
+ ! init_invs not needed for triangles
+end subroutine init_smat3
+
+subroutine init_smat4(r1,r2,r3,m1sq,m2sq,m3sq,m4sq)
+ implicit none
+ real(ki), dimension(4), intent(in) :: r1,r2,r3
+ real(ki), intent(in) :: m1sq,m2sq,m3sq,m4sq
+
+ real(ki), dimension(4) :: delt
+
+ call allocation_s(4)
+ set_ref = (/1,2,3,4/)
+ b_ref = packb(set_ref)
+ s_mat(1,1) = -m1sq-m1sq
+ delt = r1-r2
+ s_mat(1,2) = chop(scalar(delt,delt)) - m1sq - m2sq
+ delt = r1-r3
+ s_mat(1,3) = chop(scalar(delt,delt)) - m1sq - m3sq
+ delt = r1
+ s_mat(1,4) = chop(scalar(delt,delt)) - m1sq - m4sq
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -m2sq-m2sq
+ delt = r2-r3
+ s_mat(2,3) = chop(scalar(delt,delt)) - m2sq - m3sq
+ delt = r2
+ s_mat(2,4) = chop(scalar(delt,delt)) - m2sq - m4sq
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -m3sq-m3sq
+ delt = r3
+ s_mat(3,4) = chop(scalar(delt,delt)) - m3sq - m4sq
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -m4sq-m4sq
+
+ call allocate_cache(4)
+ call init_invs()
+end subroutine init_smat4
+
+subroutine init_smat5(r1,r2,r3,r4,m1sq,m2sq,m3sq,m4sq,m5sq)
+ implicit none
+ real(ki), dimension(4), intent(in) :: r1,r2,r3,r4
+ real(ki), intent(in) :: m1sq,m2sq,m3sq,m4sq,m5sq
+
+ real(ki), dimension(4) :: delt
+
+ call allocation_s(5)
+ set_ref = (/1,2,3,4,5/)
+ b_ref = packb(set_ref)
+ s_mat(1,1) = -m1sq-m1sq
+ delt = r1-r2
+ s_mat(1,2) = chop(scalar(delt,delt)) - m1sq - m2sq
+ delt = r1-r3
+ s_mat(1,3) = chop(scalar(delt,delt)) - m1sq - m3sq
+ delt = r1-r4
+ s_mat(1,4) = chop(scalar(delt,delt)) - m1sq - m4sq
+ delt = r1
+ s_mat(1,5) = chop(scalar(delt,delt)) - m1sq - m5sq
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -m2sq-m2sq
+ delt = r2-r3
+ s_mat(2,3) = chop(scalar(delt,delt)) - m2sq - m3sq
+ delt = r2-r4
+ s_mat(2,4) = chop(scalar(delt,delt)) - m2sq - m4sq
+ delt = r2
+ s_mat(2,5) = chop(scalar(delt,delt)) - m2sq - m5sq
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -m3sq-m3sq
+ delt = r3-r4
+ s_mat(3,4) = chop(scalar(delt,delt)) - m3sq - m4sq
+ delt = r3
+ s_mat(3,5) = chop(scalar(delt,delt)) - m3sq - m5sq
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -m4sq-m4sq
+ delt = r4
+ s_mat(4,5) = chop(scalar(delt,delt)) - m4sq - m5sq
+ s_mat(5,1) = s_mat(1,5)
+ s_mat(5,2) = s_mat(2,5)
+ s_mat(5,3) = s_mat(3,5)
+ s_mat(5,4) = s_mat(4,5)
+ s_mat(5,5) = -m5sq-m5sq
+
+ call allocate_cache(5)
+ call init_invs()
+end subroutine init_smat5
+
+subroutine init_smat6(r1,r2,r3,r4,r5,m1sq,m2sq,m3sq,m4sq,m5sq,m6sq)
+ implicit none
+ real(ki), dimension(4), intent(in) :: r1,r2,r3,r4,r5
+ real(ki), intent(in) :: m1sq,m2sq,m3sq,m4sq,m5sq,m6sq
+
+ real(ki), dimension(4) :: delt
+
+ call allocation_s(6)
+ set_ref = (/1,2,3,4,5,6/)
+ b_ref = packb(set_ref)
+ s_mat(1,1) = -m1sq-m1sq
+ delt = r1-r2
+ s_mat(1,2) = chop(scalar(delt,delt)) - m1sq - m2sq
+ delt = r1-r3
+ s_mat(1,3) = chop(scalar(delt,delt)) - m1sq - m3sq
+ delt = r1-r4
+ s_mat(1,4) = chop(scalar(delt,delt)) - m1sq - m4sq
+ delt = r1-r5
+ s_mat(1,5) = chop(scalar(delt,delt)) - m1sq - m5sq
+ delt = r1
+ s_mat(1,6) = chop(scalar(delt,delt)) - m1sq - m6sq
+ s_mat(2,1) = s_mat(1,2)
+ s_mat(2,2) = -m2sq-m2sq
+ delt = r2-r3
+ s_mat(2,3) = chop(scalar(delt,delt)) - m2sq - m3sq
+ delt = r2-r4
+ s_mat(2,4) = chop(scalar(delt,delt)) - m2sq - m4sq
+ delt = r2-r5
+ s_mat(2,5) = chop(scalar(delt,delt)) - m2sq - m5sq
+ delt = r2
+ s_mat(2,6) = chop(scalar(delt,delt)) - m2sq - m6sq
+ s_mat(3,1) = s_mat(1,3)
+ s_mat(3,2) = s_mat(2,3)
+ s_mat(3,3) = -m3sq-m3sq
+ delt = r3-r4
+ s_mat(3,4) = chop(scalar(delt,delt)) - m3sq - m4sq
+ delt = r3-r5
+ s_mat(3,5) = chop(scalar(delt,delt)) - m3sq - m5sq
+ delt = r3
+ s_mat(3,6) = chop(scalar(delt,delt)) - m3sq - m6sq
+ s_mat(4,1) = s_mat(1,4)
+ s_mat(4,2) = s_mat(2,4)
+ s_mat(4,3) = s_mat(3,4)
+ s_mat(4,4) = -m4sq-m4sq
+ delt = r4-r5
+ s_mat(4,5) = chop(scalar(delt,delt)) - m4sq - m5sq
+ delt = r4
+ s_mat(4,6) = chop(scalar(delt,delt)) - m4sq - m6sq
+ s_mat(5,1) = s_mat(1,5)
+ s_mat(5,2) = s_mat(2,5)
+ s_mat(5,3) = s_mat(3,5)
+ s_mat(5,4) = s_mat(4,5)
+ s_mat(5,5) = -m5sq-m5sq
+ delt = r5
+ s_mat(5,6) = chop(scalar(delt,delt)) - m5sq - m6sq
+ s_mat(6,1) = s_mat(1,6)
+ s_mat(6,2) = s_mat(2,6)
+ s_mat(6,3) = s_mat(3,6)
+ s_mat(6,4) = s_mat(4,6)
+ s_mat(6,5) = s_mat(5,6)
+ s_mat(6,6) = -m6sq-m6sq
+
+ call allocate_cache(6)
+ call init_invs()
+end subroutine init_smat6
+
+subroutine done_smat()
+ implicit none
+ call clear_cache()
+ call deallocation_s()
+end subroutine done_smat
+!---#] init_smat :
+!---#[ One point tensor integrals :
+subroutine ti1r0(tens,m1,flag,pinches)
+ implicit none
+ type(form_factor), intent(out) :: tens
+ real(ki), intent(in) :: m1
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ logical :: f_init_smat, f_dispose_smat
+
+ integer, dimension(:), pointer :: lpinches
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+
+ if(f_init_smat) call init_smat(m1*m1)
+
+ tens = a10(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti1r0
+
+subroutine ti1r1(tens,m1,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4), intent(out) :: tens
+ real(ki), intent(in) :: m1
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ logical :: f_init_smat, f_dispose_smat
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if(f_init_smat) call init_smat(m1*m1)
+
+ tens(:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti1r1
+!---#] One point tensor integrals :
+!---#[ Two point tensor integrals :
+subroutine ti2r0(tens,r1,m1,m2,flag,pinches)
+ implicit none
+ type(form_factor), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1
+ real(ki), intent(in) :: m1, m2
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+
+ if(f_init_smat) call init_smat(r1,m1*m1,m2*m2)
+
+ tens = a20(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti2r0
+
+subroutine ti2r1(tens,r1,m1,m2,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1
+ real(ki), intent(in) :: m1, m2
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4) :: term
+ integer, dimension(2) :: unpinched
+ unpinched = unpackb(pminus(b_ref,packb(pinches)),2)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+
+ if(f_init_smat) call init_smat(r1,m1*m1,m2*m2)
+
+ call symmetric_A_coeff(term,r1)
+ tens(:) = term * A21(unpinched(1),lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti2r1
+
+subroutine ti2r2(tens,r1,m1,m2,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1
+ real(ki), intent(in) :: m1, m2
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4) :: term
+ integer, dimension(2) :: unpinched
+ unpinched = unpackb(pminus(b_ref,packb(pinches)),2)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+
+ if(f_init_smat) call init_smat(r1,m1*m1,m2*m2)
+
+ call symmetric_A_coeff(term,r1,r1)
+ tens(:,:) = term(:,:) * A22(unpinched(1),unpinched(1),lpinches)
+ call symmetric_B_coeff(term)
+ tens(:,:) = tens(:,:) + term(:,:) * B22(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti2r2
+!---#] Two point tensor integrals :
+!---#[ Three point tensor integrals :
+subroutine ti3r0(tens,r1,r2,m1,m2,m3,flag,pinches)
+ implicit none
+ type(form_factor), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2
+ real(ki), intent(in) :: m1, m2, m3
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+
+ if(f_init_smat) call init_smat(r1,r2,m1*m1,m2*m2,m3*m3)
+
+ tens = A30(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti3r0
+
+subroutine ti3r1(tens,r1,r2,m1,m2,m3,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2
+ real(ki), intent(in) :: m1, m2, m3
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ integer, dimension(3) :: unpinched
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),2)
+
+ if(f_init_smat) call init_smat(r1,r2,m1*m1,m2*m2,m3*m3)
+
+ tens(:) = r1(:) * A31(unpinched(1),lpinches) &
+ & + r2(:) * A31(unpinched(2),lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti3r1
+
+subroutine ti3r2(tens,r1,r2,m1,m2,m3,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2
+ real(ki), intent(in) :: m1, m2, m3
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4) :: term
+ real(ki), dimension(2,4) :: rarr
+ integer :: j1, j2
+ integer, dimension(3) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),3)
+
+ if(f_init_smat) call init_smat(r1,r2,m1*m1,m2*m2,m3*m3)
+
+ tens(:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,2
+ do j2=1,2
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:))
+ tens(:,:) = tens(:,:) &
+ & + term(:,:) * A32(unpinched(j1),unpinched(j2),lpinches)
+ end do
+ end do
+ call symmetric_B_coeff(term)
+ tens(:,:) = tens(:,:) + term(:,:) * B32(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti3r2
+
+subroutine ti3r3(tens,r1,r2,m1,m2,m3,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2
+ real(ki), intent(in) :: m1, m2, m3
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4) :: term
+ real(ki), dimension(2,4) :: rarr
+ integer :: j1, j2, j3
+ integer, dimension(3) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),3)
+
+ if(f_init_smat) call init_smat(r1,r2,m1*m1,m2*m2,m3*m3)
+
+ tens(:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,2
+ do j2=1,2
+ do j3=1,2
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:))
+ tens(:,:,:) = tens(:,:,:) &
+ & + term(:,:,:) * A33(unpinched(j1),unpinched(j2),unpinched(j3),&
+ & lpinches)
+ end do
+ end do
+ call symmetric_B_coeff(term,rarr(j1,:))
+ tens(:,:,:) = tens(:,:,:) &
+ & + term(:,:,:) * B33(unpinched(j1),lpinches)
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti3r3
+!---#] Three point tensor integrals :
+!---#[ Four point tensor integrals :
+subroutine ti4r0(tens,r1,r2,r3,m1,m2,m3,m4,flag,pinches)
+ implicit none
+ type(form_factor), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3
+ real(ki), intent(in) :: m1, m2, m3, m4
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+
+ if(f_init_smat) call init_smat(r1,r2,r3,m1*m1,m2*m2,m3*m3,m4*m4)
+
+ tens = A40(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti4r0
+
+subroutine ti4r1(tens,r1,r2,r3,m1,m2,m3,m4,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3
+ real(ki), intent(in) :: m1, m2, m3, m4
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4) :: term
+ real(ki), dimension(3,4) :: rarr
+ integer :: j1
+ integer, dimension(4) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),4)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,m1*m1,m2*m2,m3*m3,m4*m4)
+
+ tens(:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,3
+ call symmetric_A_coeff(term,rarr(j1,:))
+ tens(:) = tens(:) + term(:) * A41(unpinched(j1),lpinches)
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti4r1
+subroutine ti4r2(tens,r1,r2,r3,m1,m2,m3,m4,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3
+ real(ki), intent(in) :: m1, m2, m3, m4
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4) :: term
+ real(ki), dimension(3,4) :: rarr
+ integer :: j1, j2
+ integer, dimension(4) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),4)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,m1*m1,m2*m2,m3*m3,m4*m4)
+
+ tens(:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,3
+ do j2=1,3
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:))
+ tens(:,:) = tens(:,:) &
+ & + term(:,:) * A42(unpinched(j1),unpinched(j2),lpinches)
+ end do
+ end do
+ call symmetric_B_coeff(term)
+ tens(:,:) = tens(:,:) + term(:,:) * B42(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti4r2
+
+subroutine ti4r3(tens,r1,r2,r3,m1,m2,m3,m4,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3
+ real(ki), intent(in) :: m1, m2, m3, m4
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4) :: term
+ real(ki), dimension(3,4) :: rarr
+ integer :: j1, j2, j3
+ integer, dimension(4) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),4)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,m1*m1,m2*m2,m3*m3,m4*m4)
+
+ tens(:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,3
+ do j2=1,3
+ do j3=1,3
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:))
+ tens(:,:,:) = tens(:,:,:) &
+ & + term(:,:,:) * A43(unpinched(j1),unpinched(j2),unpinched(j3),&
+ & lpinches)
+ end do
+ end do
+ call symmetric_B_coeff(term,rarr(unpinched(j1),:))
+ tens(:,:,:) = tens(:,:,:) + term(:,:,:) * B43(j1,lpinches)
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti4r3
+
+subroutine ti4r4(tens,r1,r2,r3,m1,m2,m3,m4,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3
+ real(ki), intent(in) :: m1, m2, m3, m4
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4,4) :: term
+ real(ki), dimension(3,4) :: rarr
+ integer :: j1, j2, j3, j4
+ integer, dimension(4) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),4)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,m1*m1,m2*m2,m3*m3,m4*m4)
+
+ tens(:,:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,3
+ do j2=1,3
+ do j3=1,3
+ do j4=1,3
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:),rarr(j4,:))
+ tens(:,:,:,:) = tens(:,:,:,:) &
+ & + term(:,:,:,:) * A44(unpinched(j1),unpinched(j2), &
+ & unpinched(j3),unpinched(j4),lpinches)
+ end do
+ end do
+ call symmetric_B_coeff(term,rarr(j1,:),rarr(j2,:))
+ tens(:,:,:,:) = tens(:,:,:,:) &
+ & + term(:,:,:,:) * B44(unpinched(j1),unpinched(j2),lpinches)
+ end do
+ end do
+ call symmetric_C_coeff(term)
+ tens(:,:,:,:) = tens(:,:,:,:) + term(:,:,:,:) * C44(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti4r4
+!---#] Four point tensor integrals :
+!---#[ Five point tensor integrals :
+subroutine ti5r0(tens,r1,r2,r3,r4,m1,m2,m3,m4,m5,flag,pinches)
+ implicit none
+ type(form_factor), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4
+ real(ki), intent(in) :: m1, m2, m3, m4, m5
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,m1*m1,m2*m2,m3*m3,m4*m4,m5*m5)
+
+ tens = A50(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti5r0
+subroutine ti5r1(tens,r1,r2,r3,r4,m1,m2,m3,m4,m5,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4
+ real(ki), intent(in) :: m1, m2, m3, m4, m5
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4) :: term
+ real(ki), dimension(4,4) :: rarr
+ integer :: j1
+ integer, dimension(5) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),5)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,m1*m1,m2*m2,m3*m3,m4*m4,m5*m5)
+
+ tens(:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,4
+ call symmetric_A_coeff(term,rarr(j1,:))
+ tens(:) = tens(:) + term(:) * A51(unpinched(j1),lpinches)
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti5r1
+subroutine ti5r2(tens,r1,r2,r3,r4,m1,m2,m3,m4,m5,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4
+ real(ki), intent(in) :: m1, m2, m3, m4, m5
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4) :: term
+ real(ki), dimension(4,4) :: rarr
+ integer :: j1, j2
+ integer, dimension(5) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),5)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,m1*m1,m2*m2,m3*m3,m4*m4,m5*m5)
+
+ tens(:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,4
+ do j2=1,4
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:))
+ tens(:,:) = tens(:,:) &
+ & + term(:,:) * A52(unpinched(j1),unpinched(j2),lpinches)
+ end do
+ end do
+ call symmetric_B_coeff(term)
+ tens(:,:) = tens(:,:) + term(:,:) * B52(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti5r2
+subroutine ti5r3(tens,r1,r2,r3,r4,m1,m2,m3,m4,m5,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4
+ real(ki), intent(in) :: m1, m2, m3, m4, m5
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4) :: term
+ real(ki), dimension(4,4) :: rarr
+ integer :: j1, j2, j3
+ integer, dimension(5) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),5)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,m1*m1,m2*m2,m3*m3,m4*m4,m5*m5)
+
+ tens(:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,4
+ do j2=1,4
+ do j3=1,4
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:))
+ tens(:,:,:) = tens(:,:,:) &
+ & + term(:,:,:) * A53(unpinched(j1),unpinched(j2), &
+ & unpinched(j3),lpinches)
+ end do
+ end do
+ call symmetric_B_coeff(term,rarr(j1,:))
+ tens(:,:,:) = tens(:,:,:) + term(:,:,:) * B53(unpinched(j1),lpinches)
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti5r3
+subroutine ti5r4(tens,r1,r2,r3,r4,m1,m2,m3,m4,m5,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4
+ real(ki), intent(in) :: m1, m2, m3, m4, m5
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4,4) :: term
+ real(ki), dimension(4,4) :: rarr
+ integer :: j1, j2, j3, j4
+ integer, dimension(5) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),5)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,m1*m1,m2*m2,m3*m3,m4*m4,m5*m5)
+
+ tens(:,:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,4
+ do j2=1,4
+ do j3=1,4
+ do j4=1,4
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:),rarr(j4,:))
+ tens(:,:,:,:) = tens(:,:,:,:) + term(:,:,:,:) * &
+ & A54(unpinched(j1),unpinched(j2),unpinched(j3),unpinched(j4),lpinches)
+ end do
+ end do
+ call symmetric_B_coeff(term,rarr(j1,:),rarr(j2,:))
+ tens(:,:,:,:) = tens(:,:,:,:) &
+ & + term(:,:,:,:) * B54(unpinched(j1),unpinched(j2),lpinches)
+ end do
+ end do
+ call symmetric_C_coeff(term)
+ tens(:,:,:,:) = tens(:,:,:,:) + term(:,:,:,:) * C54(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti5r4
+subroutine ti5r5(tens,r1,r2,r3,r4,m1,m2,m3,m4,m5,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4
+ real(ki), intent(in) :: m1, m2, m3, m4, m5
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4,4,4) :: term
+ real(ki), dimension(4,4) :: rarr
+ integer :: j1, j2, j3, j4, j5
+ integer, dimension(5) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),5)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,m1*m1,m2*m2,m3*m3,m4*m4,m5*m5)
+
+ tens(:,:,:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,4
+ do j2=1,4
+ do j3=1,4
+ do j4=1,4
+ do j5=1,4
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:),rarr(j4,:),&
+ & rarr(j5,:))
+ tens(:,:,:,:,:) = tens(:,:,:,:,:) + term(:,:,:,:,:) * &
+ & A55(unpinched(j1),unpinched(j2),unpinched(j3),unpinched(j4),&
+ & unpinched(j5),lpinches)
+ end do
+ end do
+ call symmetric_B_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:))
+ tens(:,:,:,:,:) = tens(:,:,:,:,:) + term(:,:,:,:,:) * &
+ & B55(unpinched(j1),unpinched(j2),unpinched(j3),lpinches)
+ end do
+ end do
+ call symmetric_C_coeff(term,rarr(j1,:))
+ tens(:,:,:,:,:) = tens(:,:,:,:,:) + term(:,:,:,:,:) * &
+ & C55(unpinched(j1),lpinches)
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti5r5
+!---#] Five point tensor integrals :
+!---#[ Six point tensor integrals :
+subroutine ti6r0(tens,r1,r2,r3,r4,r5,m1,m2,m3,m4,m5,m6,flag,pinches)
+ implicit none
+ type(form_factor), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4, r5
+ real(ki), intent(in) :: m1, m2, m3, m4, m5, m6
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,r5,m1*m1,m2*m2,m3*m3,m4*m4,&
+ & m5*m5,m6*m6)
+
+ tens = A60(lpinches)
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti6r0
+
+subroutine ti6r1(tens,r1,r2,r3,r4,r5,m1,m2,m3,m4,m5,m6,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4, r5
+ real(ki), intent(in) :: m1, m2, m3, m4, m5, m6
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4) :: term
+ real(ki), dimension(5,4) :: rarr
+ integer :: j1
+ integer, dimension(6) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+ rarr(5,:) = r5(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),6)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,r5,m1*m1,m2*m2,m3*m3,m4*m4,&
+ & m5*m5,m6*m6)
+
+ tens(:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,5
+ call symmetric_A_coeff(term,rarr(j1,:))
+ tens(:) = tens(:) + term(:) * A61(unpinched(j1),lpinches)
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti6r1
+subroutine ti6r2(tens,r1,r2,r3,r4,r5,m1,m2,m3,m4,m5,m6,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4, r5
+ real(ki), intent(in) :: m1, m2, m3, m4, m5, m6
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4) :: term
+ real(ki), dimension(5,4) :: rarr
+ integer :: j1, j2
+ integer, dimension(6) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+ rarr(5,:) = r5(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),6)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,r5,m1*m1,m2*m2,m3*m3,m4*m4,&
+ & m5*m5,m6*m6)
+
+ tens(:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,5
+ do j2=1,5
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:))
+ tens(:,:) = tens(:,:) &
+ & + term(:,:) * A62(unpinched(j1),unpinched(j2),lpinches)
+ end do
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti6r2
+subroutine ti6r3(tens,r1,r2,r3,r4,r5,m1,m2,m3,m4,m5,m6,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4, r5
+ real(ki), intent(in) :: m1, m2, m3, m4, m5, m6
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4) :: term
+ real(ki), dimension(5,4) :: rarr
+ integer :: j1, j2, j3
+ integer, dimension(6) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+ rarr(5,:) = r5(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),6)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,r5,m1*m1,m2*m2,m3*m3,m4*m4,&
+ & m5*m5,m6*m6)
+
+ tens(:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,5
+ do j2=1,5
+ do j3=1,5
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:))
+ tens(:,:,:) = tens(:,:,:) &
+ & + term(:,:,:) * A63(unpinched(j1),unpinched(j2),unpinched(j3),&
+ & lpinches)
+ end do
+ end do
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti6r3
+subroutine ti6r4(tens,r1,r2,r3,r4,r5,m1,m2,m3,m4,m5,m6,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4, r5
+ real(ki), intent(in) :: m1, m2, m3, m4, m5, m6
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4,4) :: term
+ real(ki), dimension(5,4) :: rarr
+ integer :: j1, j2, j3, j4
+ integer, dimension(6) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+ rarr(5,:) = r5(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),6)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,r5,m1*m1,m2*m2,m3*m3,m4*m4,&
+ & m5*m5,m6*m6)
+
+ tens(:,:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,5
+ do j2=1,5
+ do j3=1,5
+ do j4=1,5
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:),rarr(j4,:))
+ tens(:,:,:,:) = tens(:,:,:,:) + term(:,:,:,:) * &
+ & A64(unpinched(j1),unpinched(j2),unpinched(j3),unpinched(j4),lpinches)
+ end do
+ end do
+ end do
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti6r4
+subroutine ti6r5(tens,r1,r2,r3,r4,r5,m1,m2,m3,m4,m5,m6,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4, r5
+ real(ki), intent(in) :: m1, m2, m3, m4, m5, m6
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4,4,4) :: term
+ real(ki), dimension(5,4) :: rarr
+ integer :: j1, j2, j3, j4, j5
+ integer, dimension(6) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+ rarr(5,:) = r5(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),6)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,r5,m1*m1,m2*m2,m3*m3,m4*m4,&
+ & m5*m5,m6*m6)
+
+ tens(:,:,:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,5
+ do j2=1,5
+ do j3=1,5
+ do j4=1,5
+ do j5=1,5
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:),rarr(j4,:),&
+ & rarr(j5,:))
+ tens(:,:,:,:,:) = tens(:,:,:,:,:) + term(:,:,:,:,:) * &
+ & A65(unpinched(j1),unpinched(j2),unpinched(j3),unpinched(j4), &
+ & unpinched(j5),lpinches)
+ end do
+ end do
+ end do
+ end do
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti6r5
+subroutine ti6r6(tens,r1,r2,r3,r4,r5,m1,m2,m3,m4,m5,m6,flag,pinches)
+ implicit none
+ type(form_factor), dimension(4,4,4,4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3, r4, r5
+ real(ki), intent(in) :: m1, m2, m3, m4, m5, m6
+ integer, optional, intent(in) :: flag
+ integer, dimension(:), target, optional, intent(in) :: pinches
+ integer, dimension(:), pointer :: lpinches
+ logical :: f_init_smat, f_dispose_smat
+ real(ki), dimension(4,4,4,4,4,4) :: term
+ real(ki), dimension(5,4) :: rarr
+ integer :: j1, j2, j3, j4, j5, j6
+ integer, dimension(6) :: unpinched
+
+ rarr(1,:) = r1(:)
+ rarr(2,:) = r2(:)
+ rarr(3,:) = r3(:)
+ rarr(4,:) = r4(:)
+ rarr(5,:) = r5(:)
+
+ if(present(flag)) then
+ f_init_smat = iand(flag, use_existing_smat) .eq. 0
+ f_dispose_smat = iand(flag, keep_smat_on_exit) .eq. 0
+ else
+ f_init_smat = .true.
+ f_dispose_smat = .true.
+ end if
+
+ if (present(pinches)) then
+ lpinches => pinches
+ else
+ lpinches => loc_s_null
+ end if
+ unpinched = unpackb(pminus(b_ref,packb(lpinches)),6)
+
+ if(f_init_smat) call init_smat(r1,r2,r3,r4,r5,m1*m1,m2*m2,m3*m3,m4*m4,&
+ & m5*m5,m6*m6)
+
+ tens(:,:,:,:,:,:) = form_factor(0.0_ki, 0.0_ki, 0.0_ki)
+ do j1=1,5
+ do j2=1,5
+ do j3=1,5
+ do j4=1,5
+ do j5=1,5
+ do j6=1,5
+ call symmetric_A_coeff(term,rarr(j1,:),rarr(j2,:),rarr(j3,:),rarr(j4,:),&
+ & rarr(j5,:),rarr(j6,:))
+ tens(:,:,:,:,:,:) = tens(:,:,:,:,:,:) + term(:,:,:,:,:,:) * &
+ & A66(unpinched(j1),unpinched(j2),unpinched(j3),unpinched(j4),&
+ & unpinched(j5),unpinched(j6),lpinches)
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+ if(f_dispose_smat) call done_smat()
+end subroutine ti6r6
+!---#] Six point tensor integrals :
+!---#[ Symmetric A coefficients :
+pure subroutine symmetric_A_coeff1(tens,r1)
+ implicit none
+ real(ki), dimension(4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1
+
+ tens(:) = r1(:)
+end subroutine symmetric_A_coeff1
+
+pure subroutine symmetric_A_coeff2(tens,r1,r2)
+ implicit none
+ real(ki), dimension(4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1,r2
+
+ integer :: i1,i2
+
+ tens(:,:) = 0.0_ki
+
+ !$omp parallel do
+ do i1 = 1,4
+ do i2 = 1,4
+ tens(i1,i2) = r1(i1)*r2(i2)
+ end do
+ end do
+ !$omp end parallel do
+end subroutine symmetric_A_coeff2
+
+pure subroutine symmetric_A_coeff3(tens,r1,r2,r3)
+ implicit none
+ real(ki), dimension(4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1,r2,r3
+
+ integer :: i1,i2,i3
+
+ !$omp parallel do
+ do i1 = 1,4
+ do i2 = 1,4
+ do i3 = 1,4
+ tens(i1,i2,i3) = r1(i1)*r2(i2)*r3(i3)
+ end do
+ end do
+ end do
+ !$omp end parallel do
+end subroutine symmetric_A_coeff3
+
+pure subroutine symmetric_A_coeff4(tens,r1,r2,r3,r4)
+ implicit none
+ real(ki), dimension(4), intent(in) :: r1,r2,r3,r4
+ real(ki), dimension(4,4,4,4), intent(out) :: tens
+
+ integer :: i1,i2,i3,i4
+
+ !$omp parallel do
+ do i1 = 1,4
+ do i2 = 1,4
+ do i3 = 1,4
+ do i4 = 1,4
+ tens(i1,i2,i3,i4) = r1(i1)*r2(i2)*r3(i3)*r4(i4)
+ end do
+ end do
+ end do
+ end do
+ !$omp end parallel do
+end subroutine symmetric_A_coeff4
+
+pure subroutine symmetric_A_coeff5(tens,r1,r2,r3,r4,r5)
+ implicit none
+ real(ki), dimension(4), intent(in) :: r1,r2,r3,r4,r5
+ real(ki), dimension(4,4,4,4,4), intent(out) :: tens
+
+ integer :: i1,i2,i3,i4,i5
+
+ !$omp parallel do
+ do i1 = 1,4
+ do i2 = 1,4
+ do i3 = 1,4
+ do i4 = 1,4
+ do i5 = 1,4
+ tens(i1,i2,i3,i4,i5) = r1(i1)*r2(i2)*r3(i3)*r4(i4)*r5(i5)
+ end do
+ end do
+ end do
+ end do
+ end do
+ !$omp end parallel do
+end subroutine symmetric_A_coeff5
+
+pure subroutine symmetric_A_coeff6(tens,r1,r2,r3,r4,r5,r6)
+ implicit none
+ real(ki), dimension(4), intent(in) :: r1,r2,r3,r4,r5,r6
+ real(ki), dimension(4,4,4,4,4,4), intent(out) :: tens
+
+ integer :: i1,i2,i3,i4,i5,i6
+
+ !$omp parallel do
+ do i1 = 1,4
+ do i2 = 1,4
+ do i3 = 1,4
+ do i4 = 1,4
+ do i5 = 1,4
+ do i6 = 1,4
+ tens(i1,i2,i3,i4,i5,i6) = r1(i1)*r2(i2)*r3(i3)*r4(i4)*r5(i5)*r6(i6)
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ !$omp end parallel do
+end subroutine symmetric_A_coeff6
+!---#] Symmetric A coefficients :
+!---#[ Symmetric B coefficients :
+pure subroutine symmetric_B_coeff2(tens)
+ implicit none
+ real(ki), dimension(4,4), intent(out) :: tens
+
+ tens(:,:) = 0.0_ki
+ tens(1,1) = 1.0_ki
+ tens(2,2) = -1.0_ki
+ tens(3,3) = -1.0_ki
+ tens(4,4) = -1.0_ki
+end subroutine symmetric_B_coeff2
+
+pure subroutine symmetric_B_coeff3(tens,r1)
+ implicit none
+ real(ki), dimension(4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1
+
+ real(ki), dimension(4) :: atens
+ real(ki) :: term
+ integer :: i1,i2,i3
+ integer :: s1, s2
+
+ call symmetric_A_coeff(atens,r1)
+
+ !$omp parallel do
+ do i1=1,4
+ s1 = -sign(1, 2*i1-3)
+ do i2=1,4
+ s2 = -sign(1, 2*i2-3)
+ do i3=1,4
+ term = 0.0_ki
+ if(i2==i3) term = term + s2*atens(i1)
+ if(i1==i3) term = term + s1*atens(i2)
+ if(i1==i2) term = term + s1*atens(i3)
+ tens(i1,i2,i3) = term
+ enddo
+ enddo
+ enddo
+ !$omp end parallel do
+end subroutine symmetric_B_coeff3
+
+pure subroutine symmetric_B_coeff4(tens,r1,r2)
+ implicit none
+ real(ki), dimension(4,4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2
+
+ real(ki) :: term
+ real(ki), dimension(4,4) :: atens
+ integer :: i1,i2,i3,i4
+ integer :: s1,s2,s3
+
+ call symmetric_A_coeff(atens,r1,r2)
+
+ !$omp parallel do
+ do i1=1,4
+ s1 = -sign(1, 2*i1-3)
+ do i2=1,4
+ s2 = -sign(1, 2*i2-3)
+ do i3=1,4
+ s3 = -sign(1, 2*i3-3)
+ do i4=1,4
+ term = 0.0_ki
+ if(i3==i4) term = term + s3*atens(i1,i2)
+ if(i2==i4) term = term + s2*atens(i1,i3)
+ if(i2==i3) term = term + s2*atens(i1,i4)
+ if(i1==i4) term = term + s1*atens(i2,i3)
+ if(i1==i3) term = term + s1*atens(i2,i4)
+ if(i1==i2) term = term + s1*atens(i3,i4)
+ tens(i1,i2,i3,i4) = term
+ enddo
+ enddo
+ enddo
+ enddo
+ !$omp end parallel do
+end subroutine symmetric_B_coeff4
+
+pure subroutine symmetric_B_coeff5(tens,r1,r2,r3)
+ implicit none
+ real(ki), dimension(4,4,4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1, r2, r3
+
+ real(ki) :: term
+ real(ki), dimension(4,4,4) :: atens
+ integer :: i1,i2,i3,i4,i5
+ integer :: s1,s2,s3,s4
+
+ call symmetric_A_coeff(atens,r1,r2,r3)
+
+ !$omp parallel do
+ do i1=1,4
+ s1 = -sign(1, 2*i1-3)
+ do i2=1,4
+ s2 = -sign(1, 2*i2-3)
+ do i3=1,4
+ s3 = -sign(1, 2*i3-3)
+ do i4=1,4
+ s4 = -sign(1, 2*i4-3)
+ do i5=1,4
+ term = 0.0_ki
+ if(i4==i5) term = term + s4*atens(i1,i2,i3)
+ if(i3==i5) term = term + s3*atens(i1,i2,i4)
+ if(i3==i4) term = term + s3*atens(i1,i2,i5)
+ if(i2==i5) term = term + s2*atens(i1,i3,i4)
+ if(i2==i4) term = term + s2*atens(i1,i3,i5)
+ if(i2==i3) term = term + s2*atens(i1,i4,i5)
+ if(i1==i5) term = term + s1*atens(i2,i3,i4)
+ if(i1==i4) term = term + s1*atens(i2,i3,i5)
+ if(i1==i3) term = term + s1*atens(i2,i4,i5)
+ if(i1==i2) term = term + s1*atens(i3,i4,i5)
+ tens(i1,i2,i3,i4,i5) = term
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$omp end parallel do
+end subroutine symmetric_B_coeff5
+!---#] Symmetric B coefficients :
+!---#[ Symmetric C coefficients :
+pure subroutine symmetric_C_coeff4(tens)
+ implicit none
+ real(ki), dimension(4,4,4,4), intent(out) :: tens
+
+ real(ki) :: term
+ integer :: i1,i2,i3,i4
+ integer :: s1, s2, s3
+
+ !$omp parallel do
+ do i1=1,4
+ s1 = -sign(1, 2*i1-3)
+ do i2=1,4
+ s2 = -sign(1, 2*i2-3)
+ do i3=1,4
+ s3 = -sign(1, 2*i3-3)
+ do i4=1,4
+ term = 0.0_ki
+ if((i1==i2).and.(i3==i4)) term = term + s1*s3
+ if((i1==i3).and.(i2==i4)) term = term + s1*s2
+ if((i1==i4).and.(i2==i3)) term = term + s1*s2
+ tens(i1,i2,i3,i4) = term
+ enddo
+ enddo
+ enddo
+ enddo
+ !$omp end parallel do
+end subroutine symmetric_C_coeff4
+
+pure subroutine symmetric_C_coeff5(tens,r1)
+ implicit none
+ real(ki), dimension(4,4,4,4,4), intent(out) :: tens
+ real(ki), dimension(4), intent(in) :: r1
+
+ real(ki), dimension(4) :: atens
+ real(ki) :: term
+ integer :: i1,i2,i3,i4,i5
+ integer :: s1, s2, s3, s4
+
+ call symmetric_A_coeff(atens,r1)
+
+ !$omp parallel do
+ do i1=1,4
+ s1 = -sign(1, 2*i1-3)
+ do i2=1,4
+ s2 = -sign(1, 2*i2-3)
+ do i3=1,4
+ s3 = -sign(1, 2*i3-3)
+ do i4=1,4
+ s4 = -sign(1, 2*i4-3)
+ do i5=1,4
+ term = 0.0_ki
+ if((i5==i2).and.(i3==i4)) term = term + s2*s3*atens(i1)
+ if((i5==i3).and.(i2==i4)) term = term + s3*s2*atens(i1)
+ if((i5==i4).and.(i2==i3)) term = term + s4*s2*atens(i1)
+ if((i1==i5).and.(i3==i4)) term = term + s1*s3*atens(i2)
+ if((i1==i3).and.(i5==i4)) term = term + s1*s4*atens(i2)
+ if((i1==i4).and.(i5==i3)) term = term + s1*s3*atens(i2)
+ if((i1==i2).and.(i5==i4)) term = term + s1*s4*atens(i3)
+ if((i1==i5).and.(i2==i4)) term = term + s1*s2*atens(i3)
+ if((i1==i4).and.(i2==i5)) term = term + s1*s2*atens(i3)
+ if((i1==i2).and.(i3==i5)) term = term + s1*s3*atens(i4)
+ if((i1==i3).and.(i2==i5)) term = term + s1*s2*atens(i4)
+ if((i1==i5).and.(i2==i3)) term = term + s1*s2*atens(i4)
+ if((i1==i2).and.(i3==i4)) term = term + s1*s3*atens(i5)
+ if((i1==i3).and.(i2==i4)) term = term + s1*s2*atens(i5)
+ if((i1==i4).and.(i2==i3)) term = term + s1*s2*atens(i5)
+ tens(i1,i2,i3,i4,i5) = term
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$omp end parallel do
+end subroutine symmetric_C_coeff5
+!---#] Symmetric C coefficients :
+end module tensor_integrals
diff --git a/golem95c-1.2.1/interface/tool_lt_to_golem.f90 b/golem95c-1.2.1/interface/tool_lt_to_golem.f90
new file mode 100644
index 0000000..e274bdf
--- /dev/null
+++ b/golem95c-1.2.1/interface/tool_lt_to_golem.f90
@@ -0,0 +1,93 @@
+!
+!****h* src/interface/tool_lt_to_golem
+! NAME
+!
+! Module tool_lt_to_golem
+!
+! USAGE
+!
+! use tool_lt_to_golem
+!
+! DESCRIPTION
+!
+! This module contains one function to build the interface between LoopTools
+! and Golem
+!
+! OUTPUT
+!
+! This module exports one function:
+! * extract -- extract the numbers contained in a string
+!
+! USES
+!
+!
+!
+!*****
+module tool_lt_to_golem
+ !
+ implicit none
+ !
+ private
+ !
+ public :: extract
+ !
+ contains
+ !
+ !****f* src/interface/tool_lt_to_golem/extract
+ ! NAME
+ !
+ ! Subroutine extract
+ !
+ ! USAGE
+ !
+ ! call extract(chaine,tab_int)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine takes a string of characters, extracts the numbers and puts them into an array
+ !
+ ! INPUTS
+ !
+ ! * chaine -- a character of unknown length
+ ! * tab_int -- an integer array of rank 1 whose extend is length(chaine),
+ ! it is filled with -1
+ !
+ ! SIDE EFFECTS
+ !
+ ! no side effect
+ !
+ ! RETURN VALUE
+ !
+ ! it returns an integer array of rank 1
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine extract(chaine,tab_int)
+ !
+ character (len=*), intent (in) :: chaine
+ integer, dimension(len(chaine)) :: tab_int
+ !
+ integer :: i
+ character (len=10) :: chiffre = '0123456789'
+ character (len=1) :: c
+ !
+ tab_int = -1
+ !
+ do i=1, len(chaine)
+ !
+ c = chaine(i:i+1)
+ !
+ if (verify(c,chiffre) == 0) then
+ !
+ tab_int(i) = iachar(c) - 48
+ !
+ end if
+ !
+ end do
+ !
+ end subroutine extract
+ !
+end module tool_lt_to_golem
diff --git a/golem95c-1.2.1/kinematic/Makefile.am b/golem95c-1.2.1/kinematic/Makefile.am
new file mode 100644
index 0000000..2e25951
--- /dev/null
+++ b/golem95c-1.2.1/kinematic/Makefile.am
@@ -0,0 +1,12 @@
+noinst_LTLIBRARIES=libgolem95_kinematics.la
+
+
+libgolem95_kinematics_la_SOURCES= inverse_matrice.f90 matrice_s.f90
+libgolem95_kinematics_la_FCFLAGS=\
+ -I$(builddir)/../module \
+ -I$(builddir)/../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS= matrice_s.mod inverse_matrice.mod
+CLEANFILES=*.mod
+
+include Makefile.dep
diff --git a/golem95c-1.2.1/kinematic/Makefile.dep b/golem95c-1.2.1/kinematic/Makefile.dep
new file mode 100644
index 0000000..997be1f
--- /dev/null
+++ b/golem95c-1.2.1/kinematic/Makefile.dep
@@ -0,0 +1,4 @@
+# Module dependencies
+matrice_s.o: inverse_matrice.o
+matrice_s.lo: inverse_matrice.lo
+matrice_s.obj: inverse_matrice.obj
diff --git a/golem95c-1.2.1/kinematic/Makefile.in b/golem95c-1.2.1/kinematic/Makefile.in
new file mode 100644
index 0000000..e789898
--- /dev/null
+++ b/golem95c-1.2.1/kinematic/Makefile.in
@@ -0,0 +1,560 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.dep \
+ $(srcdir)/Makefile.in
+subdir = golem95c-1.2.1/kinematic
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+LTLIBRARIES = $(noinst_LTLIBRARIES)
+libgolem95_kinematics_la_LIBADD =
+am_libgolem95_kinematics_la_OBJECTS = \
+ libgolem95_kinematics_la-inverse_matrice.lo \
+ libgolem95_kinematics_la-matrice_s.lo
+libgolem95_kinematics_la_OBJECTS = \
+ $(am_libgolem95_kinematics_la_OBJECTS)
+libgolem95_kinematics_la_LINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=link $(FCLD) \
+ $(libgolem95_kinematics_la_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem95_kinematics_la_SOURCES)
+DIST_SOURCES = $(libgolem95_kinematics_la_SOURCES)
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgincludedir)"
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+noinst_LTLIBRARIES = libgolem95_kinematics.la
+libgolem95_kinematics_la_SOURCES = inverse_matrice.f90 matrice_s.f90
+libgolem95_kinematics_la_FCFLAGS = \
+ -I$(builddir)/../module \
+ -I$(builddir)/../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS = matrice_s.mod inverse_matrice.mod
+CLEANFILES = *.mod
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/kinematic/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/kinematic/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+
+clean-noinstLTLIBRARIES:
+ -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+ @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem95_kinematics.la: $(libgolem95_kinematics_la_OBJECTS) $(libgolem95_kinematics_la_DEPENDENCIES)
+ $(libgolem95_kinematics_la_LINK) $(libgolem95_kinematics_la_OBJECTS) $(libgolem95_kinematics_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+libgolem95_kinematics_la-inverse_matrice.lo: inverse_matrice.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_kinematics_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_kinematics_la-inverse_matrice.lo $(FCFLAGS_f90) `test -f 'inverse_matrice.f90' || echo '$(srcdir)/'`inverse_matrice.f90
+
+libgolem95_kinematics_la-matrice_s.lo: matrice_s.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_kinematics_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_kinematics_la-matrice_s.lo $(FCFLAGS_f90) `test -f 'matrice_s.f90' || echo '$(srcdir)/'`matrice_s.f90
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libtool clean-noinstLTLIBRARIES ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+matrice_s.o: inverse_matrice.o
+matrice_s.lo: inverse_matrice.lo
+matrice_s.obj: inverse_matrice.obj
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/kinematic/inverse_matrice.f90 b/golem95c-1.2.1/kinematic/inverse_matrice.f90
new file mode 100644
index 0000000..ffc2770
--- /dev/null
+++ b/golem95c-1.2.1/kinematic/inverse_matrice.f90
@@ -0,0 +1,1562 @@
+!
+!****h* src/kinematic/inverse_matrice
+! NAME
+!
+! Module inverse_matrice
+!
+! USAGE
+!
+! use inverse_matrice
+!
+! DESCRIPTION
+!
+! This module provides some routines and tools to inverse a n x n matrix.
+!
+! OUTPUT
+!
+! This module exports two routines:
+! * inverse -- to inverse a nXn matrix
+! * imprime_mat -- to print a nXn matrix
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * equal (src/module/equal.f90)
+! * s_matrix_type (src/module/s_matrix_type.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+module inverse_matrice
+ use precision_golem
+ use equal
+ use s_matrix_type
+ use parametre, only : accuracy_par
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use constante, only:czero
+ implicit none
+ !
+ private
+ !
+ interface imprime_mat
+ !
+ module procedure imprime_mat_r, imprime_mat_c
+ module procedure imprime_mat_p
+ !
+ end interface
+ !
+ interface inverse
+ !
+ module procedure inverse_r, inverse_c
+ module procedure inverse_pr, inverse_pc
+ !
+ end interface
+ !
+ interface inverse_rescue
+ !
+ module procedure inverse_rescue_r, inverse_rescue_c
+ !
+ end interface
+ !
+ interface inverse_true
+ !
+ module procedure inverse_true_r, inverse_true_c
+ !
+ end interface
+ !
+ interface lu_decomp
+ !
+ module procedure lu_decomp_r, lu_decomp_c
+ !
+ end interface
+ !
+ interface inverse_triangular
+ !
+ module procedure inverse_triangular_r, inverse_triangular_c
+ !
+ end interface
+ !
+ interface inverse_greville
+ !
+ module procedure inverse_greville_r, inverse_greville_c
+ !
+ end interface
+ !
+ interface compt
+ !
+ module procedure compt_r, compt_c
+ !
+ end interface
+ !
+ interface verif
+ !
+ module procedure verif_r, verif_c
+ !
+ end interface
+ !
+ public :: inverse, imprime_mat
+ real(ki) :: glob_eps = 1.e-12_ki ! valeur en de ca duquelle on
+ ! passe au cas singulier
+ contains
+ !
+ !****f* src/kinematic/inverse_matrice/inverse
+ ! NAME
+ !
+ ! Subroutine inverse
+ !
+ ! USAGE
+ !
+ ! call inverse(mat,inv_mat,error,pinch1,pinch2)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine first tries the Gauss method with partial pivoting strategy.
+ ! If the error returned is too large (greater than the global variable accuracy_par),
+ ! then it switches to another method : the Greville method.
+ ! In the case of the Gauss method, if some reduced matrices need to be inverted, a new matrix is built
+ ! by removing the row(s) and column(s) pinch1,pinch2, etc. then the inverse is computed and the result returned
+ ! is a nXn matrix where the column(s) and row(s) pinch1, pinch2, etc. are filled by 0, the other elements
+ ! are those of the inverse computed. In the Greville method, the reduce matrix which is a nXn matrix
+ ! where the column(s) and row(s) pinch1, pinch2, etc. are filled by 0 is directly inverted.
+ ! Note that the error is computed in the following way:
+ ! first the matrix is rescaled : i. e. divided by the greatest (in absolute value) element
+ ! then the inverse is computed and the two matrices abs(1 - A^(-1) A) and abs(1 - A A^(-1)) are computed
+ ! the error is the greatest element of these two matrices.
+ ! In the case of the Greville method, the Moore_Penrose conditions are also tested
+ !
+ ! INPUTS
+ !
+ ! * mat -- a real/complex (type ki) array of rank 2, or an s_matrix_poly type.
+ ! * pinch1 -- an integer (optional), specified a pinch
+ ! * pinch2 -- an integer (optional), specified a pinch
+ ! * pinch3 -- an integer (optional), specified a pinch
+ ! * pinch4 -- an integer (optional), specified a pinch
+ ! * pinch5 -- an integer (optional), specified a pinch
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * inv_mat -- a real (type ki) array of rank 2, same shape, the inverse
+ ! of the matrix mat
+ ! * error -- a real (type ki), the estimation of the error of the numerical inversion
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine inverse_pr(mat_p,inv_mat_r,error,pinch1,pinch2,pinch3,pinch4,pinch5)
+ type(s_matrix_poly), intent(in) :: mat_p
+ real(ki), intent(out), dimension(size(mat_p%pt_real,1),size(mat_p%pt_real,1)) :: inv_mat_r
+ real(ki), intent(out) :: error
+ integer, optional :: pinch1, pinch2,pinch3,pinch4,pinch5
+ !
+ if (associated(mat_p%pt_real)) then
+ call inverse_r(mat_p%pt_real,inv_mat_r,error, pinch1=pinch1, pinch2=pinch2,pinch3=pinch3,pinch4=pinch4,pinch5=pinch5)
+ end if
+ !
+ end subroutine inverse_pr
+ !
+ subroutine inverse_pc(mat_p,inv_mat_c,error,pinch1,pinch2,pinch3,pinch4,pinch5)
+ type(s_matrix_poly), intent(in) :: mat_p
+ complex(ki), intent(out), dimension(size(mat_p%pt_cmplx,1),size(mat_p%pt_cmplx,1)) :: inv_mat_c
+ real(ki), intent(out) :: error
+ integer, optional :: pinch1, pinch2,pinch3,pinch4,pinch5
+ !
+ if (associated(mat_p%pt_cmplx)) then
+ call inverse_c(mat_p%pt_cmplx,inv_mat_c,error,pinch1=pinch1,pinch2=pinch2,pinch3=pinch3,pinch4=pinch4,pinch5=pinch5)
+ end if
+ !
+ end subroutine inverse_pc
+ !
+ subroutine inverse_r(mat_r,inv_mat_r,error,pinch1,pinch2,pinch3,pinch4,pinch5)
+ !
+ real(ki), intent(in), dimension(:,:) :: mat_r
+ real(ki), intent(out), dimension(size(mat_r,1),size(mat_r,1)) :: inv_mat_r
+ real(ki), intent(out) :: error
+ integer, optional :: pinch1,pinch2,pinch3,pinch4,pinch5
+ !
+ real(ki), dimension(size(mat_r,1),size(mat_r,1)) :: norm_mat_r, mat_greville
+ real(ki) :: plus_grand,g_error,o_error
+ integer :: pin1,pin2,pin3,pin4,pin5
+ !
+ pin1 = -1
+ pin2 = -1
+ pin3 = -1
+ pin4 = -1
+ pin5 = -1
+ !
+ if (present(pinch1)) pin1 = pinch1
+ if (present(pinch2)) pin2 = pinch2
+ if (present(pinch3)) pin3 = pinch3
+ if (present(pinch4)) pin4 = pinch4
+ if (present(pinch5)) pin5 = pinch5
+ !
+ g_error = 1._ki
+ o_error = 1._ki
+ !
+ !
+ ! First we rescale the matrix
+ !
+ plus_grand = maxval(array=abs(mat_r))
+ norm_mat_r = mat_r/plus_grand
+ !
+ ! We first use the Gauss method
+ !
+ call inverse_rescue(norm_mat_r,inv_mat_r,o_error,pin1,pin2,pin3,pin4,pin5)
+ !
+ if (o_error >= accuracy_par) then
+ !
+ call inverse_greville(norm_mat_r,mat_greville,g_error)
+ !
+ if (g_error .lt. o_error) then
+ inv_mat_r = mat_greville
+ end if
+ !
+ end if
+ !
+ error = min(g_error,o_error)
+ !
+ if (error >= accuracy_par) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'the Greville method failed'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the Gauss method failed too'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'the error returned %f0'
+ tab_erreur_par(3)%arg_real = error
+ call catch_exception(1)
+ !
+ end if
+ !
+ inv_mat_r = inv_mat_r/plus_grand
+ !
+ end subroutine inverse_r
+ !
+ subroutine inverse_c(mat_c,inv_mat_c,error,pinch1,pinch2,pinch3,pinch4,pinch5)
+ !
+ complex(ki), intent(in), dimension(:,:) :: mat_c
+ complex(ki), intent(out), dimension(size(mat_c,1),size(mat_c,1)) :: inv_mat_c
+ real(ki), intent(out) :: error
+ integer, optional :: pinch1,pinch2,pinch3,pinch4,pinch5
+ !
+ complex(ki), dimension(size(mat_c,1),size(mat_c,1)) :: norm_mat_c, mat_greville_c
+ real(ki) :: plus_grand,g_error,o_error
+ integer :: pin1,pin2,pin3,pin4,pin5
+ !
+ pin1 = -1
+ pin2 = -1
+ pin3 = -1
+ pin4 = -1
+ pin5 = -1
+ !
+ if (present(pinch1)) pin1 = pinch1
+ if (present(pinch2)) pin2 = pinch2
+ if (present(pinch2)) pin3 = pinch3
+ if (present(pinch2)) pin4 = pinch4
+ if (present(pinch2)) pin5 = pinch5
+ !
+ g_error = 1._ki
+ o_error = 1._ki
+ !
+ !
+ ! First we rescale the matrix
+ !
+ plus_grand = max(maxval( array=abs( real(mat_c,ki) ) ), maxval( array=abs( aimag(mat_c) ) ) )
+ norm_mat_c = mat_c/cmplx(plus_grand,0._ki,ki)
+ !
+ ! We first use the Gauss method
+ !
+ call inverse_rescue(norm_mat_c,inv_mat_c,o_error,pin1,pin2,pin3,pin4,pin5)
+ !
+ if (o_error >= accuracy_par) then
+ !
+ call inverse_greville(norm_mat_c,mat_greville_c,g_error)
+ !
+ if (g_error .lt. o_error) then
+ inv_mat_c = mat_greville_c
+ end if
+ end if
+ !
+ error = min(g_error,o_error)
+ !
+ if (error >= accuracy_par) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'the Greville method failed'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the Gauss method failed too'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'the error returned %f0'
+ tab_erreur_par(3)%arg_real = error
+ call catch_exception(1)
+ !
+ end if
+ !
+ inv_mat_c = inv_mat_c/plus_grand
+ !
+ end subroutine inverse_c
+ !****if* src/kinematic/inverse_matrice/inverse_rescue
+ ! NAME
+ !
+ ! Subroutine inverse_rescue
+ !
+ ! USAGE
+ !
+ ! call inverse_rescue(mat,inv_mat,error,pinch1,pinch2)
+ !
+ ! DESCRIPTION
+ !
+ ! The role of this routine is just to reduce the size the input
+ ! matrix mat if pinch1 and/or pinch2 etc. is/are present
+ !
+ ! INPUTS
+ !
+ ! * mat -- a real/complex (type ki) array of rank 2
+ ! * pinch1 -- an integer (optional), specified a pinch
+ ! * pinch2 -- an integer (optional), specified a pinch
+ ! * pinch3 -- an integer (optional), specified a pinch
+ ! * pinch4 -- an integer (optional), specified a pinch
+ ! * pinch5 -- an integer (optional), specified a pinch
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * inv_mat -- a real/compelx (type ki) array of rank 2, same shape, the inverse
+ ! of the matrix mat
+ ! * error -- a real (type ki), the estimation of the error of the numerical inversion
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine inverse_rescue_r(mat_r,inv_mat_r,error,pin1,pin2,pin3,pin4,pin5)
+ !
+ real(ki), intent(in), dimension(:,:) :: mat_r
+ real(ki), intent(out), dimension(size(mat_r,1),size(mat_r,1)) :: inv_mat_r
+ real(ki), intent(out) :: error
+ integer, intent(in) :: pin1,pin2,pin3,pin4,pin5
+ !
+ integer :: i,j,n_dim
+ logical, dimension(size(mat_r,1),size(mat_r,1)) :: masque
+ real(ki), dimension(size(mat_r,1),size(mat_r,1)) :: f2
+ real(ki), dimension(:,:), allocatable :: true_mat_r,true_inv_mat_r
+ real(ki), dimension(:), allocatable :: true_vect_r
+ integer, dimension(5) :: tab_pinch
+ integer :: nb_pinch
+ !
+ tab_pinch = (/pin1,pin2,pin3,pin4,pin5/)
+ nb_pinch = count(mask=tab_pinch /= -1)
+ masque = .true.
+ !
+ n_dim = size(mat_r,1)-nb_pinch
+ !
+ allocate(true_mat_r(n_dim,n_dim))
+ allocate(true_inv_mat_r(n_dim,n_dim))
+ allocate(true_vect_r(n_dim*n_dim))
+ !
+ select case (nb_pinch)
+ !
+ case(0)
+ !
+ true_mat_r = mat_r
+ !
+ case default ! nb_pinch > 0
+ !
+ do i = 1, size(tab_pinch)
+ j=tab_pinch(i)
+ if (j /= -1) then
+ masque(j,:) = .false.
+ masque(:,j) = .false.
+ end if
+ end do
+ true_vect_r = pack(mat_r,mask=masque)
+ true_mat_r = reshape(source=true_vect_r,shape=(/n_dim,n_dim/))
+ end select
+ !
+ call inverse_true(true_mat_r,true_inv_mat_r,error)
+ !
+ f2(:,:) = 0._ki
+ true_vect_r = pack(true_inv_mat_r,.true.)
+ inv_mat_r = unpack(true_vect_r,masque,f2)
+ !
+ deallocate(true_mat_r)
+ deallocate(true_inv_mat_r)
+ deallocate(true_vect_r)
+ !
+ end subroutine inverse_rescue_r
+ !
+ subroutine inverse_rescue_c(mat_c,inv_mat_c,error,pin1,pin2,pin3,pin4,pin5)
+ !
+ complex(ki), intent(in), dimension(:,:) :: mat_c
+ complex(ki), intent(out), dimension(size(mat_c,1),size(mat_c,1)) :: inv_mat_c
+ real(ki), intent(out) :: error
+ integer, intent(in) :: pin1,pin2,pin3,pin4,pin5
+ !
+ integer :: i,j,n_dim
+ logical, dimension(size(mat_c,1),size(mat_c,1)) :: masque
+ complex(ki), dimension(size(mat_c,1),size(mat_c,1)) :: f2
+ complex(ki), dimension(:,:), allocatable :: true_mat_c,true_inv_mat_c
+ complex(ki), dimension(:), allocatable :: true_vect_c
+ integer, dimension(5) :: tab_pinch
+ integer :: nb_pinch
+ !
+ tab_pinch = (/pin1,pin2,pin3,pin4,pin5/)
+ nb_pinch = count(mask=tab_pinch /= -1)
+ masque = .true.
+ !
+ n_dim = size(mat_c,1)-nb_pinch
+ !
+ allocate(true_mat_c(n_dim,n_dim))
+ allocate(true_inv_mat_c(n_dim,n_dim))
+ allocate(true_vect_c(n_dim*n_dim))
+ !
+ select case (nb_pinch)
+ !
+ case(0)
+ !
+ true_mat_c = mat_c
+ !
+ case default ! nb_pinch > 0
+ !
+ do i = 1, size(tab_pinch)
+ j=tab_pinch(i)
+ if (j /= -1) then
+ masque(j,:) = .false.
+ masque(:,j) = .false.
+ end if
+ end do
+ true_vect_c = pack(mat_c,mask=masque)
+ true_mat_c = reshape(source=true_vect_c,shape=(/n_dim,n_dim/))
+ end select
+ !
+ call inverse_true(true_mat_c,true_inv_mat_c,error)
+ !
+ f2(:,:) = czero
+ true_vect_c = pack(true_inv_mat_c,.true.)
+ inv_mat_c = unpack(true_vect_c,masque,f2)
+ !
+ deallocate(true_mat_c)
+ deallocate(true_inv_mat_c)
+ deallocate(true_vect_c)
+ !
+ end subroutine inverse_rescue_c
+ !
+ !****if* src/kinematic/inverse_matrice/inverse_true
+ ! NAME
+ !
+ ! Subroutine inverse_true
+ !
+ ! USAGE
+ !
+ ! call inverse_true(mat,inv_mat,error)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine uses a Gauss pivot method with partial pivoting to inverse M a nXn matrix.
+ ! It returns an estimation of the error by computing the two matrices abs(1 - M^(-1) M)
+ ! and abs(1 - M M^(-1)). The error is the greatest element of these two matrices.
+ !
+ ! INPUTS
+ !
+ ! * mat -- a real/complex (type ki) array of rank 2
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * inv_mat -- a real/complex (type ki) array of rank 2, same shape, the inverse
+ ! of the matrix mat
+ ! * error -- a real (type ki), the estimation of the error of the numerical inversion
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine inverse_true_r(mat_r,inv_mat_r,error)
+ !
+ real(ki), intent(in), dimension(:,:) :: mat_r
+ real(ki), intent(out), dimension(size(mat_r,1),size(mat_r,1)) :: inv_mat_r
+ real(ki), intent(out) :: error
+ !
+ real(ki), dimension(size(mat_r,1),size(mat_r,1)) :: mat1,mat2,unit_mat
+ real(ki), dimension(size(mat_r,1),size(mat_r,1)) :: p_mat,l_mat,u_mat
+ real(ki), dimension(size(mat_r,1),size(mat_r,1)) :: inv_l_mat,inv_u_mat
+ integer :: i,n_dim
+ real(ki) :: max1,max2
+ !integer :: errorflag
+ !
+ n_dim = size(mat_r,1) ! dimension de la matrice
+ unit_mat(:,:) = 0._ki
+ !
+ do i=1,n_dim
+ !
+ unit_mat(i,i) = 1._ki
+ !
+ end do
+ !
+ call lu_decomp(mat_r,p_mat,l_mat,u_mat)
+ call inverse_triangular(l_mat,'inf',inv_l_mat)
+ call inverse_triangular(u_mat,'sup',inv_u_mat)
+ inv_mat_r = matmul(inv_u_mat,inv_l_mat)
+ inv_mat_r = matmul(inv_mat_r,transpose(p_mat))
+ !
+ mat1 = matmul(inv_mat_r,mat_r)
+ mat2 = matmul(mat_r,inv_mat_r)
+ mat1 = abs(mat1-unit_mat)
+ mat2 = abs(mat2-unit_mat)
+ !
+ max1 = maxval(mat1)
+ max2 = maxval(mat2)
+ !
+ error = max(max1,max2)
+ !
+ end subroutine inverse_true_r
+ !
+ subroutine inverse_true_c(mat_c,inv_mat_c,error)
+ !
+ complex(ki), intent(in), dimension(:,:) :: mat_c
+ complex(ki), intent(out), dimension(size(mat_c,1),size(mat_c,1)) :: inv_mat_c
+ real(ki), intent(out) :: error
+ !
+ complex(ki), dimension(size(mat_c,1),size(mat_c,1)) :: mat1c,mat2c,unit_mat
+ complex(ki), dimension(size(mat_c,1),size(mat_c,1)) :: p_mat,l_mat,u_mat
+ complex(ki), dimension(size(mat_c,1),size(mat_c,1)) :: inv_l_mat,inv_u_mat
+ real(ki), dimension(size(mat_c,1),size(mat_c,1)) :: mat1, mat2
+ integer :: i,n_dim
+ real(ki) :: max1,max2
+ !integer :: errorflag
+ !
+ n_dim = size(mat_c,1) ! dimension de la matrice
+ unit_mat(:,:) = czero
+ !
+ do i=1,n_dim
+ !
+ unit_mat(i,i) = cmplx(1._ki,0._ki,ki)
+ !
+ end do
+ !
+ call lu_decomp(mat_c,p_mat,l_mat,u_mat)
+ call inverse_triangular(l_mat,'inf',inv_l_mat)
+ call inverse_triangular(u_mat,'sup',inv_u_mat)
+ inv_mat_c = matmul(inv_u_mat,inv_l_mat)
+ inv_mat_c = matmul(inv_mat_c,transpose(p_mat))
+ !
+ mat1c = matmul(inv_mat_c,mat_c)
+ mat2c = matmul(mat_c,inv_mat_c)
+ mat1 = abs(mat1c-unit_mat)
+ mat2 = abs(mat2c-unit_mat)
+ !
+ max1 = maxval(mat1)
+ max2 = maxval(mat2)
+ !
+ error = max(max1,max2)
+ !
+ end subroutine inverse_true_c
+ !
+ !****if* src/kinematic/inverse_matrice/inverse_greville
+ ! NAME
+ !
+ ! Subroutine inverse_greville
+ !
+ ! USAGE
+ !
+ ! call inverse_greville(mat,inv_mat,error)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine inverses a n x n matrix using the Greville method.
+ ! This method enables to invert singular matrix using the Moore-Penrose definition.
+ ! One builds an iterative process, a rectengular matrix A is defined with the
+ ! first row of the n x n matrix, the the other rows are added step by step
+ ! At each step, the pseudo inverse (Moore-Penrose) A' is built such that
+ ! A A' = transpose(A A')
+ ! A' A = transpose(A' A)
+ ! A' A A' = A'
+ ! A A' A = A
+ !
+ ! INPUTS
+ !
+ ! * mat -- a real/complex (type ki) array of rank 2
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * inv_mat -- a real/complex (type ki) array of rank 2, same shape, the inverse
+ ! of the matrix mat
+ ! * error -- a real (type ki), the estimation of the error of the numerical inversion
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ ! On construit un processus iteratif : on definit une matrice A qui au
+ ! debut est construit en partant de la premiere colonne
+ ! puis en ajoutant les colonnes une a une.
+ ! Pour chaque etape, on construit le pseudo inverse
+ ! (au sens de Moore-Penrose) A' tel que :
+ ! A A' = transpose(A A')
+ ! A' A = transpose(A' A)
+ ! A' A A' = A'
+ ! A A' A = A
+ ! cette routine retourne une estimation de l'erreur
+ !
+ subroutine inverse_greville_r(mat_r,inv_mat_r,error)
+ !
+ real(ki), intent(in), dimension(:,:) :: mat_r
+ real(ki), intent(out), dimension(size(mat_r,1),size(mat_r,1)) :: inv_mat_r
+ real(ki), intent(out) :: error
+ !
+ real(ki), dimension(size(mat_r,1),size(mat_r,1)) :: id_mat, mat1, mat2
+ real(ki), dimension(size(mat_r,1),1) :: a
+ real(ki), dimension(1,size(mat_r,1)) :: at
+ real(ki), dimension(:,:), allocatable :: ga,ga_prime
+ real(ki), dimension(:,:), allocatable :: gab,gab_prime
+ integer :: k,n_dim
+ integer :: res
+ real(ki) :: denom, max1, max2
+ !
+ n_dim = size(mat_r,1) ! dimension de la matrice
+ !
+ !
+ id_mat = 0._ki
+ do k=1,n_dim
+ id_mat(k,k) = 1._ki
+ end do
+ !
+ ! premiere iteration
+ !
+ allocate(ga(n_dim,1),stat=res)
+ allocate(ga_prime(1,n_dim),stat=res)
+ !
+ a(:,1) = mat_r(:,1) ! premiere colonne de mat
+ ga = a ! A est la 1ere colonne de mat
+ at = transpose(a)
+ denom = sum(matmul(at,a)) ! on utilise sum pour rendre scalaire
+ ! matmul, sinon tableau (1,1)
+ if (sqrt(denom) >= glob_eps) then
+ !
+ ga_prime = at/denom ! cas standard A' pseudo-inverse de A
+ !
+ else
+ !
+ ga_prime(:,:) = 0._ki ! si mat est singuliere
+ !
+ end if
+ !
+ ! autres iterations
+ !
+ do k=2,n_dim
+ !
+ allocate(gab(n_dim,k),stat=res)
+ allocate(gab_prime(k,n_dim),stat=res)
+ !
+ a(:,1) = mat_r(:,k)
+ call compt(n_dim,k-1,a,ga,ga_prime,gab,gab_prime)
+! call verif(n_dim,k,gab,gab_prime,error)
+ !
+ deallocate(ga,stat=res)
+ deallocate(ga_prime,stat=res)
+ !
+ allocate(ga(n_dim,k),stat=res)
+ allocate(ga_prime(k,n_dim),stat=res)
+ !
+ ga = gab
+ ga_prime = gab_prime
+ !
+ deallocate(gab,stat=res)
+ deallocate(gab_prime,stat=res)
+ !
+ end do
+ !
+ inv_mat_r = ga_prime
+ !
+ mat1 = matmul(inv_mat_r,mat_r)
+ mat2 = matmul(mat_r,inv_mat_r)
+ mat1 = abs(mat1-id_mat)
+ mat2 = abs(mat2-id_mat)
+ !
+ max1 = maxval(mat1)
+ max2 = maxval(mat2)
+ !
+ error = max(max1,max2)
+ !
+ end subroutine inverse_greville_r
+ !
+ subroutine inverse_greville_c(mat_c,inv_mat_c,error)
+ !
+ complex(ki), intent(in), dimension(:,:) :: mat_c
+ complex(ki), intent(out), dimension(size(mat_c,1),size(mat_c,1)) :: inv_mat_c
+ real(ki), intent(out) :: error
+ !
+ complex(ki), dimension(size(mat_c,1),size(mat_c,1)) :: id_mat, mat1, mat2
+ complex(ki), dimension(size(mat_c,1),1) :: a
+ complex(ki), dimension(1,size(mat_c,1)) :: at
+ complex(ki), dimension(:,:), allocatable :: ga,ga_prime
+ complex(ki), dimension(:,:), allocatable :: gab,gab_prime
+ integer :: k,n_dim
+ integer :: res
+ real(ki) :: denom, max1, max2
+ !
+ n_dim = size(mat_c,1) ! dimension de la matrice
+ !
+ id_mat = czero
+ do k=1,n_dim
+ id_mat(k,k) = cmplx(1._ki,0._ki,ki)
+ end do
+ !
+ ! premiere iteration
+ !
+ allocate(ga(n_dim,1),stat=res)
+ allocate(ga_prime(1,n_dim),stat=res)
+ !
+ a(:,1) = mat_c(:,1) ! premiere colonne de mat
+ ga = a ! A est la 1ere colonne de mat
+ at = conjg(transpose(a))
+ denom = real(sum(matmul(at,a)),ki) ! on utilise sum pour rendre scalaire
+ ! matmul, sinon tableau (1,1)
+ if (sqrt(denom) >= glob_eps) then
+ !
+ ga_prime = at/denom ! cas standard A' pseudo-inverse de A
+ !
+ else
+ !
+ ga_prime(:,:) = czero ! si mat est singuliere
+ !
+ end if
+ !
+ ! autres iterations
+ !
+ do k=2, n_dim
+ !
+ allocate(gab(n_dim,k),stat=res)
+ allocate(gab_prime(k,n_dim),stat=res)
+ !
+ a(:,1) = mat_c(:,k)
+ call compt(n_dim,k-1,a,ga,ga_prime,gab,gab_prime)
+! call verif(n_dim,k,gab,gab_prime,error)
+ !
+ deallocate(ga,stat=res)
+ deallocate(ga_prime,stat=res)
+ !
+ allocate(ga(n_dim,k),stat=res)
+ allocate(ga_prime(k,n_dim),stat=res)
+ !
+ ga = gab
+ ga_prime = gab_prime
+ !
+ deallocate(gab,stat=res)
+ deallocate(gab_prime,stat=res)
+ !
+ end do
+ !
+ inv_mat_c = ga_prime
+ !
+ mat1 = matmul(inv_mat_c,mat_c)
+ mat2 = matmul(mat_c,inv_mat_c)
+ mat1 = abs(mat1-id_mat)
+ mat2 = abs(mat2-id_mat)
+ !
+ max1 = maxval(real(mat1,ki))
+ max2 = maxval(real(mat2,ki))
+ !
+ error = max(max1,max2)
+ end subroutine inverse_greville_c
+ !
+ !****if* src/kinematic/inverse_matrice/compt
+ ! NAME
+ !
+ ! Subroutine compt
+ !
+ ! USAGE
+ !
+ ! call compt(n,k,a,ga,ga_prime,ga_plus,ga_prime_plus)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine is used to iterate the inversion processus
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the shape of the matrix to inverse
+ ! * k -- an integer, number of rows
+ ! * a -- a real/complex (type ki) array of rank 2, its shape is (n,1)
+ ! * ga -- a real/complex (type ki) array of rank 2, its shapes is (n,k)
+ ! * ga_prime -- a real/complex (type ki) array of rank 2, its shapes is (k,n)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * ga_plus -- a real/complex(type ki) array of rank 2, its shape is (n,k+1)
+ ! * ga_prime_plus -- a real/complex(type ki) array of rank 2, its shape is (k+1,n)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ ! cette routine itere le processus, elle recoit en argument les dimensions
+ ! de A at A' ainsi que A et A' et retourne A+ et A'+, A+ a une colonne de
+ ! plus que A et A'+ une ligne de plus que A'
+ !
+ subroutine compt_r(n,k,a,ga,ga_prime,ga_plus,ga_prime_plus)
+ !
+ integer, intent(in) :: n,k
+ real(ki), intent(in), dimension(n,1) :: a
+ real(ki), intent(in), dimension(n,k) :: ga
+ real(ki), intent(in), dimension(k,n) :: ga_prime
+ real(ki), intent(out), dimension(n,k+1) :: ga_plus
+ real(ki), intent(out), dimension(k+1,n) :: ga_prime_plus
+ !
+ real(ki), dimension(k,1) :: d
+ real(ki), dimension(1,k) :: dt
+ real(ki), dimension(n,1) :: c
+ real(ki), dimension(1,n) :: ct
+ real(ki) :: denom
+ !
+ !
+ d = matmul(ga_prime,a)
+ dt = transpose(d)
+ c = a - matmul(ga,d)
+ ct = transpose(c) ! cas standard
+ denom = sum(matmul(ct,c)) ! cas standard
+ !
+ if (sqrt(denom) < glob_eps) then
+ !
+ ct = matmul(dt,ga_prime) ! cas singulier
+ denom = 1._ki + sum(matmul(dt,d)) ! cas singulier
+ !
+ end if
+ !
+ ga_prime_plus(1:k,:) = ga_prime - matmul(d,ct)/denom
+ ga_prime_plus(k+1,:) = ct(1,:)/denom
+ ga_plus(:,1:k) = ga
+ ga_plus(:,k+1) = a(:,1)
+ !
+ end subroutine compt_r
+
+ subroutine compt_c(n,k,a,ga,ga_prime,ga_plus,ga_prime_plus)
+ !
+ integer, intent(in) :: n,k
+ complex(ki), intent(in), dimension(n,1) :: a
+ complex(ki), intent(in), dimension(n,k) :: ga
+ complex(ki), intent(in), dimension(k,n) :: ga_prime
+ complex(ki), intent(out), dimension(n,k+1) :: ga_plus
+ complex(ki), intent(out), dimension(k+1,n) :: ga_prime_plus
+ !
+ complex(ki), dimension(k,1) :: d
+ complex(ki), dimension(1,k) :: dt
+ complex(ki), dimension(n,1) :: c
+ complex(ki), dimension(1,n) :: ct
+ real(ki) :: denom
+ !
+ d = matmul(ga_prime,a)
+ dt = conjg(transpose(d))
+ c = a - matmul(ga,d)
+ ct = conjg(transpose(c)) ! cas standard
+ denom = real(sum(matmul(ct,c)),ki) ! cas standard
+ !
+ if (sqrt(abs(denom)) < glob_eps) then
+ !
+ ct = matmul(dt,ga_prime) ! cas singulier
+ denom = 1._ki + real(sum(matmul(dt,d)),ki) ! cas singulier
+ !
+ end if
+ !
+ ga_prime_plus(1:k,:) = ga_prime - matmul(d,ct)/denom
+ ga_prime_plus(k+1,:) = ct(1,:)/denom
+ ga_plus(:,1:k) = ga
+ ga_plus(:,k+1) = a(:,1)
+ !
+ end subroutine compt_c
+
+ !
+ !****if* src/kinematic/inverse_matrice/verif
+ ! NAME
+ !
+ ! Subroutine verif
+ !
+ ! USAGE
+ !
+ ! call verif(n,k,ga,ga_prime,error)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine verifies the Moor-Penrose conditions, it returns the
+ ! maximum error obtained
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the shape of the matrix to inverse
+ ! * k -- an integer, number of rows
+ ! * ga -- a real/complex(type ki) array of rank 2, its shapes is (n,k)
+ ! * ga_prime -- a real/complex(type ki) array of rank 2, its shapes is (k,n)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * error -- a real(type ki), the maximum error obtained to fulfill the
+ ! Moor-Penrose conditions
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ ! cette routine verifie les differentes conditions de Moor-Penrose,
+ ! elle retourne une erreur qui est le maximum des nombres trouves
+ ! au lieu de 0
+ !
+ subroutine verif_r(n,k,ga,ga_prime,error)
+ !
+ integer, intent(in) :: n,k
+ real(ki), intent(in), dimension(n,k) :: ga
+ real(ki), intent(in), dimension(k,n) :: ga_prime
+ real(ki), intent (out) :: error
+ !
+ real(ki), dimension(n,n) :: mat1
+ real(ki), dimension(k,k) :: mat2
+ real(ki), dimension(n,k) :: mat3
+ real(ki), dimension(k,n) :: mat4
+ real(ki) :: max1,max2,max3,max4
+ !
+ mat1 = matmul(ga,ga_prime)
+ mat2 = matmul(ga_prime,ga)
+ mat3 = abs(matmul(mat1,ga)-ga)
+ mat4 = abs(matmul(mat2,ga_prime)-ga_prime)
+ !
+ mat1 = abs(mat1-transpose(mat1))
+ mat2 = abs(mat2-transpose(mat2))
+ !
+ max1 = maxval(mat1)
+ max2 = maxval(mat2)
+ max3 = maxval(mat3)
+ max4 = maxval(mat4)
+ !
+ error = max(max1,max2,max3,max4)
+ !
+ end subroutine verif_r
+
+ subroutine verif_c(n,k,ga,ga_prime,error)
+ !
+ integer, intent(in) :: n,k
+ complex(ki), intent(in), dimension(n,k) :: ga
+ complex(ki), intent(in), dimension(k,n) :: ga_prime
+ real(ki), intent (out) :: error
+ !
+ complex(ki), dimension(n,n) :: mat1
+ complex(ki), dimension(k,k) :: mat2
+ real(ki), dimension(n,n) :: mat1a
+ real(ki), dimension(k,k) :: mat2a
+ real(ki), dimension(n,k) :: mat3
+ real(ki), dimension(k,n) :: mat4
+ real(ki) :: max1,max2,max3,max4
+ !
+ mat1 = matmul(ga,ga_prime)
+ mat2 = matmul(ga_prime,ga)
+ mat3 = abs(matmul(mat1,ga)-ga)
+ mat4 = abs(matmul(mat2,ga_prime)-ga_prime)
+ !
+ mat1a = abs(mat1-transpose(mat1))
+ mat2a = abs(mat2-transpose(mat2))
+ !
+ max1 = maxval(mat1a)
+ max2 = maxval(mat2a)
+ max3 = maxval(mat3)
+ max4 = maxval(mat4)
+ !
+ error = max(max1,max2,max3,max4)
+ !
+ end subroutine verif_c
+ !
+ !****f* src/kinematic/inverse_matrice/imprime_mat
+ ! NAME
+ !
+ ! Subroutine imprime_mat
+ !
+ ! USAGE
+ !
+ ! call imprime_mat(mat)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine prints a n x n matrix
+ !
+ ! INPUTS
+ !
+ ! * mat -- a real/complex (type ki) array of rank 2
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! No value returned
+ !
+ ! EXAMPLE
+ !
+ ! WARNING: swapped lines and columns! mat(line, column)
+ !
+ !*****
+ ! cette routine sert a imprimer une matrice carree
+
+ subroutine imprime_mat_p(mat_p)
+ type(s_matrix_poly), intent(inout) :: mat_p
+ !
+ if (associated(mat_p%pt_cmplx)) then
+ call imprime_mat(mat_p%pt_cmplx)
+ elseif (associated(mat_p%pt_real)) then
+ call imprime_mat(mat_p%pt_real)
+ end if
+ !
+ end subroutine imprime_mat_p
+ !
+ !
+ subroutine imprime_mat_r(mat)
+ !
+ real(ki), intent(in), dimension(:,:) :: mat
+ !
+ character(len=11*(size(mat,2)-1)+8+14) :: form
+ integer :: i
+ integer, dimension(2) :: dim
+ !
+ dim = shape(mat)
+ form = '(1x,"[",'//repeat('E17.10,TR2,', dim(2)-1)//'E17.10,"]",1x)'
+
+ do i=1,dim(1)
+ !
+ write (*, fmt=form ) mat(i,:)
+ !
+ end do
+ !
+ end subroutine imprime_mat_r
+ !
+ subroutine imprime_mat_c(matc)
+ !
+ complex(ki), intent(in), dimension(:,:) :: matc
+ !
+ character(len=32*(size(matc,2)-1)+30) :: form
+ integer :: i
+ integer, dimension(2) :: dim
+ !
+ dim = shape(matc)
+ form = ""
+ !
+ do i=1,dim(2)-1
+ !
+ form = trim(form)//'"(",e16.10,1x,"I*",e16.10,")",2x'
+ !
+ end do
+ !
+ form = trim(form)//'"(",e16.10,1x,"I*",e16.10,")"'
+ !
+ do i=1,dim(1)
+ !
+ write (*,'(1x,"[",'//form//',"]")') matc(i,:)
+ !
+ end do
+ !
+ end subroutine imprime_mat_c
+ !
+ !****if* src/kinematic/inverse_matrice/inverse_triangular
+ ! NAME
+ !
+ ! Subroutine inverse_triangular
+ !
+ ! USAGE
+ !
+ ! call inverse_triangular(mat,inf_or_sup,inv_mat)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine inverses an upper or lower triangular matrix
+ ! The program assumes that the matrix is lower triangular, if it is upper
+ ! the program works with the transposed matrix
+ !
+ ! INPUTS
+ !
+ ! * mat -- a real/complex (type ki) array of rank 2
+ ! * inf_or_sup -- a string of 3 characters : inf or sup
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * inv_mat -- a real/complex (type ki) array of rank 2, the inverse of the triangular matrix
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine inverse_triangular_r(mat_r,inf_or_sup,inv_mat_r)
+ !
+ real(ki), intent(in), dimension(:,:) :: mat_r
+ character(len=3), intent(in) :: inf_or_sup
+ real(ki), intent(out), dimension(size(mat_r,1),size(mat_r,1)) :: inv_mat_r
+ !
+ logical :: inversible,triangular_sup,triangular_inf
+ integer :: n_dim,i,j,k
+ real(ki) :: somme
+ real(ki), dimension(size(mat_r,1),size(mat_r,1)) :: mat1
+ !
+ n_dim = size(mat_r,1) ! dimension de la matrice
+ inversible = .true.
+ triangular_inf = .false.
+ triangular_sup = .false.
+ inv_mat_r(:,:) = 0._ki
+ !
+ if (inf_or_sup == 'inf') triangular_inf = .true.
+ if (inf_or_sup == 'sup') triangular_sup = .true.
+ !
+ do i=1,n_dim
+ !
+ inversible = inversible .and. .not.(equal_real(mat_r(i,i),0._ki))
+ !
+ end do
+ !
+ if ( (inversible) .and. (triangular_inf .or. triangular_sup) ) then
+ !
+ if (triangular_inf) then
+ !
+ mat1 = mat_r
+ !
+ else
+ !
+ mat1 = transpose(mat_r)
+ !
+ end if
+ !
+ do i=1,n_dim
+ !
+ do j=1,i
+ !
+ if (j == i) then
+ !
+ inv_mat_r(i,j) = 1._ki/mat1(i,i)
+ !
+ else
+ !
+ somme = 0._ki
+ !
+ do k=1,i-1
+ !
+ somme = somme + mat1(i,k)*inv_mat_r(k,j)
+ !
+ end do
+ !
+ inv_mat_r(i,j) = -somme/mat1(i,i)
+ !
+ end if
+ !
+ end do
+ !
+ end do
+ !
+ if (triangular_sup) inv_mat_r = transpose(inv_mat_r)
+ !
+ else
+ !
+ !~ if (.not.(inversible)) write(*,*) 'matrice pas inversible'
+ if (.not.(inversible)) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'alerte, internal error'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'In the LU decomposition'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'One triangular matrix is not invertible'
+ call catch_exception(1)
+ end if
+ !~ if (triangular_inf .and. triangular_sup) write(*,*) 'matrice pas diagonal'
+ if (triangular_inf .and. triangular_sup) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'alerte, internal error'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'In the LU decomposition'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'One matrix is not diagonal'
+ call catch_exception(1)
+ end if
+ !
+ end if
+ !
+ end subroutine inverse_triangular_r
+ !
+ subroutine inverse_triangular_c(mat_c,inf_or_sup,inv_mat_c)
+ !
+ complex(ki), intent(in), dimension(:,:) :: mat_c
+ character(len=3), intent(in) :: inf_or_sup
+ complex(ki), intent(out), dimension(size(mat_c,1),size(mat_c,1)) :: inv_mat_c
+ !
+ logical :: inversible,triangular_sup,triangular_inf
+ integer :: n_dim,i,j,k
+ complex(ki) :: somme
+ complex(ki), dimension(size(mat_c,1),size(mat_c,1)) :: mat1
+ !
+ n_dim = size(mat_c,1) ! dimension de la matrice
+ inversible = .true.
+ triangular_inf = .false.
+ triangular_sup = .false.
+ inv_mat_c(:,:) = czero
+ !
+ if (inf_or_sup == 'inf') triangular_inf = .true.
+ if (inf_or_sup == 'sup') triangular_sup = .true.
+ !
+ do i=1,n_dim
+ !
+ inversible = inversible .and. .not.(equal_real(abs(mat_c(i,i)),0._ki))
+ !
+ end do
+ !
+ if ( (inversible) .and. (triangular_inf .or. triangular_sup) ) then
+ !
+ if (triangular_inf) then
+ !
+ mat1 = mat_c
+ !
+ else
+ !
+ mat1 = transpose(mat_c)
+ !
+ end if
+ !
+ do i=1,n_dim
+ !
+ do j=1,i
+ !
+ if (j == i) then
+ !
+ inv_mat_c(i,j) = cmplx(1._ki,0._ki,ki)/mat1(i,i)
+ !
+ else
+ !
+ somme = czero
+ !
+ do k=1,i-1
+ !
+ somme = somme + mat1(i,k)*inv_mat_c(k,j)
+ !
+ end do
+ !
+ inv_mat_c(i,j) = -somme/mat1(i,i)
+ !
+ end if
+ !
+ end do
+ !
+ end do
+ !
+ if (triangular_sup) inv_mat_c = transpose(inv_mat_c)
+ !
+ else
+ !
+ !~ if (.not.(inversible)) write(*,*) 'matrice pas inversible'
+ if (.not.(inversible)) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'alerte, internal error'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'In the LU decomposition'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'One triangular matrix is not invertible'
+ call catch_exception(1)
+ end if
+ !~ if (triangular_inf .and. triangular_sup) write(*,*) 'matrice pas diagonal'
+ if (triangular_inf .and. triangular_sup) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'alerte, internal error'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'In the LU decomposition'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'One matrix is not diagonal'
+ call catch_exception(1)
+ end if
+ !
+ end if
+ !
+ end subroutine inverse_triangular_c
+ !
+ !****if* src/kinematic/inverse_matrice/inverse_diagonal
+ ! NAME
+ !
+ ! Subroutine inverse_diagonal
+ !
+ ! USAGE
+ !
+ ! call inverse_diagonal(mat,inv_mat)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine inverses a diagonal matrix
+ !
+ ! INPUTS
+ !
+ ! * mat -- a real (type ki) array of rank 2
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * inv_mat -- a real (type ki) array of rank 2, the inverse of the triangular matrix
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine inverse_diagonal(mat,inv_mat)
+ !
+ real(ki), intent(in), dimension(:,:) :: mat
+ real(ki), intent(out), dimension(size(mat,1),size(mat,1)) :: inv_mat
+ !
+ logical :: inversible
+ integer :: n_dim,i
+ !
+ n_dim = size(mat,1) ! dimension de la matrice
+ inversible = .true.
+ inv_mat(:,:) = 0._ki
+ !
+ do i=1,n_dim
+ !
+ inversible = inversible .and. (mat(i,i) /= 0._ki)
+ !
+ end do
+ !
+ if (inversible) then
+ !
+ do i=1,n_dim
+ !
+ inv_mat(i,i) = 1._ki/mat(i,i)
+ !
+ end do
+ !
+ else
+ !
+ !~ write(*,*) 'matrice pas inversible'
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'alerte, internal error'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'In the LU decomposition'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'One diagonal matrix is not invertible'
+ call catch_exception(1)
+ !
+ end if
+ !
+ end subroutine inverse_diagonal
+ !
+ !
+ !****if* src/kinematic/inverse_matrice/lu_decomp
+ ! NAME
+ !
+ ! Subroutine lu_decomp
+ !
+ ! USAGE
+ !
+ ! call lu_decomp(mat,p_mat,l_mat,u_mat)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine writes a symmetric matrix as P L U where P is a
+ ! permutation matrix, L is a lower triangular matrix and
+ ! U is an upper triangular matrix
+ !
+ ! INPUTS
+ !
+ ! * mat -- a real (type ki) array of rank 2
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * p_mat -- a real (type ki) array of rank 2, the permutation matrix
+ ! * l_mat -- a real (type ki) array of rank 2, the lower triangular matrix
+ ! * u_mat -- a real (type ki) array of rank 2, the upper triangular matrix
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine lu_decomp_r(mat_r,p_mat,l_mat,u_mat)
+ !
+ real(ki), intent(in), dimension(:,:) :: mat_r
+ real(ki), intent(out), dimension(size(mat_r,1),size(mat_r,1)) :: l_mat,u_mat,p_mat
+ !
+ integer :: n_dim,i,j,k
+ integer, dimension(1) :: loc_m
+ real(ki), dimension(size(mat_r,1),size(mat_r,1)) :: mat_b
+ real(ki), dimension(size(mat_r,1),size(mat_r,1)) :: temp_mat,id_mat
+ real(ki), dimension(size(mat_r,1)) :: temp_vec
+ !
+ n_dim = size(mat_r,1) ! dimension de la matrice
+ u_mat(:,:) = 0._ki
+ id_mat(:,:) = 0._ki
+ !
+ do i=1,n_dim
+ !
+ id_mat(i,i) = 1._ki
+ !
+ end do
+ !
+ mat_b = mat_r
+ l_mat(:,:) = 0._ki
+ p_mat = id_mat
+ !
+ do k=1,n_dim-1
+ !
+ ! plus grand element de la colonne k entre les lignes k et n_dim
+ !
+ loc_m = maxloc(abs(mat_b(k:n_dim,k))) + k - 1
+ !
+ ! si ce plus grand element n'est pas sur la ligne k ou bien on ne
+ ! traite pas la derniere ligne, on permute les lignes.
+ ! p_mat garde trace de la permutation
+ !
+ if ( (loc_m(1) /= k) .and.(k /= n_dim) ) then
+ !
+ temp_vec = mat_b(k,:)
+ mat_b(k,:) = mat_b(loc_m(1),:)
+ mat_b(loc_m(1),:) = temp_vec
+ !
+ temp_vec = l_mat(k,:)
+ l_mat(k,:) = l_mat(loc_m(1),:)
+ l_mat(loc_m(1),:) = temp_vec
+ !
+ temp_mat = id_mat
+ temp_mat(k,:) = id_mat(loc_m(1),:)
+ temp_mat(loc_m(1),:) = id_mat(k,:)
+ p_mat = matmul(p_mat,temp_mat)
+ !
+ end if
+ !
+ l_mat(k,k) = 1._ki
+ l_mat(k+1:n_dim,k) = mat_b(k+1:n_dim,k)/mat_b(k,k)
+ !
+ do i=k+1,n_dim
+ !
+ mat_b(i,1:k) = 0._ki
+ !
+ do j=k+1,n_dim
+ !
+ mat_b(i,j) = mat_b(i,j) - l_mat(i,k)*mat_b(k,j)
+ !
+ end do
+ !
+ end do
+ !
+ end do
+ !
+ l_mat(n_dim,n_dim) = 1._ki
+ u_mat = mat_b
+ !
+ end subroutine lu_decomp_r
+ !
+ !
+ subroutine lu_decomp_c(mat_c,p_mat,l_mat,u_mat)
+ !
+ complex(ki), intent(in), dimension(:,:) :: mat_c
+ complex(ki), intent(out), dimension(size(mat_c,1),size(mat_c,1)) :: l_mat,u_mat,p_mat
+ !
+ integer :: n_dim,i,j,k
+ integer, dimension(1) :: loc_m
+ complex(ki), dimension(size(mat_c,1),size(mat_c,1)) :: mat_b
+ complex(ki), dimension(size(mat_c,1),size(mat_c,1)) :: temp_mat,id_mat
+ complex(ki), dimension(size(mat_c,1)) :: temp_vec
+ !
+ n_dim = size(mat_c,1) ! dimension de la matrice
+ u_mat(:,:) = czero
+ id_mat(:,:) = czero
+ !
+ do i=1,n_dim
+ !
+ id_mat(i,i) = cmplx(1._ki,0._ki,ki)
+ !
+ end do
+ !
+ mat_b = mat_c
+ l_mat(:,:) = czero
+ p_mat = id_mat
+ !
+ do k=1,n_dim-1
+ !
+ ! plus grand element de la colonne k entre les lignes k et n_dim
+ !
+ loc_m = maxloc(abs(mat_b(k:n_dim,k))) + k - 1
+ !
+ ! si ce plus grand element n'est pas sur la ligne k ou bien on ne
+ ! traite pas la derniere ligne, on permute les lignes.
+ ! p_mat garde trace de la permutation
+ !
+ if ( (loc_m(1) /= k) .and.(k /= n_dim) ) then
+ !
+ temp_vec = mat_b(k,:)
+ mat_b(k,:) = mat_b(loc_m(1),:)
+ mat_b(loc_m(1),:) = temp_vec
+ !
+ temp_vec = l_mat(k,:)
+ l_mat(k,:) = l_mat(loc_m(1),:)
+ l_mat(loc_m(1),:) = temp_vec
+ !
+ temp_mat = id_mat
+ temp_mat(k,:) = id_mat(loc_m(1),:)
+ temp_mat(loc_m(1),:) = id_mat(k,:)
+ p_mat = matmul(p_mat,temp_mat)
+ !
+ end if
+ !
+ l_mat(k,k) = cmplx(1._ki,0._ki,ki)
+ l_mat(k+1:n_dim,k) = mat_b(k+1:n_dim,k)/mat_b(k,k)
+ !
+ do i=k+1,n_dim
+ !
+ mat_b(i,1:k) = czero
+ !
+ do j=k+1,n_dim
+ !
+ mat_b(i,j) = mat_b(i,j) - l_mat(i,k)*mat_b(k,j)
+ !
+ end do
+ !
+ end do
+ !
+ end do
+ !
+ l_mat(n_dim,n_dim) = cmplx(1._ki,0._ki,ki)
+ u_mat = mat_b
+ !
+ end subroutine lu_decomp_c
+ !
+end module inverse_matrice
diff --git a/golem95c-1.2.1/kinematic/matrice_s.f90 b/golem95c-1.2.1/kinematic/matrice_s.f90
new file mode 100644
index 0000000..b53a80c
--- /dev/null
+++ b/golem95c-1.2.1/kinematic/matrice_s.f90
@@ -0,0 +1,1372 @@
+!
+!****h* src/kinematic/matrice_s
+! NAME
+!
+! Module matrice_s
+!
+! USAGE
+!
+! use matrice_s
+!
+! DESCRIPTION
+!
+! This module is used : to reserve some memory in order to pass the S matrix, its
+! shape, the set of propagator labels; to compute the inverse
+! of S matrix and the related quantities : the b's and sumb, also for all
+! possible reduced matrices. The S matrix is allocated here and also its dimension
+! and it returns the result through the three functions inv_s, b and sumb.
+!
+!
+! OUTPUT
+!
+! This module exports five variables:
+! * dim_s -- an integer, the shape of the initial S matrix
+! * set_ref -- an integer array, the set of initial propagators
+! * s_mat_c -- a complex (type ki) array of rank 2, the S matrix.
+! * s_mat_p -- a derived type, including the S matrix for either real or complex masses
+! and integer-bits encoding the positions of masses with non-vanishing Im-part,
+! and vanishing masses.
+! * s_mat -- A pointer associated with s_mat_c. The user can fill s_mat or s_mat_c with complex or
+! real values.
+!
+! and also eleven functions:
+! * initgolem95 -- calls allocation_s, initializes the cache, associates s_mat.
+! * allocation_s -- to allocate the required memory
+! * deallocation_s -- to deallocate the used memory
+! * preparesmatrix -- fill s_mat_r with the real part of s_mat_c, sets the bit integers in s_mat_p
+! calls init_invs.
+! * init_invs -- to fill all the array for the inverse of the S matrix
+! and the inverse of the reduce S matrix
+! * inv_s -- it contains the inverse of the S matrix
+! * hj -- it contains H matrix (pseudo-inverse of G)
+! * b -- it contains the b coefficients
+! * sumb -- it contains the B coeficient
+! * norma_sumb -- it contains the normalised B coefficient
+! * exitgolem95 -- deallocates memory, clear the cache.
+!
+! Only dim_s and set_ref take a value in this module, not the other variables
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * cache (src/module/cache.f90)
+! * inverse_matrice (src/kinematic/inverse_matrice.f90)
+! * tri_croissant (src/module/tri_croissant.f90)
+! * array (src/module/array.f90)
+! * parametre (src/module/parametre.f90)
+! * s_matrix_type (src/module/s_matrix_type.f90)
+!
+!*****
+!
+module matrice_s
+ !
+ use precision_golem
+ use sortie_erreur
+ use cache
+ use inverse_matrice
+ use tri_croissant
+ use array
+ use parametre
+ use s_matrix_type
+ use constante, only:czero
+ implicit none
+ !
+ !
+ private
+ !
+ integer :: dim_s
+ integer, dimension(:), allocatable :: set_ref
+ integer, dimension(6) :: ref_vector = (/ 1, 2, 3, 4, 5, 6 /)
+ integer :: b_ref
+ real(ki), dimension(:,:), allocatable :: s_mat_r
+ complex(ki), dimension(:,:), allocatable, target :: s_mat_c
+ type(s_matrix_poly) :: s_mat_p
+ complex(ki), dimension(:,:), pointer :: s_mat
+ !
+ public :: dim_s, set_ref, b_ref, s_mat_c, s_mat_p, s_mat
+ !
+ ! The first index of the following arrays is (b_pin/2)+1, the remaining indices
+ ! are for the indices of the representing rank-n tensor.
+ !
+ real(ki), dimension(:,:,:), allocatable :: hjj_r
+ complex(ki), dimension(:,:,:), allocatable :: hjj_c
+ !
+ real(ki), dimension(:,:,:), allocatable :: invs_n_r
+ complex(ki), dimension(:,:,:), allocatable :: invs_n_c
+ !
+ real(ki), dimension(:,:), allocatable :: b_n_r
+ complex(ki), dimension(:,:), allocatable :: b_n_c
+ !
+ real(ki), dimension(:), allocatable :: sumb_n_r
+ complex(ki), dimension(:), allocatable :: sumb_n_c
+ !
+ real(ki), dimension(:), allocatable :: norma_sumb_n_r
+ complex(ki), dimension(:), allocatable :: norma_sumb_n_c
+ !
+ integer :: err
+ !
+ public :: allocation_s, deallocation_s, init_invs, inv_s, hj, b, sumb, norma_sumb
+ public :: initgolem95, preparesmatrix, prepare_s_matrix_local, exitgolem95
+ !
+ interface put_to_zero
+ !
+ module procedure put_to_zero_r, put_to_zero_c
+ !
+ end interface
+ !
+ contains
+ !
+ !****f* src/kinematic/matrice_s/initgolem95
+ ! NAME
+ !
+ ! Subroutine initgolem95
+ !
+ ! USAGE
+ !
+ ! call initgolem95(dim, opt_set)
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine is the first of three macro functions which needs to be called by the user.
+ ! It allocates memory for all internal matrices needed in subsequent calculations.
+ ! The caching system is initialized.
+ ! A pointer s_mat is associated with a complex matrix s_mat_c.
+ ! This is the s matrix which has to be filled after initgolem95() is called.
+ ! The argument 'dim' sets the maximal number of external legs.
+ ! An optional array for the numbering of propagators can be given.
+ ! The default is set to (/ 1, ... , dim /)
+ !
+ ! INPUTS
+ !
+ ! * dim -- an integer, the maximal number of external legs
+ ! * opt_set -- an optional integer array for the numbering of propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! A call to allocation_s is made, implying all side effects given there.
+ ! The caching system is initialized.
+ ! A pointer 's_mat' is associated with the global matrix s_mat_c.
+ ! The internal parameter rmass_or_cmass_par is set to cmass. If a purely real
+ ! s matrix is given by the user it will be set to rmass in the call of
+ ! preparesmatrix.
+ !
+ ! RETURN VALUE
+ !
+ ! No return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine initgolem95(dim, opt_set)
+ !
+ integer, intent(in) :: dim
+ integer, dimension(:), optional, intent(in) :: opt_set
+ !
+ rmass_or_cmass_par = cmass
+ !
+ call allocation_s(dim)
+ !
+ if (present(opt_set) ) then
+ !
+ set_ref(:) = opt_set(:)
+ !
+ else
+ !
+ set_ref(:) = ref_vector(1:dim)
+ !
+ end if
+ !
+ b_ref = packb(set_ref)
+ !
+ call allocate_cache(dim)
+ !
+ s_mat => s_mat_c
+ !
+ end subroutine initgolem95
+ !
+ !****f* src/kinematic/matrice_s/allocation_s
+ ! NAME
+ !
+ ! Subroutine allocation_s
+ !
+ ! USAGE
+ !
+ ! call allocation_s(dim)
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine reserves the memory for several internal objects.
+ ! In case of rmass_or_cmass_par==cmass, there complex copies of each preceding array
+ ! are also allocated.
+ !
+ ! After memory allocation, s_mat_p is then assigned the matrix s_mat_c or s_mat_r,
+ ! respectively. The corresponding pointers in s_mat_p are associated or nullified.
+ ! In case a complex matrix is assigned, there will be also a pointer associated with
+ ! a real matrix, which has entries according to the real part of the complex matrix.
+ !
+ ! INPUTS
+ !
+ ! * dim -- an integer, the maximal number of external legs
+ !
+ ! SIDE EFFECTS
+ !
+ ! This routine modify the value of the variable dim_s
+ ! It initialises invs_n, hjj, b_n, sumb_n, norma_sumb_n to zero
+ ! It associates the global objects s_mat_p with s_mat_r or s_mat_c.
+ !
+ ! RETURN VALUE
+ !
+ ! No return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine allocation_s(dim)
+ !
+ integer, intent(in) :: dim
+ !
+ if (rmass_or_cmass_par%rmass_selected) then
+ !
+ call allocation_s_r(dim)
+ s_mat_p = assign_s_matrix(s_mat_r)
+ !
+ else if (rmass_or_cmass_par%cmass_selected) then
+ !
+ call allocation_s_r(dim)
+ call allocation_s_c(dim)
+ s_mat_p = assign_s_matrix(s_mat_c,s_mat_r)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'rmass_or_cmass_par has wrong value'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end subroutine allocation_s
+ !
+ subroutine allocation_s_r(dim)
+ !
+ integer, intent(in) :: dim
+ integer :: err
+ !
+ dim_s = dim
+ !
+ allocate(s_mat_c(dim_s,dim_s),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for s_mat'
+ call catch_exception(0)
+ !
+ end if
+ !
+ allocate(s_mat_r(dim_s,dim_s),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for s_mat'
+ call catch_exception(0)
+ !
+ end if
+ !
+ allocate(set_ref(dim_s),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for set_ref'
+ call catch_exception(0)
+ !
+ end if
+ if (dim>= 1 .and. dim <= 6 ) then
+ allocate( invs_n_r(2**dim,dim,dim), &
+ hjj_r(dim,dim,dim),b_n_r(2**dim,dim), sumb_n_r(2**dim), &
+ norma_sumb_n_r(2**dim), stat=err)
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for invs_n_r or ...'
+ call catch_exception(0)
+ !
+ end if
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'dimension %d0 not supported.'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ end if
+ !
+ invs_n_r = 0._ki
+ b_n_r = 0._ki
+ sumb_n_r = 0._ki
+ norma_sumb_n_r = 0._ki
+ !
+ end subroutine allocation_s_r
+ !
+ subroutine allocation_s_c(dim)
+ !
+ integer, intent(in) :: dim
+ integer :: err
+ !
+ dim_s = dim
+ !
+ !
+ !
+ if (dim>= 1 .and. dim <= 6 ) then
+ allocate( invs_n_c(2**dim,dim,dim), &
+ hjj_c(dim,dim,dim),b_n_c(2**dim,dim), sumb_n_c(2**dim), &
+ norma_sumb_n_c(2**dim), stat=err)
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for invs_n_r or ...'
+ call catch_exception(0)
+ !
+ end if
+ end if
+ !
+ invs_n_c = czero
+ b_n_c = czero
+ sumb_n_c = czero
+ norma_sumb_n_c = czero
+ !
+ end subroutine allocation_s_c
+ !
+ !****f* src/kinematic/matrice_s/preparesmatrix
+ ! NAME
+ !
+ ! Subroutine preparesmatrix
+ !
+ ! USAGE
+ !
+ ! call preparesmatrix()
+ ! call prepare_s_matrix_local(s_mat_p_loc,set_ref_loc)
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine prepares the global or local s_mat_p object, consisting
+ ! of pointers to s_mat_c and s_mat_r and integer bits b_cmplx and b_zero.
+ ! A call to init_invs is made to fill the inverse matrices needed
+ ! in the form factor calculations.
+ ! If the user has defined a purely real s matrix, the internal parameter
+ ! rmass_or_cmass_par is set to rmass and only the real branch of the library
+ ! is used.
+ ! In the complex case, form factors which are not affected by complex
+ ! masses will be called with a sub matrix of s_mat_r, the real part of s_mat_c.
+ ! The routine also sets the bits for complex mass and zero mass-
+ ! entries.
+ ! The subroutine prepare_s_matrix_local is used internally to prepare local type
+ ! s_matrix_poly objects. This subroutine does not interact with the inverse matrices
+ ! and the caching system.
+ !
+ ! INPUTS
+ !
+ ! For prepare_s_matrix_local, s_mat_p and set_ref need to be given.
+ !
+ ! RETURN VALUE
+ !
+ ! No return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine preparesmatrix()
+ !
+ rmass_or_cmass_par = cmass
+ if (.not. associated(s_mat_p%pt_cmplx) ) s_mat_p%pt_cmplx => s_mat_c
+ !
+ call fill_s_matrix(s_mat_p)
+ call set_s_matrix_bits(s_mat_p,set_ref)
+ !
+ if ( s_mat_p%b_cmplx == 0 ) then
+ !
+ rmass_or_cmass_par = rmass
+ nullify(s_mat_p%pt_cmplx)
+ !
+ end if
+ !
+ call reset_cache()
+ call init_invs()
+ !
+ end subroutine preparesmatrix
+ !
+ subroutine prepare_s_matrix_local(s_mat_poly,set_ref_loc)
+ type(s_matrix_poly),intent (inout) :: s_mat_poly
+ integer, dimension(:) :: set_ref_loc
+ !
+ call fill_s_matrix(s_mat_poly)
+ call set_s_matrix_bits(s_mat_poly,set_ref_loc)
+ !
+ end subroutine prepare_s_matrix_local
+ !
+ !
+ !****f* src/kinematic/matrice_s/deallocation_s
+ ! NAME
+ !
+ ! Subroutine deallocation_s
+ !
+ ! USAGE
+ !
+ ! call deallocation_s()
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine deallocates the memory reserved by the preceeding
+ ! subroutine.
+ ! The pointers in s_mat_p are nullified.
+ !
+ ! INPUTS
+ !
+ ! No input
+ !
+ ! SIDE EFFECTS
+ !
+ ! This routine destroys all the variables initialised in the
+ ! preceeding subroutine as well as any associations in s_mat_p.
+ !
+ ! RETURN VALUE
+ !
+ ! No return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine deallocation_s()
+ !
+ call nullify_s_matrix(s_mat_p)
+ !
+ if (rmass_or_cmass_par%rmass_selected) then
+ !
+ call deallocation_s_r()
+ !
+ else if (rmass_or_cmass_par%cmass_selected) then
+ !
+ call deallocation_s_c()
+ call deallocation_s_r()
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine deallocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'rmass_or_cmass has wrong value'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end subroutine deallocation_s
+ !
+ subroutine deallocation_s_r()
+ !
+ integer :: err
+ !
+ deallocate(s_mat_r,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine deallocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for s_mat'
+ call catch_exception(0)
+ end if
+ !
+ deallocate(set_ref,stat=err)
+ !
+ if (err /= 0) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine deallocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for s_ref'
+ call catch_exception(0)
+ end if
+ !
+ deallocate(invs_n_r,hjj_r,b_n_r, sumb_n_r, norma_sumb_n_r,stat=err)
+ !
+ if (err /= 0) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine deallocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for invs_n_r or hjj or b or sumb_n_r or norma_sumb_n_r'
+ call catch_exception(0)
+ end if
+ !
+ end subroutine deallocation_s_r
+ !
+ subroutine deallocation_s_c()
+ !
+ integer :: err
+ !
+ deallocate(s_mat_c,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine deallocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for s_mat'
+ call catch_exception(0)
+ end if
+ !
+ deallocate(invs_n_c,b_n_c,sumb_n_c,norma_sumb_n_c,hjj_c,stat=err)
+ !
+ if (err /= 0) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine deallocation_s'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for invs_n or b_n or sumb_n or norma_sumb_n or hjj_c'
+ call catch_exception(0)
+ end if
+ !
+ end subroutine deallocation_s_c
+ !
+ !****f* src/kinematic/inversion/init_invs
+ ! NAME
+ !
+ ! Subroutine init_invs
+ !
+ ! USAGE
+ !
+ ! call init_invs()
+ !
+ ! DESCRIPTION
+ !
+ ! This function comes in two copies for real masses and complex masses.
+ ! The respective arrays are filled.
+ !
+ ! This routine fills the arrays:
+ ! invs_n, hjj, b_n, sumb_n, norma_sumb_n
+ !
+ ! One can print a typical error due to the numerical inversion
+ !
+ ! INPUTS
+ !
+ ! No input
+ !
+ ! SIDE EFFECTS
+ !
+ ! This routine modifies the values of the real or complex arrays
+ ! invs_n, hjj, b_n, sumb_n, norma_sumb_n
+ !
+ ! RETURN VALUE
+ !
+ ! No return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine init_invs()
+ !
+ !
+ if (rmass_or_cmass_par%cmass_selected) then
+ !
+ call init_invs_c()
+ call init_invs_r()
+ !
+ else if (rmass_or_cmass_par%rmass_selected) then
+ !
+ call init_invs_r()
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine init_invs case()'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'rmass_or_cmass_par has wrong value'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end subroutine init_invs
+ !
+ !
+ subroutine init_invs_r()
+ !
+ integer :: i1,i2,i,j,k,pin_count
+ real(ki), dimension(:,:), allocatable :: temp_mat_r,temp1_mat_r
+
+ real(ki) :: error,tmp_error
+ real(ki) :: plus_grand
+ integer, dimension(5) :: pinch
+ !
+ plus_grand = maxval(array=abs(s_mat_r))
+ b_ref = packb(set_ref)
+ allocate(temp_mat_r(dim_s,dim_s),temp1_mat_r(dim_s,dim_s),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine init_invs'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for temp_mat and temp1_mat'
+ call catch_exception(0)
+ !
+ end if
+ !
+ error=0
+ do i = 0, 2**dim_s-2 ! iterate over all possible pinches
+ pinch=-1
+ pinch=unpackb(i*2,size(pinch))
+ pin_count=countb(i)
+ origine_inv_info_par = achar(dim_s+48)//'x'//achar(dim_s+48)//' matrix'
+ !
+ if (pin_count>0) then
+ origine_inv_info_par = trim(origine_inv_info_par)//'pinch'
+ origine_inv_info_par = trim(origine_inv_info_par)//' '//achar(pinch(j)+48)
+ call put_to_zero(pinch(1),s_mat_r,temp_mat_r)
+ else
+ temp_mat_r=s_mat_r
+ end if
+ !
+ do j = 2, pin_count
+ origine_inv_info_par = trim(origine_inv_info_par)//' '//achar(pinch(j)+48)
+ call put_to_zero(pinch(j),temp_mat_r,temp1_mat_r)
+ temp_mat_r=temp1_mat_r
+ end do
+ invs_n_r(i+1,:,:)=0._ki
+ call inverse(temp_mat_r,invs_n_r(i+1,:,:),tmp_error,pinch(1),pinch(2),pinch(3),pinch(4),pinch(5))
+ b_n_r(i+1,:) = sum(invs_n_r(i+1,:,:),dim=1)
+ sumb_n_r(i+1) = sum(b_n_r(i+1,:))
+ norma_sumb_n_r(i+1) = sumb_n_r(i+1)*plus_grand
+ if(pin_count<=2 .and. tmp_error>error) then ! for compatibility with old error variable
+ error=tmp_error
+ end if
+ end do
+ !
+ if (dim_s==6) then
+ do i=1,6
+ do i1=1,6
+ do i2=1,6
+ hjj_r(i1,i2,i) = -2._ki*( invs_n_r(1,i1,i2) &
+ - invs_n_r(1,i,i1)*b_n_r(1,i2)/b_n_r(1,i) &
+ - invs_n_r(1,i,i2)*b_n_r(1,i1)/b_n_r(1,i) &
+ + invs_n_r(1,i,i)*b_n_r(1,i1)*b_n_r(1,i2) &
+ /b_n_r(1,i)**2 )
+ end do
+ end do
+ end do
+ end if
+ !
+ deallocate(temp_mat_r,temp1_mat_r,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine init_invs'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for temp_mat and temp1_mat'
+ call catch_exception(0)
+ !
+ end if
+ end subroutine init_invs_r
+ !
+ subroutine init_invs_c()
+ !
+ integer :: i1,i2,i,j,pin_count
+ complex(ki), dimension(:,:), allocatable :: temp_mat_c,temp1_mat_c
+ real(ki) :: error,tmp_error
+ real(ki) :: plus_grand
+ integer, dimension(6) :: pinch
+ !
+ plus_grand = maxval(array=abs(s_mat_c))
+ b_ref = packb(set_ref)
+ allocate(temp_mat_c(dim_s,dim_s),temp1_mat_c(dim_s,dim_s), stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine init_invs'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for temp_mat and temp1_mat'
+ call catch_exception(0)
+ !
+ end if
+ !
+ error=0
+ do i = 0, 2**dim_s-2 ! iterate over all possible pinches
+ pinch=-1
+ pinch=unpackb(i*2,6)
+ pin_count=countb(i)
+ origine_inv_info_par = achar(dim_s+48)//'x'//achar(dim_s+48)//' matrix'
+ if (pin_count>0) then
+ origine_inv_info_par = trim(origine_inv_info_par)//'pinch'
+ origine_inv_info_par = trim(origine_inv_info_par)//' '//achar(pinch(j)+48)
+ call put_to_zero(pinch(1),s_mat_c,temp_mat_c)
+ else
+ temp_mat_c=s_mat_c
+ end if
+ !
+ do j = 2, pin_count
+ origine_inv_info_par = trim(origine_inv_info_par)//' '//achar(pinch(j)+48)
+ call put_to_zero(pinch(j),temp_mat_c,temp1_mat_c)
+ temp_mat_c=temp1_mat_c
+ end do
+ call inverse(temp_mat_c,invs_n_c(i+1,:,:),tmp_error,pinch(1),pinch(2),pinch(3),pinch(4),pinch(5))
+ b_n_c(i+1,:) = sum(invs_n_c(i+1,:,:),dim=1)
+ sumb_n_c(i+1) = sum(b_n_c(i+1,:))
+ norma_sumb_n_c(i+1) = sumb_n_c(i+1)*plus_grand
+ if(pin_count<=2 .and. tmp_error>error) then ! to be compatible with old error variable
+ error=tmp_error
+ end if
+ end do
+ !
+ if (dim_s==6) then
+ do i=1,6
+ do i1=1,6
+ do i2=1,6
+ hjj_c(i1,i2,i) = -2._ki*( invs_n_c(1,i1,i2) &
+ - invs_n_c(1,i,i1)*b_n_c(1,i2)/b_n_c(1,i) &
+ - invs_n_c(1,i,i2)*b_n_c(1,i1)/b_n_c(1,i) &
+ + invs_n_c(1,i,i)*b_n_c(1,i1)*b_n_c(1,i2) &
+ /b_n_c(1,i)**2 )
+ end do
+ end do
+ end do
+ end if
+ !
+ deallocate(temp_mat_c,temp1_mat_c,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine init_invs'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for temp_mat and temp1_mat_c'
+ call catch_exception(0)
+ !
+ end if
+ end subroutine init_invs_c
+ !
+ !****if* src/kinematic/inversion/put_to_zero
+ ! NAME
+ !
+ ! Subroutine put_to_zero
+ !
+ ! USAGE
+ !
+ ! call put_to_zero(i,mati,matf)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine put to 0 the line and the column i of the square matrix mati
+ ! It returns a square matrix matf of dim n x n (n being the
+ ! dimension of mati). It is overloaded with a real and complex version.
+ !
+ ! INPUTS
+ !
+ ! * i -- an integer, the value of the line/column to be put to zero
+ ! * mati -- an real/complex (type ki) array of rank 2
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * matf -- an real/copmplex (type ki) array of rank 2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine put_to_zero_r(i,mati,matf)
+ !
+ integer, intent(in) :: i
+ real(ki), dimension(:,:), intent(in) :: mati
+ real(ki), dimension(size(mati,1),size(mati,2)), intent(out) :: matf
+ !
+ integer :: n
+ !
+ n = size(mati,1) ! la matrice mati est carree
+ matf = mati
+ matf(i,:) = 0._ki
+ matf(:,i) = 0._ki
+ !
+ end subroutine put_to_zero_r
+ !
+ subroutine put_to_zero_c(i,mati,matf)
+ !
+ integer, intent(in) :: i
+ complex(ki), dimension(:,:), intent(in) :: mati
+ complex(ki), dimension(size(mati,1),size(mati,2)), intent(out) :: matf
+ !
+ integer :: n
+ !
+ n = size(mati,1) ! la matrice mati est carree
+ matf = mati
+ matf(i,:) = czero
+ matf(:,i) = czero
+ !
+ end subroutine put_to_zero_c
+ !
+ !****f* src/kinematic/inversion/inv_s
+ ! NAME
+ !
+ ! Function inv_s
+ !
+ ! USAGE
+ !
+ ! complex = inv_s(i,j,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function gives the generic inverse of the S matrix whatever
+ ! its dimension (<=6)
+ !
+ ! INPUTS
+ !
+ ! * i -- an integer, line number
+ ! * j -- an integer, row number
+ ! * set -- an integer array of rank 1, the set of pinch propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! Warning: Now a complex (type ki) is returned! [TK Sep10]
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ function inv_s(i,j,b_pin)
+ !
+ integer, intent (in) :: i,j
+ integer, intent (in) :: b_pin
+ complex(ki) :: inv_s
+ !
+ call check_pin(b_pin,"inv_s")
+ if (ior(s_mat_p%b_cmplx,b_pin) .eq. b_pin) then
+ !
+ inv_s = cmplx(inv_s_r(i,j,b_pin),0._ki,ki)
+ !
+ else
+ !
+ inv_s = inv_s_c(i,j,b_pin)
+ !
+ end if
+ !write (*, *) "INV_S(",i,j,b_pin,")=", inv_s
+ !
+ end function inv_s
+ !
+ function inv_s_r(i,j,b_pin)
+ integer, intent (in) :: i,j
+ integer, intent (in) :: b_pin
+ real(ki) :: inv_s_r
+ !
+ inv_s_r = invs_n_r((b_pin/2)+1,i,j)
+ end function inv_s_r
+ !
+ function inv_s_c(i,j,b_pin)
+ integer, intent (in) :: i,j
+ integer, intent (in) :: b_pin
+ complex(ki) :: inv_s_c
+ !
+ inv_s_c = invs_n_c((b_pin/2)+1,i,j)
+ end function inv_s_c
+ !
+ !****f* src/kinematic/inversion/hj
+ ! NAME
+ !
+ ! Function hj
+ !
+ ! USAGE
+ !
+ ! complex = hj(i,j,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function gives the H matrix (pseudo-inverse of G) (dim=6)
+ !
+ ! INPUTS
+ !
+ ! * i -- an integer, line number
+ ! * j -- an integer, row number
+ ! * set -- an integer array of rank 1, the set of pinch propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! Warning: Now a complex (type ki) is returned! [TK Sep10]
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ function hj(i,j,b_pin)
+ !
+ integer, intent (in) :: i,j
+ integer, intent (in) :: b_pin
+ complex(ki) :: hj
+ !
+ call check_pin(b_pin,'hj')
+ if (ior(s_mat_p%b_cmplx,b_pin) .eq. b_pin) then
+ !
+ hj = cmplx(hj_r(i,j,b_pin),0._ki,ki)
+ !
+ else
+ !
+ hj = hj_c(i,j,b_pin)
+ !
+ end if
+ !
+ end function hj
+ !
+ function hj_r(i,j,b_pin)
+ !
+ integer, intent (in) :: i,j
+ integer, intent (in) :: b_pin
+ real(ki) :: hj_r
+ !
+ integer :: k
+ integer, dimension(1) :: set
+ integer :: dim_set
+ !
+ if (b_pin < 256) then
+ dim_set = bit_count(b_pin)
+ if (dim_set /= 0) then
+ !
+ !allocate(set(1:dim_set))
+ k = bit_sets(b_pin*8)
+ !
+ else
+ k = 0
+ end if
+ else
+ dim_set = countb(b_pin)
+ if (dim_set /= 0) then
+ !
+ !allocate(set(1:dim_set))
+ set = unpackb(b_pin,1)
+ k = set(1)
+ !
+ else
+ k = 0
+ end if
+ end if
+ !
+ select case(dim_s)
+ !
+ case(6) ! case where we start with a 6-point amplitude
+ !
+ if (dim_set == 1) then
+ if ( (i == k) .or. (j == k) ) then
+ !
+ hj_r = 0._ki
+ !
+ else
+ !
+ hj_r = hjj_r(i,j,k)
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hj, for 6-point'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the array set has not the right dimension: %d0'
+ tab_erreur_par(2)%arg_int = dim_set
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hj'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of the S matrix is not&
+ & correct %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end select
+ end function hj_r
+ !
+ function hj_c(i,j,b_pin)
+ !
+ integer, intent (in) :: i,j
+ integer, intent (in) :: b_pin
+ complex(ki) :: hj_c
+ !
+ integer :: k
+ integer, dimension(1) :: set
+ integer :: dim_set
+ !
+ if (b_pin < 256) then
+ dim_set = bit_count(b_pin)
+ if (dim_set /= 0) then
+ !
+ !allocate(set(1:dim_set))
+ k = bit_sets(b_pin*8)
+ !
+ else
+ k = 0
+ end if
+ else
+ dim_set = countb(b_pin)
+ if (dim_set /= 0) then
+ !
+ !allocate(set(1:dim_set))
+ set = unpackb(b_pin,1)
+ k = set(1)
+ !
+ else
+ k = 0
+ end if
+ end if
+ !
+ select case(dim_s)
+ !
+ case(6) ! case where we start with a 6-point amplitude
+ !
+ if (dim_set == 1) then
+ if ( (i == k) .or. (j == k) ) then
+ !
+ hj_c = czero
+ !
+ else
+ !
+ hj_c = hjj_c(i,j,k)
+ !
+ end if
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hj, for 6-point'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the array set has not the right dimension: %d0'
+ tab_erreur_par(2)%arg_int = dim_set
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ case default
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In function hj'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the dimension of the S matrix is not&
+ & correct %d0'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end select
+ end function hj_c
+ !
+ !****f* src/kinematic/inversion/b
+ ! NAME
+ !
+ ! Function b
+ !
+ ! USAGE
+ !
+ ! complex = b(i,set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function gives the b coefficients whatever the S matrix dimension (<=6)
+ !
+ ! INPUTS
+ !
+ ! * i -- an integer, label of the b coefficients
+ ! * set -- an integer array of rank 1, the set of pinch propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! Warning: Now a complex (type ki) is returned! [TK Sep10]
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ function b(i,b_pin)
+ !
+ integer, intent (in) :: i
+ integer, intent (in) :: b_pin
+ complex(ki) :: b
+ !
+ call check_pin(b_pin,'b')
+ if (ior(s_mat_p%b_cmplx,b_pin) .eq. b_pin) then
+ !
+ b = cmplx(b_r(i,b_pin),0._ki,ki)
+ !
+ else
+ !
+ b = b_c(i,b_pin)
+ !
+ end if
+ ! write (*, *) "B(",i,b_pin,")=", b
+ !
+ end function b
+ !
+ function b_r(i,b_pin)
+ integer, intent (in) :: i
+ integer, intent (in) :: b_pin
+ real(ki) :: b_r
+ b_r= b_n_r((b_pin)/2+1,i)
+ end function b_r
+ function b_c(i,b_pin)
+ integer, intent (in) :: i
+ integer, intent (in) :: b_pin
+ complex(ki) :: b_c
+ b_c= b_n_c((b_pin/2)+1,i)
+ end function b_c
+ !
+ !****f* src/kinematic/inversion/sumb
+ ! NAME
+ !
+ ! Function sumb
+ !
+ ! USAGE
+ !
+ ! complex = sumb(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function gives the B coefficient whatever the S matrix dimension (<=6)
+ !
+ ! INPUTS
+ !
+ ! * set -- an integer array of rank 1, the set of pinch propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! Warning: Now a complex (type ki) is returned! [TK Sep10]
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ function sumb(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ complex(ki) :: sumb
+ !
+ if (ior(s_mat_p%b_cmplx,b_pin) .eq. b_pin) then
+ !
+ sumb = cmplx(sumb_r(b_pin),0._ki,ki)
+ !
+ else
+ !
+ sumb = sumb_c(b_pin)
+ !
+ end if
+ !
+ end function sumb
+ !
+ function sumb_r(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ real(ki) :: sumb_r
+ !
+ sumb_r=sumb_n_r(b_pin/2+1)
+ end function sumb_r
+ function sumb_c(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ complex(ki) :: sumb_c
+ sumb_c=sumb_n_c(b_pin/2+1)
+ end function sumb_c
+ !
+ !****f* src/kinematic/inversion/norma_sumb
+ ! NAME
+ !
+ ! Function norma_sumb
+ !
+ ! USAGE
+ !
+ ! complex = norma_sumb(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function gives the B coefficient whatever the S matrix dimension (<=6)
+ ! divided by the greatest (in absolute value) element of the S matrix
+ !
+ ! INPUTS
+ !
+ ! * set -- an integer array of rank 1, the set of pinch propagators
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! Warning: Now a complex (type ki) is returned! [TK Sep10]
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ function norma_sumb(b_pin)
+ !
+ integer, intent(in) :: b_pin
+ complex(ki) :: norma_sumb
+ !
+ call check_pin(b_pin,'norma_sumb')
+ if (ior(s_mat_p%b_cmplx,b_pin) .eq. b_pin) then
+ !
+ norma_sumb = cmplx(norma_sumb_r(b_pin),0._ki,ki)
+ !
+ else
+ !
+ norma_sumb = norma_sumb_c(b_pin)
+ !
+ end if
+ !
+ end function norma_sumb
+ !
+ function norma_sumb_r(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ real(ki) :: norma_sumb_r
+ !
+ norma_sumb_r=norma_sumb_n_r(b_pin/2+1)
+ end function
+ function norma_sumb_c(b_pin)
+ !
+ integer, intent (in) :: b_pin
+ complex(ki) :: norma_sumb_c
+ !
+ norma_sumb_c=norma_sumb_n_c(b_pin/2+1)
+ end function
+ !
+ !
+ !****f* src/kinematic/matrice_s/exitgolem95
+ ! NAME
+ !
+ ! Subroutine exitgolem95
+ !
+ ! USAGE
+ !
+ ! call exitgolem95()
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine should be called at the end of the form factor calculation.
+ ! It frees all memory previously allocated, it clears the cache and nullifies pointers.
+ !
+ ! INPUTS
+ !
+ ! SIDE EFFECTS
+ !
+ ! RETURN VALUE
+ !
+ ! No return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine exitgolem95()
+ !
+ rmass_or_cmass_par = cmass
+ !
+ nullify(s_mat)
+ !
+ call deallocation_s()
+ !
+ call clear_cache()
+ !
+ end subroutine exitgolem95
+ !
+ subroutine check_pin(b_pin,func)
+ integer, intent(in) :: b_pin
+ character(*), intent(in) :: func
+ !
+ if (dim_s<= 0 .or. dim_s>=7) then
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine '//trim(func(:))
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'dimension %d0 not supported.'
+ tab_erreur_par(2)%arg_int = dim_s
+ call catch_exception(0)
+ end if
+ !
+ if (b_pin>=2**(dim_s+1)-1 .or. iand(b_pin,1)==1) then ! do not allow complete pinch or "0" pinched
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine '//func(:)
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'parameter b_pin=%d0 invalid.'
+ tab_erreur_par(2)%arg_int = b_pin
+ call catch_exception(0)
+ end if
+ end subroutine check_pin
+end module matrice_s
diff --git a/golem95c-1.2.1/module/Makefile.am b/golem95c-1.2.1/module/Makefile.am
new file mode 100644
index 0000000..fba0b4e
--- /dev/null
+++ b/golem95c-1.2.1/module/Makefile.am
@@ -0,0 +1,22 @@
+noinst_LTLIBRARIES=libgolem95_module.la
+libgolem95_module_la_SOURCES= precision_golem.f90 \
+ tri.f90 array.f90 parametre.f90 constante.f90 \
+ sortie_erreur.f90 equal.f90 s_matrix_type.f90 multiply_div.f90 \
+ cache.f90 form_factor_type.f90 kronecker.f90 z_log.f90 \
+ spinor.f90 translate.f90 zdilog.f90
+libgolem95_module_la_FCFLAGS=\
+ -I$(builddir)/../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS= precision_golem.mod \
+ tri_croissant.mod array.mod \
+ cache.mod constante.mod s_matrix_type.mod dilogarithme.mod \
+ equal.mod form_factor_type.mod kronecker.mod logarithme.mod \
+ multiply_div.mod parametre.mod \
+ sortie_erreur.mod spinor.mod translate.mod
+
+CLEANFILES=$(nodist_pkginclude_HEADERS)
+
+include Makefile.dep
+
+%.mod: %.o %.f90
+ @true
diff --git a/golem95c-1.2.1/module/Makefile.dep b/golem95c-1.2.1/module/Makefile.dep
new file mode 100644
index 0000000..fd91f50
--- /dev/null
+++ b/golem95c-1.2.1/module/Makefile.dep
@@ -0,0 +1,28 @@
+# Module dependencies
+cache.o: sortie_erreur.o
+cache.lo: sortie_erreur.lo
+cache.obj: sortie_erreur.obj
+equal.o: constante.o parametre.o sortie_erreur.o
+equal.lo: constante.lo parametre.lo sortie_erreur.lo
+equal.obj: constante.obj parametre.obj sortie_erreur.obj
+form_factor_type.o: constante.o
+form_factor_type.lo: constante.lo
+form_factor_type.obj: constante.obj
+s_matrix_type.o: constante.o equal.o sortie_erreur.o
+s_matrix_type.lo: constante.lo equal.lo sortie_erreur.lo
+s_matrix_type.obj: constante.obj equal.obj sortie_erreur.obj
+sortie_erreur.o: array.o parametre.o
+sortie_erreur.lo: array.lo parametre.lo
+sortie_erreur.obj: array.obj parametre.obj
+spinor.o: constante.o
+spinor.lo: constante.lo
+spinor.obj: constante.obj
+translate.o: sortie_erreur.o
+translate.lo: sortie_erreur.lo
+translate.obj: sortie_erreur.obj
+z_log.o: constante.o equal.o sortie_erreur.o
+z_log.lo: constante.lo equal.lo sortie_erreur.lo
+z_log.obj: constante.obj equal.obj sortie_erreur.obj
+zdilog.o: constante.o equal.o sortie_erreur.o z_log.o
+zdilog.lo: constante.lo equal.lo sortie_erreur.lo z_log.lo
+zdilog.obj: constante.obj equal.obj sortie_erreur.obj z_log.obj
diff --git a/golem95c-1.2.1/module/Makefile.in b/golem95c-1.2.1/module/Makefile.in
new file mode 100644
index 0000000..e7a144c
--- /dev/null
+++ b/golem95c-1.2.1/module/Makefile.in
@@ -0,0 +1,652 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.dep \
+ $(srcdir)/Makefile.in $(srcdir)/precision_golem.f90.in
+subdir = golem95c-1.2.1/module
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES = precision_golem.f90
+CONFIG_CLEAN_VPATH_FILES =
+LTLIBRARIES = $(noinst_LTLIBRARIES)
+libgolem95_module_la_LIBADD =
+am_libgolem95_module_la_OBJECTS = \
+ libgolem95_module_la-precision_golem.lo \
+ libgolem95_module_la-tri.lo libgolem95_module_la-array.lo \
+ libgolem95_module_la-parametre.lo \
+ libgolem95_module_la-constante.lo \
+ libgolem95_module_la-sortie_erreur.lo \
+ libgolem95_module_la-equal.lo \
+ libgolem95_module_la-s_matrix_type.lo \
+ libgolem95_module_la-multiply_div.lo \
+ libgolem95_module_la-cache.lo \
+ libgolem95_module_la-form_factor_type.lo \
+ libgolem95_module_la-kronecker.lo \
+ libgolem95_module_la-z_log.lo libgolem95_module_la-spinor.lo \
+ libgolem95_module_la-translate.lo \
+ libgolem95_module_la-zdilog.lo
+libgolem95_module_la_OBJECTS = $(am_libgolem95_module_la_OBJECTS)
+libgolem95_module_la_LINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=link $(FCLD) \
+ $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem95_module_la_SOURCES)
+DIST_SOURCES = $(libgolem95_module_la_SOURCES)
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgincludedir)"
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+noinst_LTLIBRARIES = libgolem95_module.la
+libgolem95_module_la_SOURCES = precision_golem.f90 \
+ tri.f90 array.f90 parametre.f90 constante.f90 \
+ sortie_erreur.f90 equal.f90 s_matrix_type.f90 multiply_div.f90 \
+ cache.f90 form_factor_type.f90 kronecker.f90 z_log.f90 \
+ spinor.f90 translate.f90 zdilog.f90
+
+libgolem95_module_la_FCFLAGS = \
+ -I$(builddir)/../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS = precision_golem.mod \
+ tri_croissant.mod array.mod \
+ cache.mod constante.mod s_matrix_type.mod dilogarithme.mod \
+ equal.mod form_factor_type.mod kronecker.mod logarithme.mod \
+ multiply_div.mod parametre.mod \
+ sortie_erreur.mod spinor.mod translate.mod
+
+CLEANFILES = $(nodist_pkginclude_HEADERS)
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/module/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/module/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+precision_golem.f90: $(top_builddir)/config.status $(srcdir)/precision_golem.f90.in
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
+
+clean-noinstLTLIBRARIES:
+ -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+ @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem95_module.la: $(libgolem95_module_la_OBJECTS) $(libgolem95_module_la_DEPENDENCIES)
+ $(libgolem95_module_la_LINK) $(libgolem95_module_la_OBJECTS) $(libgolem95_module_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+libgolem95_module_la-precision_golem.lo: precision_golem.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-precision_golem.lo $(FCFLAGS_f90) `test -f 'precision_golem.f90' || echo '$(srcdir)/'`precision_golem.f90
+
+libgolem95_module_la-tri.lo: tri.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-tri.lo $(FCFLAGS_f90) `test -f 'tri.f90' || echo '$(srcdir)/'`tri.f90
+
+libgolem95_module_la-array.lo: array.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-array.lo $(FCFLAGS_f90) `test -f 'array.f90' || echo '$(srcdir)/'`array.f90
+
+libgolem95_module_la-parametre.lo: parametre.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-parametre.lo $(FCFLAGS_f90) `test -f 'parametre.f90' || echo '$(srcdir)/'`parametre.f90
+
+libgolem95_module_la-constante.lo: constante.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-constante.lo $(FCFLAGS_f90) `test -f 'constante.f90' || echo '$(srcdir)/'`constante.f90
+
+libgolem95_module_la-sortie_erreur.lo: sortie_erreur.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-sortie_erreur.lo $(FCFLAGS_f90) `test -f 'sortie_erreur.f90' || echo '$(srcdir)/'`sortie_erreur.f90
+
+libgolem95_module_la-equal.lo: equal.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-equal.lo $(FCFLAGS_f90) `test -f 'equal.f90' || echo '$(srcdir)/'`equal.f90
+
+libgolem95_module_la-s_matrix_type.lo: s_matrix_type.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-s_matrix_type.lo $(FCFLAGS_f90) `test -f 's_matrix_type.f90' || echo '$(srcdir)/'`s_matrix_type.f90
+
+libgolem95_module_la-multiply_div.lo: multiply_div.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-multiply_div.lo $(FCFLAGS_f90) `test -f 'multiply_div.f90' || echo '$(srcdir)/'`multiply_div.f90
+
+libgolem95_module_la-cache.lo: cache.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-cache.lo $(FCFLAGS_f90) `test -f 'cache.f90' || echo '$(srcdir)/'`cache.f90
+
+libgolem95_module_la-form_factor_type.lo: form_factor_type.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-form_factor_type.lo $(FCFLAGS_f90) `test -f 'form_factor_type.f90' || echo '$(srcdir)/'`form_factor_type.f90
+
+libgolem95_module_la-kronecker.lo: kronecker.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-kronecker.lo $(FCFLAGS_f90) `test -f 'kronecker.f90' || echo '$(srcdir)/'`kronecker.f90
+
+libgolem95_module_la-z_log.lo: z_log.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-z_log.lo $(FCFLAGS_f90) `test -f 'z_log.f90' || echo '$(srcdir)/'`z_log.f90
+
+libgolem95_module_la-spinor.lo: spinor.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-spinor.lo $(FCFLAGS_f90) `test -f 'spinor.f90' || echo '$(srcdir)/'`spinor.f90
+
+libgolem95_module_la-translate.lo: translate.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-translate.lo $(FCFLAGS_f90) `test -f 'translate.f90' || echo '$(srcdir)/'`translate.f90
+
+libgolem95_module_la-zdilog.lo: zdilog.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_module_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_module_la-zdilog.lo $(FCFLAGS_f90) `test -f 'zdilog.f90' || echo '$(srcdir)/'`zdilog.f90
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libtool clean-noinstLTLIBRARIES ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+cache.o: sortie_erreur.o
+cache.lo: sortie_erreur.lo
+cache.obj: sortie_erreur.obj
+equal.o: constante.o parametre.o sortie_erreur.o
+equal.lo: constante.lo parametre.lo sortie_erreur.lo
+equal.obj: constante.obj parametre.obj sortie_erreur.obj
+form_factor_type.o: constante.o
+form_factor_type.lo: constante.lo
+form_factor_type.obj: constante.obj
+s_matrix_type.o: constante.o equal.o sortie_erreur.o
+s_matrix_type.lo: constante.lo equal.lo sortie_erreur.lo
+s_matrix_type.obj: constante.obj equal.obj sortie_erreur.obj
+sortie_erreur.o: array.o parametre.o
+sortie_erreur.lo: array.lo parametre.lo
+sortie_erreur.obj: array.obj parametre.obj
+spinor.o: constante.o
+spinor.lo: constante.lo
+spinor.obj: constante.obj
+translate.o: sortie_erreur.o
+translate.lo: sortie_erreur.lo
+translate.obj: sortie_erreur.obj
+z_log.o: constante.o equal.o sortie_erreur.o
+z_log.lo: constante.lo equal.lo sortie_erreur.lo
+z_log.obj: constante.obj equal.obj sortie_erreur.obj
+zdilog.o: constante.o equal.o sortie_erreur.o z_log.o
+zdilog.lo: constante.lo equal.lo sortie_erreur.lo z_log.lo
+zdilog.obj: constante.obj equal.obj sortie_erreur.obj z_log.obj
+
+%.mod: %.o %.f90
+ @true
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/module/array.f90 b/golem95c-1.2.1/module/array.f90
new file mode 100644
index 0000000..d26837b
--- /dev/null
+++ b/golem95c-1.2.1/module/array.f90
@@ -0,0 +1,683 @@
+!
+!****h* src/module/array
+! NAME
+!
+! Module array
+!
+! USAGE
+!
+! use array
+!
+! DESCRIPTION
+!
+! This module contains six functions which enable set manipulations knowing that
+! a set of integers is represented with the digits of an integer. The six functions
+! are : packb, unpackb, pminus, punion, countb and locateb
+!
+! OUTPUT
+!
+! This module exports six functions:
+!
+! * packb -- to transform a set of integers into an integer (unique transformation)
+! * unpackb -- to perform the inverse operation as packb do
+! * pminus -- to subtract two sets
+! * punion -- to add two sets
+! * countb -- to count the number of element of the set
+! * locateb -- to give the location of an element in a set
+!
+! USES
+!
+! none
+!
+!*****
+!
+module array
+ !
+ implicit none
+ !
+ integer, dimension(0:255), parameter :: bit_count = (/0,1,1,2,1,2,2,3,1,2,2,3&
+ &,2,3,3,4,1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,2&
+ &,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,2,3,3,4,3,4&
+ &,4,5,3,4,4,5,4,5,5,6,2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,3,4,4,5,4,5,5,6,4,5,5&
+ &,6,5,6,6,7,1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6&
+ &,2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7,2,3,3,4,3&
+ &,4,4,5,3,4,4,5,4,5,5,6,3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7,3,4,4,5,4,5,5,6,4,5&
+ &,5,6,5,6,6,7,4,5,5,6,5,6,6,7,5,6,6,7,6,7,7,8/)
+ !
+ integer, dimension(0:2047), parameter :: bit_sets = (/&
+ &-1,-1,-1,-1,-1,-1,-1,-1,&
+ &0,-1,-1,-1,-1,-1,-1,-1,&
+ &1,-1,-1,-1,-1,-1,-1,-1,&
+ &0,1,-1,-1,-1,-1,-1,-1,&
+ &2,-1,-1,-1,-1,-1,-1,-1,&
+ &0,2,-1,-1,-1,-1,-1,-1,&
+ &1,2,-1,-1,-1,-1,-1,-1,&
+ &0,1,2,-1,-1,-1,-1,-1,&
+ &3,-1,-1,-1,-1,-1,-1,-1,&
+ &0,3,-1,-1,-1,-1,-1,-1,&
+ &1,3,-1,-1,-1,-1,-1,-1,&
+ &0,1,3,-1,-1,-1,-1,-1,&
+ &2,3,-1,-1,-1,-1,-1,-1,&
+ &0,2,3,-1,-1,-1,-1,-1,&
+ &1,2,3,-1,-1,-1,-1,-1,&
+ &0,1,2,3,-1,-1,-1,-1,&
+ &4,-1,-1,-1,-1,-1,-1,-1,&
+ &0,4,-1,-1,-1,-1,-1,-1,&
+ &1,4,-1,-1,-1,-1,-1,-1,&
+ &0,1,4,-1,-1,-1,-1,-1,&
+ &2,4,-1,-1,-1,-1,-1,-1,&
+ &0,2,4,-1,-1,-1,-1,-1,&
+ &1,2,4,-1,-1,-1,-1,-1,&
+ &0,1,2,4,-1,-1,-1,-1,&
+ &3,4,-1,-1,-1,-1,-1,-1,&
+ &0,3,4,-1,-1,-1,-1,-1,&
+ &1,3,4,-1,-1,-1,-1,-1,&
+ &0,1,3,4,-1,-1,-1,-1,&
+ &2,3,4,-1,-1,-1,-1,-1,&
+ &0,2,3,4,-1,-1,-1,-1,&
+ &1,2,3,4,-1,-1,-1,-1,&
+ &0,1,2,3,4,-1,-1,-1,&
+ &5,-1,-1,-1,-1,-1,-1,-1,&
+ &0,5,-1,-1,-1,-1,-1,-1,&
+ &1,5,-1,-1,-1,-1,-1,-1,&
+ &0,1,5,-1,-1,-1,-1,-1,&
+ &2,5,-1,-1,-1,-1,-1,-1,&
+ &0,2,5,-1,-1,-1,-1,-1,&
+ &1,2,5,-1,-1,-1,-1,-1,&
+ &0,1,2,5,-1,-1,-1,-1,&
+ &3,5,-1,-1,-1,-1,-1,-1,&
+ &0,3,5,-1,-1,-1,-1,-1,&
+ &1,3,5,-1,-1,-1,-1,-1,&
+ &0,1,3,5,-1,-1,-1,-1,&
+ &2,3,5,-1,-1,-1,-1,-1,&
+ &0,2,3,5,-1,-1,-1,-1,&
+ &1,2,3,5,-1,-1,-1,-1,&
+ &0,1,2,3,5,-1,-1,-1,&
+ &4,5,-1,-1,-1,-1,-1,-1,&
+ &0,4,5,-1,-1,-1,-1,-1,&
+ &1,4,5,-1,-1,-1,-1,-1,&
+ &0,1,4,5,-1,-1,-1,-1,&
+ &2,4,5,-1,-1,-1,-1,-1,&
+ &0,2,4,5,-1,-1,-1,-1,&
+ &1,2,4,5,-1,-1,-1,-1,&
+ &0,1,2,4,5,-1,-1,-1,&
+ &3,4,5,-1,-1,-1,-1,-1,&
+ &0,3,4,5,-1,-1,-1,-1,&
+ &1,3,4,5,-1,-1,-1,-1,&
+ &0,1,3,4,5,-1,-1,-1,&
+ &2,3,4,5,-1,-1,-1,-1,&
+ &0,2,3,4,5,-1,-1,-1,&
+ &1,2,3,4,5,-1,-1,-1,&
+ &0,1,2,3,4,5,-1,-1,&
+ &6,-1,-1,-1,-1,-1,-1,-1,&
+ &0,6,-1,-1,-1,-1,-1,-1,&
+ &1,6,-1,-1,-1,-1,-1,-1,&
+ &0,1,6,-1,-1,-1,-1,-1,&
+ &2,6,-1,-1,-1,-1,-1,-1,&
+ &0,2,6,-1,-1,-1,-1,-1,&
+ &1,2,6,-1,-1,-1,-1,-1,&
+ &0,1,2,6,-1,-1,-1,-1,&
+ &3,6,-1,-1,-1,-1,-1,-1,&
+ &0,3,6,-1,-1,-1,-1,-1,&
+ &1,3,6,-1,-1,-1,-1,-1,&
+ &0,1,3,6,-1,-1,-1,-1,&
+ &2,3,6,-1,-1,-1,-1,-1,&
+ &0,2,3,6,-1,-1,-1,-1,&
+ &1,2,3,6,-1,-1,-1,-1,&
+ &0,1,2,3,6,-1,-1,-1,&
+ &4,6,-1,-1,-1,-1,-1,-1,&
+ &0,4,6,-1,-1,-1,-1,-1,&
+ &1,4,6,-1,-1,-1,-1,-1,&
+ &0,1,4,6,-1,-1,-1,-1,&
+ &2,4,6,-1,-1,-1,-1,-1,&
+ &0,2,4,6,-1,-1,-1,-1,&
+ &1,2,4,6,-1,-1,-1,-1,&
+ &0,1,2,4,6,-1,-1,-1,&
+ &3,4,6,-1,-1,-1,-1,-1,&
+ &0,3,4,6,-1,-1,-1,-1,&
+ &1,3,4,6,-1,-1,-1,-1,&
+ &0,1,3,4,6,-1,-1,-1,&
+ &2,3,4,6,-1,-1,-1,-1,&
+ &0,2,3,4,6,-1,-1,-1,&
+ &1,2,3,4,6,-1,-1,-1,&
+ &0,1,2,3,4,6,-1,-1,&
+ &5,6,-1,-1,-1,-1,-1,-1,&
+ &0,5,6,-1,-1,-1,-1,-1,&
+ &1,5,6,-1,-1,-1,-1,-1,&
+ &0,1,5,6,-1,-1,-1,-1,&
+ &2,5,6,-1,-1,-1,-1,-1,&
+ &0,2,5,6,-1,-1,-1,-1,&
+ &1,2,5,6,-1,-1,-1,-1,&
+ &0,1,2,5,6,-1,-1,-1,&
+ &3,5,6,-1,-1,-1,-1,-1,&
+ &0,3,5,6,-1,-1,-1,-1,&
+ &1,3,5,6,-1,-1,-1,-1,&
+ &0,1,3,5,6,-1,-1,-1,&
+ &2,3,5,6,-1,-1,-1,-1,&
+ &0,2,3,5,6,-1,-1,-1,&
+ &1,2,3,5,6,-1,-1,-1,&
+ &0,1,2,3,5,6,-1,-1,&
+ &4,5,6,-1,-1,-1,-1,-1,&
+ &0,4,5,6,-1,-1,-1,-1,&
+ &1,4,5,6,-1,-1,-1,-1,&
+ &0,1,4,5,6,-1,-1,-1,&
+ &2,4,5,6,-1,-1,-1,-1,&
+ &0,2,4,5,6,-1,-1,-1,&
+ &1,2,4,5,6,-1,-1,-1,&
+ &0,1,2,4,5,6,-1,-1,&
+ &3,4,5,6,-1,-1,-1,-1,&
+ &0,3,4,5,6,-1,-1,-1,&
+ &1,3,4,5,6,-1,-1,-1,&
+ &0,1,3,4,5,6,-1,-1,&
+ &2,3,4,5,6,-1,-1,-1,&
+ &0,2,3,4,5,6,-1,-1,&
+ &1,2,3,4,5,6,-1,-1,&
+ &0,1,2,3,4,5,6,-1,&
+ &7,-1,-1,-1,-1,-1,-1,-1,&
+ &0,7,-1,-1,-1,-1,-1,-1,&
+ &1,7,-1,-1,-1,-1,-1,-1,&
+ &0,1,7,-1,-1,-1,-1,-1,&
+ &2,7,-1,-1,-1,-1,-1,-1,&
+ &0,2,7,-1,-1,-1,-1,-1,&
+ &1,2,7,-1,-1,-1,-1,-1,&
+ &0,1,2,7,-1,-1,-1,-1,&
+ &3,7,-1,-1,-1,-1,-1,-1,&
+ &0,3,7,-1,-1,-1,-1,-1,&
+ &1,3,7,-1,-1,-1,-1,-1,&
+ &0,1,3,7,-1,-1,-1,-1,&
+ &2,3,7,-1,-1,-1,-1,-1,&
+ &0,2,3,7,-1,-1,-1,-1,&
+ &1,2,3,7,-1,-1,-1,-1,&
+ &0,1,2,3,7,-1,-1,-1,&
+ &4,7,-1,-1,-1,-1,-1,-1,&
+ &0,4,7,-1,-1,-1,-1,-1,&
+ &1,4,7,-1,-1,-1,-1,-1,&
+ &0,1,4,7,-1,-1,-1,-1,&
+ &2,4,7,-1,-1,-1,-1,-1,&
+ &0,2,4,7,-1,-1,-1,-1,&
+ &1,2,4,7,-1,-1,-1,-1,&
+ &0,1,2,4,7,-1,-1,-1,&
+ &3,4,7,-1,-1,-1,-1,-1,&
+ &0,3,4,7,-1,-1,-1,-1,&
+ &1,3,4,7,-1,-1,-1,-1,&
+ &0,1,3,4,7,-1,-1,-1,&
+ &2,3,4,7,-1,-1,-1,-1,&
+ &0,2,3,4,7,-1,-1,-1,&
+ &1,2,3,4,7,-1,-1,-1,&
+ &0,1,2,3,4,7,-1,-1,&
+ &5,7,-1,-1,-1,-1,-1,-1,&
+ &0,5,7,-1,-1,-1,-1,-1,&
+ &1,5,7,-1,-1,-1,-1,-1,&
+ &0,1,5,7,-1,-1,-1,-1,&
+ &2,5,7,-1,-1,-1,-1,-1,&
+ &0,2,5,7,-1,-1,-1,-1,&
+ &1,2,5,7,-1,-1,-1,-1,&
+ &0,1,2,5,7,-1,-1,-1,&
+ &3,5,7,-1,-1,-1,-1,-1,&
+ &0,3,5,7,-1,-1,-1,-1,&
+ &1,3,5,7,-1,-1,-1,-1,&
+ &0,1,3,5,7,-1,-1,-1,&
+ &2,3,5,7,-1,-1,-1,-1,&
+ &0,2,3,5,7,-1,-1,-1,&
+ &1,2,3,5,7,-1,-1,-1,&
+ &0,1,2,3,5,7,-1,-1,&
+ &4,5,7,-1,-1,-1,-1,-1,&
+ &0,4,5,7,-1,-1,-1,-1,&
+ &1,4,5,7,-1,-1,-1,-1,&
+ &0,1,4,5,7,-1,-1,-1,&
+ &2,4,5,7,-1,-1,-1,-1,&
+ &0,2,4,5,7,-1,-1,-1,&
+ &1,2,4,5,7,-1,-1,-1,&
+ &0,1,2,4,5,7,-1,-1,&
+ &3,4,5,7,-1,-1,-1,-1,&
+ &0,3,4,5,7,-1,-1,-1,&
+ &1,3,4,5,7,-1,-1,-1,&
+ &0,1,3,4,5,7,-1,-1,&
+ &2,3,4,5,7,-1,-1,-1,&
+ &0,2,3,4,5,7,-1,-1,&
+ &1,2,3,4,5,7,-1,-1,&
+ &0,1,2,3,4,5,7,-1,&
+ &6,7,-1,-1,-1,-1,-1,-1,&
+ &0,6,7,-1,-1,-1,-1,-1,&
+ &1,6,7,-1,-1,-1,-1,-1,&
+ &0,1,6,7,-1,-1,-1,-1,&
+ &2,6,7,-1,-1,-1,-1,-1,&
+ &0,2,6,7,-1,-1,-1,-1,&
+ &1,2,6,7,-1,-1,-1,-1,&
+ &0,1,2,6,7,-1,-1,-1,&
+ &3,6,7,-1,-1,-1,-1,-1,&
+ &0,3,6,7,-1,-1,-1,-1,&
+ &1,3,6,7,-1,-1,-1,-1,&
+ &0,1,3,6,7,-1,-1,-1,&
+ &2,3,6,7,-1,-1,-1,-1,&
+ &0,2,3,6,7,-1,-1,-1,&
+ &1,2,3,6,7,-1,-1,-1,&
+ &0,1,2,3,6,7,-1,-1,&
+ &4,6,7,-1,-1,-1,-1,-1,&
+ &0,4,6,7,-1,-1,-1,-1,&
+ &1,4,6,7,-1,-1,-1,-1,&
+ &0,1,4,6,7,-1,-1,-1,&
+ &2,4,6,7,-1,-1,-1,-1,&
+ &0,2,4,6,7,-1,-1,-1,&
+ &1,2,4,6,7,-1,-1,-1,&
+ &0,1,2,4,6,7,-1,-1,&
+ &3,4,6,7,-1,-1,-1,-1,&
+ &0,3,4,6,7,-1,-1,-1,&
+ &1,3,4,6,7,-1,-1,-1,&
+ &0,1,3,4,6,7,-1,-1,&
+ &2,3,4,6,7,-1,-1,-1,&
+ &0,2,3,4,6,7,-1,-1,&
+ &1,2,3,4,6,7,-1,-1,&
+ &0,1,2,3,4,6,7,-1,&
+ &5,6,7,-1,-1,-1,-1,-1,&
+ &0,5,6,7,-1,-1,-1,-1,&
+ &1,5,6,7,-1,-1,-1,-1,&
+ &0,1,5,6,7,-1,-1,-1,&
+ &2,5,6,7,-1,-1,-1,-1,&
+ &0,2,5,6,7,-1,-1,-1,&
+ &1,2,5,6,7,-1,-1,-1,&
+ &0,1,2,5,6,7,-1,-1,&
+ &3,5,6,7,-1,-1,-1,-1,&
+ &0,3,5,6,7,-1,-1,-1,&
+ &1,3,5,6,7,-1,-1,-1,&
+ &0,1,3,5,6,7,-1,-1,&
+ &2,3,5,6,7,-1,-1,-1,&
+ &0,2,3,5,6,7,-1,-1,&
+ &1,2,3,5,6,7,-1,-1,&
+ &0,1,2,3,5,6,7,-1,&
+ &4,5,6,7,-1,-1,-1,-1,&
+ &0,4,5,6,7,-1,-1,-1,&
+ &1,4,5,6,7,-1,-1,-1,&
+ &0,1,4,5,6,7,-1,-1,&
+ &2,4,5,6,7,-1,-1,-1,&
+ &0,2,4,5,6,7,-1,-1,&
+ &1,2,4,5,6,7,-1,-1,&
+ &0,1,2,4,5,6,7,-1,&
+ &3,4,5,6,7,-1,-1,-1,&
+ &0,3,4,5,6,7,-1,-1,&
+ &1,3,4,5,6,7,-1,-1,&
+ &0,1,3,4,5,6,7,-1,&
+ &2,3,4,5,6,7,-1,-1,&
+ &0,2,3,4,5,6,7,-1,&
+ &1,2,3,4,5,6,7,-1,&
+ &0,1,2,3,4,5,6,7/)
+ !
+contains
+ !
+ !****f* src/module/packb
+ ! NAME
+ !
+ ! Function packb
+ !
+ ! USAGE
+ !
+ ! integer = packb(set)
+ !
+ ! DESCRIPTION
+ !
+ ! This function transforms a set of integers into
+ ! an integer, this integer is unique
+ ! Apparently Fortran allows to use arrays
+ ! for the second argument which saves us a loop.
+ !
+ ! The elements in set have to be <= 31 which should
+ ! not be a problem for realistic applications.
+ !
+ ! INPUTS
+ !
+ ! * set -- a set of integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! an integer
+ !
+ ! EXAMPLE
+ !
+ ! i = packb( (/1,2,3/) )
+ ! i is 14 which is in binary base 1110
+ !
+ !*****
+ !
+ pure function packb(set) result(bits)
+ !
+ integer, intent(in), dimension(:) :: set
+ integer :: bits
+ !
+ bits = sum( ibset(0,pos=set) )
+ !
+ end function packb
+ !
+ !****f* src/module/unpackb
+ ! NAME
+ !
+ ! Function unpackb
+ !
+ ! USAGE
+ !
+ ! integer_set = unpackb(bits,dim)
+ !
+ ! DESCRIPTION
+ !
+ ! This function performs the inverse operation
+ ! as packb does : from an integer, it reconstructs the
+ ! set of integers
+ !
+ ! INPUTS
+ !
+ ! * bits -- an integer
+ ! * dim -- an integer, the dimension of the set obtained
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! an integer array of rank 1 and shape dim
+ !
+ ! EXAMPLE
+ !
+ ! set = unpackb( 14 )
+ ! set is (/1,2,3/) because the binary representation of 14 is 1110
+ !
+ !*****
+ !
+ pure function unpackb(bits,dim)
+ !
+ integer, intent(in) :: bits
+ integer, intent(in) :: dim
+ integer, dimension(dim) :: unpackb
+ !
+ integer :: i,k,n
+ !
+ if (bits < 256) then
+ !
+ n = bits * 8
+ unpackb = bit_sets(n:n + (dim-1))
+ !
+ else
+ !
+ i = bits
+ k = 0
+ n = 1
+ !
+ do while (i /= 0)
+ !
+ if (modulo(i,2) == 1) then
+ !
+ unpackb(n) = k
+ n = n + 1
+ !
+ end if
+ !
+ k = k+1
+ i = ishft(i,-1)
+ !
+ end do
+ !
+ end if
+ !
+ end function unpackb
+ !
+ !****f* src/module/pminus
+ ! NAME
+ !
+ ! Function pminus
+ !
+ ! USAGE
+ !
+ ! integer = pminus(bits1,bits2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function subtracts the set which is
+ ! represented by bits2 to the one that is
+ ! represented by bits1. If the two sets set1 and set2
+ ! are defined by set1=unpackb(bits1,dim1)
+ ! and set2=unpackb(bits2,dim2), then ib = pminus(bits1,bits2)
+ ! gives an integer such that unpackb(ib,dim_ib) is the set
+ ! of integers of shape dim1-dim2 (dim1 > dim2) which contains
+ ! the elements of set1 which do not belong to set2
+ ! Note that if dim1 < dim2, the result returns is pminus(bits2,bits1)
+ ! If none of the elements of set2 belongs to set1, then
+ ! pminus(bits1,bits2) = bits1
+ !
+ ! INPUTS
+ !
+ ! * bits1 -- an integer
+ ! * bits2 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! an integer
+ !
+ ! EXAMPLE
+ !
+ ! i1 = packb( (/1,2,3/) )
+ ! i2 = packb( (/2/) )
+ ! i3 = pminus(i1,i2)
+ ! unpackb(i3) is the set (/1,3/)
+ !
+ !*****
+ !
+ pure function pminus(bits1, bits2) result(bits)
+ !
+ integer, intent(in) :: bits1, bits2
+ integer :: bits
+ !
+ integer :: cits1, cits2
+ !
+ if ( bits1 >= bits2 ) then
+ !
+ cits1 = bits1
+ cits2 = bits2
+ !
+ else
+ !
+ cits1 = bits2
+ cits2 = bits1
+ !
+ end if
+ !
+ bits = iand(cits1,not(cits2))
+ !
+ end function pminus
+ !
+ !****f* src/module/punion
+ ! NAME
+ !
+ ! Function punion
+ !
+ ! USAGE
+ !
+ ! integer = punion(bits1,bits2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function adds the set which is
+ ! represented by bits2 to the one that is
+ ! represented by bits1. If the two sets set1 and set2
+ ! are defined by set1=unpackb(bits1,dim1)
+ ! and set2=unpackb(bits2,dim2), then ib = punion(bits1,bits2)
+ ! gives an integer such that unpackb(ib,dim_ib) is the set
+ ! of integers of shape dim1+dim2 which contains
+ ! the elements of set1 and those of set2
+ ! Note that if some elements of set2 belong to set1, they do not
+ ! appear twice
+ !
+ ! INPUTS
+ !
+ ! * bits1 -- an integer
+ ! * bits2 -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! an integer
+ !
+ ! EXAMPLE
+ !
+ ! i1 = packb( (/1,3,4/) )
+ ! i2 = packb( (/2/) )
+ ! i3 = punion(i1,i2)
+ ! unpackb(i3) is the set (/1,2,3,4/)
+ !
+ !*****
+ !
+ pure function punion(bits1, bits2) result(bits)
+ !
+ integer, intent(in) :: bits1, bits2
+ integer :: bits
+ !
+ bits = ior(bits1,bits2)
+ !
+ end function punion
+ !
+ !
+ !****f* src/module/countb
+ ! NAME
+ !
+ ! Function countb
+ !
+ ! USAGE
+ !
+ ! integer = countb(bits)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the shape of the rank 1 integer
+ ! set given by unpackb(bits,dim)
+ !
+ ! INPUTS
+ !
+ ! * bits -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! an integer
+ !
+ ! EXAMPLE
+ !
+ ! i1 = packb( (/1,2,3/) )
+ ! i2 = countb(i1)
+ ! i2 is 3
+ !
+ !*****
+ !
+ pure function countb(bits)
+ !
+ integer, intent(in) :: bits
+ integer :: countb
+ !
+ integer :: i
+ !
+ if (bits < 256) then
+ !
+ countb = bit_count(bits)
+ !
+ else
+ !
+ countb = 0
+ i = bits
+ do while (i /= 0)
+ !
+ countb = countb + bit_count(iand(i, 255))
+ i = ishft(i,-8)
+ !
+ end do
+ !
+ end if
+ !
+ end function countb
+ !
+ !
+ !****f* src/module/locateb
+ ! NAME
+ !
+ ! Function locateb
+ !
+ ! USAGE
+ !
+ ! integer = locateb(i,bits)
+ !
+ ! DESCRIPTION
+ !
+ ! The function locateb returns the location of the element i
+ ! in the set given by unpackb(bits,countb(bits)).
+ ! If i does not belong to bits, the function locateb
+ ! returns -1
+ !
+ !
+ ! INPUTS
+ !
+ ! * i -- an integer, the element of a
+ ! * bits -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (elemental)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an integer, the location of i in the array a
+ !
+ ! EXAMPLE
+ !
+ ! bits = packb( (/3,5,6,7/) )
+ ! j = locateb(5,bits) --> j is equal to 2
+ ! j = locateb(6,bits) --> j is equal to 3
+ ! j = locateb(4,bits) --> j is equal to -1
+ ! Note that if the set is not ordered, the packing
+ ! orders it.
+ ! Note also that this function has the attribute elemental
+ ! that means that, the argument can be a set of integers:
+ ! locateb( (/3,7/) , bits) will return (/1,4/)
+ !
+ !
+ !*****
+ !
+ elemental function locateb(i,bits)
+ !
+ integer, intent(in) :: bits
+ integer, intent(in) :: i
+ integer :: locateb
+ !
+ integer :: ib
+ !
+ if (btest(bits,i)) then
+ !
+ ib = ibits(bits,0,i)
+ if (ib < 256) then
+ !
+ locateb = bit_count(ib)+1
+ !
+ else
+ !
+ locateb = countb(ib)+1
+ !
+ end if
+ !
+ else
+ !
+ locateb = -1
+ !
+ end if
+ !
+ end function locateb
+ !
+end module array
diff --git a/golem95c-1.2.1/module/cache.f90 b/golem95c-1.2.1/module/cache.f90
new file mode 100644
index 0000000..903ba5c
--- /dev/null
+++ b/golem95c-1.2.1/module/cache.f90
@@ -0,0 +1,359 @@
+!
+!****h* src/module/cache
+! NAME
+!
+! Module cache
+!
+! USAGE
+!
+! use cache
+!
+! DESCRIPTION
+!
+! This module is used to reserve some memory to store already computed four/three
+! point functions
+!
+! OUTPUT
+!
+! This module exports three routines:
+! * allocate_cache -- to reserve the memory
+! * reset_cache -- to force the re-computation of the cache arrays
+! * clear_cache -- to clear the reserved memory
+!
+! USES
+!
+! * sortie_erreur (src/module/sortie_erreur.f90)
+!
+!
+!*****
+module cache
+ !
+ use precision_golem
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ implicit none
+ !
+ private :: ki
+ !
+ integer, private :: err
+ logical, dimension(:,:,:,:,:), allocatable :: computed_f4p_np2
+ complex(ki),dimension(:,:,:,:,:), allocatable :: results_f4p_np2
+ logical, dimension(:,:,:), allocatable :: computed_f4p_np4
+ complex(ki),dimension(:,:,:,:), allocatable :: results_f4p_np4
+ logical, dimension(:,:,:,:,:,:), allocatable :: computed_f3p
+ real(ki),dimension(:,:,:,:,:,:,:), allocatable :: results_f3p
+ logical, dimension(:,:,:,:,:,:), allocatable :: computed_f3p_np2
+ real(ki),dimension(:,:,:,:,:,:,:), allocatable :: results_f3p_np2
+ !
+ ! everything public except err, ki
+ !public :: allocate_cache, reset_cache, clear_cache
+ !
+ contains
+ !
+ !****f* src/module/cache/allocate_cache
+ ! NAME
+ !
+ ! Subroutine allocate_cache
+ !
+ ! USAGE
+ !
+ ! call allocate_cache(dim_s)
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine allocates the necessary memory to store
+ ! the n+2/n+4 four point functions and the n/n+2 three point functions
+ !
+ ! INPUTS
+ !
+ ! * dim_s -- an integer, the dimension of the S matrix
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! No return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ subroutine allocate_cache(dim_s)
+ !
+ integer, intent(in) :: dim_s
+ !
+ allocate(computed_f4p_np2(0:dim_s,0:dim_s,0:dim_s,0:dim_s,0:dim_s),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocate_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for computed_f4p_np2'
+ call catch_exception(0)
+ !
+ end if
+ !
+ allocate(computed_f4p_np4(0:dim_s,0:dim_s,0:dim_s),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocate_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for computed_f4p_np4'
+ call catch_exception(0)
+ !
+ end if
+ !
+ allocate(computed_f3p(0:dim_s,0:dim_s,0:dim_s,0:3,0:3,0:3),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocate_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for computed_f3p'
+ call catch_exception(0)
+ !
+ end if
+ !
+ allocate(computed_f3p_np2(0:dim_s,0:dim_s,0:dim_s,0:3,0:3,0:3),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocate_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for computed_f3p_np2'
+ call catch_exception(0)
+ !
+ end if
+ computed_f4p_np2 = .false.
+ computed_f4p_np4 = .false.
+ computed_f3p = .false.
+ computed_f3p_np2 = .false.
+ !
+ allocate(results_f4p_np2(0:dim_s,0:dim_s,0:dim_s,0:dim_s,0:dim_s),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocate_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for results_f4p_np2'
+ call catch_exception(0)
+ !
+ end if
+ !
+ allocate(results_f4p_np4(0:dim_s,0:dim_s,0:dim_s,2),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocate_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for computed_f4p_np4'
+ call catch_exception(0)
+ !
+ end if
+ !
+ allocate(results_f3p(0:dim_s,0:dim_s,0:dim_s,0:3,0:3,0:3,6),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocate_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for results_f3p'
+ call catch_exception(0)
+ !
+ end if
+ !
+ allocate(results_f3p_np2(0:dim_s,0:dim_s,0:dim_s,0:3,0:3,0:3,4),stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine allocate_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot allocate memory for results_f3p_np2'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end subroutine allocate_cache
+ !
+ !
+ !****f* src/module/cache/reset_cache
+ ! NAME
+ !
+ ! Subroutine reset_cache
+ !
+ ! USAGE
+ !
+ ! call reset_cache()
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine forces the cache arrays to be computed again
+ !
+ ! INPUTS
+ !
+ ! No inputs
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! No return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ subroutine reset_cache()
+ !
+ computed_f4p_np2 = .false.
+ computed_f4p_np4 = .false.
+ computed_f3p = .false.
+ computed_f3p_np2 = .false.
+ !
+ end subroutine reset_cache
+ !
+ !
+ !
+ !****f* src/module/cache/clear_cache
+ ! NAME
+ !
+ ! Subroutine clear_cache
+ !
+ ! USAGE
+ !
+ ! call clear_cache()
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine deallocates the reserved memory to store
+ ! the n+2/n+4 four point functions and the n/n+2 three point functions.
+ !
+ ! INPUTS
+ !
+ ! No inputs
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! No return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ subroutine clear_cache()
+ !
+ deallocate(computed_f4p_np2,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine clear_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for computed_f4p_np2'
+ call catch_exception(0)
+ !
+ end if
+ !
+ deallocate(results_f4p_np2,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine clear_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for results_f4p_np2'
+ call catch_exception(0)
+ !
+ end if
+ !
+ deallocate(computed_f4p_np4,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine clear_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for computed_f4p_np4'
+ call catch_exception(0)
+ !
+ end if
+ !
+ deallocate(results_f4p_np4,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine clear_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for results_f4p_np4'
+ call catch_exception(0)
+ !
+ end if
+ !
+ deallocate(computed_f3p,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine clear_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for computed_f3p'
+ call catch_exception(0)
+ !
+ end if
+ !
+ deallocate(results_f3p,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine clear_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for results_f3p'
+ call catch_exception(0)
+ !
+ end if
+ !
+ deallocate(computed_f3p_np2,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine clear_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for computed_f3p_np2'
+ call catch_exception(0)
+ !
+ end if
+ !
+ deallocate(results_f3p_np2,stat=err)
+ !
+ if (err /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine clear_cache'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'cannot deallocate memory for results_f3p_np2'
+ call catch_exception(0)
+ !
+ end if
+ !
+ end subroutine clear_cache
+ !
+end module cache
diff --git a/golem95c-1.2.1/module/constante.f90 b/golem95c-1.2.1/module/constante.f90
new file mode 100644
index 0000000..872ddbf
--- /dev/null
+++ b/golem95c-1.2.1/module/constante.f90
@@ -0,0 +1,59 @@
+!****h* src/module/constante
+! NAME
+!
+! Module constante
+!
+! USAGE
+!
+! use constante
+!
+! DESCRIPTION
+!
+! This module is used to get the values of different constants
+!
+! OUTPUT
+!
+! This module exports 13 parameters
+! * pi -- a real (type ki), pi
+! * gammae -- a real (type ki), the Euler constant
+! * i_ -- a complex (type ki), the square root of -1
+! * pi3 -- a real (type ki), pi**2/3
+! * pi6 -- a real (type ki), pi**2/6
+! * pi12 -- a real (type ki), pi**2/12
+! * un -- a real (type ki), 1
+! * zero -- a real (type ki), 0
+! * czero -- a complex (type ki), (0,0)
+! * cun -- a complex (type ki), (1,0)
+! * b_null -- an integer 0
+! * s_null -- an array with shape 0
+! * nullarray -- the same as s_null !!!!!!
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+!
+!*****
+module constante
+ !
+ use precision_golem
+ implicit none
+ !
+ private :: ki
+ !
+ real(ki), parameter :: pi = 3.1415926535897932384626433832795028841&
+ &971693993751_ki
+ real(ki), parameter :: gammae = 0.577215664901532860606512090082402&
+ &4310421593359399_ki
+ real(ki), parameter :: pi3 = pi**2/3.0_ki
+ real(ki), parameter :: pi6 = pi**2/6.0_ki
+ real(ki), parameter :: pi12 = pi**2/12.0_ki
+ real(ki), parameter :: un = 1._ki
+ real(ki), parameter :: zero = 0._ki
+ complex(ki), parameter :: i_ = (0._ki,1._ki)
+ complex(ki), parameter :: czero = (0.0_ki,0.0_ki)
+ complex(ki), parameter :: cun = (1._ki,0._ki)
+ integer, parameter :: b_null = 0
+ integer, dimension(0), parameter :: s_null = 0
+ integer, dimension(0), parameter :: nullarray = 0
+ !
+end module constante
diff --git a/golem95c-1.2.1/module/equal.f90 b/golem95c-1.2.1/module/equal.f90
new file mode 100644
index 0000000..4145bab
--- /dev/null
+++ b/golem95c-1.2.1/module/equal.f90
@@ -0,0 +1,254 @@
+!
+!****h* src/module/equal
+! NAME
+!
+! Module equal
+!
+! USAGE
+!
+! use equal
+!
+! DESCRIPTION
+!
+! This module is used to compare two objects
+!
+! OUTPUT
+!
+! This module exports two functions:
+! * equal_real -- to compare two reals
+! * cut_s -- sets the momentum s equal to zero, if the ratio s/M or the absoulute value
+! is smaller than some global parameters.
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+! * parametre (src/module/parametre.f90)
+! * constante (src/module/constante.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+!
+!*****
+module equal
+ !
+ use precision_golem
+ use parametre, only: cut_s_over_m, cut_s_abs
+ use constante, only: zero, czero
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ implicit none
+ !
+ private
+ !
+ interface cut_s
+ !
+ module procedure cut_s_s
+ module procedure cut_s_sm_r, cut_s_sm_c
+ module procedure cut_s_smm_r, cut_s_smm_c
+ !
+ end interface
+ !
+ public :: equal_real, cut_s
+ !
+ contains
+ !
+ !****f* src/module/equal/equal_real
+ ! NAME
+ !
+ ! Function equal_real
+ !
+ ! USAGE
+ !
+ ! logical = equal_real(xa,xb,echelle)
+ !
+ ! DESCRIPTION
+ !
+ ! This function compares two real (of same kind) by computing their
+ ! difference and compares it to epsilon (of the same kind)
+ ! true if | xa - xb | <= echelle*epsilon, false otherwise
+ !
+ ! INPUTS
+ !
+ ! * xa -- a real of type ki
+ ! * xb -- a real of type ki
+ ! * echelle -- a real of type ki (optional)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a logical
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ pure elemental function equal_real(xa,xb,echelle)
+ implicit none
+ !
+ real(ki), intent(in) :: xa,xb
+ real(ki), intent(in), optional :: echelle
+ logical equal_real
+ !
+ real(ki) :: my_epsilon
+ !
+ my_epsilon = epsilon(1._ki)
+ if (present(echelle)) my_epsilon=echelle*my_epsilon
+ equal_real = abs(xa-xb) <= my_epsilon
+ !
+ end function equal_real
+ !
+ !
+ !****f* src/module/equal/cut_s
+ ! NAME
+ !
+ ! subroutine cut_s
+ !
+ ! USAGE
+ !
+ ! call cut_s(s,m1,m2)
+ ! call cut_s(s,m)
+ ! call cut_s(s)
+ !
+ ! DESCRIPTION
+ !
+ ! This function sets s to zero, if either of the following conditions is fulfilled.
+ ! abs(s) is smaller than cut_s_abs.
+ ! abs(s/Sum(m)) is smaller than cut_s_over_m.
+ ! Calling this routine improves stability in the form factor calculations.
+ !
+ ! INPUTS
+ !
+ ! * s -- a real of type ki
+ ! * m, m1, m2 -- real/complex type
+ !
+ ! SIDE EFFECTS
+ !
+ ! Possible change of s to zero.
+ !
+ ! RETURN VALUE
+ !
+ ! EXAMPLE
+ !
+ !
+ !*****
+ subroutine cut_s_smm_r(s,mass1,mass2)
+ implicit none
+ real(ki), intent(inout) :: s
+ real(ki), intent(in) :: mass1, mass2
+ !
+ real(ki) :: sum_mass
+ !
+ sum_mass = mass1 + mass2
+ call cut_s(s, sum_mass)
+ !
+ end subroutine cut_s_smm_r
+ !
+ subroutine cut_s_sm_r(s,mass)
+ implicit none
+ real(ki), intent(inout) :: s
+ real(ki), intent(in) :: mass
+ !
+ if (equal_real(mass,zero)) then
+ !
+ call cut_s(s)
+ !
+ else if ( abs(s/mass) .le. cut_s_over_m) then
+ !
+ s = zero
+ !
+ else if ( abs(s) .le. cut_s_abs ) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in cut_s: s is set to zero because its absolute value is lower than cut_s_abs!'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The ratio s/Mass is not lower than the parameter cut_s_over_m!'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 's= %f0'
+ tab_erreur_par(3)%arg_real = s
+ tab_erreur_par(4)%a_imprimer = .true.
+ tab_erreur_par(4)%chaine = 'mass= %f0'
+ tab_erreur_par(4)%arg_real = mass
+ !
+ call catch_exception(1)
+ !
+ s = zero
+ !
+ end if
+ !
+ end subroutine cut_s_sm_r
+ !
+ subroutine cut_s_s(s)
+ implicit none
+ real(ki), intent(inout) :: s
+ !
+ if ( s /= zero) then
+ !
+ if ( abs(s) .le. cut_s_abs ) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in cut_s: s is set to zero because its absolute value is lower than cut_s_abs!'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 's= %f0'
+ tab_erreur_par(2)%arg_real = s
+ !
+ call catch_exception(1)
+ !
+ s = zero
+ !
+ end if
+ !
+ end if
+ !
+ end subroutine cut_s_s
+ !
+ subroutine cut_s_smm_c(s,mass1,mass2)
+ implicit none
+ real(ki), intent(inout) :: s
+ complex(ki), intent(in) :: mass1, mass2
+ !
+ real(ki) :: sum_mass
+ !
+ sum_mass = real(mass1 + mass2,ki)
+ call cut_s(s, sum_mass)
+ !
+ end subroutine cut_s_smm_c
+ !
+ subroutine cut_s_sm_c(s,mass_c)
+ implicit none
+ real(ki), intent(inout) :: s
+ complex(ki), intent(in) :: mass_c
+ !
+ real(ki) :: mass
+ !
+ mass = real(mass_c,ki)
+ !
+ if (equal_real(mass,zero)) then
+ !
+ call cut_s(s)
+ !
+ else if ( abs(s/mass) .le. cut_s_over_m) then
+ !
+ s = zero
+ !
+ else if ( abs(s) .le. cut_s_abs ) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'in cut_s: s is set to zero because its absolute value is lower than cut_s_abs!'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The ratio s/Mass is not lower than the parameter cut_s_over_m!'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 's= %f0'
+ tab_erreur_par(3)%arg_real = s
+ tab_erreur_par(4)%a_imprimer = .true.
+ tab_erreur_par(4)%chaine = 'mass= %f0'
+ tab_erreur_par(4)%arg_real = mass
+ !
+ call catch_exception(1)
+ !
+ s = zero
+ !
+ end if
+ !
+ end subroutine cut_s_sm_c
+ !
+end module equal
diff --git a/golem95c-1.2.1/module/form_factor_type.f90 b/golem95c-1.2.1/module/form_factor_type.f90
new file mode 100644
index 0000000..d4eb933
--- /dev/null
+++ b/golem95c-1.2.1/module/form_factor_type.f90
@@ -0,0 +1,761 @@
+! NAME
+! SYNOPSIS
+!****h* src/module/form_factor_type
+! NAME
+!
+! Module form_factor_type
+!
+! USAGE
+!
+! use form_factor_type
+!
+! DESCRIPTION
+!
+! This module contains two type definitions : the form factors and
+! epsilon type. This module overloads the *, /, +, -, = and ** operators
+!
+! OUTPUT
+!
+! This module exports two types:
+! * form_factor -- define the type of the fom factors
+! * epsilon_type -- define the type for object having an epsilon expansion
+!
+! five operators:
+! * * -- overload of the multiplication operator for form_factor and epsilon_type object
+! * / -- overload of the division operator for form_factor and epsilon_type object
+! * + -- overload of the addition operator for form_factor and epsilon_type object
+! * - -- overload of the subtraction operator for form_factor and epsilon_type object
+! * = -- overload of the assignment operator for form_factor and epsilon_type object
+! * ** -- overload of the power operator for form_factor and epsilon_type object
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+! * constante (src/module/constante.f90)
+!
+!
+! AUTHOR
+! Thomas Reiter
+!
+! CREATION DATE
+! Oct 19, 2007
+!
+!*****
+module form_factor_type
+ !
+ use precision_golem, only: ki
+ use constante
+ !
+ implicit none
+ !
+ private :: ki
+ !
+ !****t* src/module/form_factor_type/form_factor
+ ! NAME
+ ! form_factor -- represents the result of a form factor
+ !
+ ! SYNOPSIS
+ ! type form_factor
+ !
+ ! SOURCE
+ type form_factor
+ complex(ki) :: a
+ complex(ki) :: b
+ complex(ki) :: c
+ end type form_factor
+ !
+ ! NOTES
+ ! * a is the coefficient of the 1/epsilon^2 pole
+ ! * b is the coefficient of the 1/epsilon pole
+ ! * c is the coefficient of the finite term
+ !****
+ !
+ !****t* src/module/form_factor_type/epsilon_type
+ ! NAME
+ ! epsilon_type -- a type that represents positive
+ ! powers of epsilon
+ !
+ ! SYNOPSIS
+ ! type epsilon_type
+ !
+ ! SOURCE
+ type epsilon_type
+ complex(ki) :: coefficient
+ integer :: power
+ end type epsilon_type
+ !
+ !****
+ !
+ !****t* src/module/form_factor_type/eps
+ ! NAME
+ ! eps -- singleton object of the epsilon-type.
+ !
+ ! SYNOPSIS
+ ! type(epsilon_type), parameter :: eps
+ !
+ ! SOURCE
+ type(epsilon_type), parameter :: eps = epsilon_type(1.0, 1)
+ !
+ ! EXAMPLE
+ ! type(form_factor) :: ff1 = a20((/.../))
+ ! type(form_factor) :: ff2 = eps * ff1
+ !****
+
+ !****** src/module/form_factor_type/multiplication
+ ! NAME
+ ! c * ff -- Multiplication of a form_factor with a scalar
+ !
+ ! SYNOPSIS
+ interface operator(*)
+ !****
+ module procedure mul_complex_ff
+ module procedure mul_ff_complex
+ module procedure mul_real_ff
+ module procedure mul_ff_real
+ module procedure mul_integer_ff
+ module procedure mul_ff_integer
+ module procedure mul_ff_eps
+ module procedure mul_eps_ff
+ module procedure mul_eps_eps
+ module procedure mul_eps_real
+ module procedure mul_eps_complex
+ module procedure mul_eps_integer
+ module procedure mul_real_eps
+ module procedure mul_complex_eps
+ module procedure mul_integer_eps
+ end interface
+ !
+ private :: mul_complex_ff, mul_ff_complex
+ private :: mul_real_ff, mul_ff_real
+ private :: mul_integer_ff, mul_ff_integer
+ private :: mul_ff_eps, mul_eps_ff, mul_eps_eps
+ private :: mul_eps_real, mul_real_eps
+ private :: mul_eps_complex, mul_complex_eps
+ private :: mul_eps_integer, mul_integer_eps
+ !
+ !****** src/module/form_factor_type/division
+ ! NAME
+ ! ff / c -- Division of a form_factor by a scalar
+ !
+ ! SYNOPSIS
+ interface operator(/)
+ !****
+ module procedure div_ff_complex
+ module procedure div_ff_real
+ module procedure div_ff_integer
+ end interface
+ !
+ private :: div_ff_complex, div_ff_real, div_ff_integer
+ !
+ !****** src/module/form_factor_type/sum
+ ! NAME
+ ! ff + x, + ff -- Sums involving form_factor(s)
+ !
+ ! SYNOPSIS
+ interface operator(+)
+ !****
+ module procedure add_complex_ff
+ module procedure add_ff_complex
+ module procedure add_real_ff
+ module procedure add_ff_real
+ module procedure add_integer_ff
+ module procedure add_ff_integer
+ module procedure add_ff_ff
+ module procedure plus_ff
+ end interface
+
+ private :: add_complex_ff, add_ff_complex
+ private :: add_real_ff, add_ff_real
+ private :: add_integer_ff, add_ff_integer
+ private :: add_ff_ff, plus_ff
+
+ !****** src/module/form_factor_type/subtraction
+ ! NAME
+ ! ff - x, - ff -- Subtractions involving form_factor(s)
+ !
+ ! SYNOPSIS
+ interface operator(-)
+ !****
+ module procedure sub_complex_ff
+ module procedure sub_ff_complex
+ module procedure sub_real_ff
+ module procedure sub_ff_real
+ module procedure sub_integer_ff
+ module procedure sub_ff_integer
+ module procedure sub_ff_ff
+ module procedure minus_ff
+ end interface
+
+ private :: sub_complex_ff, sub_ff_complex
+ private :: sub_real_ff, sub_ff_real
+ private :: sub_integer_ff, sub_ff_integer
+ private :: sub_ff_ff, minus_ff
+
+
+ !****** src/module/form_factor_type/assignment
+ ! NAME
+ ! ff = x -- Assignment to a form_factor
+ !
+ ! SYNOPSIS
+ interface assignment(=)
+ !
+ ! NOTES
+ ! In the assignment of a complex array the RHS must have the form
+ ! (/ a, b, c /).
+ ! In the assignment of a real array the RHS must have the form
+ ! (/ real(a), aimag(a), real(b), aimag(b), real(c), aimag(c) /).
+ ! The later form reflects the convention in the form factors of Golem90.
+ !****
+ module procedure assign_ff_complex
+ module procedure assign_ff_real
+ module procedure assign_ff_integer
+ module procedure assign_ff_complex_array3
+ module procedure assign_ff_real_array6
+ end interface
+
+ private :: assign_ff_complex, assign_ff_real, assign_ff_integer
+ private :: assign_ff_complex_array3, assign_ff_real_array6
+
+ interface operator(**)
+ module procedure pow_eps_int
+ end interface
+
+ private :: pow_eps_int
+contains
+
+ pure elemental function mul_complex_ff(x, ff) result(r)
+ !
+ complex(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ r%a = x * ff%a
+ r%b = x * ff%b
+ r%c = x * ff%c
+ !
+ end function mul_complex_ff
+ !
+ pure elemental function mul_ff_complex(ff, x) result(r)
+ !
+ complex(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ r%a = x * ff%a
+ r%b = x * ff%b
+ r%c = x * ff%c
+ !
+ end function mul_ff_complex
+ !
+ pure elemental function mul_real_ff(x, ff) result(r)
+ !
+ real(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0.0_ki, ki)
+ r%a = z * ff%a
+ r%b = z * ff%b
+ r%c = z * ff%c
+ !
+ end function mul_real_ff
+ !
+ pure elemental function mul_ff_real(ff, x) result(r)
+ !
+ real(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0.0_ki, ki)
+ r%a = z * ff%a
+ r%b = z * ff%b
+ r%c = z * ff%c
+ !
+ end function mul_ff_real
+ !
+ pure elemental function mul_integer_ff(x, ff) result(r)
+ implicit none
+ integer, intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0, ki)
+ r%a = z * ff%a
+ r%b = z * ff%b
+ r%c = z * ff%c
+ !
+ end function mul_integer_ff
+ !
+ pure elemental function mul_ff_integer(ff, x) result(r)
+ !
+ integer, intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0, ki)
+ r%a = z * ff%a
+ r%b = z * ff%b
+ r%c = z * ff%c
+ !
+ end function mul_ff_integer
+ !
+ pure elemental function pow_eps_int(eps, power) result(r)
+ !
+ type(epsilon_type), intent(in) :: eps
+ integer, intent(in) :: power
+ type(epsilon_type) :: r
+ !
+ r%coefficient = eps%coefficient ** power
+ r%power = power * eps%power
+ !
+ end function pow_eps_int
+
+ pure elemental function mul_eps_ff(x, ff) result(r)
+ !
+ type(epsilon_type), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ if (x%power >= 3) then
+ !
+ r%a = 0.0_ki
+ r%b = 0.0_ki
+ r%c = 0.0_ki
+ !
+ elseif (x%power == 2) then
+ !
+ r%a = 0.0_ki
+ r%b = 0.0_ki
+ r%c = x%coefficient * ff%a
+ !
+ else
+ !
+ r%a = 0.0_ki
+ r%b = x%coefficient * ff%a
+ r%c = x%coefficient * ff%b
+ !
+ end if
+ !
+ end function mul_eps_ff
+ !
+ pure elemental function mul_ff_eps(ff, x) result(r)
+ !
+ type(epsilon_type), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ if (x%power >= 3) then
+ !
+ r = 0.0_ki
+ !
+ elseif (X%power == 2) then
+ !
+ r%a = 0.0_ki
+ r%b = 0.0_ki
+ r%c = x%coefficient * r%a
+ !
+ else
+ !
+ r%a = 0.0_ki
+ r%b = x%coefficient * ff%a
+ r%c = x%coefficient * ff%b
+ !
+ end if
+ !
+ end function mul_ff_eps
+ !
+ pure elemental function mul_eps_eps(eps1, eps2) result(r)
+ !
+ type(epsilon_type), intent(in) :: eps1, eps2
+ type(epsilon_type) :: r
+ !
+ r%coefficient = eps1%coefficient * eps2%coefficient
+ r%power = eps1%power + eps2%power
+ !
+ end function mul_eps_eps
+ !
+ pure elemental function mul_eps_complex(eps, x) result(r)
+ !
+ type(epsilon_type), intent(in) :: eps
+ complex(ki), intent(in) :: x
+ type(epsilon_type) :: r
+ !
+ r%power = eps%power
+ r%coefficient = x * eps%coefficient
+ !
+ end function mul_eps_complex
+ !
+ pure elemental function mul_complex_eps(x, eps) result(r)
+ !
+ complex(ki), intent(in) :: x
+ type(epsilon_type), intent(in) :: eps
+ type(epsilon_type) :: r
+ !
+ r%power = eps%power
+ r%coefficient = x * eps%coefficient
+ !
+ end function mul_complex_eps
+ !
+ pure elemental function mul_eps_real(eps, x) result(r)
+ !
+ type(epsilon_type), intent(in) :: eps
+ real(ki), intent(in) :: x
+ type(epsilon_type) :: r
+ !
+ r%power = eps%power
+ r%coefficient = x * eps%coefficient
+ !
+ end function mul_eps_real
+ !
+ pure elemental function mul_real_eps(x, eps) result(r)
+ !
+ real(ki), intent(in) :: x
+ type(epsilon_type), intent(in) :: eps
+ type(epsilon_type) :: r
+ !
+ r%power = eps%power
+ r%coefficient = x * eps%coefficient
+ !
+ end function mul_real_eps
+ !
+ pure elemental function mul_eps_integer(eps, x) result(r)
+ !
+ type(epsilon_type), intent(in) :: eps
+ integer, intent(in) :: x
+ type(epsilon_type) :: r
+ !
+ r%power = eps%power
+ r%coefficient = cmplx(x, 0, ki) * eps%coefficient
+ !
+ end function mul_eps_integer
+ !
+ pure elemental function mul_integer_eps(x, eps) result(r)
+ !
+ integer, intent(in) :: x
+ type(epsilon_type), intent(in) :: eps
+ type(epsilon_type) :: r
+ !
+ r%power = eps%power
+ r%coefficient = cmplx(x, 0, ki) * eps%coefficient
+ !
+ end function mul_integer_eps
+
+ pure elemental function div_ff_complex(ff, x) result(r)
+ !
+ complex(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ r%a = ff%a / x
+ r%b = ff%b / x
+ r%c = ff%c / x
+ !
+ end function div_ff_complex
+ !
+ pure elemental function div_ff_real(ff, x) result(r)
+ !
+ real(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0.0_ki, ki)
+ r%a = ff%a / z
+ r%b = ff%b / z
+ r%c = ff%c / z
+ !
+ end function div_ff_real
+ !
+ pure elemental function div_ff_integer(ff, x) result(r)
+ !
+ integer, intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0, ki)
+ r%a = ff%a / z
+ r%b = ff%b / z
+ r%c = ff%c / z
+ !
+ end function div_ff_integer
+ !
+ pure elemental function add_complex_ff(x, ff) result(r)
+ !
+ complex(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ r%a = ff%a
+ r%b = ff%b
+ r%c = ff%c + x
+ !
+ end function add_complex_ff
+ !
+ pure elemental function add_ff_complex(ff, x) result(r)
+ !
+ complex(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ r%a = ff%a
+ r%b = ff%b
+ r%c = ff%c + x
+ !
+ end function add_ff_complex
+ !
+ pure elemental function add_real_ff(x, ff) result(r)
+ !
+ real(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0.0_ki, ki)
+ r%a = ff%a
+ r%b = ff%b
+ r%c = ff%c + z
+ !
+ end function add_real_ff
+ !
+ pure elemental function add_ff_real(ff, x) result(r)
+ !
+ real(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0.0_ki, ki)
+ r%a = ff%a
+ r%b = ff%b
+ r%c = ff%c + z
+ !
+ end function add_ff_real
+ !
+ pure elemental function add_integer_ff(x, ff) result(r)
+ !
+ integer, intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0, ki)
+ r%a = ff%a
+ r%b = ff%b
+ r%c = ff%c + z
+ !
+ end function add_integer_ff
+ !
+ pure elemental function add_ff_integer(ff, x) result(r)
+ !
+ integer, intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0, ki)
+ r%a = ff%a
+ r%b = ff%b
+ r%c = ff%c + z
+ !
+ end function add_ff_integer
+ !
+ pure elemental function add_ff_ff(x, ff) result(r)
+ !
+ type(form_factor), intent(in) :: ff, x
+ type(form_factor) :: r
+ !
+ r%a = ff%a + x%a
+ r%b = ff%b + x%b
+ r%c = ff%c + x%c
+ !
+ end function add_ff_ff
+ !
+ pure elemental function plus_ff(ff) result(r)
+ !
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ r = ff
+ !
+ end function plus_ff
+ !
+ pure elemental function sub_complex_ff(x, ff) result(r)
+ !
+ complex(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ r%a = ff%a
+ r%b = ff%b
+ r%c = x - ff%c
+ !
+ end function sub_complex_ff
+ !
+ pure elemental function sub_ff_complex(ff, x) result(r)
+ !
+ complex(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ r%a = ff%a
+ r%b = ff%b
+ r%c = ff%c - x
+ !
+ end function sub_ff_complex
+ !
+ pure elemental function sub_real_ff(x, ff) result(r)
+ !
+ real(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0.0_ki, ki)
+ r%a = ff%a
+ r%b = ff%b
+ r%c = z - ff%c
+ !
+ end function sub_real_ff
+ !
+ pure elemental function sub_ff_real(ff, x) result(r)
+ !
+ real(ki), intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0.0_ki, ki)
+ r%a = ff%a
+ r%b = ff%b
+ r%c = ff%c - z
+ !
+ end function sub_ff_real
+ !
+ pure elemental function sub_integer_ff(x, ff) result(r)
+ !
+ integer, intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0, ki)
+ r%a = ff%a
+ r%b = ff%b
+ r%c = z - ff%c
+ !
+ end function sub_integer_ff
+ !
+ pure elemental function sub_ff_integer(ff, x) result(r)
+ !
+ integer, intent(in) :: x
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ complex(ki) :: z
+ !
+ z = cmplx(x, 0, ki)
+ r%a = ff%a
+ r%b = ff%b
+ r%c = ff%c - z
+ !
+ end function sub_ff_integer
+ !
+ pure elemental function sub_ff_ff(ff, x) result(r)
+ !
+ type(form_factor), intent(in) :: ff, x
+ type(form_factor) :: r
+ !
+ r%a = ff%a - x%a
+ r%b = ff%b - x%b
+ r%c = ff%c - x%c
+ !
+ end function sub_ff_ff
+ !
+ pure elemental function minus_ff(ff) result(r)
+ !
+ type(form_factor), intent(in) :: ff
+ type(form_factor) :: r
+ !
+ r%a = -ff%a
+ r%b = -ff%b
+ r%c = -ff%c
+ !
+ end function minus_ff
+ !
+ !~ pure elemental subroutine assign_ff_complex(ff, x)
+ pure subroutine assign_ff_complex(ff, x)
+ !
+ type(form_factor), intent(out) :: ff
+ complex(ki), intent(in) :: x
+ !
+ ff%a = (0.0_ki, 0.0_ki)
+ ff%b = (0.0_ki, 0.0_ki)
+ ff%c = x
+ !
+ end subroutine assign_ff_complex
+ !
+ !~ pure elemental subroutine assign_ff_real(ff, x)
+ pure subroutine assign_ff_real(ff, x)
+ !
+ type(form_factor), intent(out) :: ff
+ real(ki), intent(in) :: x
+ !
+ ff%a = (0.0_ki, 0.0_ki)
+ ff%b = (0.0_ki, 0.0_ki)
+ ff%c = cmplx(x, 0.0_ki, ki)
+ !
+ end subroutine assign_ff_real
+ !
+ !~ pure elemental subroutine assign_ff_integer(ff, x)
+ pure subroutine assign_ff_integer(ff, x)
+ !
+ type(form_factor), intent(out) :: ff
+ integer, intent(in) :: x
+ !
+ ff%a = (0.0_ki, 0.0_ki)
+ ff%b = (0.0_ki, 0.0_ki)
+ ff%c = cmplx(x, 0, ki)
+ !
+ end subroutine assign_ff_integer
+ !
+ pure subroutine assign_ff_complex_array3(ff, x)
+ !
+ type(form_factor), intent(out) :: ff
+ complex(ki), dimension(1:3), intent(in) :: x
+ !
+ ff%a = x(1)
+ ff%b = x(2)
+ ff%c = x(3)
+ !
+ end subroutine assign_ff_complex_array3
+ !
+ pure subroutine assign_ff_real_array6(ff, x)
+ !
+ type(form_factor), intent(out) :: ff
+ real(ki), dimension(1:6), intent(in) :: x
+ !
+ ff%a = x(1) + i_ * x(2)
+ ff%b = x(3) + i_ * x(4)
+ ff%c = x(5) + i_ * x(6)
+ !
+ end subroutine assign_ff_real_array6
+ !
+end module form_factor_type
diff --git a/golem95c-1.2.1/module/kronecker.f90 b/golem95c-1.2.1/module/kronecker.f90
new file mode 100644
index 0000000..649f8ac
--- /dev/null
+++ b/golem95c-1.2.1/module/kronecker.f90
@@ -0,0 +1,135 @@
+!
+!****h* src/module/kronecker
+! NAME
+!
+! Module kronecker
+!
+! USAGE
+!
+! use kronecker
+!
+! DESCRIPTION
+!
+! This module contains two functions delta and deltab which correspond
+! respectively to the Kronecker symbol \delta_{ij}
+! and 1-\delta_{ij}. These two functions have two integer arguments and
+! return an integer
+!
+! OUTPUT
+!
+! This module exports two functions:
+! * delta -- the Kronecker symbol
+! * deltab -- 1-delta
+!
+! USES
+!
+! No uses
+!
+!*****
+module kronecker
+ !
+ implicit none
+ !
+ contains
+ !
+ !****f* src/module/kronecker/delta
+ ! NAME
+ !
+ ! Function delta
+ !
+ ! USAGE
+ !
+ ! integer = delta(i,j)
+ !
+ ! DESCRIPTION
+ !
+ ! This is the Kronecker symbol \delta_{ij}
+ !
+ ! INPUTS
+ !
+ ! * i -- an integer
+ ! * j -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an integer 0 or 1
+ !
+ ! EXAMPLE
+ !
+ ! k = delta(2,3) --> k = 0
+ ! k = delta(3,3) --> k = 1
+ !
+ !*****
+ function delta(i,j)
+ !
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer :: delta
+ !
+ if (i == j) then
+ !
+ delta = 1
+ !
+ else
+ !
+ delta = 0
+ !
+ end if
+ !
+ end function delta
+ !
+ !****f* src/module/kronecker/deltab
+ ! NAME
+ !
+ ! Function deltab
+ !
+ ! USAGE
+ !
+ ! integer = deltab(i,j)
+ !
+ ! DESCRIPTION
+ !
+ ! This is one minus the Kronecker symbol, 1-\delta_{ij}
+ !
+ ! INPUTS
+ !
+ ! * i -- an integer
+ ! * j -- an integer
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It returns an integer 0 or 1
+ !
+ ! EXAMPLE
+ !
+ ! k = deltab(2,3) --> k = 1
+ ! k = deltab(3,3) --> k = 0
+ !
+ !*****
+ function deltab(i,j)
+ !
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer :: deltab
+ !
+ if (i == j) then
+ !
+ deltab = 0
+ !
+ else
+ !
+ deltab = 1
+ !
+ end if
+ !
+ end function deltab
+ !
+end module kronecker
diff --git a/golem95c-1.2.1/module/multiply_div.f90 b/golem95c-1.2.1/module/multiply_div.f90
new file mode 100644
index 0000000..827eca8
--- /dev/null
+++ b/golem95c-1.2.1/module/multiply_div.f90
@@ -0,0 +1,155 @@
+!
+!****h* src/module/multiply_div
+! NAME
+!
+! Module multiply_div
+!
+! USAGE
+!
+! use multiply_div
+!
+! DESCRIPTION
+!
+! This module contains the function mult_div, This function computes
+! numericaly (1+alpha*epsilon)*(A/epsilon+B). The type of the output array is
+! identical to the type of the input array.
+!
+! OUTPUT
+!
+! This module exports the function mult_div
+!
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+!
+!*****
+!
+module multiply_div
+ !
+ use precision_golem
+ !
+ implicit none
+ !
+ private
+ !
+ interface mult_div
+ !
+ module procedure mult_div_r
+ module procedure mult_div_c
+ !
+ end interface
+ !
+ public :: mult_div
+ !
+ contains
+ !
+ !****f* src/module/multiply_div/mult_div_r
+ ! NAME
+ !
+ ! Function mult_div_r
+ !
+ ! USAGE
+ !
+ ! real_dim4 = mult_div_r(alpha,array)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes numericaly (1+alpha*epsilon)*(A/epsilon+B)
+ ! with A = a1 + i*a2 and B = b1 + i*b2. The returned result is put
+ ! into an array t (rank 1, shape 4) where t(1) = a1, t(2) = a2,
+ ! t(3) = b1+alpha*a1, t(4) = b2+alpha*a2.
+ !
+ ! INPUTS
+ !
+ ! * alpha -- a real (type ki)
+ ! * array -- a real (type ki) array of rank 1, shape 4
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! a real (type ki) array of rank 1 and shape 4
+ !
+ ! NOTES
+ !
+ ! The return value of this function is a real array of shape 4,
+ ! contrary to the complex array returned by mult_div_c.
+ !
+ ! EXAMPLE
+ !
+ ! resu = multipy_div_r(alpha,array)
+ ! resu(1) = array(1)
+ ! resu(2) = array(2)
+ ! resu(3) = array(3) + alpha*array(1)
+ ! resu(4) = array(4) + alpha*array(2)
+ !
+ !*****
+ function mult_div_r(alpha,array)
+ !
+ real(ki), intent(in) :: alpha
+ real(ki), intent(in), dimension(4) :: array
+ real(ki), dimension(4) :: mult_div_r
+ !
+ mult_div_r = array
+ mult_div_r(3) = mult_div_r(3) + alpha*array(1)
+ mult_div_r(4) = mult_div_r(4) + alpha*array(2)
+ !
+ end function mult_div_r
+ !
+ !
+ !****f* src/module/multiply_div/mult_div_c
+ ! NAME
+ !
+ ! Function mult_div_c
+ !
+ ! USAGE
+ !
+ ! cmplx_dim2 = mult_div_c(alpha,array)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes numericaly (1+alpha*epsilon)*(A/epsilon+B)
+ ! with A and B complex. The returned result is put
+ ! into an complex array t (rank 1, shape 2) where t(1) = A,
+ ! t(2) = B + alpha*A.
+ !
+ ! INPUTS
+ !
+ ! * alpha -- a real (type ki)
+ ! * array -- a complex (type ki) array of rank 1, shape 2
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! a complex (type ki) array of rank 1 and shape 2
+ !
+ ! NOTES
+ !
+ ! The return value of this function is a complex array of shape 2,
+ ! contrary to the real array returned by mult_div_r.
+ !
+ ! EXAMPLE
+ !
+ ! resu = multipy_div_c(alpha,array)
+ ! resu(1) = array(1)
+ ! resu(2) = array(2) + alpha*array(1)
+ !
+ !*****
+ function mult_div_c(alpha,array)
+ !
+ real(ki), intent(in) :: alpha
+ complex(ki), intent(in), dimension(2) :: array
+ complex(ki), dimension(2) :: mult_div_c
+ !
+ mult_div_c = array
+ mult_div_c(2) = mult_div_c(2) + alpha*array(1)
+ !
+ end function mult_div_c
+ !
+end module multiply_div
diff --git a/golem95c-1.2.1/module/parametre.f90 b/golem95c-1.2.1/module/parametre.f90
new file mode 100644
index 0000000..6585c83
--- /dev/null
+++ b/golem95c-1.2.1/module/parametre.f90
@@ -0,0 +1,274 @@
+!
+!****h* src/module/parametre
+! NAME
+!
+! Module parametre
+!
+! USAGE
+!
+! use parametre
+!
+! DESCRIPTION
+!
+! This module is used to pass some variables used by many functions of
+! the GOLEM program. Note that these variables can be rewritten.
+! It contains also a routine to print the parameters (it prints on unit 6)
+!
+! OUTPUT
+!
+! It exports the variables:
+! * tolerance -- a real (type ki), the tolerance for the numerical integration
+! * lambda_par -- a real (type ki), a parameter of the contour deformation
+! * alpha_par -- a real (type ki), a parameter of the contour deformation
+! * beta_par -- a real (type ki), a parameter of the contour deformation
+! * coupure_3p2m -- a real (type ki), a cut between numerical and analytical
+! computation for two mass three point functions
+! * coupure_3p3m -- a real (type ki), a cut between numerical and analytical
+! computation for three mass three point functions
+! * coupure_4p1m -- a real (type ki), a cut between numerical and analytical
+! computation for one mass four point functions
+! * coupure_4p2m_opp -- a real (type ki), a cut between numerical and analytical
+! computation for two mass opposite four point functions
+! * coupure_4p2m_adj -- a real (type ki), a cut between numerical and analytical
+! computation for two mass adjacent four point functions
+! * coupure_4p3m -- a real (type ki), a cut between numerical and analytical
+! computation for three mass four point functions
+! * coupure_4p4m -- a real (type ki), a cut between numerical and analytical
+! computation for four mass four point functions (not active)
+! * coupure_3p2m_1mi -- a real (type ki), a cut between numerical and analytical
+! computation for one internal mass two external mass three point functions
+! * rat_or_tot_par -- a character (len=3)
+! * rmass_or_cmass_par -- a character (len=5)
+! * if_print_info_par -- a logical, if true it prints some informations concerning the numerical
+! integration
+! * if_print_warn_par -- a logical, if true it prints some informations concerning the warning
+! about numerical precision
+! * accuracy_par -- the accuracy for the matrix inversion and the numerical integration
+! * not_enough_accuracy_par -- a flag to ring the bell if the accuracy is not reached in
+! in the matrix inversion and the numerical integration
+! * mu2_scale_par -- the square of the renormalisation scale
+! * subroutine print_parameter -- to print these variables
+! * withlt -- flag to use LoopTools instead of avh_olo for finite D0,C0
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+!
+!*****
+module parametre
+ !
+ use precision_golem
+ implicit none
+ !
+ ! here everything is public except what has been defined explicitly as private
+ private :: ki
+ !
+ type rat_or_tot_string
+ character(len=3) :: image
+ logical :: rat_selected
+ logical :: tot_selected
+ end type rat_or_tot_string
+ !
+ type rmass_or_cmass_string
+ character(len=5) :: image
+ logical :: rmass_selected
+ logical :: cmass_selected
+ end type rmass_or_cmass_string
+ !
+ !
+ real(ki),save :: tolerance = 1.e-8_ki ! precision for Gaussian integration
+ !
+ real(ki),save :: lambda_par = 1._ki ! parameters of the contour
+ real(ki),save :: alpha_par = 1._ki ! deformation
+ real(ki),save :: beta_par = 1._ki !
+ !
+ real(ki),save :: coupure_3p1m_2mi = 5.e-3_ki ! value to switch between analytical and numerical
+ ! evaluation for one mass three point functions (mod_gn)
+ real(ki),save :: coupure_3p2m = 5.e-3_ki ! value to switch between analytical and numerical
+ ! evaluation for two mass three point functions
+ real(ki),save :: coupure_3p3m = 5.e-3_ki ! value to switch between analytical and numerical
+ ! evaluation for three mass three point functions
+ real(ki),save :: coupure_4p1m = 5.e-3_ki ! value to switch between analytical and numerical
+ ! evaluation for one/zero mass four point functions
+ real(ki),save :: coupure_4p2m_opp = 5.e-3_ki ! value to switch between analytical and numerical
+ ! evaluation for two opposite mass four point functions
+ real(ki),save :: coupure_4p2m_adj = 5.e-3_ki! value to switch between analytical and numerical
+ ! evaluation for two adjacent mass four point functions
+ real(ki),save :: coupure_4p3m = 5.e-3_ki ! value to switch between analytical and numerical
+ ! evaluation for three mass four point functions
+ real(ki),save :: coupure_4p4m = 0._ki ! value to switch between analytical and numerical
+ ! evaluation for four mass four point functions
+ real(ki),save :: coupure_3p2m_1mi = 5.e-3_ki ! value to switch between analytical and numerical
+ ! evaluation for one internal mass two external mass three point functions
+ real(ki),save :: cut_s_abs = 10._ki*epsilon(1._ki)
+ real(ki),save :: cut_s_over_m = 1000000._ki*epsilon(1._ki)
+
+ type(rat_or_tot_string),parameter :: tot = rat_or_tot_string('tot', .false., .true.)
+ type(rat_or_tot_string),parameter :: rat = rat_or_tot_string('rat', .true., .false.)
+
+ type(rat_or_tot_string),save :: rat_or_tot_par = tot
+ !type(rat_or_tot_string),save :: rat_or_tot_par = rat
+
+
+ type(rmass_or_cmass_string),parameter :: rmass = rmass_or_cmass_string('rmass', .true., .false.)
+ type(rmass_or_cmass_string),parameter :: cmass = rmass_or_cmass_string('cmass', .false., .true.)
+
+ type(rmass_or_cmass_string),save :: rmass_or_cmass_par = cmass
+
+ logical, save :: if_print_info_par = .false. ! if true print information
+ logical, save :: if_print_warn_par = .false. ! if true print information for warning
+ real(ki),save :: accuracy_par = 1.e-10_ki ! the accuracy for the matrix inversion and the numerical integration
+ logical, save :: not_enough_accuracy_par = .false. !
+ real(ki), save :: mu2_scale_par = 1._ki ! the square of the renormalisation scale
+ logical, save :: olo = .false. ! flag set to true as soon as avh_olo has been called once
+ ! added to include LT option Jan2011
+ logical, save :: withlt = .false.
+
+ interface assignment(=)
+ module procedure assign_rat_or_tot_string
+ end interface
+
+ interface operator(==)
+ module procedure equals_rat_or_tot_string
+ module procedure equals_rat_or_tot_string_revd
+ end interface
+
+ private :: assign_rat_or_tot_string
+ private :: equals_rat_or_tot_string
+ private :: equals_rat_or_tot_string_revd
+
+ interface assignment(=)
+ module procedure assign_rmass_or_cmass_string
+ end interface
+
+ interface operator(==)
+ module procedure equals_rmass_or_cmass_string
+ module procedure equals_rmass_or_cmass_string_r
+ end interface
+
+ private :: assign_rmass_or_cmass_string
+ private :: equals_rmass_or_cmass_string
+ private :: equals_rmass_or_cmass_string_r
+
+ contains
+ !
+ pure subroutine assign_rat_or_tot_string(rot, ch)
+ implicit none
+ type(rat_or_tot_string), intent(out) :: rot
+ character(len=3), intent(in) :: ch
+
+ rot%image = ch
+ rot%rat_selected = ch .eq. 'rat'
+ rot%tot_selected = ch .eq. 'tot'
+ end subroutine assign_rat_or_tot_string
+ !
+ pure function equals_rat_or_tot_string(rot, ch) result(test)
+ implicit none
+ type(rat_or_tot_string), intent(in) :: rot
+ character(len=3), intent(in) :: ch
+ logical :: test
+
+ test = rot%image .eq. ch
+ end function equals_rat_or_tot_string
+ !
+ pure function equals_rat_or_tot_string_revd(ch, rot) result(test)
+ implicit none
+ character(len=3), intent(in) :: ch
+ type(rat_or_tot_string), intent(in) :: rot
+ logical :: test
+
+ test = rot%image .eq. ch
+ end function equals_rat_or_tot_string_revd
+ !
+ !
+ pure subroutine assign_rmass_or_cmass_string(roc, ch)
+ implicit none
+ type(rmass_or_cmass_string), intent(out) :: roc
+ character(len=5), intent(in) :: ch
+
+ roc%image = ch
+ roc%rmass_selected = ch .eq. 'rmass'
+ roc%cmass_selected = ch .eq. 'cmass'
+ end subroutine assign_rmass_or_cmass_string
+ !
+ pure function equals_rmass_or_cmass_string(roc, ch) result(test)
+ implicit none
+ type(rmass_or_cmass_string), intent(in) :: roc
+ character(len=5), intent(in) :: ch
+ logical :: test
+
+ test = roc%image .eq. ch
+ end function equals_rmass_or_cmass_string
+ !
+ pure function equals_rmass_or_cmass_string_r(ch, roc) result(test)
+ implicit none
+ character(len=5), intent(in) :: ch
+ type(rmass_or_cmass_string), intent(in) :: roc
+ logical :: test
+
+ test = roc%image .eq. ch
+ end function equals_rmass_or_cmass_string_r
+ !
+ !
+ !****f* src/module/print_parameter
+ ! NAME
+ !
+ ! Subroutine print_parameter
+ !
+ ! USAGE
+ !
+ ! call print_parameter()
+ !
+ ! DESCRIPTION
+ !
+ ! This routine print the variables defined in the module parametre
+ !
+ ! INPUTS
+ !
+ ! No inputs
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! It prints on the unit 6
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine print_parameter()
+ !
+ integer :: unit
+ !
+ unit = 6
+ !
+ write(unit,*) 'tolerance :',tolerance
+ write(unit,*) 'lambda_par :',lambda_par
+ write(unit,*) 'alpha_par :',alpha_par
+ write(unit,*) 'beta_par :',beta_par
+ write(unit,*) 'coupure_3p2m :',coupure_3p2m
+ write(unit,*) 'coupure_3p3m :',coupure_3p3m
+ write(unit,*) 'coupure_4p1m :',coupure_4p1m
+ write(unit,*) 'coupure_4p2m_opp :',coupure_4p2m_opp
+ write(unit,*) 'coupure_4p2m_adj :',coupure_4p2m_adj
+ write(unit,*) 'coupure_4p3m :',coupure_4p3m
+ write(unit,*) 'coupure_4p4m :',coupure_4p4m
+ write(unit,*) 'rat_or_tot_par : ',rat_or_tot_par
+ write(unit,*) 'rmass_or_cmass : ',rmass_or_cmass_par
+ write(unit,*) 'if_print_info_par : ',if_print_info_par
+ write(unit,*) 'if_print_warn_par : ',if_print_warn_par
+ write(unit,*) 'accuracy_par : ',accuracy_par
+ write(unit,*) 'not_enough_accuracy_par : ',not_enough_accuracy_par
+ write(unit,*) 'mu2_scale_par : ',mu2_scale_par
+ write(unit,*) 'accuracy_par : ',accuracy_par
+ write(unit,*) 'not_enough_accuracy_par : ',not_enough_accuracy_par
+ write(unit,*) 'mu2_scale_par : ',mu2_scale_par
+ write(unit,*) 'olo : ',olo
+ !
+ end subroutine print_parameter
+ !
+end module parametre
diff --git a/golem95c-1.2.1/module/precision_golem.f90.in b/golem95c-1.2.1/module/precision_golem.f90.in
new file mode 100644
index 0000000..bcf2c20
--- /dev/null
+++ b/golem95c-1.2.1/module/precision_golem.f90.in
@@ -0,0 +1,34 @@
+!
+!****h* src/module/precision_golem
+! NAME
+!
+! Module precision_golem
+!
+! USAGE
+!
+! use precision_golem
+!
+! DESCRIPTION
+!
+! This module defines the parameter ki which gives the representation
+! of the real and complex numbers in golem
+!
+! OUTPUT
+!
+! The integer parameter ki
+! The integer parameter ki_avh, which is the real kind used in avh_olo
+! The integer parameter ki_lt, which is the real kind used in LoopTools
+!
+! USES
+!
+! No uses
+!
+!*****
+module precision_golem
+ !
+ integer, parameter :: ki=@fortran_real_kind@
+@case_with_lt@integer, parameter :: ki_lt=@lt_real_kind@
+ integer, parameter :: ki_avh=kind(1.0d0)
+ !
+end module precision_golem
+
diff --git a/golem95c-1.2.1/module/s_matrix_type.f90 b/golem95c-1.2.1/module/s_matrix_type.f90
new file mode 100644
index 0000000..54ad212
--- /dev/null
+++ b/golem95c-1.2.1/module/s_matrix_type.f90
@@ -0,0 +1,297 @@
+!
+!****h* src/module/s_matrix_type
+! NAME
+!
+! Module s_matrix_type
+!
+! USAGE
+!
+! use s_matrix_type
+!
+! DESCRIPTION
+!
+! This module contains a type definition for the kinematic s_matrix,
+! intended to mimic a run-time polymorphism.
+!
+! OUTPUT
+!
+! This module exports the derived type:
+! * s_matrix_poly
+!
+! One function:
+! * assign_s_matrix -- associates the pointers in the s_matrix to a given real or complex matrix
+!
+! Subroutines:
+! * nullify_s_matrix -- nullifies the pointers
+! * set_s_matrix_bits -- sets an integer which describes the positions of complex masses in the s matrix.
+! sets an integer which describes the positions of zero mass entries.
+! * fill_s_matrix -- fills the real array associated with a complex array.
+!
+! USES
+!
+! * precision_golem (src/module/preci_double.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * equal (src/module/equal.f90)
+! * constante (src/module/constante.f90)
+!
+!*****
+module s_matrix_type
+ !
+ use precision_golem, only: ki
+ use sortie_erreur
+ use equal
+ use constante, only : zero
+ !
+ implicit none
+ !
+ !
+ !****t* src/module/s_matrix_type/s_matrix_poly
+ ! NAME
+ ! s_matrix_poly
+ !
+ ! SYNOPSIS
+ ! type s_matrix_poly
+ !
+ ! SOURCE
+ type s_matrix_poly
+ !
+ real(ki), dimension(:,:), pointer :: pt_real
+ complex(ki), dimension(:,:), pointer :: pt_cmplx
+ integer :: b_cmplx, b_zero
+ !
+ end type s_matrix_poly
+ !
+ ! NOTES
+ ! * pt_real points to a real array (s_mat_r) if associated.
+ ! * pt_cmplx points to a complex array (s_mat_c) if associated
+ ! * b_cmplx is a bit-integer encoding the positions of
+ ! complex mass entries in the S matrix.
+ ! * b_zero is a bit-integer encoding the positions of
+ ! vanishing masses.
+ !
+ !****
+ !
+ interface assign_s_matrix
+ !
+ module procedure assign_s_matrix_r
+ module procedure assign_s_matrix_c
+ !
+ end interface
+ !
+ !
+ private
+ !
+ !
+ public :: assign_s_matrix, set_s_matrix_bits, nullify_s_matrix, fill_s_matrix,s_matrix_poly
+ !
+ !
+contains
+ !
+ !
+ !
+ !****f* src/module/s_matrix_type/assign_s_matrix
+ ! NAME
+ !
+ ! assign_s_matrix
+ !
+ ! USAGE
+ !
+ ! assign_s_matrix(s_mat_r)
+ ! assign_s_matrix(s_mat_c,s_mat_r)
+ !
+ ! DESCRIPTION
+ !
+ ! This function associates the global (type s_matrix_poly) s_mat_p
+ ! with the given real or complex input matrix. In the case a complex
+ ! matrix is given, a real matrix, which will contain the real part of the
+ ! complex matrix, has also be given as an argument.
+ !
+ ! INPUTS
+ !
+ ! A real and a complex matrix. Or just a real matrix.
+ !
+ !
+ ! RETURN VALUE
+ !
+ ! a type (s_matrix_poly) is returned.
+ !
+ !
+ !*****
+ !
+ function assign_s_matrix_r(s_mat_r) result (s_mat_p)
+ real(ki), dimension(:,:), target, intent(in) :: s_mat_r
+ type(s_matrix_poly) :: s_mat_p
+ !
+ s_mat_p%pt_real => s_mat_r
+ nullify(s_mat_p%pt_cmplx)
+ s_mat_p%b_cmplx = 0
+ s_mat_p%b_zero = -1
+ !
+ end function assign_s_matrix_r
+ !
+ !
+ function assign_s_matrix_c(s_mat_c, s_mat_r) result (s_mat_p)
+ complex(ki), dimension(:,:), target, intent(in) :: s_mat_c
+ real(ki), dimension(:,:), target, intent(in) :: s_mat_r
+ type(s_matrix_poly) :: s_mat_p
+ !
+ s_mat_p%pt_cmplx => s_mat_c
+ s_mat_p%pt_real => s_mat_r
+ s_mat_p%b_cmplx = -1
+ s_mat_p%b_zero = -1
+ !
+ end function assign_s_matrix_c
+ !
+ !****f* src/module/s_matrix_type/fill_s_matrix
+ ! NAME
+ !
+ ! Subroutine fill_s_matrix
+ !
+ ! USAGE
+ !
+ ! call fill_s_matrix(s_mat_p)
+ !
+ ! DESCRIPTION
+ !
+ ! This procedure fills the associated real array with the
+ ! real entries of a complex s_matrix if the corresponding
+ ! pointer to the complex array is associated.
+ !
+ ! INPUTS
+ !
+ ! * a type (s_matrix_poly) object
+ !
+ ! RETURN VALUE
+ !
+ ! none
+ !
+ !
+ !*****
+ !
+ subroutine fill_s_matrix(s_mat_p)
+ type(s_matrix_poly) :: s_mat_p
+ !
+ if (associated(s_mat_p%pt_cmplx) ) then
+ !
+ s_mat_p%pt_real = real(s_mat_p%pt_cmplx,ki)
+ !
+ end if
+ !
+ end subroutine fill_s_matrix
+ !
+ !****f* src/module/s_matrix_type/set_s_matrix_bits
+ ! NAME
+ !
+ ! Subroutine set_s_matrix_bits
+ !
+ ! USAGE
+ !
+ ! call set_s_matrix_bits(s_mat_p,set_ref)
+ !
+ ! DESCRIPTION
+ !
+ ! This procedure checks the diagonal of the given matrix for complex
+ ! entries with non-vanishing imaginary part and vanishing masses as well.
+ ! The results are encoded in bit-integers included in the derived type s_mat_p.
+ !
+ ! INPUTS
+ !
+ ! * a type (s_matrix_poly) object
+ ! * a reference set of numbers associated with the diagonal entries.
+ ! (typically an array (/1,2,...,n/) ).
+ !
+ ! RETURN VALUE
+ !
+ ! none
+ !
+ !
+ !*****
+ !
+ subroutine set_s_matrix_bits(s_mat_poly,set_ref)
+ type(s_matrix_poly), intent (inout) :: s_mat_poly
+ integer, intent(in), dimension(:) :: set_ref
+ integer, dimension(size(set_ref)) :: position_c, position_r
+ complex(ki), dimension(size(set_ref)) :: diagonal
+ real(ki), dimension(size(set_ref)) :: diag_imag, diag_real
+ integer :: i,n
+ !
+ n = size(set_ref)
+ position_c = 0
+ position_r = 0
+ !
+ if (associated(s_mat_poly%pt_cmplx)) then
+ !
+ do i = 1, n
+ diagonal(i) = s_mat_poly%pt_cmplx(i,i)
+ end do
+ !
+ diag_imag = aimag(diagonal)
+ !
+ if (minval(diag_imag) .lt. 0._ki) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine set_s_matrix_bits:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The S matrix contains masses with positive imaginary part!'
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'This might lead to wrong results!'
+ call catch_exception(1)
+ !
+ end if
+ !
+ where (diag_imag .gt. 2.0_ki*epsilon(1.0_ki)) position_c = set_ref
+ ! twice epsilon to give consistency with for rounding-error size imaginary parts
+ where (position_c .ne. 0) position_c = ibset(0,pos=position_c)
+ s_mat_poly%b_cmplx = sum (position_c)
+ end if
+ !
+ do i = 1, n
+ diag_real(i) = s_mat_poly%pt_real(i,i)
+ end do
+ !
+ where ( (position_c == 0) .and. (equal_real(diag_real,zero) ) ) position_r = set_ref
+ !
+ where (position_r .ne. 0) position_r = ibset(0,pos=position_r)
+ s_mat_poly%b_zero = sum (position_r)
+ !
+ end subroutine set_s_matrix_bits
+ !
+ !
+ !****f* src/module/s_matrix_type/nullify_s_matrix
+ ! NAME
+ !
+ ! Subroutine nullify_s_matrix
+ !
+ ! USAGE
+ !
+ ! nullify_s_matrix(s_mat_p)
+ !
+ ! DESCRIPTION
+ !
+ ! This procedure nullifies the pointers in the input object.
+ !
+ ! INPUTS
+ !
+ ! * type (s_matrix_poly) object
+ !
+ ! RETURN VALUE
+ !
+ ! none
+ !
+ !
+ !*****
+ !
+ subroutine nullify_s_matrix(s_mat_p)
+ type(s_matrix_poly) :: s_mat_p
+ !
+ if (associated(s_mat_p%pt_real)) then
+ nullify(s_mat_p%pt_real)
+ end if
+ !
+ if (associated(s_mat_p%pt_cmplx)) then
+ nullify(s_mat_p%pt_cmplx)
+ end if
+ !
+ end subroutine nullify_s_matrix
+ !
+end module s_matrix_type
diff --git a/golem95c-1.2.1/module/sortie_erreur.f90 b/golem95c-1.2.1/module/sortie_erreur.f90
new file mode 100644
index 0000000..e9aefa7
--- /dev/null
+++ b/golem95c-1.2.1/module/sortie_erreur.f90
@@ -0,0 +1,284 @@
+!****h* src/module/sortie_erreur
+! NAME
+!
+! Module sortie_erreur
+!
+! USAGE
+!
+! use sortie_erreur
+!
+! DESCRIPTION
+!
+! This module is used to generate error exception or to print some information from
+! a function/subroutine
+!
+! OUTPUT
+!
+! This module exports:
+! * erreur -- derived type
+! * tab_erreur_par -- an array of 7 derived type erreur
+! * catch_exception -- a subroutine to perform an action depending on the level
+! * print_type -- a subroutine to print the type erreur
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+! * parametre (src/module/parametre.f90)
+! * array (src/module/array.f90)
+!
+!*****
+module sortie_erreur
+ !
+ use precision_golem
+ use parametre, only : if_print_info_par,if_print_warn_par,not_enough_accuracy_par
+ use array, only : unpackb
+ implicit none
+ !
+ private
+ !
+ !****t* src/module/sortie_erreur/erreur
+ ! NAME
+ !
+ ! erreur -- derived type, to print error/info
+ !
+ ! SYNOPSIS
+ !
+ ! type erreur
+ !
+ ! SOURCE
+ !
+ type erreur
+ !
+ character(len=256) :: chaine
+ logical :: a_imprimer = .false.
+ integer :: arg_int
+ real(ki) :: arg_real
+ complex(ki) :: arg_comp
+ character(len=32) :: arg_char
+ integer, dimension(2) :: arg_int_tab
+ !
+ end type erreur
+ !
+ ! NOTES
+ !
+ ! * set erreur%a_imprimer = .true. to print it
+ ! * arg_in_tab(1) : packb(tab), arg_int_tab(2) : size(tab)
+ !
+ !****
+ !
+ integer :: max_err = 7
+ !
+ ! an array of 7 derived type is reserved
+ !
+ type(erreur), dimension(7), save :: tab_erreur_par
+ character (len=132),save :: origine_info_par = "" ! the type of function which are integrated
+ real(ki),save :: num_grand_b_info_par = 0._ki ! the numerator of B
+ real(ki),save :: denom_grand_b_info_par = 0._ki ! the denominator of B
+ character (len=22),save :: origine_inv_info_par = "" ! the size of the matrix to inverse
+ !
+ public :: erreur,tab_erreur_par,catch_exception
+ public :: origine_info_par,num_grand_b_info_par,denom_grand_b_info_par
+ public :: origine_inv_info_par
+ !
+ contains
+ !
+ !****f* src/module/sortie_erreur/catch_exception
+ ! NAME
+ !
+ ! Subroutine catch_exception
+ !
+ ! USAGE
+ !
+ ! call catch_exception(level)
+ !
+ ! DESCRIPTION
+ !
+ ! For the error exception
+ ! This routine prints on the unit 0 (stderr for fortran)
+ ! the array tab_erreur_par
+ !
+ ! INPUTS
+ !
+ ! * level -- a integer : 0 the program stops, 1 warning, 2 info
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! write on the unit 0 (stderr for fortran) : level=0,1
+ ! or write on the unit 12 : level=2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine catch_exception(level)
+ !
+ integer, intent(in) :: level
+ !
+ integer :: unit
+ integer :: i
+ !
+ select case(level)
+ !
+ case(0)
+ !
+ unit = 0
+ !
+ write(unit,*) '+++++++++++++++ERROR+++++++++++++++++++++++'
+ write(unit,*) 'The program stops because'
+ !
+ do i=1,max_err
+ !
+ if (tab_erreur_par(i)%a_imprimer) call print_type(unit,tab_erreur_par(i))
+ !
+ end do
+ !
+ stop
+ !
+ case(1)
+ !
+ unit = 0
+ !
+ if (if_print_warn_par) then
+ !
+ write(unit,*) '+++++++++++++++WARNING+++++++++++++++++++++++'
+ !
+ do i=1,max_err
+ !
+ if (tab_erreur_par(i)%a_imprimer) then
+ call print_type(unit,tab_erreur_par(i))
+ tab_erreur_par(i)%a_imprimer = .false.
+ end if
+ !
+ end do
+ write(unit,*) 'Type of Feynman integrals :',trim(origine_info_par)
+ write(unit,*) 'Numerator of B :',num_grand_b_info_par
+ write(unit,*) 'Denominator of B :',denom_grand_b_info_par
+ write(unit,*) 'Type of matrix :',trim(origine_inv_info_par)
+ !
+ end if
+ !
+ not_enough_accuracy_par = .true.
+ !
+ case(2)
+ !
+ if (if_print_info_par) then
+ !
+ unit = 12
+ !
+ write(unit,*) '+++++++++++++++++INFO++++++++++++++++++++++'
+ !
+ do i=1,max_err
+ !
+ if (tab_erreur_par(i)%a_imprimer) then
+ call print_type(unit,tab_erreur_par(i))
+ tab_erreur_par(i)%a_imprimer = .false.
+ end if
+ !
+ end do
+ !
+ else
+ !
+ do i=1,max_err
+ !
+ tab_erreur_par(i)%a_imprimer = .false.
+ !
+ end do
+ !
+ end if
+ !
+ case default
+ !
+ unit = 0
+ !
+ write(unit,*) 'The level argument of the routine catch_exception must be less or equal than 2'
+ write(unit,*) 'this argument is :',level
+ !
+ stop
+ !
+ end select
+ !
+ end subroutine catch_exception
+ !
+ !****if* src/module/sortie_erreur/print_type
+ ! NAME
+ !
+ ! Subroutine print_type
+ !
+ ! USAGE
+ !
+ ! call print_type(unit,type_err)
+ !
+ ! DESCRIPTION
+ !
+ ! For the error exception
+ ! This routine prints on the unit 0 (stderr for fortran)
+ ! a string of characters and an integer/real/complex/string of
+ ! characters or an array of integers/reals
+ !
+ ! INPUTS
+ !
+ ! * unit -- an integer, the unit where to print
+ ! * type_err -- type(erreur), the derived type which will printed
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! write on the unit unit
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine print_type(unit,type_err)
+ !
+ integer, intent(in) :: unit
+ type(erreur), intent(in) :: type_err
+ !
+ integer :: i
+ character(len=3), dimension(5) :: car =(/'%d0','%f0','%z0','%c0','%d1'/)
+ integer, dimension(5) :: l
+ !
+ do i=1,size(l)
+ !
+ l(i) = index(trim(type_err%chaine),car(i))
+ !
+ end do
+ !
+ if (maxval(l) == 0) then
+ !
+ write(unit,*) trim(type_err%chaine)
+ !
+ else if (l(1) /= 0) then
+ !
+ write(unit,*) type_err%chaine(1:l(1)-1),type_err%arg_int
+ !
+ else if (l(2) /= 0) then
+ !
+ write(unit,*) type_err%chaine(1:l(2)-1),type_err%arg_real
+ !
+ else if (l(3) /= 0) then
+ !
+ write(unit,*) type_err%chaine(1:l(3)-1),type_err%arg_comp
+ !
+ else if (l(4) /= 0) then
+ !
+ write(unit,*) type_err%chaine(1:l(4)-1),type_err%arg_char
+ !
+ else if (l(5) /= 0) then
+ !
+ write(unit,*) type_err%chaine(1:l(5)-1),unpackb(type_err%arg_int_tab(1),type_err%arg_int_tab(2))
+ !
+ end if
+ !
+ end subroutine print_type
+ !
+end module sortie_erreur
diff --git a/golem95c-1.2.1/module/spinor.f90 b/golem95c-1.2.1/module/spinor.f90
new file mode 100644
index 0000000..5ccf065
--- /dev/null
+++ b/golem95c-1.2.1/module/spinor.f90
@@ -0,0 +1,616 @@
+!
+!****h* src/module/spinor
+! NAME
+!
+! Module spinor
+!
+! USAGE
+!
+! use spinor
+!
+! DESCRIPTION
+!
+! This module contains all the function to compute the spinorial products,
+! scalar products and epsilon_tensor
+!
+! OUTPUT
+!
+! It exports:
+! * ket -- a function to compute the ket spinor
+! * bra -- a function to compute the bra spinor
+! * pslash -- a function to compute p^{\mu} \gamma_{\mu}
+! * bra_ket -- a function to compute the spinorial product
+! * eps_prod_sca -- a function to compute the scalar product e_i.p_j
+! * eps_prod_eps -- a function to compute the scalar product e_i.e_j
+! * scalar -- a function to compute the scalar product
+! * e_ -- a function to compute the epsilon tensor
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+!
+!*****
+module spinor
+ !
+ use precision_golem
+ use constante, only : i_
+ implicit none
+ !
+ private
+ !
+ complex(ki), dimension(16), parameter :: g0_col = (/0._ki,0._ki,1._ki,0._ki,&
+ &0._ki,0._ki,0._ki,1._ki,&
+ &1._ki,0._ki,0._ki,0._ki,&
+ &0._ki,1._ki,0._ki,0._ki/)
+ complex(ki), dimension(16), parameter :: g1_col = (/0._ki,0._ki,0._ki,1._ki,&
+ &0._ki,0._ki,1._ki,0._ki,&
+ &0._ki,-1._ki,0._ki,0._ki,&
+ &-1._ki,0._ki,0._ki,0._ki/)
+ complex(ki), dimension(16), parameter :: g2_col = (/0._ki,0._ki,0._ki,1._ki,&
+ &0._ki,0._ki,-1._ki,0._ki,&
+ &0._ki,-1._ki,0._ki,0._ki,&
+ &1._ki,0._ki,0._ki,0._ki/)
+ complex(ki), dimension(16), parameter :: g3_col = (/0._ki,0._ki,1._ki,0._ki,&
+ &0._ki,0._ki,0._ki,-1._ki,&
+ &-1._ki,0._ki,0._ki,0._ki,&
+ &0._ki,1._ki,0._ki,0._ki/)
+ !complex(ki), dimension(4,4), parameter :: gamma0 = reshape(g0_col,(/4,4/))
+ !complex(ki), dimension(4,4), parameter :: gamma1 = reshape(g1_col,(/4,4/))
+ !complex(ki), dimension(4,4), parameter :: gamma2 = i_*reshape(g2_col,(/4,4/))
+ !complex(ki), dimension(4,4), parameter :: gamma3 = reshape(g3_col,(/4,4/))
+ !
+ public ket,bra,pslash,bra_ket,eps_prod_sca,eps_prod_eps,scalar,e_
+ !
+ contains
+ !
+ !****f* src/module/spinor/ket
+ ! NAME
+ !
+ ! Function ket
+ !
+ ! USAGE
+ !
+ ! complex_dim4_1 = ket(p,i)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the spinor using the chinese's paper
+ ! Nucl. Phys. B291 (1987) 392-428 equation A.16
+ ! modified for non physical configuration E < 0.
+ ! The functions bra and ket verify the conditions:
+ ! <-p-|q+> = <p-|-q+> = i <p-|q+>
+ ! <-p+|q-> = <p+|-q-> = i <p+|q->
+ ! <-p-|-q+> = - <p-|q+>
+ ! <-p+|-q-> = - <p+|q->
+ !
+ ! INPUTS
+ !
+ ! * p -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ ! * i -- an integer, the value of the helicity (= 1,-1)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex array (type ki) of rank 2 and shape 4,1
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ pure function ket(p,i)
+ !
+ real(ki), dimension(4), intent(in) :: p
+ integer, intent(in) :: i
+ complex(ki), dimension(4,1) :: ket
+ !
+ real(ki) :: p_plus,p_moins,t1
+ complex(ki) :: p_perp,c1,extra_phase
+ !
+ p_plus = p(1)+p(4)
+ p_moins = p(1)-p(4)
+ p_perp = sign(1._ki,p(1))*(p(2)+i_*p(3))
+ extra_phase = (1._ki,0._ki)
+ !
+ ! for non physical configuration
+ !
+ if (p(1) < 0._ki) then
+ !
+ extra_phase = i_
+ !
+ end if
+ !
+ t1 = sqrt(abs(p_plus))
+ !
+ if (p_plus == 0._ki) then
+ !
+ c1 = sqrt(p_moins)
+ !
+ else
+ !
+ c1 = p_perp/t1
+ !
+ end if
+ !
+ if (i == 1) then
+ !
+ ket(1,:) = extra_phase*t1
+ ket(2,:) = extra_phase*c1
+ ket(3,:) = 0._ki
+ ket(4,:) = 0._ki
+ !
+ else if (i == -1) then
+ !
+ ket(1,:) = 0._ki
+ ket(2,:) = 0._ki
+ ket(3,:) = extra_phase*conjg(c1)
+ ket(4,:) = -extra_phase*t1
+ !
+ end if
+ !
+ end function ket
+ !
+ !****f* src/module/spinor/bra
+ ! NAME
+ !
+ ! Function bra
+ !
+ ! USAGE
+ !
+ ! complex_dim1_4 = bra(p,i)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes the spinor bra using
+ ! bra(p) = ket(p)^{\dagger} \gamma_0
+ ! modified for non physical configuration p_0 < 0.
+ ! The functions bra and ket verify the conditions:
+ ! <-p-|q+> = <p-|-q+> = i <p-|q+>
+ ! <-p+|q-> = <p+|-q-> = i <p+|q->
+ ! <-p-|-q+> = - <p-|q+>
+ ! <-p+|-q-> = - <p+|q->
+ !
+ ! INPUTS
+ !
+ ! * p -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ ! * i -- an integer, the value of the helicity (= 1,-1)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex array (type ki) of rank 2 and shape 1,4
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ pure function bra(p,i)
+ !
+ real(ki), dimension(4), intent(in) :: p
+ integer, intent(in) :: i
+ complex(ki), dimension(1,4) :: bra
+ !
+ complex(ki), dimension(1,4) :: tra
+ complex(ki), dimension(4,4) :: gamma0
+
+ gamma0 = reshape(g0_col,(/4,4/))
+ !
+ tra = transpose(ket(p,i))
+ bra = sign(1._ki,p(1))*conjg(tra)
+ bra = matmul(bra,gamma0)
+ !
+ end function bra
+ !
+ !****f* src/module/spinor/pslash
+ ! NAME
+ !
+ ! Function pslash
+ !
+ ! USAGE
+ !
+ ! complex_dim4_4 = pslash(p)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes p_{\mu} \gamma^{\mu}, i.e.
+ ! p0 gamma0 - p1 gamma1 - p2 gamma2 - p3 gamma3
+ ! taking the Chinese convention for the gamma matrices in
+ ! Weyl representation
+ !
+ ! INPUTS
+ !
+ ! * p -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex array (type ki) of rank 2 and shape 4,4
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ pure function pslash(p)
+ !
+ real(ki), dimension(4), intent(in) :: p
+ complex(ki), dimension(4,4) :: pslash
+ !
+ real(ki) :: p_plus,p_moins
+ complex(ki) :: p_perp
+ !
+ p_plus = p(1) + p(4)
+ p_moins = p(1) - p(4)
+ p_perp = p(2) + i_*p(3)
+ !
+ pslash = 0._ki
+ pslash(1,3) = p_plus
+ pslash(1,4) = conjg(p_perp)
+ pslash(2,3) = p_perp
+ pslash(2,4) = p_moins
+ pslash(3,1) = p_moins
+ pslash(3,2) = -conjg(p_perp)
+ pslash(4,1) = -p_perp
+ pslash(4,2) = p_plus
+ !
+ end function pslash
+ !
+ !****f* src/module/spinor/bra_ket
+ ! NAME
+ !
+ ! Function bra_ket
+ !
+ ! USAGE
+ !
+ ! complex = bra_ket(p1,i1,p2,i2,k1,k2,k3,k4,k5,k6,k7,k8,k9,k10)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes <p1 i1|k1slash*k2slash*...*k10slash|p2 i2>
+ ! i1 and i2 = +/- 1 are the helicities
+ ! where the inner argument k1slash,k2slash,...,k10slash are optional
+ !
+ ! INPUTS
+ !
+ ! * p1 -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ ! * i1 -- an integer, the value of the helicity (= 1,-1)
+ ! * p2 -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ ! * i2 -- an integer, the value of the helicity (= 1,-1)
+ ! * k1 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ ! * k2 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ ! * k3 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ ! * k4 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ ! * k5 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ ! * k6 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ ! * k7 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ ! * k8 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ ! * k9 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ ! * k10 -- a real array (type ki) of rank 1, shape 4; a 4-momentum optional
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ pure function bra_ket(p1,i1,p2,i2,k1,k2,k3,k4,k5,k6,k7,k8,k9,k10)
+ !
+ real(ki), dimension(4), intent(in) :: p1,p2
+ real(ki), dimension(4), intent(in), optional :: k1,k2,k3,k4,k5,&
+ &k6,k7,k8,k9,k10
+ integer, intent(in) :: i1,i2
+ complex(ki) :: bra_ket
+ !
+ complex(ki), dimension(1,1) :: temp
+ complex(ki), dimension(4,4) :: c_mat
+ complex(ki), dimension(4,1) :: c_col
+ integer :: nb_arg
+ logical :: test
+ !
+ nb_arg = 2
+ ! calcul du nombre d'arguments optionnels
+ if (present(k1)) nb_arg = nb_arg + 1
+ if (present(k2)) nb_arg = nb_arg + 1
+ if (present(k3)) nb_arg = nb_arg + 1
+ if (present(k4)) nb_arg = nb_arg + 1
+ if (present(k5)) nb_arg = nb_arg + 1
+ if (present(k6)) nb_arg = nb_arg + 1
+ if (present(k7)) nb_arg = nb_arg + 1
+ if (present(k8)) nb_arg = nb_arg + 1
+ if (present(k9)) nb_arg = nb_arg + 1
+ if (present(k10)) nb_arg = nb_arg + 1
+ !
+ test = ( (modulo(nb_arg,2) == 0) .and. (i1*i2 == -1) ) .or. &
+ ( (modulo(nb_arg,2) == 1) .and. (i1*i2 == 1) )
+ !
+ if ( test ) then
+ !
+ if (present(k1)) then
+ !
+ c_mat = pslash(k1)
+ !
+ if (present(k2)) c_mat = matmul(c_mat,pslash(k2))
+ if (present(k3)) c_mat = matmul(c_mat,pslash(k3))
+ if (present(k4)) c_mat = matmul(c_mat,pslash(k4))
+ if (present(k5)) c_mat = matmul(c_mat,pslash(k5))
+ if (present(k6)) c_mat = matmul(c_mat,pslash(k6))
+ if (present(k7)) c_mat = matmul(c_mat,pslash(k7))
+ if (present(k8)) c_mat = matmul(c_mat,pslash(k8))
+ if (present(k9)) c_mat = matmul(c_mat,pslash(k9))
+ if (present(k10)) c_mat = matmul(c_mat,pslash(k10))
+ !
+ c_col = matmul(c_mat,ket(p2,i2))
+ temp = matmul(bra(p1,i1),c_col)
+ !
+ else
+ !
+ temp = matmul(bra(p1,i1),ket(p2,i2))
+ !
+ end if
+ !
+ bra_ket = temp(1,1)
+ !
+ else
+ !
+ bra_ket = 0._ki
+ !
+ end if
+ !
+ end function bra_ket
+ !
+ !****f* src/module/spinor/eps_prod_sca
+ ! NAME
+ !
+ ! Function eps_prod_sca
+ !
+ ! USAGE
+ !
+ ! complex = eps_prod_sca(i,r1,p1,p2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes e^i(p1).p2 where r1 is the reference momentum
+ ! be careful that p2 is assumed to be a lightlike vector
+ !
+ ! INPUTS
+ !
+ ! * i -- an integer, the value of the helicity (= 1,-1)
+ ! * r1 -- a real array (type ki) of rank 1, shape 4; the refrence momentum
+ ! * p1 -- a real array (type ki) of rank 1, shape 4; the momentum of the spin 1
+ ! * p2 -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ pure function eps_prod_sca(i,r1,p1,p2)
+ !
+ integer, intent(in) :: i
+ real(ki), dimension(4), intent(in) :: r1,p1,p2
+ complex(ki) :: eps_prod_sca
+ !
+ complex(ki) :: ctemp,cjtemp
+ real(ki) :: denom
+ !
+ ctemp = bra_ket(r1,-1,p1,1)
+ cjtemp = conjg(ctemp)
+ denom = ctemp*cjtemp*sqrt(2._ki)
+ !
+ if (i == 1) then
+ !
+ eps_prod_sca = bra_ket(r1,-1,p1,-1,p2)*cjtemp/denom
+ !
+ else if (i == -1) then
+ !
+ eps_prod_sca = bra_ket(r1,1,p1,1,p2)*ctemp/denom
+ else
+ !
+ eps_prod_sca = huge(1.0_ki)
+ !
+ end if
+ !
+ end function eps_prod_sca
+ !
+ !****f* src/module/spinor/eps_prod_eps
+ ! NAME
+ !
+ ! Function eps_prod_eps
+ !
+ ! USAGE
+ !
+ ! complex = eps_prod_eps(i1,r1,p1,i2,r2,p2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function computes e^i(p1).e^j(p) where r1 is the reference momemtum
+ ! for e(p1) and r2 is the reference momemtum for e(p2)
+ !
+ ! INPUTS
+ !
+ ! * i1 -- an integer, the value of the helicity (= 1,-1)
+ ! * r1 -- a real array (type ki) of rank 1, shape 4; the refrence momentum
+ ! * p1 -- a real array (type ki) of rank 1, shape 4; the momentum of the spin 1
+ ! * i2 -- an integer, the value of the helicity (= 1,-1)
+ ! * r2 -- a real array (type ki) of rank 1, shape 4; the refrence momentum
+ ! * p2 -- a real array (type ki) of rank 1, shape 4; the momentum of the spin 1
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ pure function eps_prod_eps(i1,r1,p1,i2,r2,p2)
+ !
+ integer, intent(in) :: i1,i2
+ real(ki), dimension(4), intent(in) :: r1,p1,r2,p2
+ complex(ki) :: eps_prod_eps
+ !
+ complex(ki) :: c1temp,c1jtemp,c2temp,c2jtemp
+ real(ki) :: denom
+ !
+ c1temp = bra_ket(r1,-1,p1,1)
+ c1jtemp = conjg(c1temp)
+ c2temp = bra_ket(r2,-1,p2,1)
+ c2jtemp = conjg(c2temp)
+ denom = c1temp*c1jtemp*c2temp*c2jtemp
+ !
+ if ( (i1 == 1) .and. (i2 == 1) ) then
+ !
+ eps_prod_eps = bra_ket(r2,-1,r1,1)*bra_ket(p1,1,p2,-1) &
+ *c1jtemp*c2jtemp/denom
+ !
+ else if ( (i1 == 1) .and. (i2 == -1) ) then
+ !
+ eps_prod_eps = bra_ket(r2,1,p1,-1)*bra_ket(r1,-1,p2,1) &
+ *c1jtemp*c2temp/denom
+ !
+ else if ( (i1 == -1) .and. (i2 == 1) ) then
+ !
+ eps_prod_eps = bra_ket(r1,1,p2,-1)*bra_ket(r2,-1,p1,1) &
+ *c2jtemp*c1temp/denom
+ !
+ else if ( (i1 == -1) .and. (i2 == -1) ) then
+ !
+ eps_prod_eps = bra_ket(p2,-1,p1,1)*bra_ket(r1,1,r2,-1) &
+ *c1temp*c2temp/denom
+ else
+ eps_prod_eps = huge(1.0_ki)
+ !
+ end if
+ !
+ end function eps_prod_eps
+ !
+ !****f* src/module/spinor/scalar
+ ! NAME
+ !
+ ! Function scalar
+ !
+ ! USAGE
+ !
+ ! real = scalar(p1,p2)
+ !
+ ! DESCRIPTION
+ !
+ ! This function compute the scalar product of two 4 momentum
+ !
+ ! INPUTS
+ !
+ ! * p1 -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ ! * p2 -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a real (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ pure function scalar(p1,p2)
+ !
+ real(ki), intent (in), dimension(4) :: p1,p2
+ real(ki) :: scalar
+ !
+ scalar = p1(1)*p2(1) - p1(2)*p2(2) - p1(3)*p2(3) - p1(4)*p2(4)
+ !
+ end function scalar
+ !
+ !****f* src/module/spinor/e_
+ ! NAME
+ !
+ ! Function e_
+ !
+ ! USAGE
+ !
+ ! complex = e_(k1,k2,k3,k4)
+ !
+ ! DESCRIPTION
+ !
+ ! This function gives the antisymetric tensor epsilon
+ ! From Thomas Reiter
+ !
+ ! INPUTS
+ !
+ ! * k1 -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ ! * k2 -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ ! * k3 -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ ! * k4 -- a real array (type ki) of rank 1, shape 4; a 4-momentum
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect (pure function)
+ !
+ ! RETURN VALUE
+ !
+ ! It returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ pure function e_(k1,k2,k3,k4)
+ !
+ real(ki), intent (in), dimension(4) :: k1, k2, k3, k4
+ complex(ki) :: e_
+ !
+ real(ki) :: res
+ real(ki) :: k12, k23, k34, k13, k14, k24
+ !
+ k12 = k3(1)*k4(2)-k3(2)*k4(1)
+ k23 = k3(2)*k4(3)-k3(3)*k4(2)
+ k34 = k3(3)*k4(4)-k3(4)*k4(3)
+ k13 = k3(1)*k4(3)-k3(3)*k4(1)
+ k14 = k3(1)*k4(4)-k3(4)*k4(1)
+ k24 = k3(2)*k4(4)-k3(4)*k4(2)
+ !
+ res = k1(1)*(k2(2)*k34 - k2(3)*k24 + k2(4)*k23)&
+ & + k1(2)*(k2(3)*k14 - k2(1)*k34 - k2(4)*k13)&
+ & + k1(3)*(k2(1)*k24 - k2(2)*k14 + k2(4)*k12)&
+ & + k1(4)*(k2(2)*k13 - k2(1)*k23 - k2(3)*k12)
+ !
+ e_ = i_*res
+ !
+ end function e_
+ !
+end module spinor
+!
diff --git a/golem95c-1.2.1/module/translate.f90 b/golem95c-1.2.1/module/translate.f90
new file mode 100644
index 0000000..755bfc8
--- /dev/null
+++ b/golem95c-1.2.1/module/translate.f90
@@ -0,0 +1,101 @@
+!
+!****h* src/module/translate
+! NAME
+!
+! Module translate
+!
+! USAGE
+!
+! use translate
+!
+! DESCRIPTION
+!
+! This module is used to translate an array of n (=2m) reals into an array
+! of m complexs
+!
+! OUTPUT
+!
+! It exports:
+! * to_complex -- a subroutine to translate an array of n (=2m) reals into an array
+! of m complexs
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+!
+!*****
+module translate
+ !
+ use precision_golem
+ use sortie_erreur
+ implicit none
+ !
+ private
+ public :: to_complex
+ contains
+ !
+ !****f* src/module/translate/to_complex
+ ! NAME
+ !
+ ! Subroutine to_complex
+ !
+ ! USAGE
+ !
+ ! call to_complex(t,z)
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine transforms an array of reals of rank 1 and shape 2*m
+ ! t in an array of complexs of size m z, it returns z(i) = t(i) + i_*t(i+1).
+ ! If size of t is odd, the subroutine to_complex returns an error
+ !
+ ! INPUTS
+ !
+ ! * t -- a real array (type ki) of rank 1
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * z -- a complex array (type ki) of rank 1 and shape size(t)/2
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine to_complex(t,z)
+ !
+ real(ki), intent(in), dimension(:) :: t
+ complex(ki), intent(out) ,dimension(:) :: z
+ !
+ integer :: dim_t,i,j
+ !
+ dim_t = size(t)
+ !
+ if (mod(dim_t,2) == 0) then
+ !
+ do i = 1,dim_t,2
+ !
+ j = (i+1)/2
+ z(j) = cmplx(t(i),t(i+1),ki)
+ !
+ end do
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'error in subroutine to_complex'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'The size of the first argument array is odd %d0'
+ tab_erreur_par(2)%arg_int = dim_t
+ call catch_exception(0)
+ !
+ end if
+ !
+ end subroutine to_complex
+ !
+end module translate
diff --git a/golem95c-1.2.1/module/tri.f90 b/golem95c-1.2.1/module/tri.f90
new file mode 100644
index 0000000..16ffadc
--- /dev/null
+++ b/golem95c-1.2.1/module/tri.f90
@@ -0,0 +1,280 @@
+!
+!****h* src/module/tri_croissant
+! NAME
+!
+! Module tri_croissant
+!
+! USAGE
+!
+! use tri_croissant
+!
+! DESCRIPTION
+!
+! This module is used to sort an integer array or shift its elements by certain amount
+!
+! OUTPUT
+!
+! This module exports:
+! * tri_int -- a subroutine to sort out an integer array
+! * shift_param -- a subroutine to shift (modulo n) the elements of an integer array
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+!
+!*****
+module tri_croissant
+ !
+ use precision_golem
+ implicit none
+ !
+ private
+ !
+ !
+ public :: tri_int2, tri_int3, tri_int4, shift_param, exchange_param
+ !
+ !
+ contains
+ !
+ !****f* src/module/tri_croissant/tri_int
+ ! NAME
+ !
+ ! Subroutine tri_int
+ !
+ ! USAGE
+ !
+ ! call tri_int(t_in,t_out)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine sorts in increasing order an integer array t_int and put the
+ ! result in the integer array t_out
+ !
+ ! INPUTS
+ !
+ ! * t_int -- an integer array of rank 1, the array to sort
+ !
+ ! SIDE EFFECTS
+ !
+ ! NONE
+ !
+ ! RETURN VALUE
+ !
+ ! * t_out -- an integer array of rank 1, the sorted array
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ ! on trie par ordre croissant le tableau t_in et
+ ! on met le resultat dans t_out. On utilise les procedures
+ ! compare et exchange
+
+ pure subroutine tri_int2(t_in,t_out)
+ implicit none
+ integer, intent(in), dimension(2) :: t_in
+ integer, intent(out), dimension(2) :: t_out
+ integer, dimension(2) :: tmp
+
+ if (t_in(1) < t_in(2)) then
+ tmp(1) = t_in(1)
+ tmp(2) = t_in(2)
+ else
+ tmp(1) = t_in(2)
+ tmp(2) = t_in(1)
+ end if
+ t_out(:) = tmp(:)
+ end subroutine tri_int2
+
+ pure subroutine tri_int3(t_in,t_out)
+ implicit none
+ integer, intent(in), dimension(3) :: t_in
+ integer, intent(out), dimension(3) :: t_out
+ integer, dimension(3) :: tmp
+
+ tmp(:) = t_in(:)
+
+ if (tmp(1) > tmp(3)) then
+ if (tmp(1) < tmp(2)) then
+ t_out(:) = tmp((/3,1,2/))
+ else
+ if (tmp(2) > tmp(3)) then
+ t_out(:) = tmp((/3,2,1/))
+ else
+ t_out(:) = tmp((/2,3,1/))
+ end if
+ end if
+ else
+ if (tmp(2) < tmp(1)) then
+ t_out(:) = tmp((/2,1,3/))
+ else
+ if (tmp(2) < tmp(3)) then
+ t_out(:) = tmp((/1,2,3/))
+ else
+ t_out(:) = tmp((/1,3,2/))
+ end if
+ end if
+ end if
+ end subroutine tri_int3
+
+ subroutine tri_int4(t_in,t_out)
+ implicit none
+ !
+ integer, intent(in), dimension(4) :: t_in
+ integer, intent(out), dimension(4) :: t_out
+ !
+ integer :: j,i,alpha,beta
+ !
+
+ t_out(1) = t_in(1)
+ do i=2,4
+ alpha = t_in(i)
+
+ do j=1,i-1
+ if (alpha < t_out(j)) then
+ beta = t_out(j)
+ t_out(j) = alpha
+ alpha = beta
+ end if
+ end do
+ t_out(i) = alpha
+ end do
+ end subroutine tri_int4
+ !
+ !****f* src/module/tri_croissant/shift_param
+ ! NAME
+ !
+ ! Subroutine shift_param
+ !
+ ! USAGE
+ !
+ ! call shift_param(z_param_ini,shift,modd,z_param_out)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine shifts the array z_param_ini of Feynman parameters
+ ! the shift is done as following:
+ ! z --> z+shift if z+shift <= modd
+ ! else mod(z+shift-1,modd)+1 if z+shift > modd
+ ! the result is put into the array z_param_out
+ !
+ ! INPUTS
+ !
+ ! * z_param_ini -- an integer array of rank 1, the array to shift
+ ! * shift -- an integer, the value of the shift
+ ! * modd -- an integer, the shift is made modulo modd
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * z_param_out -- an integer array of rank 1, the shifted array
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine shift_param(z_param_ini,shift,modd,z_param_out)
+ !
+ integer, intent(in) :: shift,modd
+ integer, intent(in), dimension(modd) :: z_param_ini
+ integer, intent(out), dimension(modd) :: z_param_out
+ !
+ integer, dimension(modd) :: temp
+ !
+ where (z_param_ini .ne. 0)
+ temp(:) = modulo(z_param_ini(:)+shift-1, modd) + 1
+ elsewhere
+ temp(:) = 0
+ endwhere
+ !
+ select case(modd)
+ case(1)
+ z_param_out = temp
+ case(2)
+ call tri_int2(temp,z_param_out)
+ case(3)
+ call tri_int3(temp,z_param_out)
+ case(4)
+ call tri_int4(temp,z_param_out)
+ case default
+ print*, "shift_param: unimplemented value of modd: ", modd
+ stop
+ end select
+ !
+ end subroutine shift_param
+ !
+ !
+ !****f* src/module/tri_croissant/exchange_param
+ ! NAME
+ !
+ ! Subroutine exchange_param
+ !
+ ! USAGE
+ !
+ ! call exchange_param(z_param_ini,tab,modd,z_param_out)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine exchanges in the array z_param_ini of Feynman parameters
+ ! the label tab(1) with the label tab(2)
+ ! the result is put into the array z_param_out
+ !
+ ! INPUTS
+ !
+ ! * z_param_ini -- an integer array of rank 1, the array to shift
+ ! * tab -- an integer array of rank 1, the two labels to exchange
+ ! * modd -- an integer, the shift is made modulo modd
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! * z_param_out -- an integer array of rank 1, the shifted array
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine exchange_param(z_param_ini,tab,modd,z_param_out)
+ !
+ integer, intent(in) :: modd
+ integer, dimension(2), intent(in) :: tab
+ integer, intent(in), dimension(modd) :: z_param_ini
+ integer, intent(out), dimension(modd) :: z_param_out
+ !
+ integer, dimension(modd) :: temp
+ !
+ where (z_param_ini == tab(1))
+ temp = tab(2)
+ elsewhere (z_param_ini == tab(2))
+ temp = tab(1)
+ elsewhere
+ temp = z_param_ini
+ end where
+ !
+ select case(modd)
+ case(1)
+ z_param_out = temp
+ case(2)
+ call tri_int2(temp,z_param_out)
+ case(3)
+ call tri_int3(temp,z_param_out)
+ case(4)
+ call tri_int4(temp,z_param_out)
+ case default
+ print*, "shift_param: modd too large: ", modd
+ stop
+ end select
+ !
+ end subroutine exchange_param
+ !
+end module tri_croissant
+!
diff --git a/golem95c-1.2.1/module/z_log.f90 b/golem95c-1.2.1/module/z_log.f90
new file mode 100644
index 0000000..4f74016
--- /dev/null
+++ b/golem95c-1.2.1/module/z_log.f90
@@ -0,0 +1,442 @@
+!****h* src/module/logarithme
+! NAME
+!
+! Module logarithme
+!
+! USAGE
+!
+! use logarithme
+!
+! DESCRIPTION
+!
+! This module provides three public routines to compute the logarithm,
+! the logarithm squared and a special function (generalisation of ln(1-z)/z)
+! assuming that the argument is of the type z = a + i lambda s, where
+! lambda > 0 and << 1 and s = +/- 1. a can be a complex type. If its
+! imaginary part vanishes, the sign of s becomes relevant.
+!
+!
+! OUTPUT
+!
+! It exports:
+! * z_log -- a function which returns the logarithm with a complex argument
+! * z_log2 -- a function which returns the logarithm squared with a complex argument
+! * q -- a recursive function which a generalisation of ln(1-z)/z
+!
+! NOTES
+!
+! z_log (and z_log2) can be called with complex argument and parameter s. If the imaginary part vanishes,
+! z_log (or z_log2) with real argument is called. Here, s becomes important.
+!
+! USES
+!
+! * precision_golem (src/module/precision_golem.f90)
+! * constante (src/module/constante.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * equal (src/module/equal.f90)
+!
+!*****
+module logarithme
+ !
+ use precision_golem
+ use constante, only : pi,i_,un, zero
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use equal
+ !
+ implicit none
+ !
+ private
+ !
+ real(ki), parameter :: small_glob = 5.e-1_ki
+ !
+ interface z_log
+ !
+ module procedure z_log_r, z_log_c
+ !
+ end interface
+ !
+ interface z_log2
+ !
+ module procedure z_log2_r, z_log2_c
+ !
+ end interface
+ !
+ interface q
+ !
+ module procedure q_r, q_c
+ !
+ end interface
+ !
+ public :: z_log,z_log2,q,eta
+ !
+ contains
+ !
+ !****f* src/module/logarithme/z_log
+ ! NAME
+ !
+ ! Function z_log
+ !
+ ! USAGE
+ !
+ ! complex = z_log(a,s)
+ !
+ ! DESCRIPTION
+ !
+ ! Compute the ln(z) with z = a + i lambda s
+ !
+ ! INPUTS
+ !
+ ! * a -- a real/complex (type ki), the argument
+ ! * s -- a real (type ki), s = +/- 1, it gives the sign of the small imaginary part
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! NOTES
+ !
+ ! If the imaginary part of the argument vanishes, the sign of s becomes relevant.
+ !
+ !
+ !*****
+ !
+ function z_log_r(a,s)
+ !
+ real(ki), intent(in) :: a,s
+ complex(ki) :: z_log_r
+ !
+ if (abs(s) == 1._ki) then
+ !
+ if (a > 0._ki) then
+ !
+ z_log_r = cmplx(log(a), 0.0_ki, ki)
+ !
+ else
+ !
+ ! z_log_r = log(-a)+i_*pi*s
+ z_log_r = cmplx(log(-a), pi*s, ki)
+ !
+ endif
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'error in z_log:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the second argument must be 1. or -1. %f0'
+ tab_erreur_par(2)%arg_real = s
+ call catch_exception(0)
+ !
+ ! to please the compiler:
+ stop
+ !
+ endif
+ !
+ end function z_log_r
+ !
+ !
+ function z_log_c(a,s)
+ !
+ complex(ki), intent(in) :: a
+ real(ki), intent(in) :: s
+ complex(ki) :: z_log_c
+ !
+
+ if (equal_real(aimag(a),zero) ) then
+ !
+ z_log_c = z_log_r(real(a,ki),s)
+ !
+ else
+ !
+ z_log_c = log(a)
+ !
+ end if
+ !
+ end function z_log_c
+ !
+ !****f* src/module/logarithme/z_log2
+ ! NAME
+ !
+ ! Function z_log2
+ !
+ ! USAGE
+ !
+ ! complex = z_log2(a,s)
+ !
+ ! DESCRIPTION
+ !
+ ! Compute the ln(z)^2 with z = a + i lambda s
+ !
+ ! INPUTS
+ !
+ ! * a -- a real/complex (type ki), the argument
+ ! * s -- a real (type ki), s = +/- 1, it gives the sign of the small imaginary part
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! NOTES
+ !
+ ! If the imaginary part of the argument vanishes, the sign of s becomes relevant.
+ !
+ !
+ !
+ !*****
+ !
+ function z_log2_r(a,s)
+ !
+ real(ki), intent(in) :: a,s
+ complex(ki) :: z_log2_r
+
+ real(ki) :: lga
+ !
+ if (abs(s) == 1._ki) then
+ !
+ if (a > 0._ki) then
+ !
+ lga = log(a)
+ z_log2_r = cmplx(lga*lga, 0.0_ki, ki)
+ !
+ else
+ !
+ ! z_log2_r = log(-a)**2-pi**2+2._ki*pi*i_*s*log(-a)
+ lga = log(-a)
+ z_log2_r = cmplx((lga+pi)*(lga-pi), 2.0_ki*pi*s*lga, ki)
+ !
+ endif
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'error in z_log2:'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the second argument must be 1. or -1. %f0'
+ tab_erreur_par(2)%arg_real = s
+ call catch_exception(0)
+ !
+ ! to please the compiler:
+ stop
+ !
+ endif
+ !
+ end function z_log2_r
+ !
+ function z_log2_c(a,s)
+ !
+ complex(ki), intent(in) :: a
+ real(ki), intent(in) ::s
+ complex(ki) :: z_log2_c
+ !
+ if (equal_real(aimag(a),zero) ) then
+ !
+ z_log2_c = z_log2_r(real(a,ki),s)
+ !
+ else
+ !
+ z_log2_c = log(a)**2
+ !
+ end if
+ !
+ end function z_log2_c
+ !
+ !****f* src/module/logarithme/q
+ ! NAME
+ !
+ ! Function q
+ !
+ ! USAGE
+ !
+ ! complex = q(n,x,s)
+ !
+ ! DESCRIPTION
+ !
+ ! It computes the function q defined recusively by
+ ! q_n(X) = (q_{n-1}(X)+1/(n-1))/X
+ ! with q_1(X) = ln(1-X)/X
+ ! assuming that X = x + i*s*lambda and s=+/- 1,
+ ! Care is taken for small values of x.
+ ! For x < small_glob
+ ! q_n(x) = -( 1/n + \sum_{j=n+1}^\infinity x^{j-n}/j )
+ ! Note that in this case there is no imaginary part.
+ !
+ ! INPUTS
+ !
+ ! * n -- an integer, the order of q
+ ! * x -- a real/complex (type ki), the real part
+ ! * s -- a real (type ki), s = +/- 1, it gives the sign of the small imaginary part
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! NOTES
+ !
+ ! This function can now be called with complex x. If the imaginary part vanishes,
+ ! the evaluation is switched to the version with real x and the original entry for
+ ! s becomes relevant.
+ !
+ !
+ !
+ !*****
+ !
+ recursive function q_r(n,x,s) result(resq)
+ !
+ integer, intent(in) :: n
+ real(ki), intent(in) :: x,s
+ complex(ki) :: resq
+ !
+ integer :: nm1
+ real(ki) :: tt,temp,expo_x,denom
+ !
+ if (abs(x) > small_glob) then
+ !
+ if (n == 1) then
+ resq = z_log(un-x,-s)/x
+ else
+ nm1 = n - 1
+ resq = (q_r(nm1,x,s) + 1._ki/real(nm1,ki))/x
+ end if
+ !
+ else ! no imaginary part in this case
+ !
+ denom = real(n,ki)
+ tt = 1._ki/denom
+ expo_x = un
+ temp = 10._ki !artificial value to enter into the loop
+ !
+ do while(abs(tt-temp) >= epsilon(x))
+ !
+ temp = tt
+ expo_x = x*expo_x
+ denom = denom + un
+ tt = tt + expo_x/denom
+ !
+ end do
+ !
+ resq = cmplx(-tt,0._ki,ki)
+ !
+ end if
+ !
+ end function q_r
+ !
+ recursive function q_c(n,x,s) result(resq)
+ !
+ integer, intent(in) :: n
+ complex(ki), intent(in) :: x
+ real(ki), intent (in) :: s
+ complex(ki) :: resq
+ !
+ integer :: nm1
+ complex(ki) :: tt,temp,denom,expo_x
+ !
+ if (equal_real(aimag(x), zero)) then
+ !
+ resq = q_r(n,real(x,ki),s)
+ !
+ else if (abs(x) > small_glob) then
+ !
+ if (n == 1) then
+ !
+ resq = z_log((cmplx(un,0._ki,ki) - x),-s)/x
+ !
+ else
+ !
+ nm1 = n - 1
+ resq = (q_c(nm1,x,s) + 1._ki/real(nm1,ki))/x
+ !
+ end if
+ !
+ else
+ !
+ denom = cmplx(real(n,ki),0._ki,ki)
+ tt = 1._ki/denom
+ expo_x = cmplx(un,0._ki,ki)
+ temp = cmplx(10._ki,0._ki,ki) !artificial value to enter into the loop
+ !
+ do while(abs(tt-temp) >= epsilon(real(x,ki)))
+ !
+ temp = tt
+ expo_x = x*expo_x
+ denom = denom + cmplx(un,0._ki,ki)
+ tt = tt + expo_x/denom
+ !
+ end do
+ !
+ resq = -tt
+ !
+ end if
+ !
+ end function q_c
+ !
+ !****f* src/module/logarithme/eta
+ ! NAME
+ !
+ ! Function eta
+ !
+ ! USAGE
+ !
+ ! complex = eta(x,y)
+ !
+ ! DESCRIPTION
+ !
+ ! It computes the function eta defined by
+ ! eta(x,y) - ln(x*y) - ln(x) - ln(y)
+ !
+ ! INPUTS
+ !
+ ! * x -- a complex (type ki)
+ ! * y -- a complex (type ki)
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! NOTES
+ !
+ !
+ !
+ !
+ !*****
+ !
+ function eta(z1,z2)
+ !
+ complex(ki), intent(in) :: z1,z2
+ complex(ki) :: eta
+ !
+ real(ki) :: im1,im2,imt
+ !
+ im1 = aimag(z1)
+ im2 = aimag(z2)
+ imt = aimag(z1*z2)
+ !
+ if ( (im1 >= 0._ki) .and. (im2 >= 0._ki) .and. (imt < 0._ki) ) then
+ eta = -2._ki*i_*pi
+ else if ( (im1 < 0._ki) .and. (im2 < 0._ki) .and. (imt >= 0._ki) ) then
+ eta = 2._ki*i_*pi
+ else if ( (im1 == 0._ki) .and. (im2 == 0._ki) &
+ &.and. (real(z1,ki) > 0._ki) .and. (real(z2,ki) > 0._ki) ) then
+ eta = -2._ki*i_*pi
+ else
+ eta = 0._ki
+ end if
+ !
+ end function eta
+ !
+end module logarithme
diff --git a/golem95c-1.2.1/module/zdilog.f90 b/golem95c-1.2.1/module/zdilog.f90
new file mode 100644
index 0000000..dd772ef
--- /dev/null
+++ b/golem95c-1.2.1/module/zdilog.f90
@@ -0,0 +1,683 @@
+!****h* src/module/dilogarithme
+! NAME
+!
+! Module dilogarithme
+!
+! USAGE
+!
+! use dilogarithme
+!
+! DESCRIPTION
+!
+! This module provides two public routines to compute the dilogarithm with
+! real and complex argument
+!
+! OUTPUT
+!
+! It exports:
+! * zdilog -- a function which returns the dilogarithm with real (or complex) argument
+! * cdilog -- a function which returns the dilogarithm with complex argument
+!
+! NOTES
+!
+! zdilog can be called with complex argument and parameter s. If the imaginary part vanishes,
+! zdilog with real argument is called. Here, s becomes important.
+!
+! USES
+!
+! * precision_golem (src/module/precision.f90)
+! * constante (src/module/constante.f90)
+! * logarithme (src/module/z_log.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * equal (src/module/equal.f90)
+!
+!*****
+module dilogarithme
+ !
+ use precision_golem
+ use constante, only : un,pi,pi6,pi12,zero,czero,cun
+ use logarithme, only : z_log,z_log2
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use equal
+ !
+ implicit none
+ !
+ private
+ real(ki), parameter :: zeta2 = 1.6449340668482264364724151666460252_ki
+ ! bern_glob contient B_k(0)/(k+1)!
+ real(ki), dimension (0:20), parameter :: bern_glob = (/ &
+ 1.00000000000000000000000000000000_ki,&
+ -0.25000000000000000000000000000000_ki,&
+ 0.02777777777777777777777777777778_ki,&
+ -0.00027777777777777777777777777778_ki,&
+ 0.00000472411186696900982615268330_ki,&
+ -0.00000009185773074661963550852440_ki,&
+ 0.00000000189788699889709990720092_ki,&
+ -0.00000000004064761645144225526806_ki,&
+ 0.00000000000089216910204564525552_ki,&
+ -0.00000000000001993929586072107569_ki,&
+ 0.00000000000000045189800296199182_ki,&
+ -0.00000000000000001035651761218125_ki,&
+ 0.00000000000000000023952186210262_ki,&
+ -0.00000000000000000000558178587433_ki,&
+ 0.00000000000000000000013091507554_ki,&
+ -0.00000000000000000000000308741980_ki,&
+ 0.00000000000000000000000007315976_ki,&
+ -0.00000000000000000000000000174085_ki,&
+ 0.00000000000000000000000000004158_ki,&
+ -0.00000000000000000000000000000100_ki,&
+ 0.00000000000000000000000000000002_ki&
+ /)
+ integer :: imax_glob = ki+ki/4 ! determine how many elements of the array
+ ! bern_glob have to be taken as a function of ki
+
+ interface zdilog
+ !
+ module procedure zdilog_r
+ module procedure zdilog_c
+ !
+ end interface
+ !
+ public :: zdilog, cdilog
+ !
+ contains
+ !
+ !****f* src/module/dilogarithme/zdilog
+ ! NAME
+ !
+ ! Function zdilog
+ !
+ ! USAGE
+ !
+ ! complex = zdilog(a,s)
+ !
+ ! DESCRIPTION
+ !
+ ! This function returns the dilogarithm of a complex z, this complex number
+ ! has the specific form: z = a + i lambda s where lambda << 1.
+ ! a can now be complex. If the imaginary part vanishes, the sign of s is relevant.
+ !
+ ! INPUTS
+ !
+ ! * a -- a real/complex (type ki), the argument
+ ! * s -- a real (type ki), s = +/- 1, it gives the sign of the small imaginary part
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function zdilog_r(a,s)
+ !
+ real(ki), intent(in) :: a,s
+ complex(ki) :: zdilog_r
+ !
+ if (abs(s) == un) then
+ !
+ if (a <= un) then
+ !
+ zdilog_r = dilog(a)
+ !
+ else
+ !
+ zdilog_r = -dilog(1._ki/a)-pi6-0.5_ki*z_log2(-a,-s)
+ !
+ endif
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'error in zdilog :'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the second argument must be 1. or -1. %f0'
+ tab_erreur_par(2)%arg_real = s
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ endif
+ !
+ end function zdilog_r
+ !
+ function zdilog_c(a,s)
+ !
+ complex(ki), intent(in) :: a
+ real(ki), intent(in) :: s
+ complex(ki) :: zdilog_c
+ !
+ if (equal_real(aimag(a),zero) ) then
+ !
+ zdilog_c = zdilog_r(real(a,ki),s)
+ !
+ else
+ !
+ zdilog_c = cdilog(a)
+ !
+ end if
+ !
+ end function zdilog_c
+ !****if* src/module/dilogarithme/dilog
+ ! NAME
+ !
+ ! Function dilog
+ !
+ ! USAGE
+ !
+ ! real = dilog(x)
+ !
+ ! DESCRIPTION
+ !
+ ! This function return the dilogarithm of a real x for x < 1
+ !
+ ! INPUTS
+ !
+ ! * x -- a real (type ki), the argument of the dilogarithm
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a real (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function dilog(x)
+ !
+ real(ki), intent (in) :: x
+ real(ki) :: dilog
+ !
+ real(ki), parameter :: un_demi = 0.5_ki
+ real(ki) :: arg, temp_ln, add_on, s, temp, ln_arg
+ integer :: i
+ !
+ if ( equal_real(x,zero) ) then
+ !
+ dilog = zero
+ !
+ else if ( equal_real(x,un) ) then
+ !
+ dilog = pi6
+ !
+ else if ( equal_real(x,-un) ) then
+ !
+ dilog = -pi12
+ !
+ else if ( equal_real(x,un_demi) ) then
+ !
+ dilog = pi12 - 0.5_ki*log(2._ki)**2
+ !
+ else
+ !
+ if (x < -un) then
+ !
+ arg = 1._ki/(1._ki-x)
+ s = un
+ temp_ln = log(1._ki-x)
+ add_on = -pi6 + temp_ln*( 0.5_ki*temp_ln - log(-x) )
+ !
+ else if ( x < zero) then
+ !
+ arg = x/(x - 1._ki)
+ s = -un
+ add_on = -0.5_ki*log(1._ki-x)*log(1._ki-x)
+ !
+ else if ( x < un_demi) then
+ !
+ arg = x
+ s = un
+ add_on = 0._ki
+ !
+ else if ( x < un ) then
+ !
+ arg = 1._ki-x
+ s = -un
+ add_on = pi6 - log(x)*log(1._ki-x)
+ !
+ else
+ !
+
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'error in dilog :'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'dilog(x) called for x >= 1: x=%f0'
+ tab_erreur_par(2)%arg_real = x
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ ln_arg = -log(1._ki-arg)
+ temp = 1._ki
+ dilog = bern_glob(0) + bern_glob(1)*ln_arg
+ !
+ do i = 2,imax_glob
+ !
+ temp = temp*ln_arg*ln_arg
+ dilog = dilog + bern_glob(i)*temp
+ !
+ end do
+ !
+ dilog = dilog*ln_arg
+ dilog = s*dilog + add_on
+ !
+ end if
+ !
+ end function dilog
+ !
+ !****f* src/module/dilogarithme/cdilog
+ ! NAME
+ !
+ ! Function cdilog
+ !
+ ! USAGE
+ !
+ ! complex = cdilog(z)
+ !
+ ! DESCRIPTION
+ !
+ ! This function return the dilogarithm of a complex z, taken from T. Binoth
+ !
+ ! INPUTS
+ !
+ ! * z -- a complex (type ki), the argument of the dilogarithm
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ ! adapted from Binoth's program
+ ! modified 10.5.2010: set Im part to zero if < delta to avoid
+ ! errors at z=(1._ki,delta)
+ function cdilog(z)
+ !
+ complex(ki), intent (in) :: z
+ complex(ki) :: cdilog
+ real(ki) :: delta
+ !
+ delta=10._ki*epsilon(1._ki)
+ !
+ if ( (real(z)<1._ki+delta).and.(real(z)>1._ki-delta).and.(abs(aimag(z))< 0.000000045 ) ) then
+ cdilog = zeta2
+ !
+ else if (z == czero) then
+ !
+ cdilog = czero
+ !
+ else if (z == cun) then
+ !
+ cdilog = zeta2
+ !
+ else if(abs(z) <= 0.5_ki) then
+ !
+ cdilog = cdilog6(z)
+ !
+ else if(real(z) < 0._ki) then
+ !
+ cdilog = cdilog2(z)
+ !
+ ! > 0 changed to >=0 Feb 14, 2011
+ else if(real(z) >= 0._ki) then
+ !
+ cdilog = cdilog3(z)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'error in function cdilog :'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the argument z is not in the good range : %z0'
+ tab_erreur_par(2)%arg_comp = z
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ end if
+ !
+ end function cdilog
+ !
+ !****if* src/module/dilogarithme/cdilog2
+ ! NAME
+ !
+ ! Function cdilog2
+ !
+ ! USAGE
+ !
+ ! complex = cdilog2(z)
+ !
+ ! DESCRIPTION
+ !
+ ! Transform the dilog function with Re(z) < 0 to a dilog with Re(z) >= 0
+ !
+ ! INPUTS
+ !
+ ! * z -- a complex (type ki), the argument of the dilogarithm
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function cdilog2(z)
+ !
+ complex(ki), intent(in) :: z
+ complex(ki) :: cdilog2
+ !
+ if(real(z) >= 0._ki) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'spence function error in cdilog2 at z = %z0'
+ tab_erreur_par(1)%arg_comp = z
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ else !if(real(z) < 0._ki) then
+ !
+ cdilog2 = - cdilog3(1._ki - z) &
+ - (log(z))*(log(1._ki - z)) + zeta2
+ !
+ endif
+ !
+ end function cdilog2
+ !
+ !****if* src/module/dilogarithme/cdilog3
+ ! NAME
+ !
+ ! Function cdilog3
+ !
+ ! USAGE
+ !
+ ! complex = cdilog3(z)
+ !
+ ! DESCRIPTION
+ !
+ ! Transform the dilog function with Re(z) >= 0 to a dilog with Re(z)>=0 & |z|<=1
+ !
+ ! INPUTS
+ !
+ ! * z -- a complex (type ki), the argument of the dilogarithm
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function cdilog3(z)
+ !
+ complex(ki), intent(in) :: z
+ complex(ki) :: cdilog3
+ !
+ if(real(z) < 0._ki) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'spence function error in cdilog3 at z = %z0'
+ tab_erreur_par(1)%arg_comp = z
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ else if(abs(z) <= 1._ki) then
+ !
+ cdilog3 = cdilog4(z)
+ !
+ else ! if(abs(z) > 1._ki) then
+ !
+ cdilog3 = - cdilog4(1._ki /z) &
+ - 1._ki /2._ki * (log(-z))**2 - zeta2
+ !
+ endif
+ !
+ end function cdilog3
+ !
+ !****if* src/module/dilogarithme/cdilog4
+ ! NAME
+ !
+ ! Function cdilog4
+ !
+ ! USAGE
+ !
+ ! complex = cdilog4(z)
+ !
+ ! DESCRIPTION
+ !
+ ! Separate the case |z| < 1/2 and |z| >= 1/2
+ !
+ ! INPUTS
+ !
+ ! * z -- a complex (type ki), the argument of the dilogarithm
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function cdilog4(z)
+ !
+ complex(ki), intent(in) :: z
+ complex(ki) :: cdilog4
+ complex(ki) :: z1, z2, z3, z4
+ !
+ if(real(z) < 0._ki) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'spence function error 1 in cdilog4 at z = %z0'
+ tab_erreur_par(1)%arg_comp = z
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ else if(abs(z) > 1._ki) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'spence function error 2 in cdilog4 at z = %z0'
+ tab_erreur_par(1)%arg_comp = z
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ else if(abs(z) <= 0.5_ki) then
+ !
+ cdilog4 = cdilog6(z)
+ !
+ else ! if(abs(z) > 0.5_ki) then
+ !
+ z1 = sqrt(sqrt(z))
+ z2 = sqrt(1._ki + sqrt(z))
+ z3 = sqrt(z)
+ z4 = 1._ki + sqrt(z)
+ !
+ cdilog4 = 2*( &
+ 2*( cdilog5(z1) + cdilog5(1._ki /(1._ki + z1)) &
+ + cdilog5(1._ki /z2) + cdilog5(1._ki /(1._ki + 1._ki/z2)) &
+ - (log(1._ki + z1))*(log(z1)) &
+ - (log(1._ki + 1._ki /z2))*(log(1._ki /z2)) &
+ + 1._ki /2._ki * (log(1._ki + z1))**2 &
+ + 1._ki /2._ki * (log(1._ki + 1._ki /z2))**2 &
+ - 2*zeta2 &
+ ) &
+ - (log(z4))*(log(z3)) &
+ + 1._ki /2._ki * (log(z4))**2 &
+ - zeta2 &
+ )
+ endif
+ !
+ end function cdilog4
+ !
+ !****if* src/module/dilogarithme/cdilog5
+ ! NAME
+ !
+ ! Function cdilog5
+ !
+ ! USAGE
+ !
+ ! complex = cdilog5(z)
+ !
+ ! DESCRIPTION
+ !
+ ! compute the case |z| >= 1/2 and arg(z) <= Pi/8
+ !
+ ! INPUTS
+ !
+ ! * z -- a complex (type ki), the argument of the dilogarithm
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function cdilog5(z)
+ !
+ complex(ki), intent(in) :: z
+ complex(ki) :: cdilog5
+ !
+ if(abs(z) > (1._ki + 1.e-3_ki)) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'spence function error in cdilog5 at z = %z0'
+ tab_erreur_par(1)%arg_comp = z
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ else if(abs(z) <= 0.5_ki) then
+ !
+ ! this had been a place giving an error, as we didn't expect it ever to be entered. However, for z near to (1,0), but just outside the range we give (very rare), we can still enter here. Neverthelesss, the function is well-behaved here so this shouldn't cause any trouble.
+ cdilog5 = cdilog6(z)
+
+ !
+ else if(abs(aimag(log(z))) > pi/8._ki .and. .not.equal_real(abs(aimag(log(z))),pi/8._ki) ) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'spence function error in cdilog5 at z = %z0'
+ tab_erreur_par(1)%arg_comp = z
+ call catch_exception(0)
+ !
+ ! to please the compiler
+ stop
+ !
+ else
+ !
+ cdilog5 = - cdilog6(1._ki - z) &
+ - log(z)*log(1._ki - z) + zeta2
+ !
+ end if
+ !
+ end function cdilog5
+ !
+ !****if* src/module/dilogarithme/cdilog6
+ ! NAME
+ !
+ ! Function cdilog6
+ !
+ ! USAGE
+ !
+ ! complex = cdilog6(z)
+ !
+ ! DESCRIPTION
+ !
+ ! compute the case |z| <= 1/2
+ !
+ ! INPUTS
+ !
+ ! * z -- a complex (type ki), the argument of the dilogarithm
+ !
+ ! SIDE EFFECTS
+ !
+ ! No side effect
+ !
+ ! RETURN VALUE
+ !
+ ! This function returns a complex (type ki)
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ function cdilog6(z)
+ !
+ complex(ki), intent (in) :: z
+ complex(ki) :: cdilog6
+ !
+ complex(ki) :: lnz,temp
+ integer :: i
+ !
+ lnz = -log(1._ki-z)
+ temp = 1._ki
+ cdilog6 = bern_glob(0)+bern_glob(1)*lnz
+ !
+ do i = 2,imax_glob
+ !
+ temp = temp*lnz*lnz
+ cdilog6 = cdilog6 + bern_glob(i)*temp
+ !
+ end do
+ !
+ cdilog6 = cdilog6*lnz
+ !
+ end function cdilog6
+ !
+end module dilogarithme
diff --git a/golem95c-1.2.1/numerical/Makefile.am b/golem95c-1.2.1/numerical/Makefile.am
new file mode 100644
index 0000000..bc8a04e
--- /dev/null
+++ b/golem95c-1.2.1/numerical/Makefile.am
@@ -0,0 +1,11 @@
+noinst_LTLIBRARIES=libgolem95_numerical.la
+
+libgolem95_numerical_la_SOURCES= mod_adapt_gauss.f90 mod_numeric.f90
+libgolem95_numerical_la_FCFLAGS=\
+ -I$(builddir)/../module \
+ -I$(builddir)/../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS= adapt_gauss.mod numerical_evaluation.mod
+CLEANFILES=*.mod
+
+include Makefile.dep
diff --git a/golem95c-1.2.1/numerical/Makefile.dep b/golem95c-1.2.1/numerical/Makefile.dep
new file mode 100644
index 0000000..4f039d1
--- /dev/null
+++ b/golem95c-1.2.1/numerical/Makefile.dep
@@ -0,0 +1,4 @@
+# Module dependencies
+mod_numeric.o: mod_adapt_gauss.o
+mod_numeric.lo: mod_adapt_gauss.lo
+mod_numeric.obj: mod_adapt_gauss.obj
diff --git a/golem95c-1.2.1/numerical/Makefile.in b/golem95c-1.2.1/numerical/Makefile.in
new file mode 100644
index 0000000..988101e
--- /dev/null
+++ b/golem95c-1.2.1/numerical/Makefile.in
@@ -0,0 +1,560 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.dep \
+ $(srcdir)/Makefile.in
+subdir = golem95c-1.2.1/numerical
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+LTLIBRARIES = $(noinst_LTLIBRARIES)
+libgolem95_numerical_la_LIBADD =
+am_libgolem95_numerical_la_OBJECTS = \
+ libgolem95_numerical_la-mod_adapt_gauss.lo \
+ libgolem95_numerical_la-mod_numeric.lo
+libgolem95_numerical_la_OBJECTS = \
+ $(am_libgolem95_numerical_la_OBJECTS)
+libgolem95_numerical_la_LINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=link $(FCLD) \
+ $(libgolem95_numerical_la_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libgolem95_numerical_la_SOURCES)
+DIST_SOURCES = $(libgolem95_numerical_la_SOURCES)
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(pkgincludedir)"
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+noinst_LTLIBRARIES = libgolem95_numerical.la
+libgolem95_numerical_la_SOURCES = mod_adapt_gauss.f90 mod_numeric.f90
+libgolem95_numerical_la_FCFLAGS = \
+ -I$(builddir)/../module \
+ -I$(builddir)/../../avh_olo-2.2.1
+
+nodist_pkginclude_HEADERS = adapt_gauss.mod numerical_evaluation.mod
+CLEANFILES = *.mod
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu golem95c-1.2.1/numerical/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu golem95c-1.2.1/numerical/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+
+clean-noinstLTLIBRARIES:
+ -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+ @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libgolem95_numerical.la: $(libgolem95_numerical_la_OBJECTS) $(libgolem95_numerical_la_DEPENDENCIES)
+ $(libgolem95_numerical_la_LINK) $(libgolem95_numerical_la_OBJECTS) $(libgolem95_numerical_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+libgolem95_numerical_la-mod_adapt_gauss.lo: mod_adapt_gauss.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_numerical_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_numerical_la-mod_adapt_gauss.lo $(FCFLAGS_f90) `test -f 'mod_adapt_gauss.f90' || echo '$(srcdir)/'`mod_adapt_gauss.f90
+
+libgolem95_numerical_la-mod_numeric.lo: mod_numeric.f90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(libgolem95_numerical_la_FCFLAGS) $(FCFLAGS) -c -o libgolem95_numerical_la-mod_numeric.lo $(FCFLAGS_f90) `test -f 'mod_numeric.f90' || echo '$(srcdir)/'`mod_numeric.f90
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libtool clean-noinstLTLIBRARIES ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+mod_numeric.o: mod_adapt_gauss.o
+mod_numeric.lo: mod_adapt_gauss.lo
+mod_numeric.obj: mod_adapt_gauss.obj
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/golem95c-1.2.1/numerical/mod_adapt_gauss.f90 b/golem95c-1.2.1/numerical/mod_adapt_gauss.f90
new file mode 100644
index 0000000..47bba61
--- /dev/null
+++ b/golem95c-1.2.1/numerical/mod_adapt_gauss.f90
@@ -0,0 +1,1003 @@
+!****h* src/numerical/adapt_gauss
+! NAME
+!
+! Module adapt_gauss (file src/numerical/adapt_gauss.f90)
+!
+! USAGE
+!
+! use adapt_gauss
+!
+! DESCRIPTION
+!
+! This module contains several routines for a one dimensional
+! integration using Gauss Kronrod method
+!
+! OUTPUT
+!
+! The only subroutine which can be used by use association in adapt_gaus1,
+! all the other subroutines/functions of this module are private
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * array (src/module/array.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+!
+!*****
+!
+module adapt_gauss
+ !
+ use precision_golem
+ use array, only : packb
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ implicit none
+ !
+ private :: ki
+ real(ki) :: tol_glob
+ complex(ki) :: err_glob,res_glob
+ logical :: encore_glob
+ integer :: compt_call_glob,compt_cell_glob
+ character (len=3), parameter :: name_par = 'kro'
+ !~ integer, parameter :: n0_par = 10, n1_par = 21
+ integer, parameter :: n0_par = 7, n1_par = 15
+ integer, parameter :: compt_max_par = 40 ! maximal number of iteration
+ real(ki), parameter :: tol_max_par = 1.e-12_ki
+ integer, parameter :: nb_cell_max_par = 100000 ! maximal number of cells
+ !(limited by the memory requirement)
+ public :: adapt_gauss1
+ !
+ type intervalle
+ real(ki),dimension(1) :: point
+ real(ki) :: taille
+ complex(ki) :: resultat
+ complex(ki) :: erreur
+ logical :: divise
+ type(intervalle), pointer :: suivant
+ end type intervalle
+ !
+ contains
+ !
+ !****f* src/numerical/adapt_gauss/adapt_gauss1
+ ! NAME
+ !
+ ! Subroutine adapt_gauss1 (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! call adapt_gauss1(func,b_inf,b_sup,tol,rest,abserr)
+ !
+ ! DESCRIPTION
+ !
+ ! This subroutine performs a one dimensional adaptative integration of the
+ ! function func between b_inf and b_sup using a Gaussian quadrature
+ ! with Kronrod polynomial. The integrand is assumed to be complex. For a
+ ! certain criterium (function test_error), the range of integration is split
+ ! into two. All the cells are put into a chained list whose element are of
+ ! type intervalle
+ !
+ ! INPUTS
+ !
+ ! this subroutine takes as inputs:
+ ! * func -- an external function as declared by the interface block
+ ! * b_inf -- a real (type ki), the lower bound of the integration range
+ ! * b_sup -- a real (type ki), the upper bound of the integration range
+ ! * tol -- a real (type ki), the tolerance asked by the user
+ !
+ ! SIDE EFFECTS
+ !
+ ! no side effects
+ !
+ ! RETURN VALUE
+ !
+ ! it returns:
+ ! * rest -- a complex (type ki), the result of the integration
+ ! * abserr -- a complex (type ki), the absolute value of the estimated error
+ !
+ ! EXAMPLE
+ !
+ ! to integrate a function f
+ ! between 0 and 1 with a tolerance of 0.0001
+ ! the result is put in result
+ ! and the relative error returned in error
+ !
+ ! call adapt_gauss1(f,0._ki,1._ki,1.e-4_ki,result,error)
+ !
+ !*****
+ !
+ subroutine adapt_gauss1(func,b_inf,b_sup,tol,rest,abserr)
+ !
+ real(ki), intent (in) :: b_inf,b_sup,tol
+ complex(ki), intent (out) :: rest
+ complex(ki), intent (out) :: abserr
+ interface
+ function func(x)
+ use precision_golem
+ real(ki), intent (in) :: x
+ complex(ki) :: func
+ end function func
+ end interface
+ !
+ type(intervalle), pointer :: new
+ complex(ki) :: rest1,abserr1
+ integer :: compt
+ !
+ ! initialisation
+ !
+ rest = 0._ki
+ compt = 0
+ compt_call_glob = 0
+ compt_cell_glob = 0
+ tol_glob = 1._ki*tol
+ res_glob = 0._ki
+ err_glob = 0._ki
+ encore_glob = .true.
+ !
+ ! first evaluation into the entire range
+ !
+ call gauss1(func,b_inf,b_sup,rest1,abserr1)
+ !
+ compt_call_glob = compt_call_glob + n1_par
+ err_glob = abserr1
+ compt = compt + 1
+ compt_cell_glob = compt_cell_glob + 1
+ res_glob = rest1
+ !
+ if ( test_error(err_glob,tol_glob) ) then
+ !
+ rest = res_glob
+ abserr = err_glob
+ !
+ else ! one divides
+ !
+ call creation(new,b_inf,b_sup) ! creation of the nested list
+ res_glob = 0._ki
+ err_glob = 0._ki
+ ! call imprime(new)
+ !
+ do while ( encore_glob .and. (compt < compt_max_par) )
+ !
+ encore_glob = .false.
+ !
+ if (tol_glob >= tol_max_par) then
+ !
+ tol_glob = tol_glob/2._ki
+ !
+ else
+ !
+ tol_glob = tol_glob
+ !
+ end if
+ !
+ call decoupe(new,func) ! each cells marked TRUE are split in two
+ ! call imprime(new)
+ !
+ if (compt == (compt_max_par-1) ) then
+ !
+ call recupere_total(new) ! result of all remaining cells is collected
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'finished because the number of iterations reachs its maximum'
+ call catch_exception(1)
+ !
+ else if (compt_cell_glob > nb_cell_max_par) then
+ !
+ call recupere_total(new) ! result of all remaining cells is collected
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'finished because the number of cells reachs its maximum'
+ call catch_exception(1)
+ !
+ else
+ !
+ ! the results of FALSE cells are collected and the cells destroyed
+ call recupere_partiel(new)
+ !
+ end if
+ ! call imprime(new)
+ !
+ compt = compt + 1
+ !
+ end do
+ !
+ rest = res_glob
+ abserr = err_glob
+ !
+ call libere(new)
+ !
+ end if
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'Statistic in subroutine adapt_gauss1'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'number of function calls: %d0'
+ tab_erreur_par(2)%arg_int = compt_call_glob
+ tab_erreur_par(3)%a_imprimer = .true.
+ tab_erreur_par(3)%chaine = 'number of cells: %d0'
+ tab_erreur_par(3)%arg_int = compt_cell_glob
+ tab_erreur_par(4)%a_imprimer = .true.
+ tab_erreur_par(4)%chaine = 'number of iteration: %d0'
+ tab_erreur_par(4)%arg_int = compt
+ tab_erreur_par(5)%a_imprimer = .true.
+ tab_erreur_par(5)%chaine = 'number of Gauss points: %d1'
+ tab_erreur_par(5)%arg_int_tab = packb( (/n0_par,n1_par/) )
+ tab_erreur_par(6)%a_imprimer = .true.
+ tab_erreur_par(6)%chaine = 'Type of polynom: %c0'
+ tab_erreur_par(6)%arg_char = name_par
+ tab_erreur_par(7)%a_imprimer = .true.
+ tab_erreur_par(7)%chaine = 'Tolerance: %f0'
+ tab_erreur_par(7)%arg_real = tol
+ call catch_exception(2)
+ !
+ end subroutine adapt_gauss1
+ !
+ !****if* src/numerical/adapt_gauss/relative_error
+ ! NAME
+ !
+ ! function test_error (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! logical = test_error(error,tol)
+ !
+ ! DESCRIPTION
+ !
+ ! This function tests the error compared to the tolerance required, it
+ ! returns a value of type logical
+ !
+ ! INPUTS
+ !
+ ! this function take two arguments:
+ ! * error -- a complex (type ki), the absolute error
+ ! * tol -- the required tolerance
+ !
+ ! SIDE EFFECTS
+ !
+ ! no side effects
+ !
+ ! RETURN VALUE
+ !
+ ! test_error is a logical
+ !
+ ! EXAMPLE
+ !
+ !*****
+ !
+ function test_error(error,tol)
+ !
+ complex(ki), intent(in) :: error
+ real(ki), intent(in) :: tol
+ !
+ logical :: test_error
+ real(ki) :: tempa,tempb
+ !
+ tempa = real(error,ki)
+ tempb = aimag(error)
+ test_error = ( (abs(tempa) <= tol) .and. (abs(tempb) <= tol) ) .or. &
+ & ( (abs(tempa) <= tol_max_par) .and. (abs(tempb) <= tol_max_par) )
+ !
+ end function test_error
+ !
+ !****if* src/numerical/adapt_gauss/creation
+ ! NAME
+ !
+ ! subroutine creation (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! call creation(new,b_inf,b_sup)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine creates a chained list new whose elments are of type
+ ! intervalle. The pointer of the last element of the list must be null
+ ! (i.e. points on nothing). Norma f95 is used. Variables ending by _glob are
+ ! global for this module
+ !
+ !
+ ! INPUTS
+ !
+ ! * new -- an intervalle type, a pointer on the chained list
+ ! * b_inf -- a real (type ki), lower value of the list
+ ! * b_sup -- a real (type ki), upper value of the list
+ !
+ ! SIDE EFFECTS
+ !
+ ! no side effects
+ !
+ ! RETURN VALUE
+ !
+ ! after the call, new is pointer on a chained list
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine creation(new,b_inf,b_sup)
+ !
+ type(intervalle), pointer :: new
+ real(ki), intent (in) :: b_inf,b_sup
+ !
+ type(intervalle), pointer :: init,fin
+ integer :: res
+ !
+ allocate(fin,stat=res)
+ !
+ if (res /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine creation (module numerical_evaluation)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'enable to allocate fin %d0'
+ tab_erreur_par(2)%arg_int = res
+ call catch_exception(0)
+ !
+ end if
+ !
+ allocate(init,stat=res)
+ !
+ if (res /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine creation (module numerical_evaluation)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'enable to allocate init %d0'
+ tab_erreur_par(2)%arg_int = res
+ call catch_exception(0)
+ !
+ end if
+ !
+ fin%point = (/b_sup/)
+ fin%taille = 0._ki
+ fin%resultat = (0._ki,0._ki)
+ fin%erreur = 0._ki
+ fin%divise = .false.
+ fin%suivant => null()
+ new => fin
+ !
+ init%point = (/b_inf/)
+ init%taille = b_sup - b_inf
+ init%resultat = res_glob
+ init%erreur = err_glob
+ init%divise = .true.
+ init%suivant => fin
+ new => init
+ !
+ end subroutine creation
+ !
+ !****if* src/numerical/adapt_gauss/decoupe
+ ! NAME
+ !
+ ! recursive subroutine decoupe (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! call decoupe(new,func)
+ !
+ ! DESCRIPTION
+ !
+ ! For each cell of the chained list, this routine splits a 1-dimension cell
+ ! into 2 subcells if the cell is marked true For the two sub-cells, it computes
+ ! the integral in the sub-cell and marks it true of false depending the error
+ ! returned. Note that since this subroutine is recursive, it acts
+ ! globaly on the whole chained list containing the cells
+ !
+ !
+ ! INPUTS
+ !
+ ! * new -- a pointer (type intervalle) on the chained list
+ ! * func -- an external function R --> C, the integrand
+ !
+ ! SIDE EFFECTS
+ !
+ ! this routine modify the chained list whose the first pointer is new
+ !
+ ! RETURN VALUE
+ !
+ ! no return value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ recursive subroutine decoupe(new,func)
+ !
+ type(intervalle), pointer :: new
+ interface
+ function func(x)
+ use precision_golem
+ real(ki), intent (in) :: x
+ complex(ki) :: func
+ end function func
+ end interface
+ !
+ type(intervalle), pointer :: nouveau => null()
+ real(ki), dimension(1) :: vx
+ real(ki) :: n_taille
+ complex(ki) :: rest1_loc,abserr1_loc
+ logical :: div
+ integer :: res
+ !
+ if (associated(new%suivant)) then ! if this is not the last cell
+ !
+ if (new%divise) then ! if one has to split
+ !
+ n_taille = new%taille/2._ki
+ vx = (/n_taille/)
+ new%taille = n_taille
+ !
+ call gauss1(func,new%point(1),new%point(1)+new%taille,&
+ &rest1_loc,abserr1_loc)
+ !
+ compt_call_glob = compt_call_glob + n1_par
+ new%erreur = abserr1_loc
+ compt_cell_glob = compt_cell_glob + 1
+ new%resultat = rest1_loc
+ !
+ if ( test_error(new%erreur,tol_glob) ) then
+ !
+ div = .false.
+ !
+ else
+ !
+ div = .true.
+ !
+ end if
+ !
+ new%divise = div
+ allocate(nouveau,stat=res)
+ !
+ if (res /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine decoupe (module numerical_evaluation)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the allocation runs into trouble %d0'
+ tab_erreur_par(2)%arg_int = res
+ call catch_exception(0)
+ !
+ end if
+ !
+ nouveau%point = new%point + vx
+ nouveau%taille = n_taille
+ call gauss1(func,nouveau%point(1),nouveau%point(1)+nouveau%taille,&
+ &rest1_loc,abserr1_loc)
+ compt_call_glob = compt_call_glob + n1_par
+ nouveau%erreur = abserr1_loc
+ nouveau%resultat = rest1_loc
+ !
+ if ( test_error(nouveau%erreur,tol_glob) ) then
+ !
+ div = .false.
+ !
+ else
+ !
+ div = .true.
+ !
+ end if
+ !
+ nouveau%divise = div
+ nouveau%suivant => new%suivant
+ new%suivant => nouveau
+ compt_cell_glob = compt_cell_glob + 1
+ call decoupe(nouveau%suivant,func)
+ !
+ else
+ !
+ call decoupe(new%suivant,func)
+ !
+ end if
+ !
+ end if
+ !
+ end subroutine decoupe
+ !
+ !****if* src/numerical/adapt_gauss/recupere_total
+ ! NAME
+ !
+ ! recursive subroutine recupere_total (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! call recupere_total(new)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine collects the value of the integrant in each cell
+ ! (as well as the error). It acts globaly on the chained list
+ !
+ !
+ ! INPUTS
+ !
+ ! * new -- a pointer on the first entry of the chained list
+ !
+ ! SIDE EFFECTS
+ !
+ ! this routine modifies the global (for this module) variables:
+ ! * res_glob -- sum of the result of the integral for each cell
+ ! * err_glob -- sum of the error for each cell
+ !
+ ! RETURN VALUE
+ !
+ ! no returned value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ recursive subroutine recupere_total(new)
+ !
+ type(intervalle), pointer :: new
+ !
+ if (associated(new%suivant)) then
+ !
+ res_glob = res_glob + new%resultat
+ err_glob = err_glob + new%erreur
+ !
+ call recupere_total(new%suivant)
+ !
+ end if
+ !
+ end subroutine recupere_total
+ !
+ !****if* src/numerical/adapt_gauss/recupere_partiel
+ ! NAME
+ !
+ ! recursive subroutine recupere_partiel (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! call recupere_partiel(new)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine collects the value of the integrant only in cell marked FALSE
+ ! (as well as the error) and removes these cells to save space
+ !
+ !
+ ! INPUTS
+ !
+ ! * new -- a pointer (type inetrvalle) pointing on the first entry of the chained list
+ !
+ ! SIDE EFFECTS
+ !
+ ! this routine modifies the global (for this module) variables:
+ ! * res_glob -- sum of the result of the integral for each cell
+ ! * err_glob -- sum of the error for each cell
+ ! * encore_glob -- a logical, to know if there are cells marked true
+ !
+ ! RETURN VALUE
+ !
+ ! no returned value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ recursive subroutine recupere_partiel(new)
+ !
+ type(intervalle), pointer :: new
+ !
+ type(intervalle), pointer :: temp
+ type(intervalle), pointer :: temp1
+ integer :: res
+ !
+ if (associated(new%suivant)) then
+ !
+ call recupere_partiel(new%suivant)
+ encore_glob = encore_glob .or. new%divise
+ !
+ if (.not.new%divise) then
+ !
+ res_glob = res_glob + new%resultat
+ err_glob = err_glob + new%erreur
+ temp => new
+ temp1 => new%suivant
+ new => temp1
+ !
+ deallocate(temp,stat=res)
+ !
+ if (res /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine recupere_partiel (module numerical_evaluation)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the deallocation runs into trouble %d0'
+ tab_erreur_par(2)%arg_int = res
+ call catch_exception(0)
+ !
+ end if
+ !
+ end if
+ !
+ end if
+ !
+ end subroutine recupere_partiel
+ !
+ !****if* src/numerical/adapt_gauss/imprime
+ ! NAME
+ !
+ ! recursive subroutine imprime (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! call imprime(new)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine prints the value of the element of the chained list
+ ! i.e. the structure of each cell
+ !
+ !
+ ! INPUTS
+ !
+ ! * new -- a pointer (type inetrvalle) pointing on the first entry of the chained list
+ !
+ ! SIDE EFFECTS
+ !
+ ! no side effects
+ !
+ ! RETURN VALUE
+ !
+ ! no returned value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ recursive subroutine imprime(new)
+ !
+ type(intervalle), pointer :: new
+ !
+ if (associated(new%suivant)) then
+ !
+ write (*,'("borne inf",1f16.8,2x,"taille ",f16.8,2x,&
+ &" on divise? ",l2)')&
+ & new%point,new%taille,new%divise
+ write (*,'("resultat",2f16.8,2x,"erreur ",2e16.8)')&
+ & new%resultat,new%erreur
+ !
+ call imprime(new%suivant)
+ !
+ end if
+ !
+ end subroutine imprime
+ !
+ !****if* src/numerical/adapt_gauss/libere
+ ! NAME
+ !
+ ! recursive subroutine libere (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! call libere(new)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine deallocates all the elements of the chained list
+ !
+ ! INPUTS
+ !
+ ! * new -- a pointer (type inetrvalle) pointing on the first entry of the chained list
+ !
+ ! SIDE EFFECTS
+ !
+ ! destroy the chained list
+ !
+ ! RETURN VALUE
+ !
+ ! no returned value
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ recursive subroutine libere(new)
+ !
+ type(intervalle), pointer :: new
+ !
+ integer :: res
+ !
+ if (associated(new%suivant)) call libere(new%suivant)
+ !
+ deallocate(new,stat=res)
+ !
+ if (res /= 0) then
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine libere (module numerical_evaluation)'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the deallocation runs into trouble %d0'
+ tab_erreur_par(2)%arg_int = res
+ call catch_exception(0)
+ !
+ end if
+ !
+ end subroutine libere
+ !
+ !****if* src/numerical/adapt_gauss/give_me_the_weight
+ ! NAME
+ !
+ ! subroutine give_me_the_weight (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! call give_me_the_weight(nomb,name,weight,zero)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine gives the weight and zero for Legendre polynomials of
+ ! degrees : n=7,10 (created with maple file poid_gauss.m)
+ ! and also the weight and zero for Kronrod polynomials of degrees 15,21
+ ! in such a way the zeros of the Legendre polynomial of degree 7 (resp. 10)
+ ! is between the zeros of the Kronrod polynomial of degree 15 (resp. 21).
+ !
+ ! INPUTS
+ !
+ ! * nomb -- an integer, the degree of the Legendre/Kronrod polynomials
+ ! * name -- a character (dimension 3), the name of the polynom
+ !
+ ! SIDE EFFECTS
+ !
+ ! no side effects
+ !
+ ! RETURN VALUE
+ !
+ ! * weight -- an array of real (type ki) containing the weights
+ ! * zero -- an array of real (type ki) containing the zero of the polynomials
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine give_me_the_weight(nomb,name,weight,zero)
+ !
+ integer, intent (in) :: nomb
+ character (len=3), intent (in) :: name
+ real(ki), intent (out), dimension(:) :: weight,zero
+ !
+ ! poids et abscisses pour les polynomes de Legendre
+ ! (calcule avec poid_gauss.m)
+ !
+ real(ki), dimension(7) :: zero_leg_7=(/&
+ &-0.9491079123427585_ki,-0.7415311855993944_ki,&
+ &-0.4058451513773972_ki,0.0000000000000000_ki,&
+ &0.4058451513773972_ki,0.7415311855993944_ki,&
+ &0.9491079123427585_ki&
+ &/)
+ real(ki), dimension(7) :: weight_leg_7=(/&
+ &0.1294849661688697_ki,0.2797053914892767_ki,&
+ &0.3818300505051189_ki,0.4179591836734694_ki,&
+ &0.3818300505051189_ki,0.2797053914892767_ki,&
+ &0.1294849661688697_ki&
+ &/)
+ real(ki), dimension(10) :: zero_leg_10=(/&
+ &-0.9739065285171717_ki,-0.8650633666889845_ki,&
+ &-0.6794095682990244_ki,-0.4333953941292472_ki,&
+ &-0.1488743389816312_ki,0.1488743389816312_ki,&
+ &0.4333953941292472_ki,0.6794095682990244_ki,&
+ &0.8650633666889845_ki,0.9739065285171717_ki&
+ &/)
+ real(ki), dimension(10) :: weight_leg_10=(/&
+ &0.0666713443086881_ki,0.1494513491505806_ki,&
+ &0.2190863625159820_ki,0.2692667193099964_ki,&
+ &0.2955242247147529_ki,0.2955242247147529_ki,&
+ &0.2692667193099964_ki,0.2190863625159820_ki,&
+ &0.1494513491505806_ki,0.0666713443086881_ki&
+ &/)
+ !
+ ! poids et abscisses pour les polynomes de Kronrod (pris sur le WEB)
+ !
+ real(ki), dimension(15) :: zero_kro_15=(/&
+ &-0.9914553711208126_ki,-0.9491079123427585_ki,&
+ &-0.8648644233597691_ki,-0.7415311855993944_ki,&
+ &-0.5860872354676911_ki,-0.4058451513773972_ki,&
+ &-0.2077849550789850_ki,0.0e+00_ki,&
+ &0.2077849550789850_ki,0.4058451513773972_ki,&
+ &0.5860872354676911_ki,0.7415311855993944_ki,&
+ &0.8648644233597691_ki,0.9491079123427585_ki,&
+ &0.9914553711208126_ki&
+ &/)
+ real(ki), dimension(15) :: weight_kro_15=(/&
+ &0.2293532201052922e-01_ki,0.6309209262997855e-01_ki,&
+ &0.1047900103222502_ki,0.1406532597155259_ki,&
+ &0.1690047266392679_ki,0.1903505780647854_ki,&
+ &0.2044329400752989_ki,0.2094821410847278_ki,&
+ &0.2044329400752989_ki,0.1903505780647854_ki,&
+ &0.1690047266392679_ki,0.1406532597155259_ki,&
+ &0.1047900103222502_ki,0.6309209262997855e-01_ki,&
+ &0.2293532201052922e-01_ki&
+ &/)
+ !
+ real(ki), dimension(21) :: zero_kro_21=(/&
+ &-0.9956571630258081e+00_ki,-0.9739065285171717e+00_ki,&
+ &-0.9301574913557082e+00_ki,-0.8650633666889845e+00_ki,&
+ &-0.7808177265864169e+00_ki,-0.6794095682990244e+00_ki,&
+ &-0.5627571346686047e+00_ki,-0.4333953941292472e+00_ki,&
+ &-0.2943928627014602e+00_ki,-0.1488743389816312e+00_ki,&
+ &0.0e+00_ki,0.1488743389816312e+00_ki,&
+ &0.2943928627014602e+00_ki,0.4333953941292472e+00_ki,&
+ &0.5627571346686047e+00_ki,0.6794095682990244e+00_ki,&
+ &0.7808177265864169e+00_ki,0.8650633666889845e+00_ki,&
+ &0.9301574913557082e+00_ki,0.9739065285171717e+00_ki,&
+ &0.9956571630258081e+00_ki&
+ &/)
+ !
+ real(ki), dimension(21) :: weight_kro_21=(/&
+ &0.1169463886737187e-01_ki,0.3255816230796473e-01_ki,&
+ &0.5475589657435200e-01_ki,0.7503967481091995e-01_ki,&
+ &0.9312545458369761e-01_ki,0.1093871588022976e+00_ki,&
+ &0.1234919762620659e+00_ki,0.1347092173114733e+00_ki,&
+ &0.1427759385770601e+00_ki,0.1477391049013385e+00_ki,&
+ &0.1494455540029169e+00_ki,0.1477391049013385e+00_ki,&
+ &0.1427759385770601e+00_ki,0.1347092173114733e+00_ki,&
+ &0.1234919762620659e+00_ki,0.1093871588022976e+00_ki,&
+ &0.9312545458369761e-01_ki,0.7503967481091995e-01_ki,&
+ &0.5475589657435200e-01_ki,0.3255816230796473e-01_ki,&
+ &0.1169463886737187e-01_ki&
+ &/)
+ !
+ if (name == 'leg') then
+ !
+ if (nomb == 7) then
+ !
+ weight = weight_leg_7
+ zero = zero_leg_7
+ !
+ else if (nomb == 10) then
+ !
+ weight = weight_leg_10
+ zero = zero_leg_10
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine give_me_the_weight'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the number of point is incorrect for &
+ &Legendre weights: %d0'
+ tab_erreur_par(2)%arg_int = nomb
+ call catch_exception(0)
+ !
+ end if
+ !
+ else if (name == 'kro') then
+ !
+ if (nomb == 15) then
+ !
+ weight = weight_kro_15
+ zero = zero_kro_15
+ !
+ else if (nomb == 21) then
+ !
+ weight = weight_kro_21
+ zero = zero_kro_21
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine give_me_the_weight'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the number of point is incorrect for &
+ &Kronrod weights: %d0'
+ tab_erreur_par(2)%arg_int = nomb
+ call catch_exception(0)
+ !
+ end if
+ !
+ end if
+ !
+ end subroutine give_me_the_weight
+ !
+ !
+ !****if* src/numerical/adapt_gauss/gauss1
+ ! NAME
+ !
+ ! subroutine gauss1 (file src/numerical/adapt_gauss.f90)
+ !
+ ! USAGE
+ !
+ ! call gauss1(func,b_inf,b_sup,rest,err)
+ !
+ ! DESCRIPTION
+ !
+ ! This routine computes the one dimensional integration using
+ ! the Gauss-Kronrod method of the function func in the range
+ ! b_inf to b_sup
+ !
+ !
+ ! INPUTS
+ !
+ ! * func -- an external function from R to C
+ ! * b_inf -- a real (type ki), lower bound of the integration
+ ! * b_sup -- a real (type ki), upper bound of the integration
+ !
+ ! SIDE EFFECTS
+ !
+ ! no side effects
+ !
+ ! RETURN VALUE
+ !
+ ! * rest -- a complex (type ki), the result of the integration
+ ! * err -- a complex (type ki), the estimate of the absolute error returned
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ !
+ subroutine gauss1(func,b_inf,b_sup,rest,err)
+ !
+ real(ki), intent (in) :: b_inf,b_sup
+ complex(ki), intent (out) :: rest
+ complex(ki), intent (out) :: err
+ !
+ interface
+ !
+ function func(x)
+ use precision_golem
+ real(ki), intent (in) :: x
+ complex(ki) :: func
+ end function func
+ !
+ end interface
+ !
+ real(ki), dimension(n1_par) :: weight,zero
+ real(ki), dimension(:), allocatable :: weight_leg,zero_leg
+ integer :: i,j
+ real(ki) :: hm,hp
+ real(ki) :: argg,argk
+ complex(ki) :: tg,tk
+ complex(ki) :: restg,restk,restg_leg
+ !
+ ! call for the Kronrod zeros and weights
+ !
+ call give_me_the_weight(n1_par,'kro',weight,zero)
+ rest = 0._ki
+ err = 1._ki
+ allocate(weight_leg(n0_par),zero_leg(n0_par))
+ !
+ ! call for the Legendre zeros and weights
+ !
+ call give_me_the_weight(n0_par,'leg',weight_leg,zero_leg)
+ restg_leg = rest
+ restg = rest
+ restk = rest
+ hm = (b_sup - b_inf)/2._ki
+ hp = (b_sup + b_inf)/2._ki
+ !
+ do i=1,n1_par-1,2
+ !
+ argk = hm*zero(i)+hp
+ argg = hm*zero(i+1)+hp
+ tk = func(argk)
+ tg = func(argg)
+ restk = restk + weight(i)*tk
+ restg = restg + weight(i+1)*tg
+ j = (i+1)/2
+ restg_leg = restg_leg + weight_leg(j)*tg
+ !
+ end do
+ !
+ argk = hm*zero(n1_par)+hp
+ restk = restk + weight(n1_par)*func(argk)
+ rest = (restg+restk)*hm
+ err = rest-restg_leg*hm
+ !
+ deallocate(weight_leg,zero_leg)
+ !
+ end subroutine gauss1
+ !
+end module adapt_gauss
diff --git a/golem95c-1.2.1/numerical/mod_numeric.f90 b/golem95c-1.2.1/numerical/mod_numeric.f90
new file mode 100644
index 0000000..2f88be1
--- /dev/null
+++ b/golem95c-1.2.1/numerical/mod_numeric.f90
@@ -0,0 +1,112 @@
+!****h* src/numerical/numerical_evaluation
+! NAME
+!
+! Module numerical_evaluation
+!
+! USAGE
+!
+! use numerical_evaluation
+!
+! DESCRIPTION
+!
+! This module contains a generic routine for a one dimensional integration.
+! Up to now, the routine used is adapt_gauss1 (in file mod_adapt_gauss.f90).
+! To add a new integration routine, wrap it in a module, load this module
+! in this file using use association and add a new if case in the routine generic_eval_numer
+! also modify the value of choix accordingly. Of course, do not forget to modify the
+! Makefile (or better the script configure,pl) in such a way that this new module is compiled
+!
+! OUTPUT
+!
+! With this module, one can access to the routine generic_eval_numer
+!
+! USES
+!
+! * precision (src/module/precision_golem.f90)
+! * sortie_erreur (src/module/sortie_erreur.f90)
+! * parametre (src/module/parametre.f90)
+! * adapt_gauss (src/numerical/mod_adapt_gauss.f90)
+!
+!*****
+!
+module numerical_evaluation
+ !
+ use precision_golem
+ use sortie_erreur, only : tab_erreur_par,catch_exception
+ use adapt_gauss
+ implicit none
+ !
+ integer, parameter :: choix = 1
+ private :: ki,choix
+ public :: generic_eval_numer
+ !
+ contains
+ !
+ !****f* src/numerical/numerical_evaluation/generic_eval_numer
+ ! NAME
+ !
+ ! Subroutine generic_eval_numer
+ !
+ ! USAGE
+ !
+ ! call generic_eval_numer(func,b_inf,b_sup,tol,rest,abserr)
+ !
+ ! DESCRIPTION
+ !
+ ! Generic routine for the one dimensional integration.
+ !
+ ! INPUTS
+ !
+ ! * func -- an external function as declared by the interface block
+ ! * b_inf -- a real (type ki), the lower bound of the integration range
+ ! * b_sup -- a real (type ki), the upper bound of the integration range
+ ! * tol -- a real (type ki), the tolerance asked by the user
+ !
+ ! SIDE EFFECTS
+ !
+ ! no side effects
+ !
+ ! RETURN VALUE
+ !
+ ! * rest -- a complex (type ki), the result of the integration
+ ! * abserr -- a complex (type ki), the absolute value of the estimated error
+ !
+ ! EXAMPLE
+ !
+ !
+ !
+ !*****
+ subroutine generic_eval_numer(func,b_inf,b_sup,tol,rest,abserr)
+ !
+ real(ki), intent (in) :: b_inf,b_sup,tol
+ complex(ki), intent (out) :: rest
+ complex(ki), intent (out) :: abserr
+ !
+ interface
+ !
+ function func(x)
+ use precision_golem
+ real(ki), intent (in) :: x
+ complex(ki) :: func
+ end function func
+ !
+ end interface
+ !
+ if (choix == 1) then
+ !
+ call adapt_gauss1(func,b_inf,b_sup,tol,rest,abserr)
+ !
+ else
+ !
+ tab_erreur_par(1)%a_imprimer = .true.
+ tab_erreur_par(1)%chaine = 'In subroutine generic_eval_numer'
+ tab_erreur_par(2)%a_imprimer = .true.
+ tab_erreur_par(2)%chaine = 'the value of the variable choix is not correct : choix=%d0'
+ tab_erreur_par(2)%arg_int = choix
+ call catch_exception(0)
+ !
+ end if
+ !
+ end subroutine generic_eval_numer
+ !
+end module numerical_evaluation
diff --git a/gosam.conf.in b/gosam.conf.in
new file mode 100644
index 0000000..21055e0
--- /dev/null
+++ b/gosam.conf.in
@@ -0,0 +1,36 @@
+#================================================
+$prefix=@prefix@
+$exec_prefix=@exec_prefix@
+$libdir=@libdir@
+$pkgincludedir=@includedir@/@PACKAGE@
+#================================================
+
+#---#[ FF:
+@conf_with_ff@+z0099.extensions=gosam-contrib_libff
+@conf_with_ff@+gosam-contrib_libff.ldflags=-L${libdir} -lff
+@conf_with_ff@+gosam-contrib_libff.fcflags=-I${pkgincludedir}
+#---#] FF:
+#---#[ QCDLoop:
+@conf_with_ql@+z0095.extensions=gosam-contrib_libql
+@conf_with_ql@+gosam-contrib_libql.ldflags=-L${libdir} -lqcdloop
+@conf_with_ql@+gosam-contrib_libql.fcflags=-I${pkgincludedir}
+#---#] QCDLoop:
+#---#[ avh_olo:
+@conf_with_olo@+z0094.extensions=gosam-contrib_libolo
+@conf_with_olo@+gosam-contrib_libolo.ldflags=-L${libdir} -lavh_olo
+@conf_with_olo@+gosam-contrib_libolo.fcflags=-I${pkgincludedir}
+#---#] avh_olo:
+#---#[ Golem95C:
+@conf_with_golem95@golem95.fcflags=-I${pkgincludedir}
+@conf_with_golem95@golem95.ldflags=-L${libdir} -lgolem
+#---#] Golem95C:
+#---#[ Samurai:
+@conf_with_samurai@samurai.fcflags=-I${pkgincludedir}
+@conf_with_samurai@samurai.ldflags=-L${libdir} -lsamurai
+@conf_with_samurai@samurai.version=2.1.1
+#---#] Samurai:
+#---#[ Fortran Compiler:
++z0005.extensions=gosam-contrib_fc
++gosam-contrib_fc.fcflags=@FCFLAGS@
+fc.bin=@FC@
+#---#] Fortran Compiler:
diff --git a/m4/libtool.m4 b/m4/libtool.m4
new file mode 100644
index 0000000..d812584
--- /dev/null
+++ b/m4/libtool.m4
@@ -0,0 +1,7831 @@
+# libtool.m4 - Configure libtool for the host system. -*-Autoconf-*-
+#
+# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2005,
+# 2006, 2007, 2008, 2009, 2010 Free Software Foundation,
+# Inc.
+# Written by Gordon Matzigkeit, 1996
+#
+# This file is free software; the Free Software Foundation gives
+# unlimited permission to copy and/or distribute it, with or without
+# modifications, as long as this notice is preserved.
+
+m4_define([_LT_COPYING], [dnl
+# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2005,
+# 2006, 2007, 2008, 2009, 2010 Free Software Foundation,
+# Inc.
+# Written by Gordon Matzigkeit, 1996
+#
+# This file is part of GNU Libtool.
+#
+# GNU Libtool is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of
+# the License, or (at your option) any later version.
+#
+# As a special exception to the GNU General Public License,
+# if you distribute this file as part of a program or library that
+# is built using GNU Libtool, you may include this file under the
+# same distribution terms that you use for the rest of that program.
+#
+# GNU Libtool is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GNU Libtool; see the file COPYING. If not, a copy
+# can be downloaded from http://www.gnu.org/licenses/gpl.html, or
+# obtained by writing to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+])
+
+# serial 57 LT_INIT
+
+
+# LT_PREREQ(VERSION)
+# ------------------
+# Complain and exit if this libtool version is less that VERSION.
+m4_defun([LT_PREREQ],
+[m4_if(m4_version_compare(m4_defn([LT_PACKAGE_VERSION]), [$1]), -1,
+ [m4_default([$3],
+ [m4_fatal([Libtool version $1 or higher is required],
+ 63)])],
+ [$2])])
+
+
+# _LT_CHECK_BUILDDIR
+# ------------------
+# Complain if the absolute build directory name contains unusual characters
+m4_defun([_LT_CHECK_BUILDDIR],
+[case `pwd` in
+ *\ * | *\ *)
+ AC_MSG_WARN([Libtool does not cope well with whitespace in `pwd`]) ;;
+esac
+])
+
+
+# LT_INIT([OPTIONS])
+# ------------------
+AC_DEFUN([LT_INIT],
+[AC_PREREQ([2.58])dnl We use AC_INCLUDES_DEFAULT
+AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl
+AC_BEFORE([$0], [LT_LANG])dnl
+AC_BEFORE([$0], [LT_OUTPUT])dnl
+AC_BEFORE([$0], [LTDL_INIT])dnl
+m4_require([_LT_CHECK_BUILDDIR])dnl
+
+dnl Autoconf doesn't catch unexpanded LT_ macros by default:
+m4_pattern_forbid([^_?LT_[A-Z_]+$])dnl
+m4_pattern_allow([^(_LT_EOF|LT_DLGLOBAL|LT_DLLAZY_OR_NOW|LT_MULTI_MODULE)$])dnl
+dnl aclocal doesn't pull ltoptions.m4, ltsugar.m4, or ltversion.m4
+dnl unless we require an AC_DEFUNed macro:
+AC_REQUIRE([LTOPTIONS_VERSION])dnl
+AC_REQUIRE([LTSUGAR_VERSION])dnl
+AC_REQUIRE([LTVERSION_VERSION])dnl
+AC_REQUIRE([LTOBSOLETE_VERSION])dnl
+m4_require([_LT_PROG_LTMAIN])dnl
+
+_LT_SHELL_INIT([SHELL=${CONFIG_SHELL-/bin/sh}])
+
+dnl Parse OPTIONS
+_LT_SET_OPTIONS([$0], [$1])
+
+# This can be used to rebuild libtool when needed
+LIBTOOL_DEPS="$ltmain"
+
+# Always use our own libtool.
+LIBTOOL='$(SHELL) $(top_builddir)/libtool'
+AC_SUBST(LIBTOOL)dnl
+
+_LT_SETUP
+
+# Only expand once:
+m4_define([LT_INIT])
+])# LT_INIT
+
+# Old names:
+AU_ALIAS([AC_PROG_LIBTOOL], [LT_INIT])
+AU_ALIAS([AM_PROG_LIBTOOL], [LT_INIT])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_PROG_LIBTOOL], [])
+dnl AC_DEFUN([AM_PROG_LIBTOOL], [])
+
+
+# _LT_CC_BASENAME(CC)
+# -------------------
+# Calculate cc_basename. Skip known compiler wrappers and cross-prefix.
+m4_defun([_LT_CC_BASENAME],
+[for cc_temp in $1""; do
+ case $cc_temp in
+ compile | *[[\\/]]compile | ccache | *[[\\/]]ccache ) ;;
+ distcc | *[[\\/]]distcc | purify | *[[\\/]]purify ) ;;
+ \-*) ;;
+ *) break;;
+ esac
+done
+cc_basename=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"`
+])
+
+
+# _LT_FILEUTILS_DEFAULTS
+# ----------------------
+# It is okay to use these file commands and assume they have been set
+# sensibly after `m4_require([_LT_FILEUTILS_DEFAULTS])'.
+m4_defun([_LT_FILEUTILS_DEFAULTS],
+[: ${CP="cp -f"}
+: ${MV="mv -f"}
+: ${RM="rm -f"}
+])# _LT_FILEUTILS_DEFAULTS
+
+
+# _LT_SETUP
+# ---------
+m4_defun([_LT_SETUP],
+[AC_REQUIRE([AC_CANONICAL_HOST])dnl
+AC_REQUIRE([AC_CANONICAL_BUILD])dnl
+AC_REQUIRE([_LT_PREPARE_SED_QUOTE_VARS])dnl
+AC_REQUIRE([_LT_PROG_ECHO_BACKSLASH])dnl
+
+_LT_DECL([], [host_alias], [0], [The host system])dnl
+_LT_DECL([], [host], [0])dnl
+_LT_DECL([], [host_os], [0])dnl
+dnl
+_LT_DECL([], [build_alias], [0], [The build system])dnl
+_LT_DECL([], [build], [0])dnl
+_LT_DECL([], [build_os], [0])dnl
+dnl
+AC_REQUIRE([AC_PROG_CC])dnl
+AC_REQUIRE([LT_PATH_LD])dnl
+AC_REQUIRE([LT_PATH_NM])dnl
+dnl
+AC_REQUIRE([AC_PROG_LN_S])dnl
+test -z "$LN_S" && LN_S="ln -s"
+_LT_DECL([], [LN_S], [1], [Whether we need soft or hard links])dnl
+dnl
+AC_REQUIRE([LT_CMD_MAX_LEN])dnl
+_LT_DECL([objext], [ac_objext], [0], [Object file suffix (normally "o")])dnl
+_LT_DECL([], [exeext], [0], [Executable file suffix (normally "")])dnl
+dnl
+m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+m4_require([_LT_CHECK_SHELL_FEATURES])dnl
+m4_require([_LT_PATH_CONVERSION_FUNCTIONS])dnl
+m4_require([_LT_CMD_RELOAD])dnl
+m4_require([_LT_CHECK_MAGIC_METHOD])dnl
+m4_require([_LT_CHECK_SHAREDLIB_FROM_LINKLIB])dnl
+m4_require([_LT_CMD_OLD_ARCHIVE])dnl
+m4_require([_LT_CMD_GLOBAL_SYMBOLS])dnl
+m4_require([_LT_WITH_SYSROOT])dnl
+
+_LT_CONFIG_LIBTOOL_INIT([
+# See if we are running on zsh, and set the options which allow our
+# commands through without removal of \ escapes INIT.
+if test -n "\${ZSH_VERSION+set}" ; then
+ setopt NO_GLOB_SUBST
+fi
+])
+if test -n "${ZSH_VERSION+set}" ; then
+ setopt NO_GLOB_SUBST
+fi
+
+_LT_CHECK_OBJDIR
+
+m4_require([_LT_TAG_COMPILER])dnl
+
+case $host_os in
+aix3*)
+ # AIX sometimes has problems with the GCC collect2 program. For some
+ # reason, if we set the COLLECT_NAMES environment variable, the problems
+ # vanish in a puff of smoke.
+ if test "X${COLLECT_NAMES+set}" != Xset; then
+ COLLECT_NAMES=
+ export COLLECT_NAMES
+ fi
+ ;;
+esac
+
+# Global variables:
+ofile=libtool
+can_build_shared=yes
+
+# All known linkers require a `.a' archive for static linking (except MSVC,
+# which needs '.lib').
+libext=a
+
+with_gnu_ld="$lt_cv_prog_gnu_ld"
+
+old_CC="$CC"
+old_CFLAGS="$CFLAGS"
+
+# Set sane defaults for various variables
+test -z "$CC" && CC=cc
+test -z "$LTCC" && LTCC=$CC
+test -z "$LTCFLAGS" && LTCFLAGS=$CFLAGS
+test -z "$LD" && LD=ld
+test -z "$ac_objext" && ac_objext=o
+
+_LT_CC_BASENAME([$compiler])
+
+# Only perform the check for file, if the check method requires it
+test -z "$MAGIC_CMD" && MAGIC_CMD=file
+case $deplibs_check_method in
+file_magic*)
+ if test "$file_magic_cmd" = '$MAGIC_CMD'; then
+ _LT_PATH_MAGIC
+ fi
+ ;;
+esac
+
+# Use C for the default configuration in the libtool script
+LT_SUPPORTED_TAG([CC])
+_LT_LANG_C_CONFIG
+_LT_LANG_DEFAULT_CONFIG
+_LT_CONFIG_COMMANDS
+])# _LT_SETUP
+
+
+# _LT_PREPARE_SED_QUOTE_VARS
+# --------------------------
+# Define a few sed substitution that help us do robust quoting.
+m4_defun([_LT_PREPARE_SED_QUOTE_VARS],
+[# Backslashify metacharacters that are still active within
+# double-quoted strings.
+sed_quote_subst='s/\([["`$\\]]\)/\\\1/g'
+
+# Same as above, but do not quote variable references.
+double_quote_subst='s/\([["`\\]]\)/\\\1/g'
+
+# Sed substitution to delay expansion of an escaped shell variable in a
+# double_quote_subst'ed string.
+delay_variable_subst='s/\\\\\\\\\\\$/\\\\\\$/g'
+
+# Sed substitution to delay expansion of an escaped single quote.
+delay_single_quote_subst='s/'\''/'\'\\\\\\\'\''/g'
+
+# Sed substitution to avoid accidental globbing in evaled expressions
+no_glob_subst='s/\*/\\\*/g'
+])
+
+# _LT_PROG_LTMAIN
+# ---------------
+# Note that this code is called both from `configure', and `config.status'
+# now that we use AC_CONFIG_COMMANDS to generate libtool. Notably,
+# `config.status' has no value for ac_aux_dir unless we are using Automake,
+# so we pass a copy along to make sure it has a sensible value anyway.
+m4_defun([_LT_PROG_LTMAIN],
+[m4_ifdef([AC_REQUIRE_AUX_FILE], [AC_REQUIRE_AUX_FILE([ltmain.sh])])dnl
+_LT_CONFIG_LIBTOOL_INIT([ac_aux_dir='$ac_aux_dir'])
+ltmain="$ac_aux_dir/ltmain.sh"
+])# _LT_PROG_LTMAIN
+
+
+## ------------------------------------- ##
+## Accumulate code for creating libtool. ##
+## ------------------------------------- ##
+
+# So that we can recreate a full libtool script including additional
+# tags, we accumulate the chunks of code to send to AC_CONFIG_COMMANDS
+# in macros and then make a single call at the end using the `libtool'
+# label.
+
+
+# _LT_CONFIG_LIBTOOL_INIT([INIT-COMMANDS])
+# ----------------------------------------
+# Register INIT-COMMANDS to be passed to AC_CONFIG_COMMANDS later.
+m4_define([_LT_CONFIG_LIBTOOL_INIT],
+[m4_ifval([$1],
+ [m4_append([_LT_OUTPUT_LIBTOOL_INIT],
+ [$1
+])])])
+
+# Initialize.
+m4_define([_LT_OUTPUT_LIBTOOL_INIT])
+
+
+# _LT_CONFIG_LIBTOOL([COMMANDS])
+# ------------------------------
+# Register COMMANDS to be passed to AC_CONFIG_COMMANDS later.
+m4_define([_LT_CONFIG_LIBTOOL],
+[m4_ifval([$1],
+ [m4_append([_LT_OUTPUT_LIBTOOL_COMMANDS],
+ [$1
+])])])
+
+# Initialize.
+m4_define([_LT_OUTPUT_LIBTOOL_COMMANDS])
+
+
+# _LT_CONFIG_SAVE_COMMANDS([COMMANDS], [INIT_COMMANDS])
+# -----------------------------------------------------
+m4_defun([_LT_CONFIG_SAVE_COMMANDS],
+[_LT_CONFIG_LIBTOOL([$1])
+_LT_CONFIG_LIBTOOL_INIT([$2])
+])
+
+
+# _LT_FORMAT_COMMENT([COMMENT])
+# -----------------------------
+# Add leading comment marks to the start of each line, and a trailing
+# full-stop to the whole comment if one is not present already.
+m4_define([_LT_FORMAT_COMMENT],
+[m4_ifval([$1], [
+m4_bpatsubst([m4_bpatsubst([$1], [^ *], [# ])],
+ [['`$\]], [\\\&])]m4_bmatch([$1], [[!?.]$], [], [.])
+)])
+
+
+
+## ------------------------ ##
+## FIXME: Eliminate VARNAME ##
+## ------------------------ ##
+
+
+# _LT_DECL([CONFIGNAME], VARNAME, VALUE, [DESCRIPTION], [IS-TAGGED?])
+# -------------------------------------------------------------------
+# CONFIGNAME is the name given to the value in the libtool script.
+# VARNAME is the (base) name used in the configure script.
+# VALUE may be 0, 1 or 2 for a computed quote escaped value based on
+# VARNAME. Any other value will be used directly.
+m4_define([_LT_DECL],
+[lt_if_append_uniq([lt_decl_varnames], [$2], [, ],
+ [lt_dict_add_subkey([lt_decl_dict], [$2], [libtool_name],
+ [m4_ifval([$1], [$1], [$2])])
+ lt_dict_add_subkey([lt_decl_dict], [$2], [value], [$3])
+ m4_ifval([$4],
+ [lt_dict_add_subkey([lt_decl_dict], [$2], [description], [$4])])
+ lt_dict_add_subkey([lt_decl_dict], [$2],
+ [tagged?], [m4_ifval([$5], [yes], [no])])])
+])
+
+
+# _LT_TAGDECL([CONFIGNAME], VARNAME, VALUE, [DESCRIPTION])
+# --------------------------------------------------------
+m4_define([_LT_TAGDECL], [_LT_DECL([$1], [$2], [$3], [$4], [yes])])
+
+
+# lt_decl_tag_varnames([SEPARATOR], [VARNAME1...])
+# ------------------------------------------------
+m4_define([lt_decl_tag_varnames],
+[_lt_decl_filter([tagged?], [yes], $@)])
+
+
+# _lt_decl_filter(SUBKEY, VALUE, [SEPARATOR], [VARNAME1..])
+# ---------------------------------------------------------
+m4_define([_lt_decl_filter],
+[m4_case([$#],
+ [0], [m4_fatal([$0: too few arguments: $#])],
+ [1], [m4_fatal([$0: too few arguments: $#: $1])],
+ [2], [lt_dict_filter([lt_decl_dict], [$1], [$2], [], lt_decl_varnames)],
+ [3], [lt_dict_filter([lt_decl_dict], [$1], [$2], [$3], lt_decl_varnames)],
+ [lt_dict_filter([lt_decl_dict], $@)])[]dnl
+])
+
+
+# lt_decl_quote_varnames([SEPARATOR], [VARNAME1...])
+# --------------------------------------------------
+m4_define([lt_decl_quote_varnames],
+[_lt_decl_filter([value], [1], $@)])
+
+
+# lt_decl_dquote_varnames([SEPARATOR], [VARNAME1...])
+# ---------------------------------------------------
+m4_define([lt_decl_dquote_varnames],
+[_lt_decl_filter([value], [2], $@)])
+
+
+# lt_decl_varnames_tagged([SEPARATOR], [VARNAME1...])
+# ---------------------------------------------------
+m4_define([lt_decl_varnames_tagged],
+[m4_assert([$# <= 2])dnl
+_$0(m4_quote(m4_default([$1], [[, ]])),
+ m4_ifval([$2], [[$2]], [m4_dquote(lt_decl_tag_varnames)]),
+ m4_split(m4_normalize(m4_quote(_LT_TAGS)), [ ]))])
+m4_define([_lt_decl_varnames_tagged],
+[m4_ifval([$3], [lt_combine([$1], [$2], [_], $3)])])
+
+
+# lt_decl_all_varnames([SEPARATOR], [VARNAME1...])
+# ------------------------------------------------
+m4_define([lt_decl_all_varnames],
+[_$0(m4_quote(m4_default([$1], [[, ]])),
+ m4_if([$2], [],
+ m4_quote(lt_decl_varnames),
+ m4_quote(m4_shift($@))))[]dnl
+])
+m4_define([_lt_decl_all_varnames],
+[lt_join($@, lt_decl_varnames_tagged([$1],
+ lt_decl_tag_varnames([[, ]], m4_shift($@))))dnl
+])
+
+
+# _LT_CONFIG_STATUS_DECLARE([VARNAME])
+# ------------------------------------
+# Quote a variable value, and forward it to `config.status' so that its
+# declaration there will have the same value as in `configure'. VARNAME
+# must have a single quote delimited value for this to work.
+m4_define([_LT_CONFIG_STATUS_DECLARE],
+[$1='`$ECHO "$][$1" | $SED "$delay_single_quote_subst"`'])
+
+
+# _LT_CONFIG_STATUS_DECLARATIONS
+# ------------------------------
+# We delimit libtool config variables with single quotes, so when
+# we write them to config.status, we have to be sure to quote all
+# embedded single quotes properly. In configure, this macro expands
+# each variable declared with _LT_DECL (and _LT_TAGDECL) into:
+#
+# <var>='`$ECHO "$<var>" | $SED "$delay_single_quote_subst"`'
+m4_defun([_LT_CONFIG_STATUS_DECLARATIONS],
+[m4_foreach([_lt_var], m4_quote(lt_decl_all_varnames),
+ [m4_n([_LT_CONFIG_STATUS_DECLARE(_lt_var)])])])
+
+
+# _LT_LIBTOOL_TAGS
+# ----------------
+# Output comment and list of tags supported by the script
+m4_defun([_LT_LIBTOOL_TAGS],
+[_LT_FORMAT_COMMENT([The names of the tagged configurations supported by this script])dnl
+available_tags="_LT_TAGS"dnl
+])
+
+
+# _LT_LIBTOOL_DECLARE(VARNAME, [TAG])
+# -----------------------------------
+# Extract the dictionary values for VARNAME (optionally with TAG) and
+# expand to a commented shell variable setting:
+#
+# # Some comment about what VAR is for.
+# visible_name=$lt_internal_name
+m4_define([_LT_LIBTOOL_DECLARE],
+[_LT_FORMAT_COMMENT(m4_quote(lt_dict_fetch([lt_decl_dict], [$1],
+ [description])))[]dnl
+m4_pushdef([_libtool_name],
+ m4_quote(lt_dict_fetch([lt_decl_dict], [$1], [libtool_name])))[]dnl
+m4_case(m4_quote(lt_dict_fetch([lt_decl_dict], [$1], [value])),
+ [0], [_libtool_name=[$]$1],
+ [1], [_libtool_name=$lt_[]$1],
+ [2], [_libtool_name=$lt_[]$1],
+ [_libtool_name=lt_dict_fetch([lt_decl_dict], [$1], [value])])[]dnl
+m4_ifval([$2], [_$2])[]m4_popdef([_libtool_name])[]dnl
+])
+
+
+# _LT_LIBTOOL_CONFIG_VARS
+# -----------------------
+# Produce commented declarations of non-tagged libtool config variables
+# suitable for insertion in the LIBTOOL CONFIG section of the `libtool'
+# script. Tagged libtool config variables (even for the LIBTOOL CONFIG
+# section) are produced by _LT_LIBTOOL_TAG_VARS.
+m4_defun([_LT_LIBTOOL_CONFIG_VARS],
+[m4_foreach([_lt_var],
+ m4_quote(_lt_decl_filter([tagged?], [no], [], lt_decl_varnames)),
+ [m4_n([_LT_LIBTOOL_DECLARE(_lt_var)])])])
+
+
+# _LT_LIBTOOL_TAG_VARS(TAG)
+# -------------------------
+m4_define([_LT_LIBTOOL_TAG_VARS],
+[m4_foreach([_lt_var], m4_quote(lt_decl_tag_varnames),
+ [m4_n([_LT_LIBTOOL_DECLARE(_lt_var, [$1])])])])
+
+
+# _LT_TAGVAR(VARNAME, [TAGNAME])
+# ------------------------------
+m4_define([_LT_TAGVAR], [m4_ifval([$2], [$1_$2], [$1])])
+
+
+# _LT_CONFIG_COMMANDS
+# -------------------
+# Send accumulated output to $CONFIG_STATUS. Thanks to the lists of
+# variables for single and double quote escaping we saved from calls
+# to _LT_DECL, we can put quote escaped variables declarations
+# into `config.status', and then the shell code to quote escape them in
+# for loops in `config.status'. Finally, any additional code accumulated
+# from calls to _LT_CONFIG_LIBTOOL_INIT is expanded.
+m4_defun([_LT_CONFIG_COMMANDS],
+[AC_PROVIDE_IFELSE([LT_OUTPUT],
+ dnl If the libtool generation code has been placed in $CONFIG_LT,
+ dnl instead of duplicating it all over again into config.status,
+ dnl then we will have config.status run $CONFIG_LT later, so it
+ dnl needs to know what name is stored there:
+ [AC_CONFIG_COMMANDS([libtool],
+ [$SHELL $CONFIG_LT || AS_EXIT(1)], [CONFIG_LT='$CONFIG_LT'])],
+ dnl If the libtool generation code is destined for config.status,
+ dnl expand the accumulated commands and init code now:
+ [AC_CONFIG_COMMANDS([libtool],
+ [_LT_OUTPUT_LIBTOOL_COMMANDS], [_LT_OUTPUT_LIBTOOL_COMMANDS_INIT])])
+])#_LT_CONFIG_COMMANDS
+
+
+# Initialize.
+m4_define([_LT_OUTPUT_LIBTOOL_COMMANDS_INIT],
+[
+
+# The HP-UX ksh and POSIX shell print the target directory to stdout
+# if CDPATH is set.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+sed_quote_subst='$sed_quote_subst'
+double_quote_subst='$double_quote_subst'
+delay_variable_subst='$delay_variable_subst'
+_LT_CONFIG_STATUS_DECLARATIONS
+LTCC='$LTCC'
+LTCFLAGS='$LTCFLAGS'
+compiler='$compiler_DEFAULT'
+
+# A function that is used when there is no print builtin or printf.
+func_fallback_echo ()
+{
+ eval 'cat <<_LTECHO_EOF
+\$[]1
+_LTECHO_EOF'
+}
+
+# Quote evaled strings.
+for var in lt_decl_all_varnames([[ \
+]], lt_decl_quote_varnames); do
+ case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in
+ *[[\\\\\\\`\\"\\\$]]*)
+ eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED \\"\\\$sed_quote_subst\\"\\\`\\\\\\""
+ ;;
+ *)
+ eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\""
+ ;;
+ esac
+done
+
+# Double-quote double-evaled strings.
+for var in lt_decl_all_varnames([[ \
+]], lt_decl_dquote_varnames); do
+ case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in
+ *[[\\\\\\\`\\"\\\$]]*)
+ eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\""
+ ;;
+ *)
+ eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\""
+ ;;
+ esac
+done
+
+_LT_OUTPUT_LIBTOOL_INIT
+])
+
+# _LT_GENERATED_FILE_INIT(FILE, [COMMENT])
+# ------------------------------------
+# Generate a child script FILE with all initialization necessary to
+# reuse the environment learned by the parent script, and make the
+# file executable. If COMMENT is supplied, it is inserted after the
+# `#!' sequence but before initialization text begins. After this
+# macro, additional text can be appended to FILE to form the body of
+# the child script. The macro ends with non-zero status if the
+# file could not be fully written (such as if the disk is full).
+m4_ifdef([AS_INIT_GENERATED],
+[m4_defun([_LT_GENERATED_FILE_INIT],[AS_INIT_GENERATED($@)])],
+[m4_defun([_LT_GENERATED_FILE_INIT],
+[m4_require([AS_PREPARE])]dnl
+[m4_pushdef([AS_MESSAGE_LOG_FD])]dnl
+[lt_write_fail=0
+cat >$1 <<_ASEOF || lt_write_fail=1
+#! $SHELL
+# Generated by $as_me.
+$2
+SHELL=\${CONFIG_SHELL-$SHELL}
+export SHELL
+_ASEOF
+cat >>$1 <<\_ASEOF || lt_write_fail=1
+AS_SHELL_SANITIZE
+_AS_PREPARE
+exec AS_MESSAGE_FD>&1
+_ASEOF
+test $lt_write_fail = 0 && chmod +x $1[]dnl
+m4_popdef([AS_MESSAGE_LOG_FD])])])# _LT_GENERATED_FILE_INIT
+
+# LT_OUTPUT
+# ---------
+# This macro allows early generation of the libtool script (before
+# AC_OUTPUT is called), incase it is used in configure for compilation
+# tests.
+AC_DEFUN([LT_OUTPUT],
+[: ${CONFIG_LT=./config.lt}
+AC_MSG_NOTICE([creating $CONFIG_LT])
+_LT_GENERATED_FILE_INIT(["$CONFIG_LT"],
+[# Run this file to recreate a libtool stub with the current configuration.])
+
+cat >>"$CONFIG_LT" <<\_LTEOF
+lt_cl_silent=false
+exec AS_MESSAGE_LOG_FD>>config.log
+{
+ echo
+ AS_BOX([Running $as_me.])
+} >&AS_MESSAGE_LOG_FD
+
+lt_cl_help="\
+\`$as_me' creates a local libtool stub from the current configuration,
+for use in further configure time tests before the real libtool is
+generated.
+
+Usage: $[0] [[OPTIONS]]
+
+ -h, --help print this help, then exit
+ -V, --version print version number, then exit
+ -q, --quiet do not print progress messages
+ -d, --debug don't remove temporary files
+
+Report bugs to <bug-libtool@gnu.org>."
+
+lt_cl_version="\
+m4_ifset([AC_PACKAGE_NAME], [AC_PACKAGE_NAME ])config.lt[]dnl
+m4_ifset([AC_PACKAGE_VERSION], [ AC_PACKAGE_VERSION])
+configured by $[0], generated by m4_PACKAGE_STRING.
+
+Copyright (C) 2010 Free Software Foundation, Inc.
+This config.lt script is free software; the Free Software Foundation
+gives unlimited permision to copy, distribute and modify it."
+
+while test $[#] != 0
+do
+ case $[1] in
+ --version | --v* | -V )
+ echo "$lt_cl_version"; exit 0 ;;
+ --help | --h* | -h )
+ echo "$lt_cl_help"; exit 0 ;;
+ --debug | --d* | -d )
+ debug=: ;;
+ --quiet | --q* | --silent | --s* | -q )
+ lt_cl_silent=: ;;
+
+ -*) AC_MSG_ERROR([unrecognized option: $[1]
+Try \`$[0] --help' for more information.]) ;;
+
+ *) AC_MSG_ERROR([unrecognized argument: $[1]
+Try \`$[0] --help' for more information.]) ;;
+ esac
+ shift
+done
+
+if $lt_cl_silent; then
+ exec AS_MESSAGE_FD>/dev/null
+fi
+_LTEOF
+
+cat >>"$CONFIG_LT" <<_LTEOF
+_LT_OUTPUT_LIBTOOL_COMMANDS_INIT
+_LTEOF
+
+cat >>"$CONFIG_LT" <<\_LTEOF
+AC_MSG_NOTICE([creating $ofile])
+_LT_OUTPUT_LIBTOOL_COMMANDS
+AS_EXIT(0)
+_LTEOF
+chmod +x "$CONFIG_LT"
+
+# configure is writing to config.log, but config.lt does its own redirection,
+# appending to config.log, which fails on DOS, as config.log is still kept
+# open by configure. Here we exec the FD to /dev/null, effectively closing
+# config.log, so it can be properly (re)opened and appended to by config.lt.
+lt_cl_success=:
+test "$silent" = yes &&
+ lt_config_lt_args="$lt_config_lt_args --quiet"
+exec AS_MESSAGE_LOG_FD>/dev/null
+$SHELL "$CONFIG_LT" $lt_config_lt_args || lt_cl_success=false
+exec AS_MESSAGE_LOG_FD>>config.log
+$lt_cl_success || AS_EXIT(1)
+])# LT_OUTPUT
+
+
+# _LT_CONFIG(TAG)
+# ---------------
+# If TAG is the built-in tag, create an initial libtool script with a
+# default configuration from the untagged config vars. Otherwise add code
+# to config.status for appending the configuration named by TAG from the
+# matching tagged config vars.
+m4_defun([_LT_CONFIG],
+[m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+_LT_CONFIG_SAVE_COMMANDS([
+ m4_define([_LT_TAG], m4_if([$1], [], [C], [$1]))dnl
+ m4_if(_LT_TAG, [C], [
+ # See if we are running on zsh, and set the options which allow our
+ # commands through without removal of \ escapes.
+ if test -n "${ZSH_VERSION+set}" ; then
+ setopt NO_GLOB_SUBST
+ fi
+
+ cfgfile="${ofile}T"
+ trap "$RM \"$cfgfile\"; exit 1" 1 2 15
+ $RM "$cfgfile"
+
+ cat <<_LT_EOF >> "$cfgfile"
+#! $SHELL
+
+# `$ECHO "$ofile" | sed 's%^.*/%%'` - Provide generalized library-building support services.
+# Generated automatically by $as_me ($PACKAGE$TIMESTAMP) $VERSION
+# Libtool was configured on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
+# NOTE: Changes made to this file will be lost: look at ltmain.sh.
+#
+_LT_COPYING
+_LT_LIBTOOL_TAGS
+
+# ### BEGIN LIBTOOL CONFIG
+_LT_LIBTOOL_CONFIG_VARS
+_LT_LIBTOOL_TAG_VARS
+# ### END LIBTOOL CONFIG
+
+_LT_EOF
+
+ case $host_os in
+ aix3*)
+ cat <<\_LT_EOF >> "$cfgfile"
+# AIX sometimes has problems with the GCC collect2 program. For some
+# reason, if we set the COLLECT_NAMES environment variable, the problems
+# vanish in a puff of smoke.
+if test "X${COLLECT_NAMES+set}" != Xset; then
+ COLLECT_NAMES=
+ export COLLECT_NAMES
+fi
+_LT_EOF
+ ;;
+ esac
+
+ _LT_PROG_LTMAIN
+
+ # We use sed instead of cat because bash on DJGPP gets confused if
+ # if finds mixed CR/LF and LF-only lines. Since sed operates in
+ # text mode, it properly converts lines to CR/LF. This bash problem
+ # is reportedly fixed, but why not run on old versions too?
+ sed '$q' "$ltmain" >> "$cfgfile" \
+ || (rm -f "$cfgfile"; exit 1)
+
+ _LT_PROG_REPLACE_SHELLFNS
+
+ mv -f "$cfgfile" "$ofile" ||
+ (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile")
+ chmod +x "$ofile"
+],
+[cat <<_LT_EOF >> "$ofile"
+
+dnl Unfortunately we have to use $1 here, since _LT_TAG is not expanded
+dnl in a comment (ie after a #).
+# ### BEGIN LIBTOOL TAG CONFIG: $1
+_LT_LIBTOOL_TAG_VARS(_LT_TAG)
+# ### END LIBTOOL TAG CONFIG: $1
+_LT_EOF
+])dnl /m4_if
+],
+[m4_if([$1], [], [
+ PACKAGE='$PACKAGE'
+ VERSION='$VERSION'
+ TIMESTAMP='$TIMESTAMP'
+ RM='$RM'
+ ofile='$ofile'], [])
+])dnl /_LT_CONFIG_SAVE_COMMANDS
+])# _LT_CONFIG
+
+
+# LT_SUPPORTED_TAG(TAG)
+# ---------------------
+# Trace this macro to discover what tags are supported by the libtool
+# --tag option, using:
+# autoconf --trace 'LT_SUPPORTED_TAG:$1'
+AC_DEFUN([LT_SUPPORTED_TAG], [])
+
+
+# C support is built-in for now
+m4_define([_LT_LANG_C_enabled], [])
+m4_define([_LT_TAGS], [])
+
+
+# LT_LANG(LANG)
+# -------------
+# Enable libtool support for the given language if not already enabled.
+AC_DEFUN([LT_LANG],
+[AC_BEFORE([$0], [LT_OUTPUT])dnl
+m4_case([$1],
+ [C], [_LT_LANG(C)],
+ [C++], [_LT_LANG(CXX)],
+ [Java], [_LT_LANG(GCJ)],
+ [Fortran 77], [_LT_LANG(F77)],
+ [Fortran], [_LT_LANG(FC)],
+ [Windows Resource], [_LT_LANG(RC)],
+ [m4_ifdef([_LT_LANG_]$1[_CONFIG],
+ [_LT_LANG($1)],
+ [m4_fatal([$0: unsupported language: "$1"])])])dnl
+])# LT_LANG
+
+
+# _LT_LANG(LANGNAME)
+# ------------------
+m4_defun([_LT_LANG],
+[m4_ifdef([_LT_LANG_]$1[_enabled], [],
+ [LT_SUPPORTED_TAG([$1])dnl
+ m4_append([_LT_TAGS], [$1 ])dnl
+ m4_define([_LT_LANG_]$1[_enabled], [])dnl
+ _LT_LANG_$1_CONFIG($1)])dnl
+])# _LT_LANG
+
+
+# _LT_LANG_DEFAULT_CONFIG
+# -----------------------
+m4_defun([_LT_LANG_DEFAULT_CONFIG],
+[AC_PROVIDE_IFELSE([AC_PROG_CXX],
+ [LT_LANG(CXX)],
+ [m4_define([AC_PROG_CXX], defn([AC_PROG_CXX])[LT_LANG(CXX)])])
+
+AC_PROVIDE_IFELSE([AC_PROG_F77],
+ [LT_LANG(F77)],
+ [m4_define([AC_PROG_F77], defn([AC_PROG_F77])[LT_LANG(F77)])])
+
+AC_PROVIDE_IFELSE([AC_PROG_FC],
+ [LT_LANG(FC)],
+ [m4_define([AC_PROG_FC], defn([AC_PROG_FC])[LT_LANG(FC)])])
+
+dnl The call to [A][M_PROG_GCJ] is quoted like that to stop aclocal
+dnl pulling things in needlessly.
+AC_PROVIDE_IFELSE([AC_PROG_GCJ],
+ [LT_LANG(GCJ)],
+ [AC_PROVIDE_IFELSE([A][M_PROG_GCJ],
+ [LT_LANG(GCJ)],
+ [AC_PROVIDE_IFELSE([LT_PROG_GCJ],
+ [LT_LANG(GCJ)],
+ [m4_ifdef([AC_PROG_GCJ],
+ [m4_define([AC_PROG_GCJ], defn([AC_PROG_GCJ])[LT_LANG(GCJ)])])
+ m4_ifdef([A][M_PROG_GCJ],
+ [m4_define([A][M_PROG_GCJ], defn([A][M_PROG_GCJ])[LT_LANG(GCJ)])])
+ m4_ifdef([LT_PROG_GCJ],
+ [m4_define([LT_PROG_GCJ], defn([LT_PROG_GCJ])[LT_LANG(GCJ)])])])])])
+
+AC_PROVIDE_IFELSE([LT_PROG_RC],
+ [LT_LANG(RC)],
+ [m4_define([LT_PROG_RC], defn([LT_PROG_RC])[LT_LANG(RC)])])
+])# _LT_LANG_DEFAULT_CONFIG
+
+# Obsolete macros:
+AU_DEFUN([AC_LIBTOOL_CXX], [LT_LANG(C++)])
+AU_DEFUN([AC_LIBTOOL_F77], [LT_LANG(Fortran 77)])
+AU_DEFUN([AC_LIBTOOL_FC], [LT_LANG(Fortran)])
+AU_DEFUN([AC_LIBTOOL_GCJ], [LT_LANG(Java)])
+AU_DEFUN([AC_LIBTOOL_RC], [LT_LANG(Windows Resource)])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_LIBTOOL_CXX], [])
+dnl AC_DEFUN([AC_LIBTOOL_F77], [])
+dnl AC_DEFUN([AC_LIBTOOL_FC], [])
+dnl AC_DEFUN([AC_LIBTOOL_GCJ], [])
+dnl AC_DEFUN([AC_LIBTOOL_RC], [])
+
+
+# _LT_TAG_COMPILER
+# ----------------
+m4_defun([_LT_TAG_COMPILER],
+[AC_REQUIRE([AC_PROG_CC])dnl
+
+_LT_DECL([LTCC], [CC], [1], [A C compiler])dnl
+_LT_DECL([LTCFLAGS], [CFLAGS], [1], [LTCC compiler flags])dnl
+_LT_TAGDECL([CC], [compiler], [1], [A language specific compiler])dnl
+_LT_TAGDECL([with_gcc], [GCC], [0], [Is the compiler the GNU compiler?])dnl
+
+# If no C compiler was specified, use CC.
+LTCC=${LTCC-"$CC"}
+
+# If no C compiler flags were specified, use CFLAGS.
+LTCFLAGS=${LTCFLAGS-"$CFLAGS"}
+
+# Allow CC to be a program name with arguments.
+compiler=$CC
+])# _LT_TAG_COMPILER
+
+
+# _LT_COMPILER_BOILERPLATE
+# ------------------------
+# Check for compiler boilerplate output or warnings with
+# the simple compiler test code.
+m4_defun([_LT_COMPILER_BOILERPLATE],
+[m4_require([_LT_DECL_SED])dnl
+ac_outfile=conftest.$ac_objext
+echo "$lt_simple_compile_test_code" >conftest.$ac_ext
+eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err
+_lt_compiler_boilerplate=`cat conftest.err`
+$RM conftest*
+])# _LT_COMPILER_BOILERPLATE
+
+
+# _LT_LINKER_BOILERPLATE
+# ----------------------
+# Check for linker boilerplate output or warnings with
+# the simple link test code.
+m4_defun([_LT_LINKER_BOILERPLATE],
+[m4_require([_LT_DECL_SED])dnl
+ac_outfile=conftest.$ac_objext
+echo "$lt_simple_link_test_code" >conftest.$ac_ext
+eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err
+_lt_linker_boilerplate=`cat conftest.err`
+$RM -r conftest*
+])# _LT_LINKER_BOILERPLATE
+
+# _LT_REQUIRED_DARWIN_CHECKS
+# -------------------------
+m4_defun_once([_LT_REQUIRED_DARWIN_CHECKS],[
+ case $host_os in
+ rhapsody* | darwin*)
+ AC_CHECK_TOOL([DSYMUTIL], [dsymutil], [:])
+ AC_CHECK_TOOL([NMEDIT], [nmedit], [:])
+ AC_CHECK_TOOL([LIPO], [lipo], [:])
+ AC_CHECK_TOOL([OTOOL], [otool], [:])
+ AC_CHECK_TOOL([OTOOL64], [otool64], [:])
+ _LT_DECL([], [DSYMUTIL], [1],
+ [Tool to manipulate archived DWARF debug symbol files on Mac OS X])
+ _LT_DECL([], [NMEDIT], [1],
+ [Tool to change global to local symbols on Mac OS X])
+ _LT_DECL([], [LIPO], [1],
+ [Tool to manipulate fat objects and archives on Mac OS X])
+ _LT_DECL([], [OTOOL], [1],
+ [ldd/readelf like tool for Mach-O binaries on Mac OS X])
+ _LT_DECL([], [OTOOL64], [1],
+ [ldd/readelf like tool for 64 bit Mach-O binaries on Mac OS X 10.4])
+
+ AC_CACHE_CHECK([for -single_module linker flag],[lt_cv_apple_cc_single_mod],
+ [lt_cv_apple_cc_single_mod=no
+ if test -z "${LT_MULTI_MODULE}"; then
+ # By default we will add the -single_module flag. You can override
+ # by either setting the environment variable LT_MULTI_MODULE
+ # non-empty at configure time, or by adding -multi_module to the
+ # link flags.
+ rm -rf libconftest.dylib*
+ echo "int foo(void){return 1;}" > conftest.c
+ echo "$LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \
+-dynamiclib -Wl,-single_module conftest.c" >&AS_MESSAGE_LOG_FD
+ $LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \
+ -dynamiclib -Wl,-single_module conftest.c 2>conftest.err
+ _lt_result=$?
+ if test -f libconftest.dylib && test ! -s conftest.err && test $_lt_result = 0; then
+ lt_cv_apple_cc_single_mod=yes
+ else
+ cat conftest.err >&AS_MESSAGE_LOG_FD
+ fi
+ rm -rf libconftest.dylib*
+ rm -f conftest.*
+ fi])
+ AC_CACHE_CHECK([for -exported_symbols_list linker flag],
+ [lt_cv_ld_exported_symbols_list],
+ [lt_cv_ld_exported_symbols_list=no
+ save_LDFLAGS=$LDFLAGS
+ echo "_main" > conftest.sym
+ LDFLAGS="$LDFLAGS -Wl,-exported_symbols_list,conftest.sym"
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([],[])],
+ [lt_cv_ld_exported_symbols_list=yes],
+ [lt_cv_ld_exported_symbols_list=no])
+ LDFLAGS="$save_LDFLAGS"
+ ])
+ AC_CACHE_CHECK([for -force_load linker flag],[lt_cv_ld_force_load],
+ [lt_cv_ld_force_load=no
+ cat > conftest.c << _LT_EOF
+int forced_loaded() { return 2;}
+_LT_EOF
+ echo "$LTCC $LTCFLAGS -c -o conftest.o conftest.c" >&AS_MESSAGE_LOG_FD
+ $LTCC $LTCFLAGS -c -o conftest.o conftest.c 2>&AS_MESSAGE_LOG_FD
+ echo "$AR cru libconftest.a conftest.o" >&AS_MESSAGE_LOG_FD
+ $AR cru libconftest.a conftest.o 2>&AS_MESSAGE_LOG_FD
+ echo "$RANLIB libconftest.a" >&AS_MESSAGE_LOG_FD
+ $RANLIB libconftest.a 2>&AS_MESSAGE_LOG_FD
+ cat > conftest.c << _LT_EOF
+int main() { return 0;}
+_LT_EOF
+ echo "$LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a" >&AS_MESSAGE_LOG_FD
+ $LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a 2>conftest.err
+ _lt_result=$?
+ if test -f conftest && test ! -s conftest.err && test $_lt_result = 0 && $GREP forced_load conftest 2>&1 >/dev/null; then
+ lt_cv_ld_force_load=yes
+ else
+ cat conftest.err >&AS_MESSAGE_LOG_FD
+ fi
+ rm -f conftest.err libconftest.a conftest conftest.c
+ rm -rf conftest.dSYM
+ ])
+ case $host_os in
+ rhapsody* | darwin1.[[012]])
+ _lt_dar_allow_undefined='${wl}-undefined ${wl}suppress' ;;
+ darwin1.*)
+ _lt_dar_allow_undefined='${wl}-flat_namespace ${wl}-undefined ${wl}suppress' ;;
+ darwin*) # darwin 5.x on
+ # if running on 10.5 or later, the deployment target defaults
+ # to the OS version, if on x86, and 10.4, the deployment
+ # target defaults to 10.4. Don't you love it?
+ case ${MACOSX_DEPLOYMENT_TARGET-10.0},$host in
+ 10.0,*86*-darwin8*|10.0,*-darwin[[91]]*)
+ _lt_dar_allow_undefined='${wl}-undefined ${wl}dynamic_lookup' ;;
+ 10.[[012]]*)
+ _lt_dar_allow_undefined='${wl}-flat_namespace ${wl}-undefined ${wl}suppress' ;;
+ 10.*)
+ _lt_dar_allow_undefined='${wl}-undefined ${wl}dynamic_lookup' ;;
+ esac
+ ;;
+ esac
+ if test "$lt_cv_apple_cc_single_mod" = "yes"; then
+ _lt_dar_single_mod='$single_module'
+ fi
+ if test "$lt_cv_ld_exported_symbols_list" = "yes"; then
+ _lt_dar_export_syms=' ${wl}-exported_symbols_list,$output_objdir/${libname}-symbols.expsym'
+ else
+ _lt_dar_export_syms='~$NMEDIT -s $output_objdir/${libname}-symbols.expsym ${lib}'
+ fi
+ if test "$DSYMUTIL" != ":" && test "$lt_cv_ld_force_load" = "no"; then
+ _lt_dsymutil='~$DSYMUTIL $lib || :'
+ else
+ _lt_dsymutil=
+ fi
+ ;;
+ esac
+])
+
+
+# _LT_DARWIN_LINKER_FEATURES
+# --------------------------
+# Checks for linker and compiler features on darwin
+m4_defun([_LT_DARWIN_LINKER_FEATURES],
+[
+ m4_require([_LT_REQUIRED_DARWIN_CHECKS])
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=no
+ _LT_TAGVAR(hardcode_direct, $1)=no
+ _LT_TAGVAR(hardcode_automatic, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=unsupported
+ if test "$lt_cv_ld_force_load" = "yes"; then
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience ${wl}-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`'
+ else
+ _LT_TAGVAR(whole_archive_flag_spec, $1)=''
+ fi
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ _LT_TAGVAR(allow_undefined_flag, $1)="$_lt_dar_allow_undefined"
+ case $cc_basename in
+ ifort*) _lt_dar_can_shared=yes ;;
+ *) _lt_dar_can_shared=$GCC ;;
+ esac
+ if test "$_lt_dar_can_shared" = "yes"; then
+ output_verbose_link_cmd=func_echo_all
+ _LT_TAGVAR(archive_cmds, $1)="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod${_lt_dsymutil}"
+ _LT_TAGVAR(module_cmds, $1)="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dsymutil}"
+ _LT_TAGVAR(archive_expsym_cmds, $1)="sed 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring ${_lt_dar_single_mod}${_lt_dar_export_syms}${_lt_dsymutil}"
+ _LT_TAGVAR(module_expsym_cmds, $1)="sed -e 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags${_lt_dar_export_syms}${_lt_dsymutil}"
+ m4_if([$1], [CXX],
+[ if test "$lt_cv_apple_cc_single_mod" != "yes"; then
+ _LT_TAGVAR(archive_cmds, $1)="\$CC -r -keep_private_externs -nostdlib -o \${lib}-master.o \$libobjs~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \${lib}-master.o \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring${_lt_dsymutil}"
+ _LT_TAGVAR(archive_expsym_cmds, $1)="sed 's,^,_,' < \$export_symbols > \$output_objdir/\${libname}-symbols.expsym~\$CC -r -keep_private_externs -nostdlib -o \${lib}-master.o \$libobjs~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \${lib}-master.o \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring${_lt_dar_export_syms}${_lt_dsymutil}"
+ fi
+],[])
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+])
+
+# _LT_SYS_MODULE_PATH_AIX([TAGNAME])
+# ----------------------------------
+# Links a minimal program and checks the executable
+# for the system default hardcoded library path. In most cases,
+# this is /usr/lib:/lib, but when the MPI compilers are used
+# the location of the communication and MPI libs are included too.
+# If we don't find anything, use the default library path according
+# to the aix ld manual.
+# Store the results from the different compilers for each TAGNAME.
+# Allow to override them for all tags through lt_cv_aix_libpath.
+m4_defun([_LT_SYS_MODULE_PATH_AIX],
+[m4_require([_LT_DECL_SED])dnl
+if test "${lt_cv_aix_libpath+set}" = set; then
+ aix_libpath=$lt_cv_aix_libpath
+else
+ AC_CACHE_VAL([_LT_TAGVAR([lt_cv_aix_libpath_], [$1])],
+ [AC_LINK_IFELSE([AC_LANG_PROGRAM],[
+ lt_aix_libpath_sed='[
+ /Import File Strings/,/^$/ {
+ /^0/ {
+ s/^0 *\([^ ]*\) *$/\1/
+ p
+ }
+ }]'
+ _LT_TAGVAR([lt_cv_aix_libpath_], [$1])=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ # Check for a 64-bit object if we didn't find anything.
+ if test -z "$_LT_TAGVAR([lt_cv_aix_libpath_], [$1])"; then
+ _LT_TAGVAR([lt_cv_aix_libpath_], [$1])=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"`
+ fi],[])
+ if test -z "$_LT_TAGVAR([lt_cv_aix_libpath_], [$1])"; then
+ _LT_TAGVAR([lt_cv_aix_libpath_], [$1])="/usr/lib:/lib"
+ fi
+ ])
+ aix_libpath=$_LT_TAGVAR([lt_cv_aix_libpath_], [$1])
+fi
+])# _LT_SYS_MODULE_PATH_AIX
+
+
+# _LT_SHELL_INIT(ARG)
+# -------------------
+m4_define([_LT_SHELL_INIT],
+[m4_divert_text([M4SH-INIT], [$1
+])])# _LT_SHELL_INIT
+
+
+
+# _LT_PROG_ECHO_BACKSLASH
+# -----------------------
+# Find how we can fake an echo command that does not interpret backslash.
+# In particular, with Autoconf 2.60 or later we add some code to the start
+# of the generated configure script which will find a shell with a builtin
+# printf (which we can use as an echo command).
+m4_defun([_LT_PROG_ECHO_BACKSLASH],
+[ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO
+ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO
+
+AC_MSG_CHECKING([how to print strings])
+# Test print first, because it will be a builtin if present.
+if test "X`( print -r -- -n ) 2>/dev/null`" = X-n && \
+ test "X`print -r -- $ECHO 2>/dev/null`" = "X$ECHO"; then
+ ECHO='print -r --'
+elif test "X`printf %s $ECHO 2>/dev/null`" = "X$ECHO"; then
+ ECHO='printf %s\n'
+else
+ # Use this function as a fallback that always works.
+ func_fallback_echo ()
+ {
+ eval 'cat <<_LTECHO_EOF
+$[]1
+_LTECHO_EOF'
+ }
+ ECHO='func_fallback_echo'
+fi
+
+# func_echo_all arg...
+# Invoke $ECHO with all args, space-separated.
+func_echo_all ()
+{
+ $ECHO "$*"
+}
+
+case "$ECHO" in
+ printf*) AC_MSG_RESULT([printf]) ;;
+ print*) AC_MSG_RESULT([print -r]) ;;
+ *) AC_MSG_RESULT([cat]) ;;
+esac
+
+m4_ifdef([_AS_DETECT_SUGGESTED],
+[_AS_DETECT_SUGGESTED([
+ test -n "${ZSH_VERSION+set}${BASH_VERSION+set}" || (
+ ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+ ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO
+ ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO
+ PATH=/empty FPATH=/empty; export PATH FPATH
+ test "X`printf %s $ECHO`" = "X$ECHO" \
+ || test "X`print -r -- $ECHO`" = "X$ECHO" )])])
+
+_LT_DECL([], [SHELL], [1], [Shell to use when invoking shell scripts])
+_LT_DECL([], [ECHO], [1], [An echo program that protects backslashes])
+])# _LT_PROG_ECHO_BACKSLASH
+
+
+# _LT_WITH_SYSROOT
+# ----------------
+AC_DEFUN([_LT_WITH_SYSROOT],
+[AC_MSG_CHECKING([for sysroot])
+AC_ARG_WITH([sysroot],
+[ --with-sysroot[=DIR] Search for dependent libraries within DIR
+ (or the compiler's sysroot if not specified).],
+[], [with_sysroot=no])
+
+dnl lt_sysroot will always be passed unquoted. We quote it here
+dnl in case the user passed a directory name.
+lt_sysroot=
+case ${with_sysroot} in #(
+ yes)
+ if test "$GCC" = yes; then
+ lt_sysroot=`$CC --print-sysroot 2>/dev/null`
+ fi
+ ;; #(
+ /*)
+ lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"`
+ ;; #(
+ no|'')
+ ;; #(
+ *)
+ AC_MSG_RESULT([${with_sysroot}])
+ AC_MSG_ERROR([The sysroot must be an absolute path.])
+ ;;
+esac
+
+ AC_MSG_RESULT([${lt_sysroot:-no}])
+_LT_DECL([], [lt_sysroot], [0], [The root where to search for ]dnl
+[dependent libraries, and in which our libraries should be installed.])])
+
+# _LT_ENABLE_LOCK
+# ---------------
+m4_defun([_LT_ENABLE_LOCK],
+[AC_ARG_ENABLE([libtool-lock],
+ [AS_HELP_STRING([--disable-libtool-lock],
+ [avoid locking (might break parallel builds)])])
+test "x$enable_libtool_lock" != xno && enable_libtool_lock=yes
+
+# Some flags need to be propagated to the compiler or linker for good
+# libtool support.
+case $host in
+ia64-*-hpux*)
+ # Find out which ABI we are using.
+ echo 'int i;' > conftest.$ac_ext
+ if AC_TRY_EVAL(ac_compile); then
+ case `/usr/bin/file conftest.$ac_objext` in
+ *ELF-32*)
+ HPUX_IA64_MODE="32"
+ ;;
+ *ELF-64*)
+ HPUX_IA64_MODE="64"
+ ;;
+ esac
+ fi
+ rm -rf conftest*
+ ;;
+*-*-irix6*)
+ # Find out which ABI we are using.
+ echo '[#]line '$LINENO' "configure"' > conftest.$ac_ext
+ if AC_TRY_EVAL(ac_compile); then
+ if test "$lt_cv_prog_gnu_ld" = yes; then
+ case `/usr/bin/file conftest.$ac_objext` in
+ *32-bit*)
+ LD="${LD-ld} -melf32bsmip"
+ ;;
+ *N32*)
+ LD="${LD-ld} -melf32bmipn32"
+ ;;
+ *64-bit*)
+ LD="${LD-ld} -melf64bmip"
+ ;;
+ esac
+ else
+ case `/usr/bin/file conftest.$ac_objext` in
+ *32-bit*)
+ LD="${LD-ld} -32"
+ ;;
+ *N32*)
+ LD="${LD-ld} -n32"
+ ;;
+ *64-bit*)
+ LD="${LD-ld} -64"
+ ;;
+ esac
+ fi
+ fi
+ rm -rf conftest*
+ ;;
+
+x86_64-*kfreebsd*-gnu|x86_64-*linux*|ppc*-*linux*|powerpc*-*linux*| \
+s390*-*linux*|s390*-*tpf*|sparc*-*linux*)
+ # Find out which ABI we are using.
+ echo 'int i;' > conftest.$ac_ext
+ if AC_TRY_EVAL(ac_compile); then
+ case `/usr/bin/file conftest.o` in
+ *32-bit*)
+ case $host in
+ x86_64-*kfreebsd*-gnu)
+ LD="${LD-ld} -m elf_i386_fbsd"
+ ;;
+ x86_64-*linux*)
+ LD="${LD-ld} -m elf_i386"
+ ;;
+ ppc64-*linux*|powerpc64-*linux*)
+ LD="${LD-ld} -m elf32ppclinux"
+ ;;
+ s390x-*linux*)
+ LD="${LD-ld} -m elf_s390"
+ ;;
+ sparc64-*linux*)
+ LD="${LD-ld} -m elf32_sparc"
+ ;;
+ esac
+ ;;
+ *64-bit*)
+ case $host in
+ x86_64-*kfreebsd*-gnu)
+ LD="${LD-ld} -m elf_x86_64_fbsd"
+ ;;
+ x86_64-*linux*)
+ LD="${LD-ld} -m elf_x86_64"
+ ;;
+ ppc*-*linux*|powerpc*-*linux*)
+ LD="${LD-ld} -m elf64ppc"
+ ;;
+ s390*-*linux*|s390*-*tpf*)
+ LD="${LD-ld} -m elf64_s390"
+ ;;
+ sparc*-*linux*)
+ LD="${LD-ld} -m elf64_sparc"
+ ;;
+ esac
+ ;;
+ esac
+ fi
+ rm -rf conftest*
+ ;;
+
+*-*-sco3.2v5*)
+ # On SCO OpenServer 5, we need -belf to get full-featured binaries.
+ SAVE_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -belf"
+ AC_CACHE_CHECK([whether the C compiler needs -belf], lt_cv_cc_needs_belf,
+ [AC_LANG_PUSH(C)
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([[]],[[]])],[lt_cv_cc_needs_belf=yes],[lt_cv_cc_needs_belf=no])
+ AC_LANG_POP])
+ if test x"$lt_cv_cc_needs_belf" != x"yes"; then
+ # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf
+ CFLAGS="$SAVE_CFLAGS"
+ fi
+ ;;
+sparc*-*solaris*)
+ # Find out which ABI we are using.
+ echo 'int i;' > conftest.$ac_ext
+ if AC_TRY_EVAL(ac_compile); then
+ case `/usr/bin/file conftest.o` in
+ *64-bit*)
+ case $lt_cv_prog_gnu_ld in
+ yes*) LD="${LD-ld} -m elf64_sparc" ;;
+ *)
+ if ${LD-ld} -64 -r -o conftest2.o conftest.o >/dev/null 2>&1; then
+ LD="${LD-ld} -64"
+ fi
+ ;;
+ esac
+ ;;
+ esac
+ fi
+ rm -rf conftest*
+ ;;
+esac
+
+need_locks="$enable_libtool_lock"
+])# _LT_ENABLE_LOCK
+
+
+# _LT_PROG_AR
+# -----------
+m4_defun([_LT_PROG_AR],
+[AC_CHECK_TOOLS(AR, [ar], false)
+: ${AR=ar}
+: ${AR_FLAGS=cru}
+_LT_DECL([], [AR], [1], [The archiver])
+_LT_DECL([], [AR_FLAGS], [1], [Flags to create an archive])
+
+AC_CACHE_CHECK([for archiver @FILE support], [lt_cv_ar_at_file],
+ [lt_cv_ar_at_file=no
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM],
+ [echo conftest.$ac_objext > conftest.lst
+ lt_ar_try='$AR $AR_FLAGS libconftest.a @conftest.lst >&AS_MESSAGE_LOG_FD'
+ AC_TRY_EVAL([lt_ar_try])
+ if test "$ac_status" -eq 0; then
+ # Ensure the archiver fails upon bogus file names.
+ rm -f conftest.$ac_objext libconftest.a
+ AC_TRY_EVAL([lt_ar_try])
+ if test "$ac_status" -ne 0; then
+ lt_cv_ar_at_file=@
+ fi
+ fi
+ rm -f conftest.* libconftest.a
+ ])
+ ])
+
+if test "x$lt_cv_ar_at_file" = xno; then
+ archiver_list_spec=
+else
+ archiver_list_spec=$lt_cv_ar_at_file
+fi
+_LT_DECL([], [archiver_list_spec], [1],
+ [How to feed a file listing to the archiver])
+])# _LT_PROG_AR
+
+
+# _LT_CMD_OLD_ARCHIVE
+# -------------------
+m4_defun([_LT_CMD_OLD_ARCHIVE],
+[_LT_PROG_AR
+
+AC_CHECK_TOOL(STRIP, strip, :)
+test -z "$STRIP" && STRIP=:
+_LT_DECL([], [STRIP], [1], [A symbol stripping program])
+
+AC_CHECK_TOOL(RANLIB, ranlib, :)
+test -z "$RANLIB" && RANLIB=:
+_LT_DECL([], [RANLIB], [1],
+ [Commands used to install an old-style archive])
+
+# Determine commands to create old-style static archives.
+old_archive_cmds='$AR $AR_FLAGS $oldlib$oldobjs'
+old_postinstall_cmds='chmod 644 $oldlib'
+old_postuninstall_cmds=
+
+if test -n "$RANLIB"; then
+ case $host_os in
+ openbsd*)
+ old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$oldlib"
+ ;;
+ *)
+ old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$oldlib"
+ ;;
+ esac
+ old_archive_cmds="$old_archive_cmds~\$RANLIB \$oldlib"
+fi
+
+case $host_os in
+ darwin*)
+ lock_old_archive_extraction=yes ;;
+ *)
+ lock_old_archive_extraction=no ;;
+esac
+_LT_DECL([], [old_postinstall_cmds], [2])
+_LT_DECL([], [old_postuninstall_cmds], [2])
+_LT_TAGDECL([], [old_archive_cmds], [2],
+ [Commands used to build an old-style archive])
+_LT_DECL([], [lock_old_archive_extraction], [0],
+ [Whether to use a lock for old archive extraction])
+])# _LT_CMD_OLD_ARCHIVE
+
+
+# _LT_COMPILER_OPTION(MESSAGE, VARIABLE-NAME, FLAGS,
+# [OUTPUT-FILE], [ACTION-SUCCESS], [ACTION-FAILURE])
+# ----------------------------------------------------------------
+# Check whether the given compiler option works
+AC_DEFUN([_LT_COMPILER_OPTION],
+[m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+m4_require([_LT_DECL_SED])dnl
+AC_CACHE_CHECK([$1], [$2],
+ [$2=no
+ m4_if([$4], , [ac_outfile=conftest.$ac_objext], [ac_outfile=$4])
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+ lt_compiler_flag="$3"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ # The option is referenced via a variable to avoid confusing sed.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [[^ ]]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&AS_MESSAGE_LOG_FD)
+ (eval "$lt_compile" 2>conftest.err)
+ ac_status=$?
+ cat conftest.err >&AS_MESSAGE_LOG_FD
+ echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD
+ if (exit $ac_status) && test -s "$ac_outfile"; then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings other than the usual output.
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then
+ $2=yes
+ fi
+ fi
+ $RM conftest*
+])
+
+if test x"[$]$2" = xyes; then
+ m4_if([$5], , :, [$5])
+else
+ m4_if([$6], , :, [$6])
+fi
+])# _LT_COMPILER_OPTION
+
+# Old name:
+AU_ALIAS([AC_LIBTOOL_COMPILER_OPTION], [_LT_COMPILER_OPTION])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_LIBTOOL_COMPILER_OPTION], [])
+
+
+# _LT_LINKER_OPTION(MESSAGE, VARIABLE-NAME, FLAGS,
+# [ACTION-SUCCESS], [ACTION-FAILURE])
+# ----------------------------------------------------
+# Check whether the given linker option works
+AC_DEFUN([_LT_LINKER_OPTION],
+[m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+m4_require([_LT_DECL_SED])dnl
+AC_CACHE_CHECK([$1], [$2],
+ [$2=no
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS $3"
+ echo "$lt_simple_link_test_code" > conftest.$ac_ext
+ if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then
+ # The linker can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ if test -s conftest.err; then
+ # Append any errors to the config.log.
+ cat conftest.err 1>&AS_MESSAGE_LOG_FD
+ $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp
+ $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2
+ if diff conftest.exp conftest.er2 >/dev/null; then
+ $2=yes
+ fi
+ else
+ $2=yes
+ fi
+ fi
+ $RM -r conftest*
+ LDFLAGS="$save_LDFLAGS"
+])
+
+if test x"[$]$2" = xyes; then
+ m4_if([$4], , :, [$4])
+else
+ m4_if([$5], , :, [$5])
+fi
+])# _LT_LINKER_OPTION
+
+# Old name:
+AU_ALIAS([AC_LIBTOOL_LINKER_OPTION], [_LT_LINKER_OPTION])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_LIBTOOL_LINKER_OPTION], [])
+
+
+# LT_CMD_MAX_LEN
+#---------------
+AC_DEFUN([LT_CMD_MAX_LEN],
+[AC_REQUIRE([AC_CANONICAL_HOST])dnl
+# find the maximum length of command line arguments
+AC_MSG_CHECKING([the maximum length of command line arguments])
+AC_CACHE_VAL([lt_cv_sys_max_cmd_len], [dnl
+ i=0
+ teststring="ABCD"
+
+ case $build_os in
+ msdosdjgpp*)
+ # On DJGPP, this test can blow up pretty badly due to problems in libc
+ # (any single argument exceeding 2000 bytes causes a buffer overrun
+ # during glob expansion). Even if it were fixed, the result of this
+ # check would be larger than it should be.
+ lt_cv_sys_max_cmd_len=12288; # 12K is about right
+ ;;
+
+ gnu*)
+ # Under GNU Hurd, this test is not required because there is
+ # no limit to the length of command line arguments.
+ # Libtool will interpret -1 as no limit whatsoever
+ lt_cv_sys_max_cmd_len=-1;
+ ;;
+
+ cygwin* | mingw* | cegcc*)
+ # On Win9x/ME, this test blows up -- it succeeds, but takes
+ # about 5 minutes as the teststring grows exponentially.
+ # Worse, since 9x/ME are not pre-emptively multitasking,
+ # you end up with a "frozen" computer, even though with patience
+ # the test eventually succeeds (with a max line length of 256k).
+ # Instead, let's just punt: use the minimum linelength reported by
+ # all of the supported platforms: 8192 (on NT/2K/XP).
+ lt_cv_sys_max_cmd_len=8192;
+ ;;
+
+ mint*)
+ # On MiNT this can take a long time and run out of memory.
+ lt_cv_sys_max_cmd_len=8192;
+ ;;
+
+ amigaos*)
+ # On AmigaOS with pdksh, this test takes hours, literally.
+ # So we just punt and use a minimum line length of 8192.
+ lt_cv_sys_max_cmd_len=8192;
+ ;;
+
+ netbsd* | freebsd* | openbsd* | darwin* | dragonfly*)
+ # This has been around since 386BSD, at least. Likely further.
+ if test -x /sbin/sysctl; then
+ lt_cv_sys_max_cmd_len=`/sbin/sysctl -n kern.argmax`
+ elif test -x /usr/sbin/sysctl; then
+ lt_cv_sys_max_cmd_len=`/usr/sbin/sysctl -n kern.argmax`
+ else
+ lt_cv_sys_max_cmd_len=65536 # usable default for all BSDs
+ fi
+ # And add a safety zone
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4`
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3`
+ ;;
+
+ interix*)
+ # We know the value 262144 and hardcode it with a safety zone (like BSD)
+ lt_cv_sys_max_cmd_len=196608
+ ;;
+
+ osf*)
+ # Dr. Hans Ekkehard Plesser reports seeing a kernel panic running configure
+ # due to this test when exec_disable_arg_limit is 1 on Tru64. It is not
+ # nice to cause kernel panics so lets avoid the loop below.
+ # First set a reasonable default.
+ lt_cv_sys_max_cmd_len=16384
+ #
+ if test -x /sbin/sysconfig; then
+ case `/sbin/sysconfig -q proc exec_disable_arg_limit` in
+ *1*) lt_cv_sys_max_cmd_len=-1 ;;
+ esac
+ fi
+ ;;
+ sco3.2v5*)
+ lt_cv_sys_max_cmd_len=102400
+ ;;
+ sysv5* | sco5v6* | sysv4.2uw2*)
+ kargmax=`grep ARG_MAX /etc/conf/cf.d/stune 2>/dev/null`
+ if test -n "$kargmax"; then
+ lt_cv_sys_max_cmd_len=`echo $kargmax | sed 's/.*[[ ]]//'`
+ else
+ lt_cv_sys_max_cmd_len=32768
+ fi
+ ;;
+ *)
+ lt_cv_sys_max_cmd_len=`(getconf ARG_MAX) 2> /dev/null`
+ if test -n "$lt_cv_sys_max_cmd_len"; then
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4`
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3`
+ else
+ # Make teststring a little bigger before we do anything with it.
+ # a 1K string should be a reasonable start.
+ for i in 1 2 3 4 5 6 7 8 ; do
+ teststring=$teststring$teststring
+ done
+ SHELL=${SHELL-${CONFIG_SHELL-/bin/sh}}
+ # If test is not a shell built-in, we'll probably end up computing a
+ # maximum length that is only half of the actual maximum length, but
+ # we can't tell.
+ while { test "X"`func_fallback_echo "$teststring$teststring" 2>/dev/null` \
+ = "X$teststring$teststring"; } >/dev/null 2>&1 &&
+ test $i != 17 # 1/2 MB should be enough
+ do
+ i=`expr $i + 1`
+ teststring=$teststring$teststring
+ done
+ # Only check the string length outside the loop.
+ lt_cv_sys_max_cmd_len=`expr "X$teststring" : ".*" 2>&1`
+ teststring=
+ # Add a significant safety factor because C++ compilers can tack on
+ # massive amounts of additional arguments before passing them to the
+ # linker. It appears as though 1/2 is a usable value.
+ lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 2`
+ fi
+ ;;
+ esac
+])
+if test -n $lt_cv_sys_max_cmd_len ; then
+ AC_MSG_RESULT($lt_cv_sys_max_cmd_len)
+else
+ AC_MSG_RESULT(none)
+fi
+max_cmd_len=$lt_cv_sys_max_cmd_len
+_LT_DECL([], [max_cmd_len], [0],
+ [What is the maximum length of a command?])
+])# LT_CMD_MAX_LEN
+
+# Old name:
+AU_ALIAS([AC_LIBTOOL_SYS_MAX_CMD_LEN], [LT_CMD_MAX_LEN])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_LIBTOOL_SYS_MAX_CMD_LEN], [])
+
+
+# _LT_HEADER_DLFCN
+# ----------------
+m4_defun([_LT_HEADER_DLFCN],
+[AC_CHECK_HEADERS([dlfcn.h], [], [], [AC_INCLUDES_DEFAULT])dnl
+])# _LT_HEADER_DLFCN
+
+
+# _LT_TRY_DLOPEN_SELF (ACTION-IF-TRUE, ACTION-IF-TRUE-W-USCORE,
+# ACTION-IF-FALSE, ACTION-IF-CROSS-COMPILING)
+# ----------------------------------------------------------------
+m4_defun([_LT_TRY_DLOPEN_SELF],
+[m4_require([_LT_HEADER_DLFCN])dnl
+if test "$cross_compiling" = yes; then :
+ [$4]
+else
+ lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
+ lt_status=$lt_dlunknown
+ cat > conftest.$ac_ext <<_LT_EOF
+[#line $LINENO "configure"
+#include "confdefs.h"
+
+#if HAVE_DLFCN_H
+#include <dlfcn.h>
+#endif
+
+#include <stdio.h>
+
+#ifdef RTLD_GLOBAL
+# define LT_DLGLOBAL RTLD_GLOBAL
+#else
+# ifdef DL_GLOBAL
+# define LT_DLGLOBAL DL_GLOBAL
+# else
+# define LT_DLGLOBAL 0
+# endif
+#endif
+
+/* We may have to define LT_DLLAZY_OR_NOW in the command line if we
+ find out it does not work in some platform. */
+#ifndef LT_DLLAZY_OR_NOW
+# ifdef RTLD_LAZY
+# define LT_DLLAZY_OR_NOW RTLD_LAZY
+# else
+# ifdef DL_LAZY
+# define LT_DLLAZY_OR_NOW DL_LAZY
+# else
+# ifdef RTLD_NOW
+# define LT_DLLAZY_OR_NOW RTLD_NOW
+# else
+# ifdef DL_NOW
+# define LT_DLLAZY_OR_NOW DL_NOW
+# else
+# define LT_DLLAZY_OR_NOW 0
+# endif
+# endif
+# endif
+# endif
+#endif
+
+/* When -fvisbility=hidden is used, assume the code has been annotated
+ correspondingly for the symbols needed. */
+#if defined(__GNUC__) && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3))
+int fnord () __attribute__((visibility("default")));
+#endif
+
+int fnord () { return 42; }
+int main ()
+{
+ void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW);
+ int status = $lt_dlunknown;
+
+ if (self)
+ {
+ if (dlsym (self,"fnord")) status = $lt_dlno_uscore;
+ else
+ {
+ if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore;
+ else puts (dlerror ());
+ }
+ /* dlclose (self); */
+ }
+ else
+ puts (dlerror ());
+
+ return status;
+}]
+_LT_EOF
+ if AC_TRY_EVAL(ac_link) && test -s conftest${ac_exeext} 2>/dev/null; then
+ (./conftest; exit; ) >&AS_MESSAGE_LOG_FD 2>/dev/null
+ lt_status=$?
+ case x$lt_status in
+ x$lt_dlno_uscore) $1 ;;
+ x$lt_dlneed_uscore) $2 ;;
+ x$lt_dlunknown|x*) $3 ;;
+ esac
+ else :
+ # compilation failed
+ $3
+ fi
+fi
+rm -fr conftest*
+])# _LT_TRY_DLOPEN_SELF
+
+
+# LT_SYS_DLOPEN_SELF
+# ------------------
+AC_DEFUN([LT_SYS_DLOPEN_SELF],
+[m4_require([_LT_HEADER_DLFCN])dnl
+if test "x$enable_dlopen" != xyes; then
+ enable_dlopen=unknown
+ enable_dlopen_self=unknown
+ enable_dlopen_self_static=unknown
+else
+ lt_cv_dlopen=no
+ lt_cv_dlopen_libs=
+
+ case $host_os in
+ beos*)
+ lt_cv_dlopen="load_add_on"
+ lt_cv_dlopen_libs=
+ lt_cv_dlopen_self=yes
+ ;;
+
+ mingw* | pw32* | cegcc*)
+ lt_cv_dlopen="LoadLibrary"
+ lt_cv_dlopen_libs=
+ ;;
+
+ cygwin*)
+ lt_cv_dlopen="dlopen"
+ lt_cv_dlopen_libs=
+ ;;
+
+ darwin*)
+ # if libdl is installed we need to link against it
+ AC_CHECK_LIB([dl], [dlopen],
+ [lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-ldl"],[
+ lt_cv_dlopen="dyld"
+ lt_cv_dlopen_libs=
+ lt_cv_dlopen_self=yes
+ ])
+ ;;
+
+ *)
+ AC_CHECK_FUNC([shl_load],
+ [lt_cv_dlopen="shl_load"],
+ [AC_CHECK_LIB([dld], [shl_load],
+ [lt_cv_dlopen="shl_load" lt_cv_dlopen_libs="-ldld"],
+ [AC_CHECK_FUNC([dlopen],
+ [lt_cv_dlopen="dlopen"],
+ [AC_CHECK_LIB([dl], [dlopen],
+ [lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-ldl"],
+ [AC_CHECK_LIB([svld], [dlopen],
+ [lt_cv_dlopen="dlopen" lt_cv_dlopen_libs="-lsvld"],
+ [AC_CHECK_LIB([dld], [dld_link],
+ [lt_cv_dlopen="dld_link" lt_cv_dlopen_libs="-ldld"])
+ ])
+ ])
+ ])
+ ])
+ ])
+ ;;
+ esac
+
+ if test "x$lt_cv_dlopen" != xno; then
+ enable_dlopen=yes
+ else
+ enable_dlopen=no
+ fi
+
+ case $lt_cv_dlopen in
+ dlopen)
+ save_CPPFLAGS="$CPPFLAGS"
+ test "x$ac_cv_header_dlfcn_h" = xyes && CPPFLAGS="$CPPFLAGS -DHAVE_DLFCN_H"
+
+ save_LDFLAGS="$LDFLAGS"
+ wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $export_dynamic_flag_spec\"
+
+ save_LIBS="$LIBS"
+ LIBS="$lt_cv_dlopen_libs $LIBS"
+
+ AC_CACHE_CHECK([whether a program can dlopen itself],
+ lt_cv_dlopen_self, [dnl
+ _LT_TRY_DLOPEN_SELF(
+ lt_cv_dlopen_self=yes, lt_cv_dlopen_self=yes,
+ lt_cv_dlopen_self=no, lt_cv_dlopen_self=cross)
+ ])
+
+ if test "x$lt_cv_dlopen_self" = xyes; then
+ wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $lt_prog_compiler_static\"
+ AC_CACHE_CHECK([whether a statically linked program can dlopen itself],
+ lt_cv_dlopen_self_static, [dnl
+ _LT_TRY_DLOPEN_SELF(
+ lt_cv_dlopen_self_static=yes, lt_cv_dlopen_self_static=yes,
+ lt_cv_dlopen_self_static=no, lt_cv_dlopen_self_static=cross)
+ ])
+ fi
+
+ CPPFLAGS="$save_CPPFLAGS"
+ LDFLAGS="$save_LDFLAGS"
+ LIBS="$save_LIBS"
+ ;;
+ esac
+
+ case $lt_cv_dlopen_self in
+ yes|no) enable_dlopen_self=$lt_cv_dlopen_self ;;
+ *) enable_dlopen_self=unknown ;;
+ esac
+
+ case $lt_cv_dlopen_self_static in
+ yes|no) enable_dlopen_self_static=$lt_cv_dlopen_self_static ;;
+ *) enable_dlopen_self_static=unknown ;;
+ esac
+fi
+_LT_DECL([dlopen_support], [enable_dlopen], [0],
+ [Whether dlopen is supported])
+_LT_DECL([dlopen_self], [enable_dlopen_self], [0],
+ [Whether dlopen of programs is supported])
+_LT_DECL([dlopen_self_static], [enable_dlopen_self_static], [0],
+ [Whether dlopen of statically linked programs is supported])
+])# LT_SYS_DLOPEN_SELF
+
+# Old name:
+AU_ALIAS([AC_LIBTOOL_DLOPEN_SELF], [LT_SYS_DLOPEN_SELF])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_LIBTOOL_DLOPEN_SELF], [])
+
+
+# _LT_COMPILER_C_O([TAGNAME])
+# ---------------------------
+# Check to see if options -c and -o are simultaneously supported by compiler.
+# This macro does not hard code the compiler like AC_PROG_CC_C_O.
+m4_defun([_LT_COMPILER_C_O],
+[m4_require([_LT_DECL_SED])dnl
+m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+m4_require([_LT_TAG_COMPILER])dnl
+AC_CACHE_CHECK([if $compiler supports -c -o file.$ac_objext],
+ [_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)],
+ [_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)=no
+ $RM -r conftest 2>/dev/null
+ mkdir conftest
+ cd conftest
+ mkdir out
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ lt_compiler_flag="-o out/conftest2.$ac_objext"
+ # Insert the option either (1) after the last *FLAGS variable, or
+ # (2) before a word containing "conftest.", or (3) at the end.
+ # Note that $ac_compile itself does not contain backslashes and begins
+ # with a dollar sign (not a hyphen), so the echo should work correctly.
+ lt_compile=`echo "$ac_compile" | $SED \
+ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \
+ -e 's: [[^ ]]*conftest\.: $lt_compiler_flag&:; t' \
+ -e 's:$: $lt_compiler_flag:'`
+ (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&AS_MESSAGE_LOG_FD)
+ (eval "$lt_compile" 2>out/conftest.err)
+ ac_status=$?
+ cat out/conftest.err >&AS_MESSAGE_LOG_FD
+ echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD
+ if (exit $ac_status) && test -s out/conftest2.$ac_objext
+ then
+ # The compiler can only warn and ignore the option if not recognized
+ # So say no if there are warnings
+ $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp
+ $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2
+ if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then
+ _LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)=yes
+ fi
+ fi
+ chmod u+w . 2>&AS_MESSAGE_LOG_FD
+ $RM conftest*
+ # SGI C++ compiler will create directory out/ii_files/ for
+ # template instantiation
+ test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files
+ $RM out/* && rmdir out
+ cd ..
+ $RM -r conftest
+ $RM conftest*
+])
+_LT_TAGDECL([compiler_c_o], [lt_cv_prog_compiler_c_o], [1],
+ [Does compiler simultaneously support -c and -o options?])
+])# _LT_COMPILER_C_O
+
+
+# _LT_COMPILER_FILE_LOCKS([TAGNAME])
+# ----------------------------------
+# Check to see if we can do hard links to lock some files if needed
+m4_defun([_LT_COMPILER_FILE_LOCKS],
+[m4_require([_LT_ENABLE_LOCK])dnl
+m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+_LT_COMPILER_C_O([$1])
+
+hard_links="nottested"
+if test "$_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)" = no && test "$need_locks" != no; then
+ # do not overwrite the value of need_locks provided by the user
+ AC_MSG_CHECKING([if we can lock with hard links])
+ hard_links=yes
+ $RM conftest*
+ ln conftest.a conftest.b 2>/dev/null && hard_links=no
+ touch conftest.a
+ ln conftest.a conftest.b 2>&5 || hard_links=no
+ ln conftest.a conftest.b 2>/dev/null && hard_links=no
+ AC_MSG_RESULT([$hard_links])
+ if test "$hard_links" = no; then
+ AC_MSG_WARN([`$CC' does not support `-c -o', so `make -j' may be unsafe])
+ need_locks=warn
+ fi
+else
+ need_locks=no
+fi
+_LT_DECL([], [need_locks], [1], [Must we lock files when doing compilation?])
+])# _LT_COMPILER_FILE_LOCKS
+
+
+# _LT_CHECK_OBJDIR
+# ----------------
+m4_defun([_LT_CHECK_OBJDIR],
+[AC_CACHE_CHECK([for objdir], [lt_cv_objdir],
+[rm -f .libs 2>/dev/null
+mkdir .libs 2>/dev/null
+if test -d .libs; then
+ lt_cv_objdir=.libs
+else
+ # MS-DOS does not allow filenames that begin with a dot.
+ lt_cv_objdir=_libs
+fi
+rmdir .libs 2>/dev/null])
+objdir=$lt_cv_objdir
+_LT_DECL([], [objdir], [0],
+ [The name of the directory that contains temporary libtool files])dnl
+m4_pattern_allow([LT_OBJDIR])dnl
+AC_DEFINE_UNQUOTED(LT_OBJDIR, "$lt_cv_objdir/",
+ [Define to the sub-directory in which libtool stores uninstalled libraries.])
+])# _LT_CHECK_OBJDIR
+
+
+# _LT_LINKER_HARDCODE_LIBPATH([TAGNAME])
+# --------------------------------------
+# Check hardcoding attributes.
+m4_defun([_LT_LINKER_HARDCODE_LIBPATH],
+[AC_MSG_CHECKING([how to hardcode library paths into programs])
+_LT_TAGVAR(hardcode_action, $1)=
+if test -n "$_LT_TAGVAR(hardcode_libdir_flag_spec, $1)" ||
+ test -n "$_LT_TAGVAR(runpath_var, $1)" ||
+ test "X$_LT_TAGVAR(hardcode_automatic, $1)" = "Xyes" ; then
+
+ # We can hardcode non-existent directories.
+ if test "$_LT_TAGVAR(hardcode_direct, $1)" != no &&
+ # If the only mechanism to avoid hardcoding is shlibpath_var, we
+ # have to relink, otherwise we might link with an installed library
+ # when we should be linking with a yet-to-be-installed one
+ ## test "$_LT_TAGVAR(hardcode_shlibpath_var, $1)" != no &&
+ test "$_LT_TAGVAR(hardcode_minus_L, $1)" != no; then
+ # Linking always hardcodes the temporary library directory.
+ _LT_TAGVAR(hardcode_action, $1)=relink
+ else
+ # We can link without hardcoding, and we can hardcode nonexisting dirs.
+ _LT_TAGVAR(hardcode_action, $1)=immediate
+ fi
+else
+ # We cannot hardcode anything, or else we can only hardcode existing
+ # directories.
+ _LT_TAGVAR(hardcode_action, $1)=unsupported
+fi
+AC_MSG_RESULT([$_LT_TAGVAR(hardcode_action, $1)])
+
+if test "$_LT_TAGVAR(hardcode_action, $1)" = relink ||
+ test "$_LT_TAGVAR(inherit_rpath, $1)" = yes; then
+ # Fast installation is not supported
+ enable_fast_install=no
+elif test "$shlibpath_overrides_runpath" = yes ||
+ test "$enable_shared" = no; then
+ # Fast installation is not necessary
+ enable_fast_install=needless
+fi
+_LT_TAGDECL([], [hardcode_action], [0],
+ [How to hardcode a shared library path into an executable])
+])# _LT_LINKER_HARDCODE_LIBPATH
+
+
+# _LT_CMD_STRIPLIB
+# ----------------
+m4_defun([_LT_CMD_STRIPLIB],
+[m4_require([_LT_DECL_EGREP])
+striplib=
+old_striplib=
+AC_MSG_CHECKING([whether stripping libraries is possible])
+if test -n "$STRIP" && $STRIP -V 2>&1 | $GREP "GNU strip" >/dev/null; then
+ test -z "$old_striplib" && old_striplib="$STRIP --strip-debug"
+ test -z "$striplib" && striplib="$STRIP --strip-unneeded"
+ AC_MSG_RESULT([yes])
+else
+# FIXME - insert some real tests, host_os isn't really good enough
+ case $host_os in
+ darwin*)
+ if test -n "$STRIP" ; then
+ striplib="$STRIP -x"
+ old_striplib="$STRIP -S"
+ AC_MSG_RESULT([yes])
+ else
+ AC_MSG_RESULT([no])
+ fi
+ ;;
+ *)
+ AC_MSG_RESULT([no])
+ ;;
+ esac
+fi
+_LT_DECL([], [old_striplib], [1], [Commands to strip libraries])
+_LT_DECL([], [striplib], [1])
+])# _LT_CMD_STRIPLIB
+
+
+# _LT_SYS_DYNAMIC_LINKER([TAG])
+# -----------------------------
+# PORTME Fill in your ld.so characteristics
+m4_defun([_LT_SYS_DYNAMIC_LINKER],
+[AC_REQUIRE([AC_CANONICAL_HOST])dnl
+m4_require([_LT_DECL_EGREP])dnl
+m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+m4_require([_LT_DECL_OBJDUMP])dnl
+m4_require([_LT_DECL_SED])dnl
+m4_require([_LT_CHECK_SHELL_FEATURES])dnl
+AC_MSG_CHECKING([dynamic linker characteristics])
+m4_if([$1],
+ [], [
+if test "$GCC" = yes; then
+ case $host_os in
+ darwin*) lt_awk_arg="/^libraries:/,/LR/" ;;
+ *) lt_awk_arg="/^libraries:/" ;;
+ esac
+ case $host_os in
+ mingw* | cegcc*) lt_sed_strip_eq="s,=\([[A-Za-z]]:\),\1,g" ;;
+ *) lt_sed_strip_eq="s,=/,/,g" ;;
+ esac
+ lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e $lt_sed_strip_eq`
+ case $lt_search_path_spec in
+ *\;*)
+ # if the path contains ";" then we assume it to be the separator
+ # otherwise default to the standard path separator (i.e. ":") - it is
+ # assumed that no part of a normal pathname contains ";" but that should
+ # okay in the real world where ";" in dirpaths is itself problematic.
+ lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED 's/;/ /g'`
+ ;;
+ *)
+ lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED "s/$PATH_SEPARATOR/ /g"`
+ ;;
+ esac
+ # Ok, now we have the path, separated by spaces, we can step through it
+ # and add multilib dir if necessary.
+ lt_tmp_lt_search_path_spec=
+ lt_multi_os_dir=`$CC $CPPFLAGS $CFLAGS $LDFLAGS -print-multi-os-directory 2>/dev/null`
+ for lt_sys_path in $lt_search_path_spec; do
+ if test -d "$lt_sys_path/$lt_multi_os_dir"; then
+ lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path/$lt_multi_os_dir"
+ else
+ test -d "$lt_sys_path" && \
+ lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path"
+ fi
+ done
+ lt_search_path_spec=`$ECHO "$lt_tmp_lt_search_path_spec" | awk '
+BEGIN {RS=" "; FS="/|\n";} {
+ lt_foo="";
+ lt_count=0;
+ for (lt_i = NF; lt_i > 0; lt_i--) {
+ if ($lt_i != "" && $lt_i != ".") {
+ if ($lt_i == "..") {
+ lt_count++;
+ } else {
+ if (lt_count == 0) {
+ lt_foo="/" $lt_i lt_foo;
+ } else {
+ lt_count--;
+ }
+ }
+ }
+ }
+ if (lt_foo != "") { lt_freq[[lt_foo]]++; }
+ if (lt_freq[[lt_foo]] == 1) { print lt_foo; }
+}'`
+ # AWK program above erroneously prepends '/' to C:/dos/paths
+ # for these hosts.
+ case $host_os in
+ mingw* | cegcc*) lt_search_path_spec=`$ECHO "$lt_search_path_spec" |\
+ $SED 's,/\([[A-Za-z]]:\),\1,g'` ;;
+ esac
+ sys_lib_search_path_spec=`$ECHO "$lt_search_path_spec" | $lt_NL2SP`
+else
+ sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib"
+fi])
+library_names_spec=
+libname_spec='lib$name'
+soname_spec=
+shrext_cmds=".so"
+postinstall_cmds=
+postuninstall_cmds=
+finish_cmds=
+finish_eval=
+shlibpath_var=
+shlibpath_overrides_runpath=unknown
+version_type=none
+dynamic_linker="$host_os ld.so"
+sys_lib_dlsearch_path_spec="/lib /usr/lib"
+need_lib_prefix=unknown
+hardcode_into_libs=no
+
+# when you set need_version to no, make sure it does not cause -set_version
+# flags to be left without arguments
+need_version=unknown
+
+case $host_os in
+aix3*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix $libname.a'
+ shlibpath_var=LIBPATH
+
+ # AIX 3 has no versioning support, so we append a major version to the name.
+ soname_spec='${libname}${release}${shared_ext}$major'
+ ;;
+
+aix[[4-9]]*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ hardcode_into_libs=yes
+ if test "$host_cpu" = ia64; then
+ # AIX 5 supports IA64
+ library_names_spec='${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext}$versuffix $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ else
+ # With GCC up to 2.95.x, collect2 would create an import file
+ # for dependence libraries. The import file would start with
+ # the line `#! .'. This would cause the generated library to
+ # depend on `.', always an invalid library. This was fixed in
+ # development snapshots of GCC prior to 3.0.
+ case $host_os in
+ aix4 | aix4.[[01]] | aix4.[[01]].*)
+ if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)'
+ echo ' yes '
+ echo '#endif'; } | ${CC} -E - | $GREP yes > /dev/null; then
+ :
+ else
+ can_build_shared=no
+ fi
+ ;;
+ esac
+ # AIX (on Power*) has no versioning support, so currently we can not hardcode correct
+ # soname into executable. Probably we can add versioning support to
+ # collect2, so additional links can be useful in future.
+ if test "$aix_use_runtimelinking" = yes; then
+ # If using run time linking (on AIX 4.2 or later) use lib<name>.so
+ # instead of lib<name>.a to let people know that these are not
+ # typical AIX shared libraries.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ else
+ # We preserve .a as extension for shared libraries through AIX4.2
+ # and later when we are not doing run time linking.
+ library_names_spec='${libname}${release}.a $libname.a'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ fi
+ shlibpath_var=LIBPATH
+ fi
+ ;;
+
+amigaos*)
+ case $host_cpu in
+ powerpc)
+ # Since July 2007 AmigaOS4 officially supports .so libraries.
+ # When compiling the executable, add -use-dynld -Lsobjs: to the compileline.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ ;;
+ m68k)
+ library_names_spec='$libname.ixlibrary $libname.a'
+ # Create ${libname}_ixlibrary.a entries in /sys/libs.
+ finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`func_echo_all "$lib" | $SED '\''s%^.*/\([[^/]]*\)\.ixlibrary$%\1%'\''`; test $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done'
+ ;;
+ esac
+ ;;
+
+beos*)
+ library_names_spec='${libname}${shared_ext}'
+ dynamic_linker="$host_os ld.so"
+ shlibpath_var=LIBRARY_PATH
+ ;;
+
+bsdi[[45]]*)
+ version_type=linux
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib"
+ sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib"
+ # the default ld.so.conf also contains /usr/contrib/lib and
+ # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow
+ # libtool to hard-code these into programs
+ ;;
+
+cygwin* | mingw* | pw32* | cegcc*)
+ version_type=windows
+ shrext_cmds=".dll"
+ need_version=no
+ need_lib_prefix=no
+
+ case $GCC,$cc_basename in
+ yes,*)
+ # gcc
+ library_names_spec='$libname.dll.a'
+ # DLL is installed to $(libdir)/../bin by postinstall_cmds
+ postinstall_cmds='base_file=`basename \${file}`~
+ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~
+ dldir=$destdir/`dirname \$dlpath`~
+ test -d \$dldir || mkdir -p \$dldir~
+ $install_prog $dir/$dlname \$dldir/$dlname~
+ chmod a+x \$dldir/$dlname~
+ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then
+ eval '\''$striplib \$dldir/$dlname'\'' || exit \$?;
+ fi'
+ postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~
+ dlpath=$dir/\$dldll~
+ $RM \$dlpath'
+ shlibpath_overrides_runpath=yes
+
+ case $host_os in
+ cygwin*)
+ # Cygwin DLLs use 'cyg' prefix rather than 'lib'
+ soname_spec='`echo ${libname} | sed -e 's/^lib/cyg/'``echo ${release} | $SED -e 's/[[.]]/-/g'`${versuffix}${shared_ext}'
+m4_if([$1], [],[
+ sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/lib/w32api"])
+ ;;
+ mingw* | cegcc*)
+ # MinGW DLLs use traditional 'lib' prefix
+ soname_spec='${libname}`echo ${release} | $SED -e 's/[[.]]/-/g'`${versuffix}${shared_ext}'
+ ;;
+ pw32*)
+ # pw32 DLLs use 'pw' prefix rather than 'lib'
+ library_names_spec='`echo ${libname} | sed -e 's/^lib/pw/'``echo ${release} | $SED -e 's/[[.]]/-/g'`${versuffix}${shared_ext}'
+ ;;
+ esac
+ dynamic_linker='Win32 ld.exe'
+ ;;
+
+ *,cl*)
+ # Native MSVC
+ libname_spec='$name'
+ soname_spec='${libname}`echo ${release} | $SED -e 's/[[.]]/-/g'`${versuffix}${shared_ext}'
+ library_names_spec='${libname}.dll.lib'
+
+ case $build_os in
+ mingw*)
+ sys_lib_search_path_spec=
+ lt_save_ifs=$IFS
+ IFS=';'
+ for lt_path in $LIB
+ do
+ IFS=$lt_save_ifs
+ # Let DOS variable expansion print the short 8.3 style file name.
+ lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"`
+ sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path"
+ done
+ IFS=$lt_save_ifs
+ # Convert to MSYS style.
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([[a-zA-Z]]\\):| /\\1|g' -e 's|^ ||'`
+ ;;
+ cygwin*)
+ # Convert to unix form, then to dos form, then back to unix form
+ # but this time dos style (no spaces!) so that the unix form looks
+ # like /cygdrive/c/PROGRA~1:/cygdr...
+ sys_lib_search_path_spec=`cygpath --path --unix "$LIB"`
+ sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null`
+ sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"`
+ ;;
+ *)
+ sys_lib_search_path_spec="$LIB"
+ if $ECHO "$sys_lib_search_path_spec" | [$GREP ';[c-zC-Z]:/' >/dev/null]; then
+ # It is most probably a Windows format PATH.
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'`
+ else
+ sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"`
+ fi
+ # FIXME: find the short name or the path components, as spaces are
+ # common. (e.g. "Program Files" -> "PROGRA~1")
+ ;;
+ esac
+
+ # DLL is installed to $(libdir)/../bin by postinstall_cmds
+ postinstall_cmds='base_file=`basename \${file}`~
+ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\${base_file}'\''i; echo \$dlname'\''`~
+ dldir=$destdir/`dirname \$dlpath`~
+ test -d \$dldir || mkdir -p \$dldir~
+ $install_prog $dir/$dlname \$dldir/$dlname'
+ postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~
+ dlpath=$dir/\$dldll~
+ $RM \$dlpath'
+ shlibpath_overrides_runpath=yes
+ dynamic_linker='Win32 link.exe'
+ ;;
+
+ *)
+ # Assume MSVC wrapper
+ library_names_spec='${libname}`echo ${release} | $SED -e 's/[[.]]/-/g'`${versuffix}${shared_ext} $libname.lib'
+ dynamic_linker='Win32 ld.exe'
+ ;;
+ esac
+ # FIXME: first we should search . and the directory the executable is in
+ shlibpath_var=PATH
+ ;;
+
+darwin* | rhapsody*)
+ dynamic_linker="$host_os dyld"
+ version_type=darwin
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${major}$shared_ext ${libname}$shared_ext'
+ soname_spec='${libname}${release}${major}$shared_ext'
+ shlibpath_overrides_runpath=yes
+ shlibpath_var=DYLD_LIBRARY_PATH
+ shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`'
+m4_if([$1], [],[
+ sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/local/lib"])
+ sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib'
+ ;;
+
+dgux*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname$shared_ext'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+freebsd1*)
+ dynamic_linker=no
+ ;;
+
+freebsd* | dragonfly*)
+ # DragonFly does not have aout. When/if they implement a new
+ # versioning mechanism, adjust this.
+ if test -x /usr/bin/objformat; then
+ objformat=`/usr/bin/objformat`
+ else
+ case $host_os in
+ freebsd[[123]]*) objformat=aout ;;
+ *) objformat=elf ;;
+ esac
+ fi
+ version_type=freebsd-$objformat
+ case $version_type in
+ freebsd-elf*)
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}'
+ need_version=no
+ need_lib_prefix=no
+ ;;
+ freebsd-*)
+ library_names_spec='${libname}${release}${shared_ext}$versuffix $libname${shared_ext}$versuffix'
+ need_version=yes
+ ;;
+ esac
+ shlibpath_var=LD_LIBRARY_PATH
+ case $host_os in
+ freebsd2*)
+ shlibpath_overrides_runpath=yes
+ ;;
+ freebsd3.[[01]]* | freebsdelf3.[[01]]*)
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+ freebsd3.[[2-9]]* | freebsdelf3.[[2-9]]* | \
+ freebsd4.[[0-5]] | freebsdelf4.[[0-5]] | freebsd4.1.1 | freebsdelf4.1.1)
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+ *) # from 4.6 on, and DragonFly
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+ esac
+ ;;
+
+gnu*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ hardcode_into_libs=yes
+ ;;
+
+haiku*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ dynamic_linker="$host_os runtime_loader"
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}${major} ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib'
+ hardcode_into_libs=yes
+ ;;
+
+hpux9* | hpux10* | hpux11*)
+ # Give a soname corresponding to the major version so that dld.sl refuses to
+ # link against other versions.
+ version_type=sunos
+ need_lib_prefix=no
+ need_version=no
+ case $host_cpu in
+ ia64*)
+ shrext_cmds='.so'
+ hardcode_into_libs=yes
+ dynamic_linker="$host_os dld.so"
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes # Unless +noenvvar is specified.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ if test "X$HPUX_IA64_MODE" = X32; then
+ sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib"
+ else
+ sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64"
+ fi
+ sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec
+ ;;
+ hppa*64*)
+ shrext_cmds='.sl'
+ hardcode_into_libs=yes
+ dynamic_linker="$host_os dld.sl"
+ shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH
+ shlibpath_overrides_runpath=yes # Unless +noenvvar is specified.
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64"
+ sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec
+ ;;
+ *)
+ shrext_cmds='.sl'
+ dynamic_linker="$host_os dld.sl"
+ shlibpath_var=SHLIB_PATH
+ shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ ;;
+ esac
+ # HP-UX runs *really* slowly unless shared libraries are mode 555, ...
+ postinstall_cmds='chmod 555 $lib'
+ # or fails outright, so override atomically:
+ install_override_mode=555
+ ;;
+
+interix[[3-9]]*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+
+irix5* | irix6* | nonstopux*)
+ case $host_os in
+ nonstopux*) version_type=nonstopux ;;
+ *)
+ if test "$lt_cv_prog_gnu_ld" = yes; then
+ version_type=linux
+ else
+ version_type=irix
+ fi ;;
+ esac
+ need_lib_prefix=no
+ need_version=no
+ soname_spec='${libname}${release}${shared_ext}$major'
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${release}${shared_ext} $libname${shared_ext}'
+ case $host_os in
+ irix5* | nonstopux*)
+ libsuff= shlibsuff=
+ ;;
+ *)
+ case $LD in # libtool.m4 will add one of these switches to LD
+ *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ")
+ libsuff= shlibsuff= libmagic=32-bit;;
+ *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ")
+ libsuff=32 shlibsuff=N32 libmagic=N32;;
+ *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ")
+ libsuff=64 shlibsuff=64 libmagic=64-bit;;
+ *) libsuff= shlibsuff= libmagic=never-match;;
+ esac
+ ;;
+ esac
+ shlibpath_var=LD_LIBRARY${shlibsuff}_PATH
+ shlibpath_overrides_runpath=no
+ sys_lib_search_path_spec="/usr/lib${libsuff} /lib${libsuff} /usr/local/lib${libsuff}"
+ sys_lib_dlsearch_path_spec="/usr/lib${libsuff} /lib${libsuff}"
+ hardcode_into_libs=yes
+ ;;
+
+# No shared lib support for Linux oldld, aout, or coff.
+linux*oldld* | linux*aout* | linux*coff*)
+ dynamic_linker=no
+ ;;
+
+# This must be Linux ELF.
+linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+
+ # Some binutils ld are patched to set DT_RUNPATH
+ AC_CACHE_VAL([lt_cv_shlibpath_overrides_runpath],
+ [lt_cv_shlibpath_overrides_runpath=no
+ save_LDFLAGS=$LDFLAGS
+ save_libdir=$libdir
+ eval "libdir=/foo; wl=\"$_LT_TAGVAR(lt_prog_compiler_wl, $1)\"; \
+ LDFLAGS=\"\$LDFLAGS $_LT_TAGVAR(hardcode_libdir_flag_spec, $1)\""
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([],[])],
+ [AS_IF([ ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null],
+ [lt_cv_shlibpath_overrides_runpath=yes])])
+ LDFLAGS=$save_LDFLAGS
+ libdir=$save_libdir
+ ])
+ shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath
+
+ # This implies no fast_install, which is unacceptable.
+ # Some rework will be needed to allow for fast_install
+ # before this can be enabled.
+ hardcode_into_libs=yes
+
+ # Append ld.so.conf contents to the search path
+ if test -f /etc/ld.so.conf; then
+ lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \[$]2)); skip = 1; } { if (!skip) print \[$]0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;s/"//g;/^$/d' | tr '\n' ' '`
+ sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra"
+ fi
+
+ # We used to test for /lib/ld.so.1 and disable shared libraries on
+ # powerpc, because MkLinux only supported shared libraries with the
+ # GNU dynamic linker. Since this was broken with cross compilers,
+ # most powerpc-linux boxes support dynamic linking these days and
+ # people can always --disable-shared, the test was removed, and we
+ # assume the GNU/Linux dynamic linker is in use.
+ dynamic_linker='GNU/Linux ld.so'
+ ;;
+
+netbsd*)
+ version_type=sunos
+ need_lib_prefix=no
+ need_version=no
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir'
+ dynamic_linker='NetBSD (a.out) ld.so'
+ else
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ dynamic_linker='NetBSD ld.elf_so'
+ fi
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ ;;
+
+newsos6)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ ;;
+
+*nto* | *qnx*)
+ version_type=qnx
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ dynamic_linker='ldqnx.so'
+ ;;
+
+openbsd*)
+ version_type=sunos
+ sys_lib_dlsearch_path_spec="/usr/lib"
+ need_lib_prefix=no
+ # Some older versions of OpenBSD (3.3 at least) *do* need versioned libs.
+ case $host_os in
+ openbsd3.3 | openbsd3.3.*) need_version=yes ;;
+ *) need_version=no ;;
+ esac
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ case $host_os in
+ openbsd2.[[89]] | openbsd2.[[89]].*)
+ shlibpath_overrides_runpath=no
+ ;;
+ *)
+ shlibpath_overrides_runpath=yes
+ ;;
+ esac
+ else
+ shlibpath_overrides_runpath=yes
+ fi
+ ;;
+
+os2*)
+ libname_spec='$name'
+ shrext_cmds=".dll"
+ need_lib_prefix=no
+ library_names_spec='$libname${shared_ext} $libname.a'
+ dynamic_linker='OS/2 ld.exe'
+ shlibpath_var=LIBPATH
+ ;;
+
+osf3* | osf4* | osf5*)
+ version_type=osf
+ need_lib_prefix=no
+ need_version=no
+ soname_spec='${libname}${release}${shared_ext}$major'
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib"
+ sys_lib_dlsearch_path_spec="$sys_lib_search_path_spec"
+ ;;
+
+rdos*)
+ dynamic_linker=no
+ ;;
+
+solaris*)
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ # ldd complains unless libraries are executable
+ postinstall_cmds='chmod +x $lib'
+ ;;
+
+sunos4*)
+ version_type=sunos
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${shared_ext}$versuffix'
+ finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ if test "$with_gnu_ld" = yes; then
+ need_lib_prefix=no
+ fi
+ need_version=yes
+ ;;
+
+sysv4 | sysv4.3*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ case $host_vendor in
+ sni)
+ shlibpath_overrides_runpath=no
+ need_lib_prefix=no
+ runpath_var=LD_RUN_PATH
+ ;;
+ siemens)
+ need_lib_prefix=no
+ ;;
+ motorola)
+ need_lib_prefix=no
+ need_version=no
+ shlibpath_overrides_runpath=no
+ sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib'
+ ;;
+ esac
+ ;;
+
+sysv4*MP*)
+ if test -d /usr/nec ;then
+ version_type=linux
+ library_names_spec='$libname${shared_ext}.$versuffix $libname${shared_ext}.$major $libname${shared_ext}'
+ soname_spec='$libname${shared_ext}.$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ fi
+ ;;
+
+sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
+ version_type=freebsd-elf
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext} $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=yes
+ hardcode_into_libs=yes
+ if test "$with_gnu_ld" = yes; then
+ sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib'
+ else
+ sys_lib_search_path_spec='/usr/ccs/lib /usr/lib'
+ case $host_os in
+ sco3.2v5*)
+ sys_lib_search_path_spec="$sys_lib_search_path_spec /lib"
+ ;;
+ esac
+ fi
+ sys_lib_dlsearch_path_spec='/usr/lib'
+ ;;
+
+tpf*)
+ # TPF is a cross-target only. Preferred cross-host = GNU/Linux.
+ version_type=linux
+ need_lib_prefix=no
+ need_version=no
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ shlibpath_var=LD_LIBRARY_PATH
+ shlibpath_overrides_runpath=no
+ hardcode_into_libs=yes
+ ;;
+
+uts4*)
+ version_type=linux
+ library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major $libname${shared_ext}'
+ soname_spec='${libname}${release}${shared_ext}$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*)
+ dynamic_linker=no
+ ;;
+esac
+AC_MSG_RESULT([$dynamic_linker])
+test "$dynamic_linker" = no && can_build_shared=no
+
+variables_saved_for_relink="PATH $shlibpath_var $runpath_var"
+if test "$GCC" = yes; then
+ variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH"
+fi
+
+if test "${lt_cv_sys_lib_search_path_spec+set}" = set; then
+ sys_lib_search_path_spec="$lt_cv_sys_lib_search_path_spec"
+fi
+if test "${lt_cv_sys_lib_dlsearch_path_spec+set}" = set; then
+ sys_lib_dlsearch_path_spec="$lt_cv_sys_lib_dlsearch_path_spec"
+fi
+
+_LT_DECL([], [variables_saved_for_relink], [1],
+ [Variables whose values should be saved in libtool wrapper scripts and
+ restored at link time])
+_LT_DECL([], [need_lib_prefix], [0],
+ [Do we need the "lib" prefix for modules?])
+_LT_DECL([], [need_version], [0], [Do we need a version for libraries?])
+_LT_DECL([], [version_type], [0], [Library versioning type])
+_LT_DECL([], [runpath_var], [0], [Shared library runtime path variable])
+_LT_DECL([], [shlibpath_var], [0],[Shared library path variable])
+_LT_DECL([], [shlibpath_overrides_runpath], [0],
+ [Is shlibpath searched before the hard-coded library search path?])
+_LT_DECL([], [libname_spec], [1], [Format of library name prefix])
+_LT_DECL([], [library_names_spec], [1],
+ [[List of archive names. First name is the real one, the rest are links.
+ The last name is the one that the linker finds with -lNAME]])
+_LT_DECL([], [soname_spec], [1],
+ [[The coded name of the library, if different from the real name]])
+_LT_DECL([], [install_override_mode], [1],
+ [Permission mode override for installation of shared libraries])
+_LT_DECL([], [postinstall_cmds], [2],
+ [Command to use after installation of a shared archive])
+_LT_DECL([], [postuninstall_cmds], [2],
+ [Command to use after uninstallation of a shared archive])
+_LT_DECL([], [finish_cmds], [2],
+ [Commands used to finish a libtool library installation in a directory])
+_LT_DECL([], [finish_eval], [1],
+ [[As "finish_cmds", except a single script fragment to be evaled but
+ not shown]])
+_LT_DECL([], [hardcode_into_libs], [0],
+ [Whether we should hardcode library paths into libraries])
+_LT_DECL([], [sys_lib_search_path_spec], [2],
+ [Compile-time system search path for libraries])
+_LT_DECL([], [sys_lib_dlsearch_path_spec], [2],
+ [Run-time system search path for libraries])
+])# _LT_SYS_DYNAMIC_LINKER
+
+
+# _LT_PATH_TOOL_PREFIX(TOOL)
+# --------------------------
+# find a file program which can recognize shared library
+AC_DEFUN([_LT_PATH_TOOL_PREFIX],
+[m4_require([_LT_DECL_EGREP])dnl
+AC_MSG_CHECKING([for $1])
+AC_CACHE_VAL(lt_cv_path_MAGIC_CMD,
+[case $MAGIC_CMD in
+[[\\/*] | ?:[\\/]*])
+ lt_cv_path_MAGIC_CMD="$MAGIC_CMD" # Let the user override the test with a path.
+ ;;
+*)
+ lt_save_MAGIC_CMD="$MAGIC_CMD"
+ lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR
+dnl $ac_dummy forces splitting on constant user-supplied paths.
+dnl POSIX.2 word splitting is done only on the output of word expansions,
+dnl not every word. This closes a longstanding sh security hole.
+ ac_dummy="m4_if([$2], , $PATH, [$2])"
+ for ac_dir in $ac_dummy; do
+ IFS="$lt_save_ifs"
+ test -z "$ac_dir" && ac_dir=.
+ if test -f $ac_dir/$1; then
+ lt_cv_path_MAGIC_CMD="$ac_dir/$1"
+ if test -n "$file_magic_test_file"; then
+ case $deplibs_check_method in
+ "file_magic "*)
+ file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"`
+ MAGIC_CMD="$lt_cv_path_MAGIC_CMD"
+ if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null |
+ $EGREP "$file_magic_regex" > /dev/null; then
+ :
+ else
+ cat <<_LT_EOF 1>&2
+
+*** Warning: the command libtool uses to detect shared libraries,
+*** $file_magic_cmd, produces output that libtool cannot recognize.
+*** The result is that libtool may fail to recognize shared libraries
+*** as such. This will affect the creation of libtool libraries that
+*** depend on shared libraries, but programs linked with such libtool
+*** libraries will work regardless of this problem. Nevertheless, you
+*** may want to report the problem to your system manager and/or to
+*** bug-libtool@gnu.org
+
+_LT_EOF
+ fi ;;
+ esac
+ fi
+ break
+ fi
+ done
+ IFS="$lt_save_ifs"
+ MAGIC_CMD="$lt_save_MAGIC_CMD"
+ ;;
+esac])
+MAGIC_CMD="$lt_cv_path_MAGIC_CMD"
+if test -n "$MAGIC_CMD"; then
+ AC_MSG_RESULT($MAGIC_CMD)
+else
+ AC_MSG_RESULT(no)
+fi
+_LT_DECL([], [MAGIC_CMD], [0],
+ [Used to examine libraries when file_magic_cmd begins with "file"])dnl
+])# _LT_PATH_TOOL_PREFIX
+
+# Old name:
+AU_ALIAS([AC_PATH_TOOL_PREFIX], [_LT_PATH_TOOL_PREFIX])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_PATH_TOOL_PREFIX], [])
+
+
+# _LT_PATH_MAGIC
+# --------------
+# find a file program which can recognize a shared library
+m4_defun([_LT_PATH_MAGIC],
+[_LT_PATH_TOOL_PREFIX(${ac_tool_prefix}file, /usr/bin$PATH_SEPARATOR$PATH)
+if test -z "$lt_cv_path_MAGIC_CMD"; then
+ if test -n "$ac_tool_prefix"; then
+ _LT_PATH_TOOL_PREFIX(file, /usr/bin$PATH_SEPARATOR$PATH)
+ else
+ MAGIC_CMD=:
+ fi
+fi
+])# _LT_PATH_MAGIC
+
+
+# LT_PATH_LD
+# ----------
+# find the pathname to the GNU or non-GNU linker
+AC_DEFUN([LT_PATH_LD],
+[AC_REQUIRE([AC_PROG_CC])dnl
+AC_REQUIRE([AC_CANONICAL_HOST])dnl
+AC_REQUIRE([AC_CANONICAL_BUILD])dnl
+m4_require([_LT_DECL_SED])dnl
+m4_require([_LT_DECL_EGREP])dnl
+m4_require([_LT_PROG_ECHO_BACKSLASH])dnl
+
+AC_ARG_WITH([gnu-ld],
+ [AS_HELP_STRING([--with-gnu-ld],
+ [assume the C compiler uses GNU ld @<:@default=no@:>@])],
+ [test "$withval" = no || with_gnu_ld=yes],
+ [with_gnu_ld=no])dnl
+
+ac_prog=ld
+if test "$GCC" = yes; then
+ # Check if gcc -print-prog-name=ld gives a path.
+ AC_MSG_CHECKING([for ld used by $CC])
+ case $host in
+ *-*-mingw*)
+ # gcc leaves a trailing carriage return which upsets mingw
+ ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;;
+ *)
+ ac_prog=`($CC -print-prog-name=ld) 2>&5` ;;
+ esac
+ case $ac_prog in
+ # Accept absolute paths.
+ [[\\/]]* | ?:[[\\/]]*)
+ re_direlt='/[[^/]][[^/]]*/\.\./'
+ # Canonicalize the pathname of ld
+ ac_prog=`$ECHO "$ac_prog"| $SED 's%\\\\%/%g'`
+ while $ECHO "$ac_prog" | $GREP "$re_direlt" > /dev/null 2>&1; do
+ ac_prog=`$ECHO $ac_prog| $SED "s%$re_direlt%/%"`
+ done
+ test -z "$LD" && LD="$ac_prog"
+ ;;
+ "")
+ # If it fails, then pretend we aren't using GCC.
+ ac_prog=ld
+ ;;
+ *)
+ # If it is relative, then search for the first ld in PATH.
+ with_gnu_ld=unknown
+ ;;
+ esac
+elif test "$with_gnu_ld" = yes; then
+ AC_MSG_CHECKING([for GNU ld])
+else
+ AC_MSG_CHECKING([for non-GNU ld])
+fi
+AC_CACHE_VAL(lt_cv_path_LD,
+[if test -z "$LD"; then
+ lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR
+ for ac_dir in $PATH; do
+ IFS="$lt_save_ifs"
+ test -z "$ac_dir" && ac_dir=.
+ if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then
+ lt_cv_path_LD="$ac_dir/$ac_prog"
+ # Check to see if the program is GNU ld. I'd rather use --version,
+ # but apparently some variants of GNU ld only accept -v.
+ # Break only if it was the GNU/non-GNU ld that we prefer.
+ case `"$lt_cv_path_LD" -v 2>&1 </dev/null` in
+ *GNU* | *'with BFD'*)
+ test "$with_gnu_ld" != no && break
+ ;;
+ *)
+ test "$with_gnu_ld" != yes && break
+ ;;
+ esac
+ fi
+ done
+ IFS="$lt_save_ifs"
+else
+ lt_cv_path_LD="$LD" # Let the user override the test with a path.
+fi])
+LD="$lt_cv_path_LD"
+if test -n "$LD"; then
+ AC_MSG_RESULT($LD)
+else
+ AC_MSG_RESULT(no)
+fi
+test -z "$LD" && AC_MSG_ERROR([no acceptable ld found in \$PATH])
+_LT_PATH_LD_GNU
+AC_SUBST([LD])
+
+_LT_TAGDECL([], [LD], [1], [The linker used to build libraries])
+])# LT_PATH_LD
+
+# Old names:
+AU_ALIAS([AM_PROG_LD], [LT_PATH_LD])
+AU_ALIAS([AC_PROG_LD], [LT_PATH_LD])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AM_PROG_LD], [])
+dnl AC_DEFUN([AC_PROG_LD], [])
+
+
+# _LT_PATH_LD_GNU
+#- --------------
+m4_defun([_LT_PATH_LD_GNU],
+[AC_CACHE_CHECK([if the linker ($LD) is GNU ld], lt_cv_prog_gnu_ld,
+[# I'd rather use --version here, but apparently some GNU lds only accept -v.
+case `$LD -v 2>&1 </dev/null` in
+*GNU* | *'with BFD'*)
+ lt_cv_prog_gnu_ld=yes
+ ;;
+*)
+ lt_cv_prog_gnu_ld=no
+ ;;
+esac])
+with_gnu_ld=$lt_cv_prog_gnu_ld
+])# _LT_PATH_LD_GNU
+
+
+# _LT_CMD_RELOAD
+# --------------
+# find reload flag for linker
+# -- PORTME Some linkers may need a different reload flag.
+m4_defun([_LT_CMD_RELOAD],
+[AC_CACHE_CHECK([for $LD option to reload object files],
+ lt_cv_ld_reload_flag,
+ [lt_cv_ld_reload_flag='-r'])
+reload_flag=$lt_cv_ld_reload_flag
+case $reload_flag in
+"" | " "*) ;;
+*) reload_flag=" $reload_flag" ;;
+esac
+reload_cmds='$LD$reload_flag -o $output$reload_objs'
+case $host_os in
+ cygwin* | mingw* | pw32* | cegcc*)
+ if test "$GCC" != yes; then
+ reload_cmds=false
+ fi
+ ;;
+ darwin*)
+ if test "$GCC" = yes; then
+ reload_cmds='$LTCC $LTCFLAGS -nostdlib ${wl}-r -o $output$reload_objs'
+ else
+ reload_cmds='$LD$reload_flag -o $output$reload_objs'
+ fi
+ ;;
+esac
+_LT_TAGDECL([], [reload_flag], [1], [How to create reloadable object files])dnl
+_LT_TAGDECL([], [reload_cmds], [2])dnl
+])# _LT_CMD_RELOAD
+
+
+# _LT_CHECK_MAGIC_METHOD
+# ----------------------
+# how to check for library dependencies
+# -- PORTME fill in with the dynamic library characteristics
+m4_defun([_LT_CHECK_MAGIC_METHOD],
+[m4_require([_LT_DECL_EGREP])
+m4_require([_LT_DECL_OBJDUMP])
+AC_CACHE_CHECK([how to recognize dependent libraries],
+lt_cv_deplibs_check_method,
+[lt_cv_file_magic_cmd='$MAGIC_CMD'
+lt_cv_file_magic_test_file=
+lt_cv_deplibs_check_method='unknown'
+# Need to set the preceding variable on all platforms that support
+# interlibrary dependencies.
+# 'none' -- dependencies not supported.
+# `unknown' -- same as none, but documents that we really don't know.
+# 'pass_all' -- all dependencies passed with no checks.
+# 'test_compile' -- check by making test program.
+# 'file_magic [[regex]]' -- check by looking for files in library path
+# which responds to the $file_magic_cmd with a given extended regex.
+# If you have `file' or equivalent on your system and you're not sure
+# whether `pass_all' will *always* work, you probably want this one.
+
+case $host_os in
+aix[[4-9]]*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+beos*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+bsdi[[45]]*)
+ lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[ML]]SB (shared object|dynamic lib)'
+ lt_cv_file_magic_cmd='/usr/bin/file -L'
+ lt_cv_file_magic_test_file=/shlib/libc.so
+ ;;
+
+cygwin*)
+ # func_win32_libid is a shell function defined in ltmain.sh
+ lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL'
+ lt_cv_file_magic_cmd='func_win32_libid'
+ ;;
+
+mingw* | pw32*)
+ # Base MSYS/MinGW do not provide the 'file' command needed by
+ # func_win32_libid shell function, so use a weaker test based on 'objdump',
+ # unless we find 'file', for example because we are cross-compiling.
+ # func_win32_libid assumes BSD nm, so disallow it if using MS dumpbin.
+ if ( test "$lt_cv_nm_interface" = "BSD nm" && file / ) >/dev/null 2>&1; then
+ lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL'
+ lt_cv_file_magic_cmd='func_win32_libid'
+ else
+ # Keep this pattern in sync with the one in func_win32_libid.
+ lt_cv_deplibs_check_method='file_magic file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)'
+ lt_cv_file_magic_cmd='$OBJDUMP -f'
+ fi
+ ;;
+
+cegcc*)
+ # use the weaker test based on 'objdump'. See mingw*.
+ lt_cv_deplibs_check_method='file_magic file format pe-arm-.*little(.*architecture: arm)?'
+ lt_cv_file_magic_cmd='$OBJDUMP -f'
+ ;;
+
+darwin* | rhapsody*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+freebsd* | dragonfly*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then
+ case $host_cpu in
+ i*86 )
+ # Not sure whether the presence of OpenBSD here was a mistake.
+ # Let's accept both of them until this is cleared up.
+ lt_cv_deplibs_check_method='file_magic (FreeBSD|OpenBSD|DragonFly)/i[[3-9]]86 (compact )?demand paged shared library'
+ lt_cv_file_magic_cmd=/usr/bin/file
+ lt_cv_file_magic_test_file=`echo /usr/lib/libc.so.*`
+ ;;
+ esac
+ else
+ lt_cv_deplibs_check_method=pass_all
+ fi
+ ;;
+
+gnu*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+haiku*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+hpux10.20* | hpux11*)
+ lt_cv_file_magic_cmd=/usr/bin/file
+ case $host_cpu in
+ ia64*)
+ lt_cv_deplibs_check_method='file_magic (s[[0-9]][[0-9]][[0-9]]|ELF-[[0-9]][[0-9]]) shared object file - IA64'
+ lt_cv_file_magic_test_file=/usr/lib/hpux32/libc.so
+ ;;
+ hppa*64*)
+ [lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF[ -][0-9][0-9])(-bit)?( [LM]SB)? shared object( file)?[, -]* PA-RISC [0-9]\.[0-9]']
+ lt_cv_file_magic_test_file=/usr/lib/pa20_64/libc.sl
+ ;;
+ *)
+ lt_cv_deplibs_check_method='file_magic (s[[0-9]][[0-9]][[0-9]]|PA-RISC[[0-9]]\.[[0-9]]) shared library'
+ lt_cv_file_magic_test_file=/usr/lib/libc.sl
+ ;;
+ esac
+ ;;
+
+interix[[3-9]]*)
+ # PIC code is broken on Interix 3.x, that's why |\.a not |_pic\.a here
+ lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so|\.a)$'
+ ;;
+
+irix5* | irix6* | nonstopux*)
+ case $LD in
+ *-32|*"-32 ") libmagic=32-bit;;
+ *-n32|*"-n32 ") libmagic=N32;;
+ *-64|*"-64 ") libmagic=64-bit;;
+ *) libmagic=never-match;;
+ esac
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+# This must be Linux ELF.
+linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then
+ lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so\.[[0-9]]+\.[[0-9]]+|_pic\.a)$'
+ else
+ lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so|_pic\.a)$'
+ fi
+ ;;
+
+newos6*)
+ lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[ML]]SB (executable|dynamic lib)'
+ lt_cv_file_magic_cmd=/usr/bin/file
+ lt_cv_file_magic_test_file=/usr/lib/libnls.so
+ ;;
+
+*nto* | *qnx*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+openbsd*)
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so\.[[0-9]]+\.[[0-9]]+|\.so|_pic\.a)$'
+ else
+ lt_cv_deplibs_check_method='match_pattern /lib[[^/]]+(\.so\.[[0-9]]+\.[[0-9]]+|_pic\.a)$'
+ fi
+ ;;
+
+osf3* | osf4* | osf5*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+rdos*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+solaris*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+
+sysv4 | sysv4.3*)
+ case $host_vendor in
+ motorola)
+ lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[ML]]SB (shared object|dynamic lib) M[[0-9]][[0-9]]* Version [[0-9]]'
+ lt_cv_file_magic_test_file=`echo /usr/lib/libc.so*`
+ ;;
+ ncr)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+ sequent)
+ lt_cv_file_magic_cmd='/bin/file'
+ lt_cv_deplibs_check_method='file_magic ELF [[0-9]][[0-9]]*-bit [[LM]]SB (shared object|dynamic lib )'
+ ;;
+ sni)
+ lt_cv_file_magic_cmd='/bin/file'
+ lt_cv_deplibs_check_method="file_magic ELF [[0-9]][[0-9]]*-bit [[LM]]SB dynamic lib"
+ lt_cv_file_magic_test_file=/lib/libc.so
+ ;;
+ siemens)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+ pc)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+ esac
+ ;;
+
+tpf*)
+ lt_cv_deplibs_check_method=pass_all
+ ;;
+esac
+])
+
+file_magic_glob=
+want_nocaseglob=no
+if test "$build" = "$host"; then
+ case $host_os in
+ mingw* | pw32*)
+ if ( shopt | grep nocaseglob ) >/dev/null 2>&1; then
+ want_nocaseglob=yes
+ else
+ file_magic_glob=`echo aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ | $SED -e "s/\(..\)/s\/[[\1]]\/[[\1]]\/g;/g"`
+ fi
+ ;;
+ esac
+fi
+
+file_magic_cmd=$lt_cv_file_magic_cmd
+deplibs_check_method=$lt_cv_deplibs_check_method
+test -z "$deplibs_check_method" && deplibs_check_method=unknown
+
+_LT_DECL([], [deplibs_check_method], [1],
+ [Method to check whether dependent libraries are shared objects])
+_LT_DECL([], [file_magic_cmd], [1],
+ [Command to use when deplibs_check_method = "file_magic"])
+_LT_DECL([], [file_magic_glob], [1],
+ [How to find potential files when deplibs_check_method = "file_magic"])
+_LT_DECL([], [want_nocaseglob], [1],
+ [Find potential files using nocaseglob when deplibs_check_method = "file_magic"])
+])# _LT_CHECK_MAGIC_METHOD
+
+
+# LT_PATH_NM
+# ----------
+# find the pathname to a BSD- or MS-compatible name lister
+AC_DEFUN([LT_PATH_NM],
+[AC_REQUIRE([AC_PROG_CC])dnl
+AC_CACHE_CHECK([for BSD- or MS-compatible name lister (nm)], lt_cv_path_NM,
+[if test -n "$NM"; then
+ # Let the user override the test.
+ lt_cv_path_NM="$NM"
+else
+ lt_nm_to_check="${ac_tool_prefix}nm"
+ if test -n "$ac_tool_prefix" && test "$build" = "$host"; then
+ lt_nm_to_check="$lt_nm_to_check nm"
+ fi
+ for lt_tmp_nm in $lt_nm_to_check; do
+ lt_save_ifs="$IFS"; IFS=$PATH_SEPARATOR
+ for ac_dir in $PATH /usr/ccs/bin/elf /usr/ccs/bin /usr/ucb /bin; do
+ IFS="$lt_save_ifs"
+ test -z "$ac_dir" && ac_dir=.
+ tmp_nm="$ac_dir/$lt_tmp_nm"
+ if test -f "$tmp_nm" || test -f "$tmp_nm$ac_exeext" ; then
+ # Check to see if the nm accepts a BSD-compat flag.
+ # Adding the `sed 1q' prevents false positives on HP-UX, which says:
+ # nm: unknown option "B" ignored
+ # Tru64's nm complains that /dev/null is an invalid object file
+ case `"$tmp_nm" -B /dev/null 2>&1 | sed '1q'` in
+ */dev/null* | *'Invalid file or object type'*)
+ lt_cv_path_NM="$tmp_nm -B"
+ break
+ ;;
+ *)
+ case `"$tmp_nm" -p /dev/null 2>&1 | sed '1q'` in
+ */dev/null*)
+ lt_cv_path_NM="$tmp_nm -p"
+ break
+ ;;
+ *)
+ lt_cv_path_NM=${lt_cv_path_NM="$tmp_nm"} # keep the first match, but
+ continue # so that we can try to find one that supports BSD flags
+ ;;
+ esac
+ ;;
+ esac
+ fi
+ done
+ IFS="$lt_save_ifs"
+ done
+ : ${lt_cv_path_NM=no}
+fi])
+if test "$lt_cv_path_NM" != "no"; then
+ NM="$lt_cv_path_NM"
+else
+ # Didn't find any BSD compatible name lister, look for dumpbin.
+ if test -n "$DUMPBIN"; then :
+ # Let the user override the test.
+ else
+ AC_CHECK_TOOLS(DUMPBIN, [dumpbin "link -dump"], :)
+ case `$DUMPBIN -symbols /dev/null 2>&1 | sed '1q'` in
+ *COFF*)
+ DUMPBIN="$DUMPBIN -symbols"
+ ;;
+ *)
+ DUMPBIN=:
+ ;;
+ esac
+ fi
+ AC_SUBST([DUMPBIN])
+ if test "$DUMPBIN" != ":"; then
+ NM="$DUMPBIN"
+ fi
+fi
+test -z "$NM" && NM=nm
+AC_SUBST([NM])
+_LT_DECL([], [NM], [1], [A BSD- or MS-compatible name lister])dnl
+
+AC_CACHE_CHECK([the name lister ($NM) interface], [lt_cv_nm_interface],
+ [lt_cv_nm_interface="BSD nm"
+ echo "int some_variable = 0;" > conftest.$ac_ext
+ (eval echo "\"\$as_me:$LINENO: $ac_compile\"" >&AS_MESSAGE_LOG_FD)
+ (eval "$ac_compile" 2>conftest.err)
+ cat conftest.err >&AS_MESSAGE_LOG_FD
+ (eval echo "\"\$as_me:$LINENO: $NM \\\"conftest.$ac_objext\\\"\"" >&AS_MESSAGE_LOG_FD)
+ (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out)
+ cat conftest.err >&AS_MESSAGE_LOG_FD
+ (eval echo "\"\$as_me:$LINENO: output\"" >&AS_MESSAGE_LOG_FD)
+ cat conftest.out >&AS_MESSAGE_LOG_FD
+ if $GREP 'External.*some_variable' conftest.out > /dev/null; then
+ lt_cv_nm_interface="MS dumpbin"
+ fi
+ rm -f conftest*])
+])# LT_PATH_NM
+
+# Old names:
+AU_ALIAS([AM_PROG_NM], [LT_PATH_NM])
+AU_ALIAS([AC_PROG_NM], [LT_PATH_NM])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AM_PROG_NM], [])
+dnl AC_DEFUN([AC_PROG_NM], [])
+
+# _LT_CHECK_SHAREDLIB_FROM_LINKLIB
+# --------------------------------
+# how to determine the name of the shared library
+# associated with a specific link library.
+# -- PORTME fill in with the dynamic library characteristics
+m4_defun([_LT_CHECK_SHAREDLIB_FROM_LINKLIB],
+[m4_require([_LT_DECL_EGREP])
+m4_require([_LT_DECL_OBJDUMP])
+m4_require([_LT_DECL_DLLTOOL])
+AC_CACHE_CHECK([how to associate runtime and link libraries],
+lt_cv_sharedlib_from_linklib_cmd,
+[lt_cv_sharedlib_from_linklib_cmd='unknown'
+
+case $host_os in
+cygwin* | mingw* | pw32* | cegcc*)
+ # two different shell functions defined in ltmain.sh
+ # decide which to use based on capabilities of $DLLTOOL
+ case `$DLLTOOL --help 2>&1` in
+ *--identify-strict*)
+ lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib
+ ;;
+ *)
+ lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib_fallback
+ ;;
+ esac
+ ;;
+*)
+ # fallback: assume linklib IS sharedlib
+ lt_cv_sharedlib_from_linklib_cmd="$ECHO"
+ ;;
+esac
+])
+sharedlib_from_linklib_cmd=$lt_cv_sharedlib_from_linklib_cmd
+test -z "$sharedlib_from_linklib_cmd" && sharedlib_from_linklib_cmd=$ECHO
+
+_LT_DECL([], [sharedlib_from_linklib_cmd], [1],
+ [Command to associate shared and link libraries])
+])# _LT_CHECK_SHAREDLIB_FROM_LINKLIB
+
+
+# _LT_PATH_MANIFEST_TOOL
+# ----------------------
+# locate the manifest tool
+m4_defun([_LT_PATH_MANIFEST_TOOL],
+[AC_CHECK_TOOL(MANIFEST_TOOL, mt, :)
+test -z "$MANIFEST_TOOL" && MANIFEST_TOOL=mt
+AC_CACHE_CHECK([if $MANIFEST_TOOL is a manifest tool], [lt_cv_path_mainfest_tool],
+ [lt_cv_path_mainfest_tool=no
+ echo "$as_me:$LINENO: $MANIFEST_TOOL '-?'" >&AS_MESSAGE_LOG_FD
+ $MANIFEST_TOOL '-?' 2>conftest.err > conftest.out
+ cat conftest.err >&AS_MESSAGE_LOG_FD
+ if $GREP 'Manifest Tool' conftest.out > /dev/null; then
+ lt_cv_path_mainfest_tool=yes
+ fi
+ rm -f conftest*])
+if test "x$lt_cv_path_mainfest_tool" != xyes; then
+ MANIFEST_TOOL=:
+fi
+_LT_DECL([], [MANIFEST_TOOL], [1], [Manifest tool])dnl
+])# _LT_PATH_MANIFEST_TOOL
+
+
+# LT_LIB_M
+# --------
+# check for math library
+AC_DEFUN([LT_LIB_M],
+[AC_REQUIRE([AC_CANONICAL_HOST])dnl
+LIBM=
+case $host in
+*-*-beos* | *-*-cegcc* | *-*-cygwin* | *-*-haiku* | *-*-pw32* | *-*-darwin*)
+ # These system don't have libm, or don't need it
+ ;;
+*-ncr-sysv4.3*)
+ AC_CHECK_LIB(mw, _mwvalidcheckl, LIBM="-lmw")
+ AC_CHECK_LIB(m, cos, LIBM="$LIBM -lm")
+ ;;
+*)
+ AC_CHECK_LIB(m, cos, LIBM="-lm")
+ ;;
+esac
+AC_SUBST([LIBM])
+])# LT_LIB_M
+
+# Old name:
+AU_ALIAS([AC_CHECK_LIBM], [LT_LIB_M])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_CHECK_LIBM], [])
+
+
+# _LT_COMPILER_NO_RTTI([TAGNAME])
+# -------------------------------
+m4_defun([_LT_COMPILER_NO_RTTI],
+[m4_require([_LT_TAG_COMPILER])dnl
+
+_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=
+
+if test "$GCC" = yes; then
+ case $cc_basename in
+ nvcc*)
+ _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -Xcompiler -fno-builtin' ;;
+ *)
+ _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -fno-builtin' ;;
+ esac
+
+ _LT_COMPILER_OPTION([if $compiler supports -fno-rtti -fno-exceptions],
+ lt_cv_prog_compiler_rtti_exceptions,
+ [-fno-rtti -fno-exceptions], [],
+ [_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)="$_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1) -fno-rtti -fno-exceptions"])
+fi
+_LT_TAGDECL([no_builtin_flag], [lt_prog_compiler_no_builtin_flag], [1],
+ [Compiler flag to turn off builtin functions])
+])# _LT_COMPILER_NO_RTTI
+
+
+# _LT_CMD_GLOBAL_SYMBOLS
+# ----------------------
+m4_defun([_LT_CMD_GLOBAL_SYMBOLS],
+[AC_REQUIRE([AC_CANONICAL_HOST])dnl
+AC_REQUIRE([AC_PROG_CC])dnl
+AC_REQUIRE([AC_PROG_AWK])dnl
+AC_REQUIRE([LT_PATH_NM])dnl
+AC_REQUIRE([LT_PATH_LD])dnl
+m4_require([_LT_DECL_SED])dnl
+m4_require([_LT_DECL_EGREP])dnl
+m4_require([_LT_TAG_COMPILER])dnl
+
+# Check for command to grab the raw symbol name followed by C symbol from nm.
+AC_MSG_CHECKING([command to parse $NM output from $compiler object])
+AC_CACHE_VAL([lt_cv_sys_global_symbol_pipe],
+[
+# These are sane defaults that work on at least a few old systems.
+# [They come from Ultrix. What could be older than Ultrix?!! ;)]
+
+# Character class describing NM global symbol codes.
+symcode='[[BCDEGRST]]'
+
+# Regexp to match symbols that can be accessed directly from C.
+sympat='\([[_A-Za-z]][[_A-Za-z0-9]]*\)'
+
+# Define system-specific variables.
+case $host_os in
+aix*)
+ symcode='[[BCDT]]'
+ ;;
+cygwin* | mingw* | pw32* | cegcc*)
+ symcode='[[ABCDGISTW]]'
+ ;;
+hpux*)
+ if test "$host_cpu" = ia64; then
+ symcode='[[ABCDEGRST]]'
+ fi
+ ;;
+irix* | nonstopux*)
+ symcode='[[BCDEGRST]]'
+ ;;
+osf*)
+ symcode='[[BCDEGQRST]]'
+ ;;
+solaris*)
+ symcode='[[BDRT]]'
+ ;;
+sco3.2v5*)
+ symcode='[[DT]]'
+ ;;
+sysv4.2uw2*)
+ symcode='[[DT]]'
+ ;;
+sysv5* | sco5v6* | unixware* | OpenUNIX*)
+ symcode='[[ABDT]]'
+ ;;
+sysv4)
+ symcode='[[DFNSTU]]'
+ ;;
+esac
+
+# If we're using GNU nm, then use its standard symbol codes.
+case `$NM -V 2>&1` in
+*GNU* | *'with BFD'*)
+ symcode='[[ABCDGIRSTW]]' ;;
+esac
+
+# Transform an extracted symbol line into a proper C declaration.
+# Some systems (esp. on ia64) link data and code symbols differently,
+# so use this general approach.
+lt_cv_sys_global_symbol_to_cdecl="sed -n -e 's/^T .* \(.*\)$/extern int \1();/p' -e 's/^$symcode* .* \(.*\)$/extern char \1;/p'"
+
+# Transform an extracted symbol line into symbol name and symbol address
+lt_cv_sys_global_symbol_to_c_name_address="sed -n -e 's/^: \([[^ ]]*\)[[ ]]*$/ {\\\"\1\\\", (void *) 0},/p' -e 's/^$symcode* \([[^ ]]*\) \([[^ ]]*\)$/ {\"\2\", (void *) \&\2},/p'"
+lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="sed -n -e 's/^: \([[^ ]]*\)[[ ]]*$/ {\\\"\1\\\", (void *) 0},/p' -e 's/^$symcode* \([[^ ]]*\) \(lib[[^ ]]*\)$/ {\"\2\", (void *) \&\2},/p' -e 's/^$symcode* \([[^ ]]*\) \([[^ ]]*\)$/ {\"lib\2\", (void *) \&\2},/p'"
+
+# Handle CRLF in mingw tool chain
+opt_cr=
+case $build_os in
+mingw*)
+ opt_cr=`$ECHO 'x\{0,1\}' | tr x '\015'` # option cr in regexp
+ ;;
+esac
+
+# Try without a prefix underscore, then with it.
+for ac_symprfx in "" "_"; do
+
+ # Transform symcode, sympat, and symprfx into a raw symbol and a C symbol.
+ symxfrm="\\1 $ac_symprfx\\2 \\2"
+
+ # Write the raw and C identifiers.
+ if test "$lt_cv_nm_interface" = "MS dumpbin"; then
+ # Fake it for dumpbin and say T for any non-static function
+ # and D for any global variable.
+ # Also find C++ and __fastcall symbols from MSVC++,
+ # which start with @ or ?.
+ lt_cv_sys_global_symbol_pipe="$AWK ['"\
+" {last_section=section; section=\$ 3};"\
+" /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\
+" \$ 0!~/External *\|/{next};"\
+" / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\
+" {if(hide[section]) next};"\
+" {f=0}; \$ 0~/\(\).*\|/{f=1}; {printf f ? \"T \" : \"D \"};"\
+" {split(\$ 0, a, /\||\r/); split(a[2], s)};"\
+" s[1]~/^[@?]/{print s[1], s[1]; next};"\
+" s[1]~prfx {split(s[1],t,\"@\"); print t[1], substr(t[1],length(prfx))}"\
+" ' prfx=^$ac_symprfx]"
+ else
+ lt_cv_sys_global_symbol_pipe="sed -n -e 's/^.*[[ ]]\($symcode$symcode*\)[[ ]][[ ]]*$ac_symprfx$sympat$opt_cr$/$symxfrm/p'"
+ fi
+ lt_cv_sys_global_symbol_pipe="$lt_cv_sys_global_symbol_pipe | sed '/ __gnu_lto/d'"
+
+ # Check to see that the pipe works correctly.
+ pipe_works=no
+
+ rm -f conftest*
+ cat > conftest.$ac_ext <<_LT_EOF
+#ifdef __cplusplus
+extern "C" {
+#endif
+char nm_test_var;
+void nm_test_func(void);
+void nm_test_func(void){}
+#ifdef __cplusplus
+}
+#endif
+int main(){nm_test_var='a';nm_test_func();return(0);}
+_LT_EOF
+
+ if AC_TRY_EVAL(ac_compile); then
+ # Now try to grab the symbols.
+ nlist=conftest.nm
+ if AC_TRY_EVAL(NM conftest.$ac_objext \| "$lt_cv_sys_global_symbol_pipe" \> $nlist) && test -s "$nlist"; then
+ # Try sorting and uniquifying the output.
+ if sort "$nlist" | uniq > "$nlist"T; then
+ mv -f "$nlist"T "$nlist"
+ else
+ rm -f "$nlist"T
+ fi
+
+ # Make sure that we snagged all the symbols we need.
+ if $GREP ' nm_test_var$' "$nlist" >/dev/null; then
+ if $GREP ' nm_test_func$' "$nlist" >/dev/null; then
+ cat <<_LT_EOF > conftest.$ac_ext
+/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */
+#if defined(_WIN32) || defined(__CYGWIN__) || defined(_WIN32_WCE)
+/* DATA imports from DLLs on WIN32 con't be const, because runtime
+ relocations are performed -- see ld's documentation on pseudo-relocs. */
+# define LT@&t@_DLSYM_CONST
+#elif defined(__osf__)
+/* This system does not cope well with relocations in const data. */
+# define LT@&t@_DLSYM_CONST
+#else
+# define LT@&t@_DLSYM_CONST const
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+_LT_EOF
+ # Now generate the symbol file.
+ eval "$lt_cv_sys_global_symbol_to_cdecl"' < "$nlist" | $GREP -v main >> conftest.$ac_ext'
+
+ cat <<_LT_EOF >> conftest.$ac_ext
+
+/* The mapping between symbol names and symbols. */
+LT@&t@_DLSYM_CONST struct {
+ const char *name;
+ void *address;
+}
+lt__PROGRAM__LTX_preloaded_symbols[[]] =
+{
+ { "@PROGRAM@", (void *) 0 },
+_LT_EOF
+ $SED "s/^$symcode$symcode* \(.*\) \(.*\)$/ {\"\2\", (void *) \&\2},/" < "$nlist" | $GREP -v main >> conftest.$ac_ext
+ cat <<\_LT_EOF >> conftest.$ac_ext
+ {0, (void *) 0}
+};
+
+/* This works around a problem in FreeBSD linker */
+#ifdef FREEBSD_WORKAROUND
+static const void *lt_preloaded_setup() {
+ return lt__PROGRAM__LTX_preloaded_symbols;
+}
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+_LT_EOF
+ # Now try linking the two files.
+ mv conftest.$ac_objext conftstm.$ac_objext
+ lt_globsym_save_LIBS=$LIBS
+ lt_globsym_save_CFLAGS=$CFLAGS
+ LIBS="conftstm.$ac_objext"
+ CFLAGS="$CFLAGS$_LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)"
+ if AC_TRY_EVAL(ac_link) && test -s conftest${ac_exeext}; then
+ pipe_works=yes
+ fi
+ LIBS=$lt_globsym_save_LIBS
+ CFLAGS=$lt_globsym_save_CFLAGS
+ else
+ echo "cannot find nm_test_func in $nlist" >&AS_MESSAGE_LOG_FD
+ fi
+ else
+ echo "cannot find nm_test_var in $nlist" >&AS_MESSAGE_LOG_FD
+ fi
+ else
+ echo "cannot run $lt_cv_sys_global_symbol_pipe" >&AS_MESSAGE_LOG_FD
+ fi
+ else
+ echo "$progname: failed program was:" >&AS_MESSAGE_LOG_FD
+ cat conftest.$ac_ext >&5
+ fi
+ rm -rf conftest* conftst*
+
+ # Do not use the global_symbol_pipe unless it works.
+ if test "$pipe_works" = yes; then
+ break
+ else
+ lt_cv_sys_global_symbol_pipe=
+ fi
+done
+])
+if test -z "$lt_cv_sys_global_symbol_pipe"; then
+ lt_cv_sys_global_symbol_to_cdecl=
+fi
+if test -z "$lt_cv_sys_global_symbol_pipe$lt_cv_sys_global_symbol_to_cdecl"; then
+ AC_MSG_RESULT(failed)
+else
+ AC_MSG_RESULT(ok)
+fi
+
+# Response file support.
+if test "$lt_cv_nm_interface" = "MS dumpbin"; then
+ nm_file_list_spec='@'
+elif $NM --help 2>/dev/null | grep '[[@]]FILE' >/dev/null; then
+ nm_file_list_spec='@'
+fi
+
+_LT_DECL([global_symbol_pipe], [lt_cv_sys_global_symbol_pipe], [1],
+ [Take the output of nm and produce a listing of raw symbols and C names])
+_LT_DECL([global_symbol_to_cdecl], [lt_cv_sys_global_symbol_to_cdecl], [1],
+ [Transform the output of nm in a proper C declaration])
+_LT_DECL([global_symbol_to_c_name_address],
+ [lt_cv_sys_global_symbol_to_c_name_address], [1],
+ [Transform the output of nm in a C name address pair])
+_LT_DECL([global_symbol_to_c_name_address_lib_prefix],
+ [lt_cv_sys_global_symbol_to_c_name_address_lib_prefix], [1],
+ [Transform the output of nm in a C name address pair when lib prefix is needed])
+_LT_DECL([], [nm_file_list_spec], [1],
+ [Specify filename containing input files for $NM])
+]) # _LT_CMD_GLOBAL_SYMBOLS
+
+
+# _LT_COMPILER_PIC([TAGNAME])
+# ---------------------------
+m4_defun([_LT_COMPILER_PIC],
+[m4_require([_LT_TAG_COMPILER])dnl
+_LT_TAGVAR(lt_prog_compiler_wl, $1)=
+_LT_TAGVAR(lt_prog_compiler_pic, $1)=
+_LT_TAGVAR(lt_prog_compiler_static, $1)=
+
+m4_if([$1], [CXX], [
+ # C++ specific cases for pic, static, wl, etc.
+ if test "$GXX" = yes; then
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-static'
+
+ case $host_os in
+ aix*)
+ # All AIX code is PIC.
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC'
+ ;;
+ m68k)
+ # FIXME: we need at least 68020 code to build shared libraries, but
+ # adding the `-m68020' flag to GCC prevents building anything better,
+ # like `-m68040'.
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-m68020 -resident32 -malways-restore-a4'
+ ;;
+ esac
+ ;;
+
+ beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*)
+ # PIC is the default for these OSes.
+ ;;
+ mingw* | cygwin* | os2* | pw32* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ # Although the cygwin gcc ignores -fPIC, still need this for old-style
+ # (--disable-auto-import) libraries
+ m4_if([$1], [GCJ], [],
+ [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT'])
+ ;;
+ darwin* | rhapsody*)
+ # PIC is the default on this platform
+ # Common symbols not allowed in MH_DYLIB files
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fno-common'
+ ;;
+ *djgpp*)
+ # DJGPP does not support shared libraries at all
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)=
+ ;;
+ haiku*)
+ # PIC is the default for Haiku.
+ # The "-static" flag exists, but is broken.
+ _LT_TAGVAR(lt_prog_compiler_static, $1)=
+ ;;
+ interix[[3-9]]*)
+ # Interix 3.x gcc -fpic/-fPIC options generate broken code.
+ # Instead, we relocate shared libraries at runtime.
+ ;;
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)=-Kconform_pic
+ fi
+ ;;
+ hpux*)
+ # PIC is the default for 64-bit PA HP-UX, but not for 32-bit
+ # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag
+ # sets the default TLS model and affects inlining.
+ case $host_cpu in
+ hppa*64*)
+ ;;
+ *)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC'
+ ;;
+ esac
+ ;;
+ *qnx* | *nto*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared'
+ ;;
+ *)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC'
+ ;;
+ esac
+ else
+ case $host_os in
+ aix[[4-9]]*)
+ # All AIX code is PIC.
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ else
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-bnso -bI:/lib/syscalls.exp'
+ fi
+ ;;
+ chorus*)
+ case $cc_basename in
+ cxch68*)
+ # Green Hills C++ Compiler
+ # _LT_TAGVAR(lt_prog_compiler_static, $1)="--no_auto_instantiation -u __main -u __premain -u _abort -r $COOL_DIR/lib/libOrb.a $MVME_DIR/lib/CC/libC.a $MVME_DIR/lib/classix/libcx.s.a"
+ ;;
+ esac
+ ;;
+ mingw* | cygwin* | os2* | pw32* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ m4_if([$1], [GCJ], [],
+ [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT'])
+ ;;
+ dgux*)
+ case $cc_basename in
+ ec++*)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ ;;
+ ghcx*)
+ # Green Hills C++ Compiler
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic'
+ ;;
+ *)
+ ;;
+ esac
+ ;;
+ freebsd* | dragonfly*)
+ # FreeBSD uses GNU C++
+ ;;
+ hpux9* | hpux10* | hpux11*)
+ case $cc_basename in
+ CC*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='${wl}-a ${wl}archive'
+ if test "$host_cpu" != ia64; then
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='+Z'
+ fi
+ ;;
+ aCC*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='${wl}-a ${wl}archive'
+ case $host_cpu in
+ hppa*64*|ia64*)
+ # +Z the default
+ ;;
+ *)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='+Z'
+ ;;
+ esac
+ ;;
+ *)
+ ;;
+ esac
+ ;;
+ interix*)
+ # This is c89, which is MS Visual C++ (no shared libs)
+ # Anyone wants to do a port?
+ ;;
+ irix5* | irix6* | nonstopux*)
+ case $cc_basename in
+ CC*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared'
+ # CC pic flag -KPIC is the default.
+ ;;
+ *)
+ ;;
+ esac
+ ;;
+ linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ case $cc_basename in
+ KCC*)
+ # KAI C++ Compiler
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='--backend -Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC'
+ ;;
+ ecpc* )
+ # old Intel C++ for x86_64 which still supported -KPIC.
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-static'
+ ;;
+ icpc* )
+ # Intel C++, used to be incompatible with GCC.
+ # ICC 10 doesn't accept -KPIC any more.
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-static'
+ ;;
+ pgCC* | pgcpp*)
+ # Portland Group C++ compiler
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fpic'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+ cxx*)
+ # Compaq C++
+ # Make sure the PIC flag is empty. It appears that all Alpha
+ # Linux and Compaq Tru64 Unix objects are PIC.
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)=
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared'
+ ;;
+ xlc* | xlC* | bgxl[[cC]]* | mpixl[[cC]]*)
+ # IBM XL 8.0, 9.0 on PPC and BlueGene
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-qpic'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-qstaticlink'
+ ;;
+ *)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*)
+ # Sun C++ 5.9
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld '
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+ lynxos*)
+ ;;
+ m88k*)
+ ;;
+ mvs*)
+ case $cc_basename in
+ cxx*)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-W c,exportall'
+ ;;
+ *)
+ ;;
+ esac
+ ;;
+ netbsd*)
+ ;;
+ *qnx* | *nto*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared'
+ ;;
+ osf3* | osf4* | osf5*)
+ case $cc_basename in
+ KCC*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='--backend -Wl,'
+ ;;
+ RCC*)
+ # Rational C++ 2.4.1
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic'
+ ;;
+ cxx*)
+ # Digital/Compaq C++
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ # Make sure the PIC flag is empty. It appears that all Alpha
+ # Linux and Compaq Tru64 Unix objects are PIC.
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)=
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared'
+ ;;
+ *)
+ ;;
+ esac
+ ;;
+ psos*)
+ ;;
+ solaris*)
+ case $cc_basename in
+ CC* | sunCC*)
+ # Sun C++ 4.2, 5.x and Centerline C++
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld '
+ ;;
+ gcx*)
+ # Green Hills C++ Compiler
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC'
+ ;;
+ *)
+ ;;
+ esac
+ ;;
+ sunos4*)
+ case $cc_basename in
+ CC*)
+ # Sun C++ 4.x
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+ lcc*)
+ # Lucid
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic'
+ ;;
+ *)
+ ;;
+ esac
+ ;;
+ sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*)
+ case $cc_basename in
+ CC*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+ esac
+ ;;
+ tandem*)
+ case $cc_basename in
+ NCC*)
+ # NonStop-UX NCC 3.20
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ ;;
+ *)
+ ;;
+ esac
+ ;;
+ vxworks*)
+ ;;
+ *)
+ _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no
+ ;;
+ esac
+ fi
+],
+[
+ if test "$GCC" = yes; then
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-static'
+
+ case $host_os in
+ aix*)
+ # All AIX code is PIC.
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC'
+ ;;
+ m68k)
+ # FIXME: we need at least 68020 code to build shared libraries, but
+ # adding the `-m68020' flag to GCC prevents building anything better,
+ # like `-m68040'.
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-m68020 -resident32 -malways-restore-a4'
+ ;;
+ esac
+ ;;
+
+ beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*)
+ # PIC is the default for these OSes.
+ ;;
+
+ mingw* | cygwin* | pw32* | os2* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ # Although the cygwin gcc ignores -fPIC, still need this for old-style
+ # (--disable-auto-import) libraries
+ m4_if([$1], [GCJ], [],
+ [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT'])
+ ;;
+
+ darwin* | rhapsody*)
+ # PIC is the default on this platform
+ # Common symbols not allowed in MH_DYLIB files
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fno-common'
+ ;;
+
+ haiku*)
+ # PIC is the default for Haiku.
+ # The "-static" flag exists, but is broken.
+ _LT_TAGVAR(lt_prog_compiler_static, $1)=
+ ;;
+
+ hpux*)
+ # PIC is the default for 64-bit PA HP-UX, but not for 32-bit
+ # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag
+ # sets the default TLS model and affects inlining.
+ case $host_cpu in
+ hppa*64*)
+ # +Z the default
+ ;;
+ *)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC'
+ ;;
+ esac
+ ;;
+
+ interix[[3-9]]*)
+ # Interix 3.x gcc -fpic/-fPIC options generate broken code.
+ # Instead, we relocate shared libraries at runtime.
+ ;;
+
+ msdosdjgpp*)
+ # Just because we use GCC doesn't mean we suddenly get shared libraries
+ # on systems that don't support them.
+ _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no
+ enable_shared=no
+ ;;
+
+ *nto* | *qnx*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)=-Kconform_pic
+ fi
+ ;;
+
+ *)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC'
+ ;;
+ esac
+
+ case $cc_basename in
+ nvcc*) # Cuda Compiler Driver 2.2
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Xlinker '
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-Xcompiler -fPIC'
+ ;;
+ esac
+ else
+ # PORTME Check for flag to pass linker flags through the system compiler.
+ case $host_os in
+ aix*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ if test "$host_cpu" = ia64; then
+ # AIX 5 now supports IA64 processor
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ else
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-bnso -bI:/lib/syscalls.exp'
+ fi
+ ;;
+
+ mingw* | cygwin* | pw32* | os2* | cegcc*)
+ # This hack is so that the source file can tell whether it is being
+ # built for inclusion in a dll (and should export symbols for example).
+ m4_if([$1], [GCJ], [],
+ [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT'])
+ ;;
+
+ hpux9* | hpux10* | hpux11*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ # PIC is the default for IA64 HP-UX and 64-bit HP-UX, but
+ # not for PA HP-UX.
+ case $host_cpu in
+ hppa*64*|ia64*)
+ # +Z the default
+ ;;
+ *)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='+Z'
+ ;;
+ esac
+ # Is there a better lt_prog_compiler_static that works with the bundled CC?
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='${wl}-a ${wl}archive'
+ ;;
+
+ irix5* | irix6* | nonstopux*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ # PIC (with -KPIC) is the default.
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared'
+ ;;
+
+ linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ case $cc_basename in
+ # old Intel for x86_64 which still supported -KPIC.
+ ecc*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-static'
+ ;;
+ # icc used to be incompatible with GCC.
+ # ICC 10 doesn't accept -KPIC any more.
+ icc* | ifort*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-static'
+ ;;
+ # Lahey Fortran 8.1.
+ lf95*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='--shared'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='--static'
+ ;;
+ nagfor*)
+ # NAG Fortran compiler
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,-Wl,,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+ pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*)
+ # Portland Group compilers (*not* the Pentium gcc compiler,
+ # which looks to be a dead project)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fpic'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+ ccc*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ # All Alpha code is PIC.
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared'
+ ;;
+ xl* | bgxl* | bgf* | mpixl*)
+ # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-qpic'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-qstaticlink'
+ ;;
+ *)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ F* | *Sun*Fortran*)
+ # Sun Fortran 8.3 passes all unrecognized flags to the linker
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)=''
+ ;;
+ *Sun\ C*)
+ # Sun C 5.9
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+
+ newsos6)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+
+ *nto* | *qnx*)
+ # QNX uses GNU C++, but need to define -shared option too, otherwise
+ # it will coredump.
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC -shared'
+ ;;
+
+ osf3* | osf4* | osf5*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ # All OSF/1 code is PIC.
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared'
+ ;;
+
+ rdos*)
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-non_shared'
+ ;;
+
+ solaris*)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ case $cc_basename in
+ f77* | f90* | f95* | sunf77* | sunf90* | sunf95*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld ';;
+ *)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,';;
+ esac
+ ;;
+
+ sunos4*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Qoption ld '
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+
+ sysv4 | sysv4.2uw2* | sysv4.3*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec ;then
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-Kconform_pic'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ fi
+ ;;
+
+ sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-KPIC'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+
+ unicos*)
+ _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,'
+ _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no
+ ;;
+
+ uts4*)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)='-pic'
+ _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic'
+ ;;
+
+ *)
+ _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no
+ ;;
+ esac
+ fi
+])
+case $host_os in
+ # For platforms which do not support PIC, -DPIC is meaningless:
+ *djgpp*)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)=
+ ;;
+ *)
+ _LT_TAGVAR(lt_prog_compiler_pic, $1)="$_LT_TAGVAR(lt_prog_compiler_pic, $1)@&t@m4_if([$1],[],[ -DPIC],[m4_if([$1],[CXX],[ -DPIC],[])])"
+ ;;
+esac
+
+AC_CACHE_CHECK([for $compiler option to produce PIC],
+ [_LT_TAGVAR(lt_cv_prog_compiler_pic, $1)],
+ [_LT_TAGVAR(lt_cv_prog_compiler_pic, $1)=$_LT_TAGVAR(lt_prog_compiler_pic, $1)])
+_LT_TAGVAR(lt_prog_compiler_pic, $1)=$_LT_TAGVAR(lt_cv_prog_compiler_pic, $1)
+
+#
+# Check to make sure the PIC flag actually works.
+#
+if test -n "$_LT_TAGVAR(lt_prog_compiler_pic, $1)"; then
+ _LT_COMPILER_OPTION([if $compiler PIC flag $_LT_TAGVAR(lt_prog_compiler_pic, $1) works],
+ [_LT_TAGVAR(lt_cv_prog_compiler_pic_works, $1)],
+ [$_LT_TAGVAR(lt_prog_compiler_pic, $1)@&t@m4_if([$1],[],[ -DPIC],[m4_if([$1],[CXX],[ -DPIC],[])])], [],
+ [case $_LT_TAGVAR(lt_prog_compiler_pic, $1) in
+ "" | " "*) ;;
+ *) _LT_TAGVAR(lt_prog_compiler_pic, $1)=" $_LT_TAGVAR(lt_prog_compiler_pic, $1)" ;;
+ esac],
+ [_LT_TAGVAR(lt_prog_compiler_pic, $1)=
+ _LT_TAGVAR(lt_prog_compiler_can_build_shared, $1)=no])
+fi
+_LT_TAGDECL([pic_flag], [lt_prog_compiler_pic], [1],
+ [Additional compiler flags for building library objects])
+
+_LT_TAGDECL([wl], [lt_prog_compiler_wl], [1],
+ [How to pass a linker flag through the compiler])
+#
+# Check to make sure the static flag actually works.
+#
+wl=$_LT_TAGVAR(lt_prog_compiler_wl, $1) eval lt_tmp_static_flag=\"$_LT_TAGVAR(lt_prog_compiler_static, $1)\"
+_LT_LINKER_OPTION([if $compiler static flag $lt_tmp_static_flag works],
+ _LT_TAGVAR(lt_cv_prog_compiler_static_works, $1),
+ $lt_tmp_static_flag,
+ [],
+ [_LT_TAGVAR(lt_prog_compiler_static, $1)=])
+_LT_TAGDECL([link_static_flag], [lt_prog_compiler_static], [1],
+ [Compiler flag to prevent dynamic linking])
+])# _LT_COMPILER_PIC
+
+
+# _LT_LINKER_SHLIBS([TAGNAME])
+# ----------------------------
+# See if the linker supports building shared libraries.
+m4_defun([_LT_LINKER_SHLIBS],
+[AC_REQUIRE([LT_PATH_LD])dnl
+AC_REQUIRE([LT_PATH_NM])dnl
+m4_require([_LT_PATH_MANIFEST_TOOL])dnl
+m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+m4_require([_LT_DECL_EGREP])dnl
+m4_require([_LT_DECL_SED])dnl
+m4_require([_LT_CMD_GLOBAL_SYMBOLS])dnl
+m4_require([_LT_TAG_COMPILER])dnl
+AC_MSG_CHECKING([whether the $compiler linker ($LD) supports shared libraries])
+m4_if([$1], [CXX], [
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols'
+ _LT_TAGVAR(exclude_expsyms, $1)=['_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*']
+ case $host_os in
+ aix[[4-9]]*)
+ # If we're using GNU nm, then we don't want the "-C" option.
+ # -C means demangle to AIX nm, but means don't demangle with GNU nm
+ # Also, AIX nm treats weak defined symbols like other global defined
+ # symbols, whereas GNU nm marks them as "W".
+ if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && ([substr](\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ else
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM -BCpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && ([substr](\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ fi
+ ;;
+ pw32*)
+ _LT_TAGVAR(export_symbols_cmds, $1)="$ltdll_cmds"
+ ;;
+ cygwin* | mingw* | cegcc*)
+ case $cc_basename in
+ cl*) ;;
+ *)
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[[BCDGRS]][[ ]]/s/.*[[ ]]\([[^ ]]*\)/\1 DATA/;s/^.*[[ ]]__nm__\([[^ ]]*\)[[ ]][[^ ]]*/\1 DATA/;/^I[[ ]]/d;/^[[AITW]][[ ]]/s/.* //'\'' | sort | uniq > $export_symbols'
+ _LT_TAGVAR(exclude_expsyms, $1)=['[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname']
+ ;;
+ esac
+ ;;
+ *)
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols'
+ ;;
+ esac
+], [
+ runpath_var=
+ _LT_TAGVAR(allow_undefined_flag, $1)=
+ _LT_TAGVAR(always_export_symbols, $1)=no
+ _LT_TAGVAR(archive_cmds, $1)=
+ _LT_TAGVAR(archive_expsym_cmds, $1)=
+ _LT_TAGVAR(compiler_needs_object, $1)=no
+ _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)=
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols'
+ _LT_TAGVAR(hardcode_automatic, $1)=no
+ _LT_TAGVAR(hardcode_direct, $1)=no
+ _LT_TAGVAR(hardcode_direct_absolute, $1)=no
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=
+ _LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)=
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=
+ _LT_TAGVAR(hardcode_minus_L, $1)=no
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=unsupported
+ _LT_TAGVAR(inherit_rpath, $1)=no
+ _LT_TAGVAR(link_all_deplibs, $1)=unknown
+ _LT_TAGVAR(module_cmds, $1)=
+ _LT_TAGVAR(module_expsym_cmds, $1)=
+ _LT_TAGVAR(old_archive_from_new_cmds, $1)=
+ _LT_TAGVAR(old_archive_from_expsyms_cmds, $1)=
+ _LT_TAGVAR(thread_safe_flag_spec, $1)=
+ _LT_TAGVAR(whole_archive_flag_spec, $1)=
+ # include_expsyms should be a list of space-separated symbols to be *always*
+ # included in the symbol list
+ _LT_TAGVAR(include_expsyms, $1)=
+ # exclude_expsyms can be an extended regexp of symbols to exclude
+ # it will be wrapped by ` (' and `)$', so one must not match beginning or
+ # end of line. Example: `a|bc|.*d.*' will exclude the symbols `a' and `bc',
+ # as well as any symbol that contains `d'.
+ _LT_TAGVAR(exclude_expsyms, $1)=['_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*']
+ # Although _GLOBAL_OFFSET_TABLE_ is a valid symbol C name, most a.out
+ # platforms (ab)use it in PIC code, but their linkers get confused if
+ # the symbol is explicitly referenced. Since portable code cannot
+ # rely on this symbol name, it's probably fine to never include it in
+ # preloaded symbol tables.
+ # Exclude shared library initialization/finalization symbols.
+dnl Note also adjust exclude_expsyms for C++ above.
+ extract_expsyms_cmds=
+
+ case $host_os in
+ cygwin* | mingw* | pw32* | cegcc*)
+ # FIXME: the MSVC++ port hasn't been tested in a loooong time
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ if test "$GCC" != yes; then
+ with_gnu_ld=no
+ fi
+ ;;
+ interix*)
+ # we just hope/assume this is gcc and not c89 (= MSVC++)
+ with_gnu_ld=yes
+ ;;
+ openbsd*)
+ with_gnu_ld=no
+ ;;
+ esac
+
+ _LT_TAGVAR(ld_shlibs, $1)=yes
+
+ # On some targets, GNU ld is compatible enough with the native linker
+ # that we're better off using the native interface for both.
+ lt_use_gnu_ld_interface=no
+ if test "$with_gnu_ld" = yes; then
+ case $host_os in
+ aix*)
+ # The AIX port of GNU ld has always aspired to compatibility
+ # with the native linker. However, as the warning in the GNU ld
+ # block says, versions before 2.19.5* couldn't really create working
+ # shared libraries, regardless of the interface used.
+ case `$LD -v 2>&1` in
+ *\ \(GNU\ Binutils\)\ 2.19.5*) ;;
+ *\ \(GNU\ Binutils\)\ 2.[[2-9]]*) ;;
+ *\ \(GNU\ Binutils\)\ [[3-9]]*) ;;
+ *)
+ lt_use_gnu_ld_interface=yes
+ ;;
+ esac
+ ;;
+ *)
+ lt_use_gnu_ld_interface=yes
+ ;;
+ esac
+ fi
+
+ if test "$lt_use_gnu_ld_interface" = yes; then
+ # If archive_cmds runs LD, not CC, wlarc should be empty
+ wlarc='${wl}'
+
+ # Set some defaults for GNU ld with shared library support. These
+ # are reset later if shared libraries are not supported. Putting them
+ # here allows them to be overridden if necessary.
+ runpath_var=LD_RUN_PATH
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic'
+ # ancient GNU ld didn't support --whole-archive et. al.
+ if $LD --help 2>&1 | $GREP 'no-whole-archive' > /dev/null; then
+ _LT_TAGVAR(whole_archive_flag_spec, $1)="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive'
+ else
+ _LT_TAGVAR(whole_archive_flag_spec, $1)=
+ fi
+ supports_anon_versioning=no
+ case `$LD -v 2>&1` in
+ *GNU\ gold*) supports_anon_versioning=yes ;;
+ *\ [[01]].* | *\ 2.[[0-9]].* | *\ 2.10.*) ;; # catch versions < 2.11
+ *\ 2.11.93.0.2\ *) supports_anon_versioning=yes ;; # RH7.3 ...
+ *\ 2.11.92.0.12\ *) supports_anon_versioning=yes ;; # Mandrake 8.2 ...
+ *\ 2.11.*) ;; # other 2.11 versions
+ *) supports_anon_versioning=yes ;;
+ esac
+
+ # See if GNU ld supports shared libraries.
+ case $host_os in
+ aix[[3-9]]*)
+ # On AIX/PPC, the GNU linker is very broken
+ if test "$host_cpu" != ia64; then
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: the GNU linker, at least up to release 2.19, is reported
+*** to be unable to reliably create shared libraries on AIX.
+*** Therefore, libtool is disabling shared libraries support. If you
+*** really care for shared libraries, you may want to install binutils
+*** 2.20 or above, or modify your PATH so that a non-GNU linker is found.
+*** You will then need to restart the configuration process.
+
+_LT_EOF
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)=''
+ ;;
+ m68k)
+ _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ ;;
+ esac
+ ;;
+
+ beos*)
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ _LT_TAGVAR(allow_undefined_flag, $1)=unsupported
+ # Joseph Beckenbach <jrb3@best.com> says some releases of gcc
+ # support --undefined. This deserves some investigation. FIXME
+ _LT_TAGVAR(archive_cmds, $1)='$CC -nostart $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+
+ cygwin* | mingw* | pw32* | cegcc*)
+ # _LT_TAGVAR(hardcode_libdir_flag_spec, $1) is actually meaningless,
+ # as there is no search path for DLLs.
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-all-symbols'
+ _LT_TAGVAR(allow_undefined_flag, $1)=unsupported
+ _LT_TAGVAR(always_export_symbols, $1)=no
+ _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[[BCDGRS]][[ ]]/s/.*[[ ]]\([[^ ]]*\)/\1 DATA/;s/^.*[[ ]]__nm__\([[^ ]]*\)[[ ]][[^ ]]*/\1 DATA/;/^I[[ ]]/d;/^[[AITW]][[ ]]/s/.* //'\'' | sort | uniq > $export_symbols'
+ _LT_TAGVAR(exclude_expsyms, $1)=['[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname']
+
+ if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ # If the export-symbols file already is a .def file (1st line
+ # is EXPORTS), use it as is; otherwise, prepend...
+ _LT_TAGVAR(archive_expsym_cmds, $1)='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ cp $export_symbols $output_objdir/$soname.def;
+ else
+ echo EXPORTS > $output_objdir/$soname.def;
+ cat $export_symbols >> $output_objdir/$soname.def;
+ fi~
+ $CC -shared $output_objdir/$soname.def $libobjs $deplibs $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+
+ haiku*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ ;;
+
+ interix[[3-9]]*)
+ _LT_TAGVAR(hardcode_direct, $1)=no
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E'
+ # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc.
+ # Instead, shared libraries are loaded at an image base (0x10000000 by
+ # default) and relocated if they conflict, which is a slow very memory
+ # consuming and fragmenting process. To avoid this, we pick a random,
+ # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link
+ # time. Moving up from 0x10000000 also allows more sbrk(2) space.
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='sed "s,^,_," $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--retain-symbols-file,$output_objdir/$soname.expsym ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ ;;
+
+ gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu)
+ tmp_diet=no
+ if test "$host_os" = linux-dietlibc; then
+ case $cc_basename in
+ diet\ *) tmp_diet=yes;; # linux-dietlibc with static linking (!diet-dyn)
+ esac
+ fi
+ if $LD --help 2>&1 | $EGREP ': supported targets:.* elf' > /dev/null \
+ && test "$tmp_diet" = no
+ then
+ tmp_addflag=' $pic_flag'
+ tmp_sharedflag='-shared'
+ case $cc_basename,$host_cpu in
+ pgcc*) # Portland Group C compiler
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ tmp_addflag=' $pic_flag'
+ ;;
+ pgf77* | pgf90* | pgf95* | pgfortran*)
+ # Portland Group f77 and f90 compilers
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ tmp_addflag=' $pic_flag -Mnomain' ;;
+ ecc*,ia64* | icc*,ia64*) # Intel C compiler on ia64
+ tmp_addflag=' -i_dynamic' ;;
+ efc*,ia64* | ifort*,ia64*) # Intel Fortran compiler on ia64
+ tmp_addflag=' -i_dynamic -nofor_main' ;;
+ ifc* | ifort*) # Intel Fortran compiler
+ tmp_addflag=' -nofor_main' ;;
+ lf95*) # Lahey Fortran 8.1
+ _LT_TAGVAR(whole_archive_flag_spec, $1)=
+ tmp_sharedflag='--shared' ;;
+ xl[[cC]]* | bgxl[[cC]]* | mpixl[[cC]]*) # IBM XL C 8.0 on PPC (deal with xlf below)
+ tmp_sharedflag='-qmkshrobj'
+ tmp_addflag= ;;
+ nvcc*) # Cuda Compiler Driver 2.2
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ _LT_TAGVAR(compiler_needs_object, $1)=yes
+ ;;
+ esac
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*) # Sun C 5.9
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ _LT_TAGVAR(compiler_needs_object, $1)=yes
+ tmp_sharedflag='-G' ;;
+ *Sun\ F*) # Sun Fortran 8.3
+ tmp_sharedflag='-G' ;;
+ esac
+ _LT_TAGVAR(archive_cmds, $1)='$CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+
+ if test "x$supports_anon_versioning" = xyes; then
+ _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $output_objdir/$libname.ver~
+ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~
+ echo "local: *; };" >> $output_objdir/$libname.ver~
+ $CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-version-script ${wl}$output_objdir/$libname.ver -o $lib'
+ fi
+
+ case $cc_basename in
+ xlf* | bgf* | bgxlf* | mpixlf*)
+ # IBM XL Fortran 10.1 on PPC cannot create shared libs itself
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='--whole-archive$convenience --no-whole-archive'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=
+ _LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)='-rpath $libdir'
+ _LT_TAGVAR(archive_cmds, $1)='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib'
+ if test "x$supports_anon_versioning" = xyes; then
+ _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $output_objdir/$libname.ver~
+ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~
+ echo "local: *; };" >> $output_objdir/$libname.ver~
+ $LD -shared $libobjs $deplibs $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib'
+ fi
+ ;;
+ esac
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+
+ netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable $libobjs $deplibs $linker_flags -o $lib'
+ wlarc=
+ else
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ fi
+ ;;
+
+ solaris*)
+ if $LD -v 2>&1 | $GREP 'BFD 2\.8' > /dev/null; then
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: The releases 2.8.* of the GNU linker cannot reliably
+*** create shared libraries on Solaris systems. Therefore, libtool
+*** is disabling shared libraries support. We urge you to upgrade GNU
+*** binutils to release 2.9.1 or newer. Another option is to modify
+*** your PATH or compiler configuration so that the native linker is
+*** used, and then restart.
+
+_LT_EOF
+ elif $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*)
+ case `$LD -v 2>&1` in
+ *\ [[01]].* | *\ 2.[[0-9]].* | *\ 2.1[[0-5]].*)
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ cat <<_LT_EOF 1>&2
+
+*** Warning: Releases of the GNU linker prior to 2.16.91.0.3 can not
+*** reliably create shared libraries on SCO systems. Therefore, libtool
+*** is disabling shared libraries support. We urge you to upgrade GNU
+*** binutils to release 2.16.91.0.3 or newer. Another option is to modify
+*** your PATH or compiler configuration so that the native linker is
+*** used, and then restart.
+
+_LT_EOF
+ ;;
+ *)
+ # For security reasons, it is highly recommended that you always
+ # use absolute paths for naming shared libraries, and exclude the
+ # DT_RUNPATH tag from executables and libraries. But doing so
+ # requires that you compile everything twice, which is a pain.
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+ esac
+ ;;
+
+ sunos4*)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -assert pure-text -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ wlarc=
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ *)
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+ esac
+
+ if test "$_LT_TAGVAR(ld_shlibs, $1)" = no; then
+ runpath_var=
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)=
+ _LT_TAGVAR(whole_archive_flag_spec, $1)=
+ fi
+ else
+ # PORTME fill in a description of your system's linker (not GNU ld)
+ case $host_os in
+ aix3*)
+ _LT_TAGVAR(allow_undefined_flag, $1)=unsupported
+ _LT_TAGVAR(always_export_symbols, $1)=yes
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$LD -o $output_objdir/$soname $libobjs $deplibs $linker_flags -bE:$export_symbols -T512 -H512 -bM:SRE~$AR $AR_FLAGS $lib $output_objdir/$soname'
+ # Note: this linker hardcodes the directories in LIBPATH if there
+ # are no directories specified by -L.
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ if test "$GCC" = yes && test -z "$lt_prog_compiler_static"; then
+ # Neither direct hardcoding nor static linking is supported with a
+ # broken collect2.
+ _LT_TAGVAR(hardcode_direct, $1)=unsupported
+ fi
+ ;;
+
+ aix[[4-9]]*)
+ if test "$host_cpu" = ia64; then
+ # On IA64, the linker does run time linking by default, so we don't
+ # have to do anything special.
+ aix_use_runtimelinking=no
+ exp_sym_flag='-Bexport'
+ no_entry_flag=""
+ else
+ # If we're using GNU nm, then we don't want the "-C" option.
+ # -C means demangle to AIX nm, but means don't demangle with GNU nm
+ # Also, AIX nm treats weak defined symbols like other global
+ # defined symbols, whereas GNU nm marks them as "W".
+ if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && ([substr](\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ else
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM -BCpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B")) && ([substr](\$ 3,1,1) != ".")) { print \$ 3 } }'\'' | sort -u > $export_symbols'
+ fi
+ aix_use_runtimelinking=no
+
+ # Test if we are trying to use run time linking or normal
+ # AIX style linking. If -brtl is somewhere in LDFLAGS, we
+ # need to do runtime linking.
+ case $host_os in aix4.[[23]]|aix4.[[23]].*|aix[[5-9]]*)
+ for ld_flag in $LDFLAGS; do
+ if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then
+ aix_use_runtimelinking=yes
+ break
+ fi
+ done
+ ;;
+ esac
+
+ exp_sym_flag='-bexport'
+ no_entry_flag='-bnoentry'
+ fi
+
+ # When large executables or shared objects are built, AIX ld can
+ # have problems creating the table of contents. If linking a library
+ # or program results in "error TOC overflow" add -mminimal-toc to
+ # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not
+ # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS.
+
+ _LT_TAGVAR(archive_cmds, $1)=''
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_direct_absolute, $1)=yes
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=':'
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ _LT_TAGVAR(file_list_spec, $1)='${wl}-f,'
+
+ if test "$GCC" = yes; then
+ case $host_os in aix4.[[012]]|aix4.[[012]].*)
+ # We only want to do this on AIX 4.2 and lower, the check
+ # below for broken collect2 doesn't work under 4.3+
+ collect2name=`${CC} -print-prog-name=collect2`
+ if test -f "$collect2name" &&
+ strings "$collect2name" | $GREP resolve_lib_name >/dev/null
+ then
+ # We have reworked collect2
+ :
+ else
+ # We have old collect2
+ _LT_TAGVAR(hardcode_direct, $1)=unsupported
+ # It fails to find uninstalled libraries when the uninstalled
+ # path is not listed in the libpath. Setting hardcode_minus_L
+ # to unsupported forces relinking
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=
+ fi
+ ;;
+ esac
+ shared_flag='-shared'
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag="$shared_flag "'${wl}-G'
+ fi
+ else
+ # not using gcc
+ if test "$host_cpu" = ia64; then
+ # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release
+ # chokes on -Wl,-G. The following line is correct:
+ shared_flag='-G'
+ else
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag='${wl}-G'
+ else
+ shared_flag='${wl}-bM:SRE'
+ fi
+ fi
+ fi
+
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-bexpall'
+ # It seems that -bexpall does not export symbols beginning with
+ # underscore (_), so it is better to generate a list of symbols to export.
+ _LT_TAGVAR(always_export_symbols, $1)=yes
+ if test "$aix_use_runtimelinking" = yes; then
+ # Warning - without using the other runtime loading flags (-brtl),
+ # -berok will link without error, but may produce a broken library.
+ _LT_TAGVAR(allow_undefined_flag, $1)='-berok'
+ # Determine the default libpath from the value encoded in an
+ # empty executable.
+ _LT_SYS_MODULE_PATH_AIX([$1])
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-blibpath:$libdir:'"$aix_libpath"
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags `if test "x${allow_undefined_flag}" != "x"; then func_echo_all "${wl}${allow_undefined_flag}"; else :; fi` '"\${wl}$exp_sym_flag:\$export_symbols $shared_flag"
+ else
+ if test "$host_cpu" = ia64; then
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R $libdir:/usr/lib:/lib'
+ _LT_TAGVAR(allow_undefined_flag, $1)="-z nodefs"
+ _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags ${wl}${allow_undefined_flag} '"\${wl}$exp_sym_flag:\$export_symbols"
+ else
+ # Determine the default libpath from the value encoded in an
+ # empty executable.
+ _LT_SYS_MODULE_PATH_AIX([$1])
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-blibpath:$libdir:'"$aix_libpath"
+ # Warning - without using the other run time loading flags,
+ # -berok will link without error, but may produce a broken library.
+ _LT_TAGVAR(no_undefined_flag, $1)=' ${wl}-bernotok'
+ _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-berok'
+ if test "$with_gnu_ld" = yes; then
+ # We only use this code for GNU lds that support --whole-archive.
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive$convenience ${wl}--no-whole-archive'
+ else
+ # Exported symbols can be pulled into shared objects from archives
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='$convenience'
+ fi
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=yes
+ # This is similar to how AIX traditionally builds its shared libraries.
+ _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs ${wl}-bnoentry $compiler_flags ${wl}-bE:$export_symbols${allow_undefined_flag}~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$soname'
+ fi
+ fi
+ ;;
+
+ amigaos*)
+ case $host_cpu in
+ powerpc)
+ # see comment about AmigaOS4 .so support
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)=''
+ ;;
+ m68k)
+ _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ ;;
+ esac
+ ;;
+
+ bsdi[[45]]*)
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)=-rdynamic
+ ;;
+
+ cygwin* | mingw* | pw32* | cegcc*)
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ case $cc_basename in
+ cl*)
+ # Native MSVC
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=' '
+ _LT_TAGVAR(allow_undefined_flag, $1)=unsupported
+ _LT_TAGVAR(always_export_symbols, $1)=yes
+ _LT_TAGVAR(file_list_spec, $1)='@'
+ # Tell ltmain to make .lib files, not .a files.
+ libext=lib
+ # Tell ltmain to make .dll files, not .so files.
+ shrext_cmds=".dll"
+ # FIXME: Setting linknames here is a bad hack.
+ _LT_TAGVAR(archive_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-dll~linknames='
+ _LT_TAGVAR(archive_expsym_cmds, $1)='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ sed -n -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' -e '1\\\!p' < $export_symbols > $output_objdir/$soname.exp;
+ else
+ sed -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' < $export_symbols > $output_objdir/$soname.exp;
+ fi~
+ $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~
+ linknames='
+ # The linker will not automatically build a static lib if we build a DLL.
+ # _LT_TAGVAR(old_archive_from_new_cmds, $1)='true'
+ _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes
+ _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[[BCDGRS]][[ ]]/s/.*[[ ]]\([[^ ]]*\)/\1,DATA/'\'' | $SED -e '\''/^[[AITW]][[ ]]/s/.*[[ ]]//'\'' | sort | uniq > $export_symbols'
+ # Don't use ranlib
+ _LT_TAGVAR(old_postinstall_cmds, $1)='chmod 644 $oldlib'
+ _LT_TAGVAR(postlink_cmds, $1)='lt_outputfile="@OUTPUT@"~
+ lt_tool_outputfile="@TOOL_OUTPUT@"~
+ case $lt_outputfile in
+ *.exe|*.EXE) ;;
+ *)
+ lt_outputfile="$lt_outputfile.exe"
+ lt_tool_outputfile="$lt_tool_outputfile.exe"
+ ;;
+ esac~
+ if test "$MANIFEST_TOOL" != ":" && test -f "$lt_outputfile.manifest"; then
+ $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1;
+ $RM "$lt_outputfile.manifest";
+ fi'
+ ;;
+ *)
+ # Assume MSVC wrapper
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=' '
+ _LT_TAGVAR(allow_undefined_flag, $1)=unsupported
+ # Tell ltmain to make .lib files, not .a files.
+ libext=lib
+ # Tell ltmain to make .dll files, not .so files.
+ shrext_cmds=".dll"
+ # FIXME: Setting linknames here is a bad hack.
+ _LT_TAGVAR(archive_cmds, $1)='$CC -o $lib $libobjs $compiler_flags `func_echo_all "$deplibs" | $SED '\''s/ -lc$//'\''` -link -dll~linknames='
+ # The linker will automatically build a .lib file if we build a DLL.
+ _LT_TAGVAR(old_archive_from_new_cmds, $1)='true'
+ # FIXME: Should let the user specify the lib program.
+ _LT_TAGVAR(old_archive_cmds, $1)='lib -OUT:$oldlib$oldobjs$old_deplibs'
+ _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes
+ ;;
+ esac
+ ;;
+
+ darwin* | rhapsody*)
+ _LT_DARWIN_LINKER_FEATURES($1)
+ ;;
+
+ dgux*)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ freebsd1*)
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+
+ # FreeBSD 2.2.[012] allows us to include c++rt0.o to get C++ constructor
+ # support. Future versions do this automatically, but an explicit c++rt0.o
+ # does not break anything, and helps significantly (at the cost of a little
+ # extra space).
+ freebsd2.2*)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags /usr/lib/c++rt0.o'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir'
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ # Unfortunately, older versions of FreeBSD 2 do not have this feature.
+ freebsd2*)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ # FreeBSD 3 and greater uses gcc -shared to do shared libraries.
+ freebsd* | dragonfly*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir'
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ hpux9*)
+ if test "$GCC" = yes; then
+ _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -shared $pic_flag ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ else
+ _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$LD -b +b $install_libdir -o $output_objdir/$soname $libobjs $deplibs $linker_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ fi
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E'
+ ;;
+
+ hpux10*)
+ if test "$GCC" = yes && test "$with_gnu_ld" = no; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ _LT_TAGVAR(archive_cmds, $1)='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags'
+ fi
+ if test "$with_gnu_ld" = no; then
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)='+b $libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_direct_absolute, $1)=yes
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E'
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ fi
+ ;;
+
+ hpux11*)
+ if test "$GCC" = yes && test "$with_gnu_ld" = no; then
+ case $host_cpu in
+ hppa*64*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ ia64*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ *)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ esac
+ else
+ case $host_cpu in
+ hppa*64*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ ia64*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ *)
+ m4_if($1, [], [
+ # Older versions of the 11.00 compiler do not understand -b yet
+ # (HP92453-01 A.11.01.20 doesn't, HP92453-01 B.11.X.35175-35176.GP does)
+ _LT_LINKER_OPTION([if $CC understands -b],
+ _LT_TAGVAR(lt_cv_prog_compiler__b, $1), [-b],
+ [_LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'],
+ [_LT_TAGVAR(archive_cmds, $1)='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags'])],
+ [_LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $libobjs $deplibs $compiler_flags'])
+ ;;
+ esac
+ fi
+ if test "$with_gnu_ld" = no; then
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+
+ case $host_cpu in
+ hppa*64*|ia64*)
+ _LT_TAGVAR(hardcode_direct, $1)=no
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+ *)
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_direct_absolute, $1)=yes
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E'
+
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ ;;
+ esac
+ fi
+ ;;
+
+ irix5* | irix6* | nonstopux*)
+ if test "$GCC" = yes; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ # Try to use the -exported_symbol ld option, if it does not
+ # work, assume that -exports_file does not work either and
+ # implicitly export all symbols.
+ # This should be the same for all languages, so no per-tag cache variable.
+ AC_CACHE_CHECK([whether the $host_os linker accepts -exported_symbol],
+ [lt_cv_irix_exported_symbol],
+ [save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS -shared ${wl}-exported_symbol ${wl}foo ${wl}-update_registry ${wl}/dev/null"
+ AC_LINK_IFELSE(
+ [AC_LANG_SOURCE(
+ [AC_LANG_CASE([C], [[int foo (void) { return 0; }]],
+ [C++], [[int foo (void) { return 0; }]],
+ [Fortran 77], [[
+ subroutine foo
+ end]],
+ [Fortran], [[
+ subroutine foo
+ end]])])],
+ [lt_cv_irix_exported_symbol=yes],
+ [lt_cv_irix_exported_symbol=no])
+ LDFLAGS="$save_LDFLAGS"])
+ if test "$lt_cv_irix_exported_symbol" = yes; then
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations ${wl}-exports_file ${wl}$export_symbols -o $lib'
+ fi
+ else
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -exports_file $export_symbols -o $lib'
+ fi
+ _LT_TAGVAR(archive_cmds_need_lc, $1)='no'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+ _LT_TAGVAR(inherit_rpath, $1)=yes
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ ;;
+
+ netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' # a.out
+ else
+ _LT_TAGVAR(archive_cmds, $1)='$LD -shared -o $lib $libobjs $deplibs $linker_flags' # ELF
+ fi
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir'
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ newsos6)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ *nto* | *qnx*)
+ ;;
+
+ openbsd*)
+ if test -f /usr/libexec/ld.so; then
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ _LT_TAGVAR(hardcode_direct_absolute, $1)=yes
+ if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags ${wl}-retain-symbols-file,$export_symbols'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E'
+ else
+ case $host_os in
+ openbsd[[01]].* | openbsd2.[[0-7]] | openbsd2.[[0-7]].*)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir'
+ ;;
+ *)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir'
+ ;;
+ esac
+ fi
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+
+ os2*)
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ _LT_TAGVAR(allow_undefined_flag, $1)=unsupported
+ _LT_TAGVAR(archive_cmds, $1)='$ECHO "LIBRARY $libname INITINSTANCE" > $output_objdir/$libname.def~$ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~echo DATA >> $output_objdir/$libname.def~echo " SINGLE NONSHARED" >> $output_objdir/$libname.def~echo EXPORTS >> $output_objdir/$libname.def~emxexp $libobjs >> $output_objdir/$libname.def~$CC -Zdll -Zcrtdll -o $lib $libobjs $deplibs $compiler_flags $output_objdir/$libname.def'
+ _LT_TAGVAR(old_archive_from_new_cmds, $1)='emximp -o $output_objdir/$libname.a $output_objdir/$libname.def'
+ ;;
+
+ osf3*)
+ if test "$GCC" = yes; then
+ _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-expect_unresolved ${wl}\*'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ else
+ _LT_TAGVAR(allow_undefined_flag, $1)=' -expect_unresolved \*'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ fi
+ _LT_TAGVAR(archive_cmds_need_lc, $1)='no'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+ ;;
+
+ osf4* | osf5*) # as osf3* with the addition of -msym flag
+ if test "$GCC" = yes; then
+ _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-expect_unresolved ${wl}\*'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $pic_flag $libobjs $deplibs $compiler_flags ${wl}-msym ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ else
+ _LT_TAGVAR(allow_undefined_flag, $1)=' -expect_unresolved \*'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $libobjs $deplibs $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done; printf "%s\\n" "-hidden">> $lib.exp~
+ $CC -shared${allow_undefined_flag} ${wl}-input ${wl}$lib.exp $compiler_flags $libobjs $deplibs -soname $soname `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib~$RM $lib.exp'
+
+ # Both c and cxx compiler support -rpath directly
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-rpath $libdir'
+ fi
+ _LT_TAGVAR(archive_cmds_need_lc, $1)='no'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+ ;;
+
+ solaris*)
+ _LT_TAGVAR(no_undefined_flag, $1)=' -z defs'
+ if test "$GCC" = yes; then
+ wlarc='${wl}'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag ${wl}-z ${wl}text ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -shared $pic_flag ${wl}-z ${wl}text ${wl}-M ${wl}$lib.exp ${wl}-h ${wl}$soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp'
+ else
+ case `$CC -V 2>&1` in
+ *"Compilers 5.0"*)
+ wlarc=''
+ _LT_TAGVAR(archive_cmds, $1)='$LD -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $LD -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $linker_flags~$RM $lib.exp'
+ ;;
+ *)
+ wlarc='${wl}'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -G${allow_undefined_flag} -h $soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -G${allow_undefined_flag} -M $lib.exp -h $soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp'
+ ;;
+ esac
+ fi
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir'
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ case $host_os in
+ solaris2.[[0-5]] | solaris2.[[0-5]].*) ;;
+ *)
+ # The compiler driver will combine and reorder linker options,
+ # but understands `-z linker_flag'. GCC discards it without `$wl',
+ # but is careful enough not to reorder.
+ # Supported since Solaris 2.6 (maybe 2.5.1?)
+ if test "$GCC" = yes; then
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}-z ${wl}allextract$convenience ${wl}-z ${wl}defaultextract'
+ else
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='-z allextract$convenience -z defaultextract'
+ fi
+ ;;
+ esac
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ ;;
+
+ sunos4*)
+ if test "x$host_vendor" = xsequent; then
+ # Use $CC to link under sequent, because it throws in some extra .o
+ # files that make .init and .fini sections work.
+ _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h $soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ _LT_TAGVAR(archive_cmds, $1)='$LD -assert pure-text -Bstatic -o $lib $libobjs $deplibs $linker_flags'
+ fi
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ sysv4)
+ case $host_vendor in
+ sni)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(hardcode_direct, $1)=yes # is this really true???
+ ;;
+ siemens)
+ ## LD is ld it makes a PLAMLIB
+ ## CC just makes a GrossModule.
+ _LT_TAGVAR(archive_cmds, $1)='$LD -G -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(reload_cmds, $1)='$CC -r -o $output$reload_objs'
+ _LT_TAGVAR(hardcode_direct, $1)=no
+ ;;
+ motorola)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(hardcode_direct, $1)=no #Motorola manual says yes, but my tests say they lie
+ ;;
+ esac
+ runpath_var='LD_RUN_PATH'
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ sysv4.3*)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='-Bexport'
+ ;;
+
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ runpath_var=LD_RUN_PATH
+ hardcode_runpath_var=yes
+ _LT_TAGVAR(ld_shlibs, $1)=yes
+ fi
+ ;;
+
+ sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[[01]].[[10]]* | unixware7* | sco3.2v5.0.[[024]]*)
+ _LT_TAGVAR(no_undefined_flag, $1)='${wl}-z,text'
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=no
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ runpath_var='LD_RUN_PATH'
+
+ if test "$GCC" = yes; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ fi
+ ;;
+
+ sysv5* | sco3.2v5* | sco5v6*)
+ # Note: We can NOT use -z defs as we might desire, because we do not
+ # link with -lc, and that would cause any symbols used from libc to
+ # always be unresolved, which means just about no library would
+ # ever link correctly. If we're not using GNU ld we use -z text
+ # though, which does catch some bad symbols but isn't as heavy-handed
+ # as -z defs.
+ _LT_TAGVAR(no_undefined_flag, $1)='${wl}-z,text'
+ _LT_TAGVAR(allow_undefined_flag, $1)='${wl}-z,nodefs'
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=no
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R,$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=':'
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-Bexport'
+ runpath_var='LD_RUN_PATH'
+
+ if test "$GCC" = yes; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ else
+ _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ fi
+ ;;
+
+ uts4*)
+ _LT_TAGVAR(archive_cmds, $1)='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+
+ *)
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ esac
+
+ if test x$host_vendor = xsni; then
+ case $host in
+ sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*)
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-Blargedynsym'
+ ;;
+ esac
+ fi
+ fi
+])
+AC_MSG_RESULT([$_LT_TAGVAR(ld_shlibs, $1)])
+test "$_LT_TAGVAR(ld_shlibs, $1)" = no && can_build_shared=no
+
+_LT_TAGVAR(with_gnu_ld, $1)=$with_gnu_ld
+
+_LT_DECL([], [libext], [0], [Old archive suffix (normally "a")])dnl
+_LT_DECL([], [shrext_cmds], [1], [Shared library suffix (normally ".so")])dnl
+_LT_DECL([], [extract_expsyms_cmds], [2],
+ [The commands to extract the exported symbol list from a shared archive])
+
+#
+# Do we need to explicitly link libc?
+#
+case "x$_LT_TAGVAR(archive_cmds_need_lc, $1)" in
+x|xyes)
+ # Assume -lc should be added
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=yes
+
+ if test "$enable_shared" = yes && test "$GCC" = yes; then
+ case $_LT_TAGVAR(archive_cmds, $1) in
+ *'~'*)
+ # FIXME: we may have to deal with multi-command sequences.
+ ;;
+ '$CC '*)
+ # Test whether the compiler implicitly links with -lc since on some
+ # systems, -lgcc has to come before -lc. If gcc already passes -lc
+ # to ld, don't add -lc before -lgcc.
+ AC_CACHE_CHECK([whether -lc should be explicitly linked in],
+ [lt_cv_]_LT_TAGVAR(archive_cmds_need_lc, $1),
+ [$RM conftest*
+ echo "$lt_simple_compile_test_code" > conftest.$ac_ext
+
+ if AC_TRY_EVAL(ac_compile) 2>conftest.err; then
+ soname=conftest
+ lib=conftest
+ libobjs=conftest.$ac_objext
+ deplibs=
+ wl=$_LT_TAGVAR(lt_prog_compiler_wl, $1)
+ pic_flag=$_LT_TAGVAR(lt_prog_compiler_pic, $1)
+ compiler_flags=-v
+ linker_flags=-v
+ verstring=
+ output_objdir=.
+ libname=conftest
+ lt_save_allow_undefined_flag=$_LT_TAGVAR(allow_undefined_flag, $1)
+ _LT_TAGVAR(allow_undefined_flag, $1)=
+ if AC_TRY_EVAL(_LT_TAGVAR(archive_cmds, $1) 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1)
+ then
+ lt_cv_[]_LT_TAGVAR(archive_cmds_need_lc, $1)=no
+ else
+ lt_cv_[]_LT_TAGVAR(archive_cmds_need_lc, $1)=yes
+ fi
+ _LT_TAGVAR(allow_undefined_flag, $1)=$lt_save_allow_undefined_flag
+ else
+ cat conftest.err 1>&5
+ fi
+ $RM conftest*
+ ])
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=$lt_cv_[]_LT_TAGVAR(archive_cmds_need_lc, $1)
+ ;;
+ esac
+ fi
+ ;;
+esac
+
+_LT_TAGDECL([build_libtool_need_lc], [archive_cmds_need_lc], [0],
+ [Whether or not to add -lc for building shared libraries])
+_LT_TAGDECL([allow_libtool_libs_with_static_runtimes],
+ [enable_shared_with_static_runtimes], [0],
+ [Whether or not to disallow shared libs when runtime libs are static])
+_LT_TAGDECL([], [export_dynamic_flag_spec], [1],
+ [Compiler flag to allow reflexive dlopens])
+_LT_TAGDECL([], [whole_archive_flag_spec], [1],
+ [Compiler flag to generate shared objects directly from archives])
+_LT_TAGDECL([], [compiler_needs_object], [1],
+ [Whether the compiler copes with passing no objects directly])
+_LT_TAGDECL([], [old_archive_from_new_cmds], [2],
+ [Create an old-style archive from a shared archive])
+_LT_TAGDECL([], [old_archive_from_expsyms_cmds], [2],
+ [Create a temporary old-style archive to link instead of a shared archive])
+_LT_TAGDECL([], [archive_cmds], [2], [Commands used to build a shared archive])
+_LT_TAGDECL([], [archive_expsym_cmds], [2])
+_LT_TAGDECL([], [module_cmds], [2],
+ [Commands used to build a loadable module if different from building
+ a shared archive.])
+_LT_TAGDECL([], [module_expsym_cmds], [2])
+_LT_TAGDECL([], [with_gnu_ld], [1],
+ [Whether we are building with GNU ld or not])
+_LT_TAGDECL([], [allow_undefined_flag], [1],
+ [Flag that allows shared libraries with undefined symbols to be built])
+_LT_TAGDECL([], [no_undefined_flag], [1],
+ [Flag that enforces no undefined symbols])
+_LT_TAGDECL([], [hardcode_libdir_flag_spec], [1],
+ [Flag to hardcode $libdir into a binary during linking.
+ This must work even if $libdir does not exist])
+_LT_TAGDECL([], [hardcode_libdir_flag_spec_ld], [1],
+ [[If ld is used when linking, flag to hardcode $libdir into a binary
+ during linking. This must work even if $libdir does not exist]])
+_LT_TAGDECL([], [hardcode_libdir_separator], [1],
+ [Whether we need a single "-rpath" flag with a separated argument])
+_LT_TAGDECL([], [hardcode_direct], [0],
+ [Set to "yes" if using DIR/libNAME${shared_ext} during linking hardcodes
+ DIR into the resulting binary])
+_LT_TAGDECL([], [hardcode_direct_absolute], [0],
+ [Set to "yes" if using DIR/libNAME${shared_ext} during linking hardcodes
+ DIR into the resulting binary and the resulting library dependency is
+ "absolute", i.e impossible to change by setting ${shlibpath_var} if the
+ library is relocated])
+_LT_TAGDECL([], [hardcode_minus_L], [0],
+ [Set to "yes" if using the -LDIR flag during linking hardcodes DIR
+ into the resulting binary])
+_LT_TAGDECL([], [hardcode_shlibpath_var], [0],
+ [Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR
+ into the resulting binary])
+_LT_TAGDECL([], [hardcode_automatic], [0],
+ [Set to "yes" if building a shared library automatically hardcodes DIR
+ into the library and all subsequent libraries and executables linked
+ against it])
+_LT_TAGDECL([], [inherit_rpath], [0],
+ [Set to yes if linker adds runtime paths of dependent libraries
+ to runtime path list])
+_LT_TAGDECL([], [link_all_deplibs], [0],
+ [Whether libtool must link a program against all its dependency libraries])
+_LT_TAGDECL([], [always_export_symbols], [0],
+ [Set to "yes" if exported symbols are required])
+_LT_TAGDECL([], [export_symbols_cmds], [2],
+ [The commands to list exported symbols])
+_LT_TAGDECL([], [exclude_expsyms], [1],
+ [Symbols that should not be listed in the preloaded symbols])
+_LT_TAGDECL([], [include_expsyms], [1],
+ [Symbols that must always be exported])
+_LT_TAGDECL([], [prelink_cmds], [2],
+ [Commands necessary for linking programs (against libraries) with templates])
+_LT_TAGDECL([], [postlink_cmds], [2],
+ [Commands necessary for finishing linking programs])
+_LT_TAGDECL([], [file_list_spec], [1],
+ [Specify filename containing input files])
+dnl FIXME: Not yet implemented
+dnl _LT_TAGDECL([], [thread_safe_flag_spec], [1],
+dnl [Compiler flag to generate thread safe objects])
+])# _LT_LINKER_SHLIBS
+
+
+# _LT_LANG_C_CONFIG([TAG])
+# ------------------------
+# Ensure that the configuration variables for a C compiler are suitably
+# defined. These variables are subsequently used by _LT_CONFIG to write
+# the compiler configuration to `libtool'.
+m4_defun([_LT_LANG_C_CONFIG],
+[m4_require([_LT_DECL_EGREP])dnl
+lt_save_CC="$CC"
+AC_LANG_PUSH(C)
+
+# Source file extension for C test sources.
+ac_ext=c
+
+# Object file extension for compiled C test sources.
+objext=o
+_LT_TAGVAR(objext, $1)=$objext
+
+# Code to be used in simple compile tests
+lt_simple_compile_test_code="int some_variable = 0;"
+
+# Code to be used in simple link tests
+lt_simple_link_test_code='int main(){return(0);}'
+
+_LT_TAG_COMPILER
+# Save the default compiler, since it gets overwritten when the other
+# tags are being tested, and _LT_TAGVAR(compiler, []) is a NOP.
+compiler_DEFAULT=$CC
+
+# save warnings/boilerplate of simple test code
+_LT_COMPILER_BOILERPLATE
+_LT_LINKER_BOILERPLATE
+
+## CAVEAT EMPTOR:
+## There is no encapsulation within the following macros, do not change
+## the running order or otherwise move them around unless you know exactly
+## what you are doing...
+if test -n "$compiler"; then
+ _LT_COMPILER_NO_RTTI($1)
+ _LT_COMPILER_PIC($1)
+ _LT_COMPILER_C_O($1)
+ _LT_COMPILER_FILE_LOCKS($1)
+ _LT_LINKER_SHLIBS($1)
+ _LT_SYS_DYNAMIC_LINKER($1)
+ _LT_LINKER_HARDCODE_LIBPATH($1)
+ LT_SYS_DLOPEN_SELF
+ _LT_CMD_STRIPLIB
+
+ # Report which library types will actually be built
+ AC_MSG_CHECKING([if libtool supports shared libraries])
+ AC_MSG_RESULT([$can_build_shared])
+
+ AC_MSG_CHECKING([whether to build shared libraries])
+ test "$can_build_shared" = "no" && enable_shared=no
+
+ # On AIX, shared libraries and static libraries use the same namespace, and
+ # are all built from PIC.
+ case $host_os in
+ aix3*)
+ test "$enable_shared" = yes && enable_static=no
+ if test -n "$RANLIB"; then
+ archive_cmds="$archive_cmds~\$RANLIB \$lib"
+ postinstall_cmds='$RANLIB $lib'
+ fi
+ ;;
+
+ aix[[4-9]]*)
+ if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then
+ test "$enable_shared" = yes && enable_static=no
+ fi
+ ;;
+ esac
+ AC_MSG_RESULT([$enable_shared])
+
+ AC_MSG_CHECKING([whether to build static libraries])
+ # Make sure either enable_shared or enable_static is yes.
+ test "$enable_shared" = yes || enable_static=yes
+ AC_MSG_RESULT([$enable_static])
+
+ _LT_CONFIG($1)
+fi
+AC_LANG_POP
+CC="$lt_save_CC"
+])# _LT_LANG_C_CONFIG
+
+
+# _LT_LANG_CXX_CONFIG([TAG])
+# --------------------------
+# Ensure that the configuration variables for a C++ compiler are suitably
+# defined. These variables are subsequently used by _LT_CONFIG to write
+# the compiler configuration to `libtool'.
+m4_defun([_LT_LANG_CXX_CONFIG],
+[m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+m4_require([_LT_DECL_EGREP])dnl
+m4_require([_LT_PATH_MANIFEST_TOOL])dnl
+if test -n "$CXX" && ( test "X$CXX" != "Xno" &&
+ ( (test "X$CXX" = "Xg++" && `g++ -v >/dev/null 2>&1` ) ||
+ (test "X$CXX" != "Xg++"))) ; then
+ AC_PROG_CXXCPP
+else
+ _lt_caught_CXX_error=yes
+fi
+
+AC_LANG_PUSH(C++)
+_LT_TAGVAR(archive_cmds_need_lc, $1)=no
+_LT_TAGVAR(allow_undefined_flag, $1)=
+_LT_TAGVAR(always_export_symbols, $1)=no
+_LT_TAGVAR(archive_expsym_cmds, $1)=
+_LT_TAGVAR(compiler_needs_object, $1)=no
+_LT_TAGVAR(export_dynamic_flag_spec, $1)=
+_LT_TAGVAR(hardcode_direct, $1)=no
+_LT_TAGVAR(hardcode_direct_absolute, $1)=no
+_LT_TAGVAR(hardcode_libdir_flag_spec, $1)=
+_LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)=
+_LT_TAGVAR(hardcode_libdir_separator, $1)=
+_LT_TAGVAR(hardcode_minus_L, $1)=no
+_LT_TAGVAR(hardcode_shlibpath_var, $1)=unsupported
+_LT_TAGVAR(hardcode_automatic, $1)=no
+_LT_TAGVAR(inherit_rpath, $1)=no
+_LT_TAGVAR(module_cmds, $1)=
+_LT_TAGVAR(module_expsym_cmds, $1)=
+_LT_TAGVAR(link_all_deplibs, $1)=unknown
+_LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds
+_LT_TAGVAR(reload_flag, $1)=$reload_flag
+_LT_TAGVAR(reload_cmds, $1)=$reload_cmds
+_LT_TAGVAR(no_undefined_flag, $1)=
+_LT_TAGVAR(whole_archive_flag_spec, $1)=
+_LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no
+
+# Source file extension for C++ test sources.
+ac_ext=cpp
+
+# Object file extension for compiled C++ test sources.
+objext=o
+_LT_TAGVAR(objext, $1)=$objext
+
+# No sense in running all these tests if we already determined that
+# the CXX compiler isn't working. Some variables (like enable_shared)
+# are currently assumed to apply to all compilers on this platform,
+# and will be corrupted by setting them based on a non-working compiler.
+if test "$_lt_caught_CXX_error" != yes; then
+ # Code to be used in simple compile tests
+ lt_simple_compile_test_code="int some_variable = 0;"
+
+ # Code to be used in simple link tests
+ lt_simple_link_test_code='int main(int, char *[[]]) { return(0); }'
+
+ # ltmain only uses $CC for tagged configurations so make sure $CC is set.
+ _LT_TAG_COMPILER
+
+ # save warnings/boilerplate of simple test code
+ _LT_COMPILER_BOILERPLATE
+ _LT_LINKER_BOILERPLATE
+
+ # Allow CC to be a program name with arguments.
+ lt_save_CC=$CC
+ lt_save_CFLAGS=$CFLAGS
+ lt_save_LD=$LD
+ lt_save_GCC=$GCC
+ GCC=$GXX
+ lt_save_with_gnu_ld=$with_gnu_ld
+ lt_save_path_LD=$lt_cv_path_LD
+ if test -n "${lt_cv_prog_gnu_ldcxx+set}"; then
+ lt_cv_prog_gnu_ld=$lt_cv_prog_gnu_ldcxx
+ else
+ $as_unset lt_cv_prog_gnu_ld
+ fi
+ if test -n "${lt_cv_path_LDCXX+set}"; then
+ lt_cv_path_LD=$lt_cv_path_LDCXX
+ else
+ $as_unset lt_cv_path_LD
+ fi
+ test -z "${LDCXX+set}" || LD=$LDCXX
+ CC=${CXX-"c++"}
+ CFLAGS=$CXXFLAGS
+ compiler=$CC
+ _LT_TAGVAR(compiler, $1)=$CC
+ _LT_CC_BASENAME([$compiler])
+
+ if test -n "$compiler"; then
+ # We don't want -fno-exception when compiling C++ code, so set the
+ # no_builtin_flag separately
+ if test "$GXX" = yes; then
+ _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -fno-builtin'
+ else
+ _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=
+ fi
+
+ if test "$GXX" = yes; then
+ # Set up default GNU C++ configuration
+
+ LT_PATH_LD
+
+ # Check if GNU C++ uses GNU ld as the underlying linker, since the
+ # archiving commands below assume that GNU ld is being used.
+ if test "$with_gnu_ld" = yes; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC $pic_flag -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC $pic_flag -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic'
+
+ # If archive_cmds runs LD, not CC, wlarc should be empty
+ # XXX I think wlarc can be eliminated in ltcf-cxx, but I need to
+ # investigate it a little bit more. (MM)
+ wlarc='${wl}'
+
+ # ancient GNU ld didn't support --whole-archive et. al.
+ if eval "`$CC -print-prog-name=ld` --help 2>&1" |
+ $GREP 'no-whole-archive' > /dev/null; then
+ _LT_TAGVAR(whole_archive_flag_spec, $1)="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive'
+ else
+ _LT_TAGVAR(whole_archive_flag_spec, $1)=
+ fi
+ else
+ with_gnu_ld=no
+ wlarc=
+
+ # A generic and very simple default shared library creation
+ # command for GNU C++ for the case where it uses the native
+ # linker, instead of GNU ld. If possible, this setting should
+ # overridden to take advantage of the native linker features on
+ # the platform it is being used on.
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $lib'
+ fi
+
+ # Commands to make compiler produce verbose output that lists
+ # what "hidden" libraries, object files and flags are used when
+ # linking a shared library.
+ output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP "\-L"'
+
+ else
+ GXX=no
+ with_gnu_ld=no
+ wlarc=
+ fi
+
+ # PORTME: fill in a description of your system's C++ link characteristics
+ AC_MSG_CHECKING([whether the $compiler linker ($LD) supports shared libraries])
+ _LT_TAGVAR(ld_shlibs, $1)=yes
+ case $host_os in
+ aix3*)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ aix[[4-9]]*)
+ if test "$host_cpu" = ia64; then
+ # On IA64, the linker does run time linking by default, so we don't
+ # have to do anything special.
+ aix_use_runtimelinking=no
+ exp_sym_flag='-Bexport'
+ no_entry_flag=""
+ else
+ aix_use_runtimelinking=no
+
+ # Test if we are trying to use run time linking or normal
+ # AIX style linking. If -brtl is somewhere in LDFLAGS, we
+ # need to do runtime linking.
+ case $host_os in aix4.[[23]]|aix4.[[23]].*|aix[[5-9]]*)
+ for ld_flag in $LDFLAGS; do
+ case $ld_flag in
+ *-brtl*)
+ aix_use_runtimelinking=yes
+ break
+ ;;
+ esac
+ done
+ ;;
+ esac
+
+ exp_sym_flag='-bexport'
+ no_entry_flag='-bnoentry'
+ fi
+
+ # When large executables or shared objects are built, AIX ld can
+ # have problems creating the table of contents. If linking a library
+ # or program results in "error TOC overflow" add -mminimal-toc to
+ # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not
+ # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS.
+
+ _LT_TAGVAR(archive_cmds, $1)=''
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_direct_absolute, $1)=yes
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=':'
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ _LT_TAGVAR(file_list_spec, $1)='${wl}-f,'
+
+ if test "$GXX" = yes; then
+ case $host_os in aix4.[[012]]|aix4.[[012]].*)
+ # We only want to do this on AIX 4.2 and lower, the check
+ # below for broken collect2 doesn't work under 4.3+
+ collect2name=`${CC} -print-prog-name=collect2`
+ if test -f "$collect2name" &&
+ strings "$collect2name" | $GREP resolve_lib_name >/dev/null
+ then
+ # We have reworked collect2
+ :
+ else
+ # We have old collect2
+ _LT_TAGVAR(hardcode_direct, $1)=unsupported
+ # It fails to find uninstalled libraries when the uninstalled
+ # path is not listed in the libpath. Setting hardcode_minus_L
+ # to unsupported forces relinking
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=
+ fi
+ esac
+ shared_flag='-shared'
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag="$shared_flag "'${wl}-G'
+ fi
+ else
+ # not using gcc
+ if test "$host_cpu" = ia64; then
+ # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release
+ # chokes on -Wl,-G. The following line is correct:
+ shared_flag='-G'
+ else
+ if test "$aix_use_runtimelinking" = yes; then
+ shared_flag='${wl}-G'
+ else
+ shared_flag='${wl}-bM:SRE'
+ fi
+ fi
+ fi
+
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-bexpall'
+ # It seems that -bexpall does not export symbols beginning with
+ # underscore (_), so it is better to generate a list of symbols to
+ # export.
+ _LT_TAGVAR(always_export_symbols, $1)=yes
+ if test "$aix_use_runtimelinking" = yes; then
+ # Warning - without using the other runtime loading flags (-brtl),
+ # -berok will link without error, but may produce a broken library.
+ _LT_TAGVAR(allow_undefined_flag, $1)='-berok'
+ # Determine the default libpath from the value encoded in an empty
+ # executable.
+ _LT_SYS_MODULE_PATH_AIX([$1])
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-blibpath:$libdir:'"$aix_libpath"
+
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags `if test "x${allow_undefined_flag}" != "x"; then func_echo_all "${wl}${allow_undefined_flag}"; else :; fi` '"\${wl}$exp_sym_flag:\$export_symbols $shared_flag"
+ else
+ if test "$host_cpu" = ia64; then
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R $libdir:/usr/lib:/lib'
+ _LT_TAGVAR(allow_undefined_flag, $1)="-z nodefs"
+ _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\${wl}$no_entry_flag"' $compiler_flags ${wl}${allow_undefined_flag} '"\${wl}$exp_sym_flag:\$export_symbols"
+ else
+ # Determine the default libpath from the value encoded in an
+ # empty executable.
+ _LT_SYS_MODULE_PATH_AIX([$1])
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-blibpath:$libdir:'"$aix_libpath"
+ # Warning - without using the other run time loading flags,
+ # -berok will link without error, but may produce a broken library.
+ _LT_TAGVAR(no_undefined_flag, $1)=' ${wl}-bernotok'
+ _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-berok'
+ if test "$with_gnu_ld" = yes; then
+ # We only use this code for GNU lds that support --whole-archive.
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive$convenience ${wl}--no-whole-archive'
+ else
+ # Exported symbols can be pulled into shared objects from archives
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='$convenience'
+ fi
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=yes
+ # This is similar to how AIX traditionally builds its shared
+ # libraries.
+ _LT_TAGVAR(archive_expsym_cmds, $1)="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs ${wl}-bnoentry $compiler_flags ${wl}-bE:$export_symbols${allow_undefined_flag}~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$soname'
+ fi
+ fi
+ ;;
+
+ beos*)
+ if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then
+ _LT_TAGVAR(allow_undefined_flag, $1)=unsupported
+ # Joseph Beckenbach <jrb3@best.com> says some releases of gcc
+ # support --undefined. This deserves some investigation. FIXME
+ _LT_TAGVAR(archive_cmds, $1)='$CC -nostart $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+
+ chorus*)
+ case $cc_basename in
+ *)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ esac
+ ;;
+
+ cygwin* | mingw* | pw32* | cegcc*)
+ case $GXX,$cc_basename in
+ ,cl* | no,cl*)
+ # Native MSVC
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=' '
+ _LT_TAGVAR(allow_undefined_flag, $1)=unsupported
+ _LT_TAGVAR(always_export_symbols, $1)=yes
+ _LT_TAGVAR(file_list_spec, $1)='@'
+ # Tell ltmain to make .lib files, not .a files.
+ libext=lib
+ # Tell ltmain to make .dll files, not .so files.
+ shrext_cmds=".dll"
+ # FIXME: Setting linknames here is a bad hack.
+ _LT_TAGVAR(archive_cmds, $1)='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-dll~linknames='
+ _LT_TAGVAR(archive_expsym_cmds, $1)='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ $SED -n -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' -e '1\\\!p' < $export_symbols > $output_objdir/$soname.exp;
+ else
+ $SED -e 's/\\\\\\\(.*\\\\\\\)/-link\\\ -EXPORT:\\\\\\\1/' < $export_symbols > $output_objdir/$soname.exp;
+ fi~
+ $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~
+ linknames='
+ # The linker will not automatically build a static lib if we build a DLL.
+ # _LT_TAGVAR(old_archive_from_new_cmds, $1)='true'
+ _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes
+ # Don't use ranlib
+ _LT_TAGVAR(old_postinstall_cmds, $1)='chmod 644 $oldlib'
+ _LT_TAGVAR(postlink_cmds, $1)='lt_outputfile="@OUTPUT@"~
+ lt_tool_outputfile="@TOOL_OUTPUT@"~
+ case $lt_outputfile in
+ *.exe|*.EXE) ;;
+ *)
+ lt_outputfile="$lt_outputfile.exe"
+ lt_tool_outputfile="$lt_tool_outputfile.exe"
+ ;;
+ esac~
+ func_to_tool_file "$lt_outputfile"~
+ if test "$MANIFEST_TOOL" != ":" && test -f "$lt_outputfile.manifest"; then
+ $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1;
+ $RM "$lt_outputfile.manifest";
+ fi'
+ ;;
+ *)
+ # g++
+ # _LT_TAGVAR(hardcode_libdir_flag_spec, $1) is actually meaningless,
+ # as there is no search path for DLLs.
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-all-symbols'
+ _LT_TAGVAR(allow_undefined_flag, $1)=unsupported
+ _LT_TAGVAR(always_export_symbols, $1)=no
+ _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes
+
+ if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ # If the export-symbols file already is a .def file (1st line
+ # is EXPORTS), use it as is; otherwise, prepend...
+ _LT_TAGVAR(archive_expsym_cmds, $1)='if test "x`$SED 1q $export_symbols`" = xEXPORTS; then
+ cp $export_symbols $output_objdir/$soname.def;
+ else
+ echo EXPORTS > $output_objdir/$soname.def;
+ cat $export_symbols >> $output_objdir/$soname.def;
+ fi~
+ $CC -shared -nostdlib $output_objdir/$soname.def $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $output_objdir/$soname ${wl}--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib'
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+ esac
+ ;;
+ darwin* | rhapsody*)
+ _LT_DARWIN_LINKER_FEATURES($1)
+ ;;
+
+ dgux*)
+ case $cc_basename in
+ ec++*)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ ghcx*)
+ # Green Hills C++ Compiler
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ *)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ esac
+ ;;
+
+ freebsd[[12]]*)
+ # C++ shared libraries reported to be fairly broken before
+ # switch to ELF
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+
+ freebsd-elf*)
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=no
+ ;;
+
+ freebsd* | dragonfly*)
+ # FreeBSD 3 and later use GNU C++ and GNU ld with standard ELF
+ # conventions
+ _LT_TAGVAR(ld_shlibs, $1)=yes
+ ;;
+
+ gnu*)
+ ;;
+
+ haiku*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ ;;
+
+ hpux9*)
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E'
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes # Not in the search PATH,
+ # but as the default
+ # location of the library.
+
+ case $cc_basename in
+ CC*)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ aCC*)
+ _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -b ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ # Commands to make compiler produce verbose output that lists
+ # what "hidden" libraries, object files and flags are used when
+ # linking a shared library.
+ #
+ # There doesn't appear to be a way to prevent this compiler from
+ # explicitly linking system object files so we need to strip them
+ # from the output so that they don't get included in the library
+ # dependencies.
+ output_verbose_link_cmd='templist=`($CC -b $CFLAGS -v conftest.$objext 2>&1) | $EGREP "\-L"`; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"'
+ ;;
+ *)
+ if test "$GXX" = yes; then
+ _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -shared -nostdlib $pic_flag ${wl}+b ${wl}$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test $output_objdir/$soname = $lib || mv $output_objdir/$soname $lib'
+ else
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+ esac
+ ;;
+
+ hpux10*|hpux11*)
+ if test $with_gnu_ld = no; then
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}+b ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+
+ case $host_cpu in
+ hppa*64*|ia64*)
+ ;;
+ *)
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E'
+ ;;
+ esac
+ fi
+ case $host_cpu in
+ hppa*64*|ia64*)
+ _LT_TAGVAR(hardcode_direct, $1)=no
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ ;;
+ *)
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_direct_absolute, $1)=yes
+ _LT_TAGVAR(hardcode_minus_L, $1)=yes # Not in the search PATH,
+ # but as the default
+ # location of the library.
+ ;;
+ esac
+
+ case $cc_basename in
+ CC*)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ aCC*)
+ case $host_cpu in
+ hppa*64*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags'
+ ;;
+ ia64*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags'
+ ;;
+ *)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -b ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags'
+ ;;
+ esac
+ # Commands to make compiler produce verbose output that lists
+ # what "hidden" libraries, object files and flags are used when
+ # linking a shared library.
+ #
+ # There doesn't appear to be a way to prevent this compiler from
+ # explicitly linking system object files so we need to strip them
+ # from the output so that they don't get included in the library
+ # dependencies.
+ output_verbose_link_cmd='templist=`($CC -b $CFLAGS -v conftest.$objext 2>&1) | $GREP "\-L"`; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"'
+ ;;
+ *)
+ if test "$GXX" = yes; then
+ if test $with_gnu_ld = no; then
+ case $host_cpu in
+ hppa*64*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib -fPIC ${wl}+h ${wl}$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags'
+ ;;
+ ia64*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $pic_flag ${wl}+h ${wl}$soname ${wl}+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags'
+ ;;
+ *)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $pic_flag ${wl}+h ${wl}$soname ${wl}+b ${wl}$install_libdir -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags'
+ ;;
+ esac
+ fi
+ else
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+ esac
+ ;;
+
+ interix[[3-9]]*)
+ _LT_TAGVAR(hardcode_direct, $1)=no
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E'
+ # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc.
+ # Instead, shared libraries are loaded at an image base (0x10000000 by
+ # default) and relocated if they conflict, which is a slow very memory
+ # consuming and fragmenting process. To avoid this, we pick a random,
+ # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link
+ # time. Moving up from 0x10000000 also allows more sbrk(2) space.
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='sed "s,^,_," $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags ${wl}-h,$soname ${wl}--retain-symbols-file,$output_objdir/$soname.expsym ${wl}--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib'
+ ;;
+ irix5* | irix6*)
+ case $cc_basename in
+ CC*)
+ # SGI C++
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared -all -multigot $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+
+ # Archives containing C++ object files must be created using
+ # "CC -ar", where "CC" is the IRIX C++ compiler. This is
+ # necessary to make sure instantiated templates are included
+ # in the archive.
+ _LT_TAGVAR(old_archive_cmds, $1)='$CC -ar -WR,-u -o $oldlib $oldobjs'
+ ;;
+ *)
+ if test "$GXX" = yes; then
+ if test "$with_gnu_ld" = no; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ else
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` -o $lib'
+ fi
+ fi
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ ;;
+ esac
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+ _LT_TAGVAR(inherit_rpath, $1)=yes
+ ;;
+
+ linux* | k*bsd*-gnu | kopensolaris*-gnu)
+ case $cc_basename in
+ KCC*)
+ # Kuck and Associates, Inc. (KAI) C++ Compiler
+
+ # KCC will only create a shared library if the output file
+ # ends with ".so" (or ".sl" for HP-UX), so rename the library
+ # to its proper name (with version) after linking.
+ _LT_TAGVAR(archive_cmds, $1)='tempext=`echo $shared_ext | $SED -e '\''s/\([[^()0-9A-Za-z{}]]\)/\\\\\1/g'\''`; templib=`echo $lib | $SED -e "s/\${tempext}\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib; mv \$templib $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='tempext=`echo $shared_ext | $SED -e '\''s/\([[^()0-9A-Za-z{}]]\)/\\\\\1/g'\''`; templib=`echo $lib | $SED -e "s/\${tempext}\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib ${wl}-retain-symbols-file,$export_symbols; mv \$templib $lib'
+ # Commands to make compiler produce verbose output that lists
+ # what "hidden" libraries, object files and flags are used when
+ # linking a shared library.
+ #
+ # There doesn't appear to be a way to prevent this compiler from
+ # explicitly linking system object files so we need to strip them
+ # from the output so that they don't get included in the library
+ # dependencies.
+ output_verbose_link_cmd='templist=`$CC $CFLAGS -v conftest.$objext -o libconftest$shared_ext 2>&1 | $GREP "ld"`; rm -f libconftest$shared_ext; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"'
+
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic'
+
+ # Archives containing C++ object files must be created using
+ # "CC -Bstatic", where "CC" is the KAI C++ compiler.
+ _LT_TAGVAR(old_archive_cmds, $1)='$CC -Bstatic -o $oldlib $oldobjs'
+ ;;
+ icpc* | ecpc* )
+ # Intel C++
+ with_gnu_ld=yes
+ # version 8.0 and above of icpc choke on multiply defined symbols
+ # if we add $predep_objects and $postdep_objects, however 7.1 and
+ # earlier do not add the objects themselves.
+ case `$CC -V 2>&1` in
+ *"Version 7."*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ ;;
+ *) # Version 8.0 or newer
+ tmp_idyn=
+ case $host_cpu in
+ ia64*) tmp_idyn=' -i_dynamic';;
+ esac
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-retain-symbols-file $wl$export_symbols -o $lib'
+ ;;
+ esac
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=no
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic'
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive$convenience ${wl}--no-whole-archive'
+ ;;
+ pgCC* | pgcpp*)
+ # Portland Group C++ compiler
+ case `$CC -V` in
+ *pgCC\ [[1-5]].* | *pgcpp\ [[1-5]].*)
+ _LT_TAGVAR(prelink_cmds, $1)='tpldir=Template.dir~
+ rm -rf $tpldir~
+ $CC --prelink_objects --instantiation_dir $tpldir $objs $libobjs $compile_deplibs~
+ compile_command="$compile_command `find $tpldir -name \*.o | sort | $NL2SP`"'
+ _LT_TAGVAR(old_archive_cmds, $1)='tpldir=Template.dir~
+ rm -rf $tpldir~
+ $CC --prelink_objects --instantiation_dir $tpldir $oldobjs$old_deplibs~
+ $AR $AR_FLAGS $oldlib$oldobjs$old_deplibs `find $tpldir -name \*.o | sort | $NL2SP`~
+ $RANLIB $oldlib'
+ _LT_TAGVAR(archive_cmds, $1)='tpldir=Template.dir~
+ rm -rf $tpldir~
+ $CC --prelink_objects --instantiation_dir $tpldir $predep_objects $libobjs $deplibs $convenience $postdep_objects~
+ $CC -shared $pic_flag $predep_objects $libobjs $deplibs `find $tpldir -name \*.o | sort | $NL2SP` $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='tpldir=Template.dir~
+ rm -rf $tpldir~
+ $CC --prelink_objects --instantiation_dir $tpldir $predep_objects $libobjs $deplibs $convenience $postdep_objects~
+ $CC -shared $pic_flag $predep_objects $libobjs $deplibs `find $tpldir -name \*.o | sort | $NL2SP` $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname ${wl}-retain-symbols-file ${wl}$export_symbols -o $lib'
+ ;;
+ *) # Version 6 and above use weak symbols
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname ${wl}-retain-symbols-file ${wl}$export_symbols -o $lib'
+ ;;
+ esac
+
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}--rpath ${wl}$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic'
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ ;;
+ cxx*)
+ # Compaq C++
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $wl$soname -o $lib ${wl}-retain-symbols-file $wl$export_symbols'
+
+ runpath_var=LD_RUN_PATH
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-rpath $libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+
+ # Commands to make compiler produce verbose output that lists
+ # what "hidden" libraries, object files and flags are used when
+ # linking a shared library.
+ #
+ # There doesn't appear to be a way to prevent this compiler from
+ # explicitly linking system object files so we need to strip them
+ # from the output so that they don't get included in the library
+ # dependencies.
+ output_verbose_link_cmd='templist=`$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "ld"`; templist=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld .*$\)/\1/"`; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "X$list" | $Xsed'
+ ;;
+ xl* | mpixl* | bgxl*)
+ # IBM XL 8.0 on PPC, with GNU ld
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}--export-dynamic'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -qmkshrobj $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname -o $lib'
+ if test "x$supports_anon_versioning" = xyes; then
+ _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $output_objdir/$libname.ver~
+ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~
+ echo "local: *; };" >> $output_objdir/$libname.ver~
+ $CC -qmkshrobj $libobjs $deplibs $compiler_flags ${wl}-soname $wl$soname ${wl}-version-script ${wl}$output_objdir/$libname.ver -o $lib'
+ fi
+ ;;
+ *)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*)
+ # Sun C++ 5.9
+ _LT_TAGVAR(no_undefined_flag, $1)=' -zdefs'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -G${allow_undefined_flag} -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G${allow_undefined_flag} -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-retain-symbols-file ${wl}$export_symbols'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir'
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` ${wl}--no-whole-archive'
+ _LT_TAGVAR(compiler_needs_object, $1)=yes
+
+ # Not sure whether something based on
+ # $CC $CFLAGS -v conftest.$objext -o libconftest$shared_ext 2>&1
+ # would be better.
+ output_verbose_link_cmd='func_echo_all'
+
+ # Archives containing C++ object files must be created using
+ # "CC -xar", where "CC" is the Sun C++ compiler. This is
+ # necessary to make sure instantiated templates are included
+ # in the archive.
+ _LT_TAGVAR(old_archive_cmds, $1)='$CC -xar -o $oldlib $oldobjs'
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+
+ lynxos*)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+
+ m88k*)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+
+ mvs*)
+ case $cc_basename in
+ cxx*)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ *)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ esac
+ ;;
+
+ netbsd*)
+ if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then
+ _LT_TAGVAR(archive_cmds, $1)='$LD -Bshareable -o $lib $predep_objects $libobjs $deplibs $postdep_objects $linker_flags'
+ wlarc=
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir'
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ fi
+ # Workaround some broken pre-1.5 toolchains
+ output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP conftest.$objext | $SED -e "s:-lgcc -lc -lgcc::"'
+ ;;
+
+ *nto* | *qnx*)
+ _LT_TAGVAR(ld_shlibs, $1)=yes
+ ;;
+
+ openbsd2*)
+ # C++ shared libraries are fairly broken
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+
+ openbsd*)
+ if test -f /usr/libexec/ld.so; then
+ _LT_TAGVAR(hardcode_direct, $1)=yes
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ _LT_TAGVAR(hardcode_direct_absolute, $1)=yes
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $lib'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir'
+ if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-retain-symbols-file,$export_symbols -o $lib'
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-E'
+ _LT_TAGVAR(whole_archive_flag_spec, $1)="$wlarc"'--whole-archive$convenience '"$wlarc"'--no-whole-archive'
+ fi
+ output_verbose_link_cmd=func_echo_all
+ else
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+
+ osf3* | osf4* | osf5*)
+ case $cc_basename in
+ KCC*)
+ # Kuck and Associates, Inc. (KAI) C++ Compiler
+
+ # KCC will only create a shared library if the output file
+ # ends with ".so" (or ".sl" for HP-UX), so rename the library
+ # to its proper name (with version) after linking.
+ _LT_TAGVAR(archive_cmds, $1)='tempext=`echo $shared_ext | $SED -e '\''s/\([[^()0-9A-Za-z{}]]\)/\\\\\1/g'\''`; templib=`echo "$lib" | $SED -e "s/\${tempext}\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib; mv \$templib $lib'
+
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath,$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+
+ # Archives containing C++ object files must be created using
+ # the KAI C++ compiler.
+ case $host in
+ osf3*) _LT_TAGVAR(old_archive_cmds, $1)='$CC -Bstatic -o $oldlib $oldobjs' ;;
+ *) _LT_TAGVAR(old_archive_cmds, $1)='$CC -o $oldlib $oldobjs' ;;
+ esac
+ ;;
+ RCC*)
+ # Rational C++ 2.4.1
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ cxx*)
+ case $host in
+ osf3*)
+ _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-expect_unresolved ${wl}\*'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname $soname `test -n "$verstring" && func_echo_all "${wl}-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ ;;
+ *)
+ _LT_TAGVAR(allow_undefined_flag, $1)=' -expect_unresolved \*'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared${allow_undefined_flag} $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done~
+ echo "-hidden">> $lib.exp~
+ $CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -msym -soname $soname ${wl}-input ${wl}$lib.exp `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry ${output_objdir}/so_locations -o $lib~
+ $RM $lib.exp'
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-rpath $libdir'
+ ;;
+ esac
+
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+
+ # Commands to make compiler produce verbose output that lists
+ # what "hidden" libraries, object files and flags are used when
+ # linking a shared library.
+ #
+ # There doesn't appear to be a way to prevent this compiler from
+ # explicitly linking system object files so we need to strip them
+ # from the output so that they don't get included in the library
+ # dependencies.
+ output_verbose_link_cmd='templist=`$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "ld" | $GREP -v "ld:"`; templist=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld.*$\)/\1/"`; list=""; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"'
+ ;;
+ *)
+ if test "$GXX" = yes && test "$with_gnu_ld" = no; then
+ _LT_TAGVAR(allow_undefined_flag, $1)=' ${wl}-expect_unresolved ${wl}\*'
+ case $host in
+ osf3*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib ${allow_undefined_flag} $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ ;;
+ *)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib ${allow_undefined_flag} $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-msym ${wl}-soname ${wl}$soname `test -n "$verstring" && func_echo_all "${wl}-set_version ${wl}$verstring"` ${wl}-update_registry ${wl}${output_objdir}/so_locations -o $lib'
+ ;;
+ esac
+
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-rpath ${wl}$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=:
+
+ # Commands to make compiler produce verbose output that lists
+ # what "hidden" libraries, object files and flags are used when
+ # linking a shared library.
+ output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP "\-L"'
+
+ else
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ fi
+ ;;
+ esac
+ ;;
+
+ psos*)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+
+ sunos4*)
+ case $cc_basename in
+ CC*)
+ # Sun C++ 4.x
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ lcc*)
+ # Lucid
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ *)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ esac
+ ;;
+
+ solaris*)
+ case $cc_basename in
+ CC* | sunCC*)
+ # Sun C++ 4.2, 5.x and Centerline C++
+ _LT_TAGVAR(archive_cmds_need_lc,$1)=yes
+ _LT_TAGVAR(no_undefined_flag, $1)=' -zdefs'
+ _LT_TAGVAR(archive_cmds, $1)='$CC -G${allow_undefined_flag} -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -G${allow_undefined_flag} ${wl}-M ${wl}$lib.exp -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp'
+
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-R$libdir'
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ case $host_os in
+ solaris2.[[0-5]] | solaris2.[[0-5]].*) ;;
+ *)
+ # The compiler driver will combine and reorder linker options,
+ # but understands `-z linker_flag'.
+ # Supported since Solaris 2.6 (maybe 2.5.1?)
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='-z allextract$convenience -z defaultextract'
+ ;;
+ esac
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+
+ output_verbose_link_cmd='func_echo_all'
+
+ # Archives containing C++ object files must be created using
+ # "CC -xar", where "CC" is the Sun C++ compiler. This is
+ # necessary to make sure instantiated templates are included
+ # in the archive.
+ _LT_TAGVAR(old_archive_cmds, $1)='$CC -xar -o $oldlib $oldobjs'
+ ;;
+ gcx*)
+ # Green Hills C++ Compiler
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-h $wl$soname -o $lib'
+
+ # The C++ compiler must be used to create the archive.
+ _LT_TAGVAR(old_archive_cmds, $1)='$CC $LDFLAGS -archive -o $oldlib $oldobjs'
+ ;;
+ *)
+ # GNU C++ compiler with Solaris linker
+ if test "$GXX" = yes && test "$with_gnu_ld" = no; then
+ _LT_TAGVAR(no_undefined_flag, $1)=' ${wl}-z ${wl}defs'
+ if $CC --version | $GREP -v '^2\.7' > /dev/null; then
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $LDFLAGS $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-h $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -shared $pic_flag -nostdlib ${wl}-M $wl$lib.exp -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp'
+
+ # Commands to make compiler produce verbose output that lists
+ # what "hidden" libraries, object files and flags are used when
+ # linking a shared library.
+ output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP "\-L"'
+ else
+ # g++ 2.7 appears to require `-G' NOT `-shared' on this
+ # platform.
+ _LT_TAGVAR(archive_cmds, $1)='$CC -G -nostdlib $LDFLAGS $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags ${wl}-h $wl$soname -o $lib'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~
+ $CC -G -nostdlib ${wl}-M $wl$lib.exp -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp'
+
+ # Commands to make compiler produce verbose output that lists
+ # what "hidden" libraries, object files and flags are used when
+ # linking a shared library.
+ output_verbose_link_cmd='$CC -G $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP "\-L"'
+ fi
+
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R $wl$libdir'
+ case $host_os in
+ solaris2.[[0-5]] | solaris2.[[0-5]].*) ;;
+ *)
+ _LT_TAGVAR(whole_archive_flag_spec, $1)='${wl}-z ${wl}allextract$convenience ${wl}-z ${wl}defaultextract'
+ ;;
+ esac
+ fi
+ ;;
+ esac
+ ;;
+
+ sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[[01]].[[10]]* | unixware7* | sco3.2v5.0.[[024]]*)
+ _LT_TAGVAR(no_undefined_flag, $1)='${wl}-z,text'
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=no
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ runpath_var='LD_RUN_PATH'
+
+ case $cc_basename in
+ CC*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ *)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ esac
+ ;;
+
+ sysv5* | sco3.2v5* | sco5v6*)
+ # Note: We can NOT use -z defs as we might desire, because we do not
+ # link with -lc, and that would cause any symbols used from libc to
+ # always be unresolved, which means just about no library would
+ # ever link correctly. If we're not using GNU ld we use -z text
+ # though, which does catch some bad symbols but isn't as heavy-handed
+ # as -z defs.
+ _LT_TAGVAR(no_undefined_flag, $1)='${wl}-z,text'
+ _LT_TAGVAR(allow_undefined_flag, $1)='${wl}-z,nodefs'
+ _LT_TAGVAR(archive_cmds_need_lc, $1)=no
+ _LT_TAGVAR(hardcode_shlibpath_var, $1)=no
+ _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='${wl}-R,$libdir'
+ _LT_TAGVAR(hardcode_libdir_separator, $1)=':'
+ _LT_TAGVAR(link_all_deplibs, $1)=yes
+ _LT_TAGVAR(export_dynamic_flag_spec, $1)='${wl}-Bexport'
+ runpath_var='LD_RUN_PATH'
+
+ case $cc_basename in
+ CC*)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -G ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -G ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(old_archive_cmds, $1)='$CC -Tprelink_objects $oldobjs~
+ '"$_LT_TAGVAR(old_archive_cmds, $1)"
+ _LT_TAGVAR(reload_cmds, $1)='$CC -Tprelink_objects $reload_objs~
+ '"$_LT_TAGVAR(reload_cmds, $1)"
+ ;;
+ *)
+ _LT_TAGVAR(archive_cmds, $1)='$CC -shared ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared ${wl}-Bexport:$export_symbols ${wl}-h,$soname -o $lib $libobjs $deplibs $compiler_flags'
+ ;;
+ esac
+ ;;
+
+ tandem*)
+ case $cc_basename in
+ NCC*)
+ # NonStop-UX NCC 3.20
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ *)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ esac
+ ;;
+
+ vxworks*)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+
+ *)
+ # FIXME: insert proper C++ library support
+ _LT_TAGVAR(ld_shlibs, $1)=no
+ ;;
+ esac
+
+ AC_MSG_RESULT([$_LT_TAGVAR(ld_shlibs, $1)])
+ test "$_LT_TAGVAR(ld_shlibs, $1)" = no && can_build_shared=no
+
+ _LT_TAGVAR(GCC, $1)="$GXX"
+ _LT_TAGVAR(LD, $1)="$LD"
+
+ ## CAVEAT EMPTOR:
+ ## There is no encapsulation within the following macros, do not change
+ ## the running order or otherwise move them around unless you know exactly
+ ## what you are doing...
+ _LT_SYS_HIDDEN_LIBDEPS($1)
+ _LT_COMPILER_PIC($1)
+ _LT_COMPILER_C_O($1)
+ _LT_COMPILER_FILE_LOCKS($1)
+ _LT_LINKER_SHLIBS($1)
+ _LT_SYS_DYNAMIC_LINKER($1)
+ _LT_LINKER_HARDCODE_LIBPATH($1)
+
+ _LT_CONFIG($1)
+ fi # test -n "$compiler"
+
+ CC=$lt_save_CC
+ CFLAGS=$lt_save_CFLAGS
+ LDCXX=$LD
+ LD=$lt_save_LD
+ GCC=$lt_save_GCC
+ with_gnu_ld=$lt_save_with_gnu_ld
+ lt_cv_path_LDCXX=$lt_cv_path_LD
+ lt_cv_path_LD=$lt_save_path_LD
+ lt_cv_prog_gnu_ldcxx=$lt_cv_prog_gnu_ld
+ lt_cv_prog_gnu_ld=$lt_save_with_gnu_ld
+fi # test "$_lt_caught_CXX_error" != yes
+
+AC_LANG_POP
+])# _LT_LANG_CXX_CONFIG
+
+
+# _LT_FUNC_STRIPNAME_CNF
+# ----------------------
+# func_stripname_cnf prefix suffix name
+# strip PREFIX and SUFFIX off of NAME.
+# PREFIX and SUFFIX must not contain globbing or regex special
+# characters, hashes, percent signs, but SUFFIX may contain a leading
+# dot (in which case that matches only a dot).
+#
+# This function is identical to the (non-XSI) version of func_stripname,
+# except this one can be used by m4 code that may be executed by configure,
+# rather than the libtool script.
+m4_defun([_LT_FUNC_STRIPNAME_CNF],[dnl
+AC_REQUIRE([_LT_DECL_SED])
+AC_REQUIRE([_LT_PROG_ECHO_BACKSLASH])
+func_stripname_cnf ()
+{
+ case ${2} in
+ .*) func_stripname_result=`$ECHO "${3}" | $SED "s%^${1}%%; s%\\\\${2}\$%%"`;;
+ *) func_stripname_result=`$ECHO "${3}" | $SED "s%^${1}%%; s%${2}\$%%"`;;
+ esac
+} # func_stripname_cnf
+])# _LT_FUNC_STRIPNAME_CNF
+
+# _LT_SYS_HIDDEN_LIBDEPS([TAGNAME])
+# ---------------------------------
+# Figure out "hidden" library dependencies from verbose
+# compiler output when linking a shared library.
+# Parse the compiler output and extract the necessary
+# objects, libraries and library flags.
+m4_defun([_LT_SYS_HIDDEN_LIBDEPS],
+[m4_require([_LT_FILEUTILS_DEFAULTS])dnl
+AC_REQUIRE([_LT_FUNC_STRIPNAME_CNF])dnl
+# Dependencies to place before and after the object being linked:
+_LT_TAGVAR(predep_objects, $1)=
+_LT_TAGVAR(postdep_objects, $1)=
+_LT_TAGVAR(predeps, $1)=
+_LT_TAGVAR(postdeps, $1)=
+_LT_TAGVAR(compiler_lib_search_path, $1)=
+
+dnl we can't use the lt_simple_compile_test_code here,
+dnl because it contains code intended for an executable,
+dnl not a library. It's possible we should let each
+dnl tag define a new lt_????_link_test_code variable,
+dnl but it's only used here...
+m4_if([$1], [], [cat > conftest.$ac_ext <<_LT_EOF
+int a;
+void foo (void) { a = 0; }
+_LT_EOF
+], [$1], [CXX], [cat > conftest.$ac_ext <<_LT_EOF
+class Foo
+{
+public:
+ Foo (void) { a = 0; }
+private:
+ int a;
+};
+_LT_EOF
+], [$1], [F77], [cat > conftest.$ac_ext <<_LT_EOF
+ subroutine foo
+ implicit none
+ integer*4 a
+ a=0
+ return
+ end
+_LT_EOF
+], [$1], [FC], [cat > conftest.$ac_ext <<_LT_EOF
+ subroutine foo
+ implicit none
+ integer a
+ a=0
+ return
+ end
+_LT_EOF
+], [$1], [GCJ], [cat > conftest.$ac_ext <<_LT_EOF
+public class foo {
+ private int a;
+ public void bar (void) {
+ a = 0;
+ }
+};
+_LT_EOF
+])
+
+_lt_libdeps_save_CFLAGS=$CFLAGS
+case "$CC $CFLAGS " in #(
+*\ -flto*\ *) CFLAGS="$CFLAGS -fno-lto" ;;
+*\ -fwhopr*\ *) CFLAGS="$CFLAGS -fno-whopr" ;;
+esac
+
+dnl Parse the compiler output and extract the necessary
+dnl objects, libraries and library flags.
+if AC_TRY_EVAL(ac_compile); then
+ # Parse the compiler output and extract the necessary
+ # objects, libraries and library flags.
+
+ # Sentinel used to keep track of whether or not we are before
+ # the conftest object file.
+ pre_test_object_deps_done=no
+
+ for p in `eval "$output_verbose_link_cmd"`; do
+ case ${prev}${p} in
+
+ -L* | -R* | -l*)
+ # Some compilers place space between "-{L,R}" and the path.
+ # Remove the space.
+ if test $p = "-L" ||
+ test $p = "-R"; then
+ prev=$p
+ continue
+ fi
+
+ # Expand the sysroot to ease extracting the directories later.
+ if test -z "$prev"; then
+ case $p in
+ -L*) func_stripname_cnf '-L' '' "$p"; prev=-L; p=$func_stripname_result ;;
+ -R*) func_stripname_cnf '-R' '' "$p"; prev=-R; p=$func_stripname_result ;;
+ -l*) func_stripname_cnf '-l' '' "$p"; prev=-l; p=$func_stripname_result ;;
+ esac
+ fi
+ case $p in
+ =*) func_stripname_cnf '=' '' "$p"; p=$lt_sysroot$func_stripname_result ;;
+ esac
+ if test "$pre_test_object_deps_done" = no; then
+ case ${prev} in
+ -L | -R)
+ # Internal compiler library paths should come after those
+ # provided the user. The postdeps already come after the
+ # user supplied libs so there is no need to process them.
+ if test -z "$_LT_TAGVAR(compiler_lib_search_path, $1)"; then
+ _LT_TAGVAR(compiler_lib_search_path, $1)="${prev}${p}"
+ else
+ _LT_TAGVAR(compiler_lib_search_path, $1)="${_LT_TAGVAR(compiler_lib_search_path, $1)} ${prev}${p}"
+ fi
+ ;;
+ # The "-l" case would never come before the object being
+ # linked, so don't bother handling this case.
+ esac
+ else
+ if test -z "$_LT_TAGVAR(postdeps, $1)"; then
+ _LT_TAGVAR(postdeps, $1)="${prev}${p}"
+ else
+ _LT_TAGVAR(postdeps, $1)="${_LT_TAGVAR(postdeps, $1)} ${prev}${p}"
+ fi
+ fi
+ prev=
+ ;;
+
+ *.lto.$objext) ;; # Ignore GCC LTO objects
+ *.$objext)
+ # This assumes that the test object file only shows up
+ # once in the compiler output.
+ if test "$p" = "conftest.$objext"; then
+ pre_test_object_deps_done=yes
+ continue
+ fi
+
+ if test "$pre_test_object_deps_done" = no; then
+ if test -z "$_LT_TAGVAR(predep_objects, $1)"; then
+ _LT_TAGVAR(predep_objects, $1)="$p"
+ else
+ _LT_TAGVAR(predep_objects, $1)="$_LT_TAGVAR(predep_objects, $1) $p"
+ fi
+ else
+ if test -z "$_LT_TAGVAR(postdep_objects, $1)"; then
+ _LT_TAGVAR(postdep_objects, $1)="$p"
+ else
+ _LT_TAGVAR(postdep_objects, $1)="$_LT_TAGVAR(postdep_objects, $1) $p"
+ fi
+ fi
+ ;;
+
+ *) ;; # Ignore the rest.
+
+ esac
+ done
+
+ # Clean up.
+ rm -f a.out a.exe
+else
+ echo "libtool.m4: error: problem compiling $1 test program"
+fi
+
+$RM -f confest.$objext
+CFLAGS=$_lt_libdeps_save_CFLAGS
+
+# PORTME: override above test on systems where it is broken
+m4_if([$1], [CXX],
+[case $host_os in
+interix[[3-9]]*)
+ # Interix 3.5 installs completely hosed .la files for C++, so rather than
+ # hack all around it, let's just trust "g++" to DTRT.
+ _LT_TAGVAR(predep_objects,$1)=
+ _LT_TAGVAR(postdep_objects,$1)=
+ _LT_TAGVAR(postdeps,$1)=
+ ;;
+
+linux*)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*)
+ # Sun C++ 5.9
+
+ # The more standards-conforming stlport4 library is
+ # incompatible with the Cstd library. Avoid specifying
+ # it if it's in CXXFLAGS. Ignore libCrun as
+ # -library=stlport4 depends on it.
+ case " $CXX $CXXFLAGS " in
+ *" -library=stlport4 "*)
+ solaris_use_stlport4=yes
+ ;;
+ esac
+
+ if test "$solaris_use_stlport4" != yes; then
+ _LT_TAGVAR(postdeps,$1)='-library=Cstd -library=Crun'
+ fi
+ ;;
+ esac
+ ;;
+
+solaris*)
+ case $cc_basename in
+ CC* | sunCC*)
+ # The more standards-conforming stlport4 library is
+ # incompatible with the Cstd library. Avoid specifying
+ # it if it's in CXXFLAGS. Ignore libCrun as
+ # -library=stlport4 depends on it.
+ case " $CXX $CXXFLAGS " in
+ *" -library=stlport4 "*)
+ solaris_use_stlport4=yes
+ ;;
+ esac
+
+ # Adding this requires a known-good setup of shared libraries for
+ # Sun compiler versions before 5.6, else PIC objects from an old
+ # archive will be linked into the output, leading to subtle bugs.
+ if test "$solaris_use_stlport4" != yes; then
+ _LT_TAGVAR(postdeps,$1)='-library=Cstd -library=Crun'
+ fi
+ ;;
+ esac
+ ;;
+esac
+])
+
+case " $_LT_TAGVAR(postdeps, $1) " in
+*" -lc "*) _LT_TAGVAR(archive_cmds_need_lc, $1)=no ;;
+esac
+ _LT_TAGVAR(compiler_lib_search_dirs, $1)=
+if test -n "${_LT_TAGVAR(compiler_lib_search_path, $1)}"; then
+ _LT_TAGVAR(compiler_lib_search_dirs, $1)=`echo " ${_LT_TAGVAR(compiler_lib_search_path, $1)}" | ${SED} -e 's! -L! !g' -e 's!^ !!'`
+fi
+_LT_TAGDECL([], [compiler_lib_search_dirs], [1],
+ [The directories searched by this compiler when creating a shared library])
+_LT_TAGDECL([], [predep_objects], [1],
+ [Dependencies to place before and after the objects being linked to
+ create a shared library])
+_LT_TAGDECL([], [postdep_objects], [1])
+_LT_TAGDECL([], [predeps], [1])
+_LT_TAGDECL([], [postdeps], [1])
+_LT_TAGDECL([], [compiler_lib_search_path], [1],
+ [The library search path used internally by the compiler when linking
+ a shared library])
+])# _LT_SYS_HIDDEN_LIBDEPS
+
+
+# _LT_LANG_F77_CONFIG([TAG])
+# --------------------------
+# Ensure that the configuration variables for a Fortran 77 compiler are
+# suitably defined. These variables are subsequently used by _LT_CONFIG
+# to write the compiler configuration to `libtool'.
+m4_defun([_LT_LANG_F77_CONFIG],
+[AC_LANG_PUSH(Fortran 77)
+if test -z "$F77" || test "X$F77" = "Xno"; then
+ _lt_disable_F77=yes
+fi
+
+_LT_TAGVAR(archive_cmds_need_lc, $1)=no
+_LT_TAGVAR(allow_undefined_flag, $1)=
+_LT_TAGVAR(always_export_symbols, $1)=no
+_LT_TAGVAR(archive_expsym_cmds, $1)=
+_LT_TAGVAR(export_dynamic_flag_spec, $1)=
+_LT_TAGVAR(hardcode_direct, $1)=no
+_LT_TAGVAR(hardcode_direct_absolute, $1)=no
+_LT_TAGVAR(hardcode_libdir_flag_spec, $1)=
+_LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)=
+_LT_TAGVAR(hardcode_libdir_separator, $1)=
+_LT_TAGVAR(hardcode_minus_L, $1)=no
+_LT_TAGVAR(hardcode_automatic, $1)=no
+_LT_TAGVAR(inherit_rpath, $1)=no
+_LT_TAGVAR(module_cmds, $1)=
+_LT_TAGVAR(module_expsym_cmds, $1)=
+_LT_TAGVAR(link_all_deplibs, $1)=unknown
+_LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds
+_LT_TAGVAR(reload_flag, $1)=$reload_flag
+_LT_TAGVAR(reload_cmds, $1)=$reload_cmds
+_LT_TAGVAR(no_undefined_flag, $1)=
+_LT_TAGVAR(whole_archive_flag_spec, $1)=
+_LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no
+
+# Source file extension for f77 test sources.
+ac_ext=f
+
+# Object file extension for compiled f77 test sources.
+objext=o
+_LT_TAGVAR(objext, $1)=$objext
+
+# No sense in running all these tests if we already determined that
+# the F77 compiler isn't working. Some variables (like enable_shared)
+# are currently assumed to apply to all compilers on this platform,
+# and will be corrupted by setting them based on a non-working compiler.
+if test "$_lt_disable_F77" != yes; then
+ # Code to be used in simple compile tests
+ lt_simple_compile_test_code="\
+ subroutine t
+ return
+ end
+"
+
+ # Code to be used in simple link tests
+ lt_simple_link_test_code="\
+ program t
+ end
+"
+
+ # ltmain only uses $CC for tagged configurations so make sure $CC is set.
+ _LT_TAG_COMPILER
+
+ # save warnings/boilerplate of simple test code
+ _LT_COMPILER_BOILERPLATE
+ _LT_LINKER_BOILERPLATE
+
+ # Allow CC to be a program name with arguments.
+ lt_save_CC="$CC"
+ lt_save_GCC=$GCC
+ lt_save_CFLAGS=$CFLAGS
+ CC=${F77-"f77"}
+ CFLAGS=$FFLAGS
+ compiler=$CC
+ _LT_TAGVAR(compiler, $1)=$CC
+ _LT_CC_BASENAME([$compiler])
+ GCC=$G77
+ if test -n "$compiler"; then
+ AC_MSG_CHECKING([if libtool supports shared libraries])
+ AC_MSG_RESULT([$can_build_shared])
+
+ AC_MSG_CHECKING([whether to build shared libraries])
+ test "$can_build_shared" = "no" && enable_shared=no
+
+ # On AIX, shared libraries and static libraries use the same namespace, and
+ # are all built from PIC.
+ case $host_os in
+ aix3*)
+ test "$enable_shared" = yes && enable_static=no
+ if test -n "$RANLIB"; then
+ archive_cmds="$archive_cmds~\$RANLIB \$lib"
+ postinstall_cmds='$RANLIB $lib'
+ fi
+ ;;
+ aix[[4-9]]*)
+ if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then
+ test "$enable_shared" = yes && enable_static=no
+ fi
+ ;;
+ esac
+ AC_MSG_RESULT([$enable_shared])
+
+ AC_MSG_CHECKING([whether to build static libraries])
+ # Make sure either enable_shared or enable_static is yes.
+ test "$enable_shared" = yes || enable_static=yes
+ AC_MSG_RESULT([$enable_static])
+
+ _LT_TAGVAR(GCC, $1)="$G77"
+ _LT_TAGVAR(LD, $1)="$LD"
+
+ ## CAVEAT EMPTOR:
+ ## There is no encapsulation within the following macros, do not change
+ ## the running order or otherwise move them around unless you know exactly
+ ## what you are doing...
+ _LT_COMPILER_PIC($1)
+ _LT_COMPILER_C_O($1)
+ _LT_COMPILER_FILE_LOCKS($1)
+ _LT_LINKER_SHLIBS($1)
+ _LT_SYS_DYNAMIC_LINKER($1)
+ _LT_LINKER_HARDCODE_LIBPATH($1)
+
+ _LT_CONFIG($1)
+ fi # test -n "$compiler"
+
+ GCC=$lt_save_GCC
+ CC="$lt_save_CC"
+ CFLAGS="$lt_save_CFLAGS"
+fi # test "$_lt_disable_F77" != yes
+
+AC_LANG_POP
+])# _LT_LANG_F77_CONFIG
+
+
+# _LT_LANG_FC_CONFIG([TAG])
+# -------------------------
+# Ensure that the configuration variables for a Fortran compiler are
+# suitably defined. These variables are subsequently used by _LT_CONFIG
+# to write the compiler configuration to `libtool'.
+m4_defun([_LT_LANG_FC_CONFIG],
+[AC_LANG_PUSH(Fortran)
+
+if test -z "$FC" || test "X$FC" = "Xno"; then
+ _lt_disable_FC=yes
+fi
+
+_LT_TAGVAR(archive_cmds_need_lc, $1)=no
+_LT_TAGVAR(allow_undefined_flag, $1)=
+_LT_TAGVAR(always_export_symbols, $1)=no
+_LT_TAGVAR(archive_expsym_cmds, $1)=
+_LT_TAGVAR(export_dynamic_flag_spec, $1)=
+_LT_TAGVAR(hardcode_direct, $1)=no
+_LT_TAGVAR(hardcode_direct_absolute, $1)=no
+_LT_TAGVAR(hardcode_libdir_flag_spec, $1)=
+_LT_TAGVAR(hardcode_libdir_flag_spec_ld, $1)=
+_LT_TAGVAR(hardcode_libdir_separator, $1)=
+_LT_TAGVAR(hardcode_minus_L, $1)=no
+_LT_TAGVAR(hardcode_automatic, $1)=no
+_LT_TAGVAR(inherit_rpath, $1)=no
+_LT_TAGVAR(module_cmds, $1)=
+_LT_TAGVAR(module_expsym_cmds, $1)=
+_LT_TAGVAR(link_all_deplibs, $1)=unknown
+_LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds
+_LT_TAGVAR(reload_flag, $1)=$reload_flag
+_LT_TAGVAR(reload_cmds, $1)=$reload_cmds
+_LT_TAGVAR(no_undefined_flag, $1)=
+_LT_TAGVAR(whole_archive_flag_spec, $1)=
+_LT_TAGVAR(enable_shared_with_static_runtimes, $1)=no
+
+# Source file extension for fc test sources.
+ac_ext=${ac_fc_srcext-f}
+
+# Object file extension for compiled fc test sources.
+objext=o
+_LT_TAGVAR(objext, $1)=$objext
+
+# No sense in running all these tests if we already determined that
+# the FC compiler isn't working. Some variables (like enable_shared)
+# are currently assumed to apply to all compilers on this platform,
+# and will be corrupted by setting them based on a non-working compiler.
+if test "$_lt_disable_FC" != yes; then
+ # Code to be used in simple compile tests
+ lt_simple_compile_test_code="\
+ subroutine t
+ return
+ end
+"
+
+ # Code to be used in simple link tests
+ lt_simple_link_test_code="\
+ program t
+ end
+"
+
+ # ltmain only uses $CC for tagged configurations so make sure $CC is set.
+ _LT_TAG_COMPILER
+
+ # save warnings/boilerplate of simple test code
+ _LT_COMPILER_BOILERPLATE
+ _LT_LINKER_BOILERPLATE
+
+ # Allow CC to be a program name with arguments.
+ lt_save_CC="$CC"
+ lt_save_GCC=$GCC
+ lt_save_CFLAGS=$CFLAGS
+ CC=${FC-"f95"}
+ CFLAGS=$FCFLAGS
+ compiler=$CC
+ GCC=$ac_cv_fc_compiler_gnu
+
+ _LT_TAGVAR(compiler, $1)=$CC
+ _LT_CC_BASENAME([$compiler])
+
+ if test -n "$compiler"; then
+ AC_MSG_CHECKING([if libtool supports shared libraries])
+ AC_MSG_RESULT([$can_build_shared])
+
+ AC_MSG_CHECKING([whether to build shared libraries])
+ test "$can_build_shared" = "no" && enable_shared=no
+
+ # On AIX, shared libraries and static libraries use the same namespace, and
+ # are all built from PIC.
+ case $host_os in
+ aix3*)
+ test "$enable_shared" = yes && enable_static=no
+ if test -n "$RANLIB"; then
+ archive_cmds="$archive_cmds~\$RANLIB \$lib"
+ postinstall_cmds='$RANLIB $lib'
+ fi
+ ;;
+ aix[[4-9]]*)
+ if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then
+ test "$enable_shared" = yes && enable_static=no
+ fi
+ ;;
+ esac
+ AC_MSG_RESULT([$enable_shared])
+
+ AC_MSG_CHECKING([whether to build static libraries])
+ # Make sure either enable_shared or enable_static is yes.
+ test "$enable_shared" = yes || enable_static=yes
+ AC_MSG_RESULT([$enable_static])
+
+ _LT_TAGVAR(GCC, $1)="$ac_cv_fc_compiler_gnu"
+ _LT_TAGVAR(LD, $1)="$LD"
+
+ ## CAVEAT EMPTOR:
+ ## There is no encapsulation within the following macros, do not change
+ ## the running order or otherwise move them around unless you know exactly
+ ## what you are doing...
+ _LT_SYS_HIDDEN_LIBDEPS($1)
+ _LT_COMPILER_PIC($1)
+ _LT_COMPILER_C_O($1)
+ _LT_COMPILER_FILE_LOCKS($1)
+ _LT_LINKER_SHLIBS($1)
+ _LT_SYS_DYNAMIC_LINKER($1)
+ _LT_LINKER_HARDCODE_LIBPATH($1)
+
+ _LT_CONFIG($1)
+ fi # test -n "$compiler"
+
+ GCC=$lt_save_GCC
+ CC=$lt_save_CC
+ CFLAGS=$lt_save_CFLAGS
+fi # test "$_lt_disable_FC" != yes
+
+AC_LANG_POP
+])# _LT_LANG_FC_CONFIG
+
+
+# _LT_LANG_GCJ_CONFIG([TAG])
+# --------------------------
+# Ensure that the configuration variables for the GNU Java Compiler compiler
+# are suitably defined. These variables are subsequently used by _LT_CONFIG
+# to write the compiler configuration to `libtool'.
+m4_defun([_LT_LANG_GCJ_CONFIG],
+[AC_REQUIRE([LT_PROG_GCJ])dnl
+AC_LANG_SAVE
+
+# Source file extension for Java test sources.
+ac_ext=java
+
+# Object file extension for compiled Java test sources.
+objext=o
+_LT_TAGVAR(objext, $1)=$objext
+
+# Code to be used in simple compile tests
+lt_simple_compile_test_code="class foo {}"
+
+# Code to be used in simple link tests
+lt_simple_link_test_code='public class conftest { public static void main(String[[]] argv) {}; }'
+
+# ltmain only uses $CC for tagged configurations so make sure $CC is set.
+_LT_TAG_COMPILER
+
+# save warnings/boilerplate of simple test code
+_LT_COMPILER_BOILERPLATE
+_LT_LINKER_BOILERPLATE
+
+# Allow CC to be a program name with arguments.
+lt_save_CC=$CC
+lt_save_CFLAGS=$CFLAGS
+lt_save_GCC=$GCC
+GCC=yes
+CC=${GCJ-"gcj"}
+CFLAGS=$GCJFLAGS
+compiler=$CC
+_LT_TAGVAR(compiler, $1)=$CC
+_LT_TAGVAR(LD, $1)="$LD"
+_LT_CC_BASENAME([$compiler])
+
+# GCJ did not exist at the time GCC didn't implicitly link libc in.
+_LT_TAGVAR(archive_cmds_need_lc, $1)=no
+
+_LT_TAGVAR(old_archive_cmds, $1)=$old_archive_cmds
+_LT_TAGVAR(reload_flag, $1)=$reload_flag
+_LT_TAGVAR(reload_cmds, $1)=$reload_cmds
+
+## CAVEAT EMPTOR:
+## There is no encapsulation within the following macros, do not change
+## the running order or otherwise move them around unless you know exactly
+## what you are doing...
+if test -n "$compiler"; then
+ _LT_COMPILER_NO_RTTI($1)
+ _LT_COMPILER_PIC($1)
+ _LT_COMPILER_C_O($1)
+ _LT_COMPILER_FILE_LOCKS($1)
+ _LT_LINKER_SHLIBS($1)
+ _LT_LINKER_HARDCODE_LIBPATH($1)
+
+ _LT_CONFIG($1)
+fi
+
+AC_LANG_RESTORE
+
+GCC=$lt_save_GCC
+CC=$lt_save_CC
+CFLAGS=$lt_save_CFLAGS
+])# _LT_LANG_GCJ_CONFIG
+
+
+# _LT_LANG_RC_CONFIG([TAG])
+# -------------------------
+# Ensure that the configuration variables for the Windows resource compiler
+# are suitably defined. These variables are subsequently used by _LT_CONFIG
+# to write the compiler configuration to `libtool'.
+m4_defun([_LT_LANG_RC_CONFIG],
+[AC_REQUIRE([LT_PROG_RC])dnl
+AC_LANG_SAVE
+
+# Source file extension for RC test sources.
+ac_ext=rc
+
+# Object file extension for compiled RC test sources.
+objext=o
+_LT_TAGVAR(objext, $1)=$objext
+
+# Code to be used in simple compile tests
+lt_simple_compile_test_code='sample MENU { MENUITEM "&Soup", 100, CHECKED }'
+
+# Code to be used in simple link tests
+lt_simple_link_test_code="$lt_simple_compile_test_code"
+
+# ltmain only uses $CC for tagged configurations so make sure $CC is set.
+_LT_TAG_COMPILER
+
+# save warnings/boilerplate of simple test code
+_LT_COMPILER_BOILERPLATE
+_LT_LINKER_BOILERPLATE
+
+# Allow CC to be a program name with arguments.
+lt_save_CC="$CC"
+lt_save_CFLAGS=$CFLAGS
+lt_save_GCC=$GCC
+GCC=
+CC=${RC-"windres"}
+CFLAGS=
+compiler=$CC
+_LT_TAGVAR(compiler, $1)=$CC
+_LT_CC_BASENAME([$compiler])
+_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)=yes
+
+if test -n "$compiler"; then
+ :
+ _LT_CONFIG($1)
+fi
+
+GCC=$lt_save_GCC
+AC_LANG_RESTORE
+CC=$lt_save_CC
+CFLAGS=$lt_save_CFLAGS
+])# _LT_LANG_RC_CONFIG
+
+
+# LT_PROG_GCJ
+# -----------
+AC_DEFUN([LT_PROG_GCJ],
+[m4_ifdef([AC_PROG_GCJ], [AC_PROG_GCJ],
+ [m4_ifdef([A][M_PROG_GCJ], [A][M_PROG_GCJ],
+ [AC_CHECK_TOOL(GCJ, gcj,)
+ test "x${GCJFLAGS+set}" = xset || GCJFLAGS="-g -O2"
+ AC_SUBST(GCJFLAGS)])])[]dnl
+])
+
+# Old name:
+AU_ALIAS([LT_AC_PROG_GCJ], [LT_PROG_GCJ])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([LT_AC_PROG_GCJ], [])
+
+
+# LT_PROG_RC
+# ----------
+AC_DEFUN([LT_PROG_RC],
+[AC_CHECK_TOOL(RC, windres,)
+])
+
+# Old name:
+AU_ALIAS([LT_AC_PROG_RC], [LT_PROG_RC])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([LT_AC_PROG_RC], [])
+
+
+# _LT_DECL_EGREP
+# --------------
+# If we don't have a new enough Autoconf to choose the best grep
+# available, choose the one first in the user's PATH.
+m4_defun([_LT_DECL_EGREP],
+[AC_REQUIRE([AC_PROG_EGREP])dnl
+AC_REQUIRE([AC_PROG_FGREP])dnl
+test -z "$GREP" && GREP=grep
+_LT_DECL([], [GREP], [1], [A grep program that handles long lines])
+_LT_DECL([], [EGREP], [1], [An ERE matcher])
+_LT_DECL([], [FGREP], [1], [A literal string matcher])
+dnl Non-bleeding-edge autoconf doesn't subst GREP, so do it here too
+AC_SUBST([GREP])
+])
+
+
+# _LT_DECL_OBJDUMP
+# --------------
+# If we don't have a new enough Autoconf to choose the best objdump
+# available, choose the one first in the user's PATH.
+m4_defun([_LT_DECL_OBJDUMP],
+[AC_CHECK_TOOL(OBJDUMP, objdump, false)
+test -z "$OBJDUMP" && OBJDUMP=objdump
+_LT_DECL([], [OBJDUMP], [1], [An object symbol dumper])
+AC_SUBST([OBJDUMP])
+])
+
+# _LT_DECL_DLLTOOL
+# ----------------
+# Ensure DLLTOOL variable is set.
+m4_defun([_LT_DECL_DLLTOOL],
+[AC_CHECK_TOOL(DLLTOOL, dlltool, false)
+test -z "$DLLTOOL" && DLLTOOL=dlltool
+_LT_DECL([], [DLLTOOL], [1], [DLL creation program])
+AC_SUBST([DLLTOOL])
+])
+
+# _LT_DECL_SED
+# ------------
+# Check for a fully-functional sed program, that truncates
+# as few characters as possible. Prefer GNU sed if found.
+m4_defun([_LT_DECL_SED],
+[AC_PROG_SED
+test -z "$SED" && SED=sed
+Xsed="$SED -e 1s/^X//"
+_LT_DECL([], [SED], [1], [A sed program that does not truncate output])
+_LT_DECL([], [Xsed], ["\$SED -e 1s/^X//"],
+ [Sed that helps us avoid accidentally triggering echo(1) options like -n])
+])# _LT_DECL_SED
+
+m4_ifndef([AC_PROG_SED], [
+############################################################
+# NOTE: This macro has been submitted for inclusion into #
+# GNU Autoconf as AC_PROG_SED. When it is available in #
+# a released version of Autoconf we should remove this #
+# macro and use it instead. #
+############################################################
+
+m4_defun([AC_PROG_SED],
+[AC_MSG_CHECKING([for a sed that does not truncate output])
+AC_CACHE_VAL(lt_cv_path_SED,
+[# Loop through the user's path and test for sed and gsed.
+# Then use that list of sed's as ones to test for truncation.
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for lt_ac_prog in sed gsed; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if $as_executable_p "$as_dir/$lt_ac_prog$ac_exec_ext"; then
+ lt_ac_sed_list="$lt_ac_sed_list $as_dir/$lt_ac_prog$ac_exec_ext"
+ fi
+ done
+ done
+done
+IFS=$as_save_IFS
+lt_ac_max=0
+lt_ac_count=0
+# Add /usr/xpg4/bin/sed as it is typically found on Solaris
+# along with /bin/sed that truncates output.
+for lt_ac_sed in $lt_ac_sed_list /usr/xpg4/bin/sed; do
+ test ! -f $lt_ac_sed && continue
+ cat /dev/null > conftest.in
+ lt_ac_count=0
+ echo $ECHO_N "0123456789$ECHO_C" >conftest.in
+ # Check for GNU sed and select it if it is found.
+ if "$lt_ac_sed" --version 2>&1 < /dev/null | grep 'GNU' > /dev/null; then
+ lt_cv_path_SED=$lt_ac_sed
+ break
+ fi
+ while true; do
+ cat conftest.in conftest.in >conftest.tmp
+ mv conftest.tmp conftest.in
+ cp conftest.in conftest.nl
+ echo >>conftest.nl
+ $lt_ac_sed -e 's/a$//' < conftest.nl >conftest.out || break
+ cmp -s conftest.out conftest.nl || break
+ # 10000 chars as input seems more than enough
+ test $lt_ac_count -gt 10 && break
+ lt_ac_count=`expr $lt_ac_count + 1`
+ if test $lt_ac_count -gt $lt_ac_max; then
+ lt_ac_max=$lt_ac_count
+ lt_cv_path_SED=$lt_ac_sed
+ fi
+ done
+done
+])
+SED=$lt_cv_path_SED
+AC_SUBST([SED])
+AC_MSG_RESULT([$SED])
+])#AC_PROG_SED
+])#m4_ifndef
+
+# Old name:
+AU_ALIAS([LT_AC_PROG_SED], [AC_PROG_SED])
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([LT_AC_PROG_SED], [])
+
+
+# _LT_CHECK_SHELL_FEATURES
+# ------------------------
+# Find out whether the shell is Bourne or XSI compatible,
+# or has some other useful features.
+m4_defun([_LT_CHECK_SHELL_FEATURES],
+[AC_MSG_CHECKING([whether the shell understands some XSI constructs])
+# Try some XSI features
+xsi_shell=no
+( _lt_dummy="a/b/c"
+ test "${_lt_dummy##*/},${_lt_dummy%/*},${_lt_dummy#??}"${_lt_dummy%"$_lt_dummy"}, \
+ = c,a/b,b/c, \
+ && eval 'test $(( 1 + 1 )) -eq 2 \
+ && test "${#_lt_dummy}" -eq 5' ) >/dev/null 2>&1 \
+ && xsi_shell=yes
+AC_MSG_RESULT([$xsi_shell])
+_LT_CONFIG_LIBTOOL_INIT([xsi_shell='$xsi_shell'])
+
+AC_MSG_CHECKING([whether the shell understands "+="])
+lt_shell_append=no
+( foo=bar; set foo baz; eval "$[1]+=\$[2]" && test "$foo" = barbaz ) \
+ >/dev/null 2>&1 \
+ && lt_shell_append=yes
+AC_MSG_RESULT([$lt_shell_append])
+_LT_CONFIG_LIBTOOL_INIT([lt_shell_append='$lt_shell_append'])
+
+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
+ lt_unset=unset
+else
+ lt_unset=false
+fi
+_LT_DECL([], [lt_unset], [0], [whether the shell understands "unset"])dnl
+
+# test EBCDIC or ASCII
+case `echo X|tr X '\101'` in
+ A) # ASCII based system
+ # \n is not interpreted correctly by Solaris 8 /usr/ucb/tr
+ lt_SP2NL='tr \040 \012'
+ lt_NL2SP='tr \015\012 \040\040'
+ ;;
+ *) # EBCDIC based system
+ lt_SP2NL='tr \100 \n'
+ lt_NL2SP='tr \r\n \100\100'
+ ;;
+esac
+_LT_DECL([SP2NL], [lt_SP2NL], [1], [turn spaces into newlines])dnl
+_LT_DECL([NL2SP], [lt_NL2SP], [1], [turn newlines into spaces])dnl
+])# _LT_CHECK_SHELL_FEATURES
+
+
+# _LT_PROG_FUNCTION_REPLACE (FUNCNAME, REPLACEMENT-BODY)
+# ------------------------------------------------------
+# In `$cfgfile', look for function FUNCNAME delimited by `^FUNCNAME ()$' and
+# '^} FUNCNAME ', and replace its body with REPLACEMENT-BODY.
+m4_defun([_LT_PROG_FUNCTION_REPLACE],
+[dnl {
+sed -e '/^$1 ()$/,/^} # $1 /c\
+$1 ()\
+{\
+m4_bpatsubsts([$2], [$], [\\], [^\([ ]\)], [\\\1])
+} # Extended-shell $1 implementation' "$cfgfile" > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+test 0 -eq $? || _lt_function_replace_fail=:
+])
+
+
+# _LT_PROG_REPLACE_SHELLFNS
+# -------------------------
+# Replace existing portable implementations of several shell functions with
+# equivalent extended shell implementations where those features are available..
+m4_defun([_LT_PROG_REPLACE_SHELLFNS],
+[if test x"$xsi_shell" = xyes; then
+ _LT_PROG_FUNCTION_REPLACE([func_dirname], [dnl
+ case ${1} in
+ */*) func_dirname_result="${1%/*}${2}" ;;
+ * ) func_dirname_result="${3}" ;;
+ esac])
+
+ _LT_PROG_FUNCTION_REPLACE([func_basename], [dnl
+ func_basename_result="${1##*/}"])
+
+ _LT_PROG_FUNCTION_REPLACE([func_dirname_and_basename], [dnl
+ case ${1} in
+ */*) func_dirname_result="${1%/*}${2}" ;;
+ * ) func_dirname_result="${3}" ;;
+ esac
+ func_basename_result="${1##*/}"])
+
+ _LT_PROG_FUNCTION_REPLACE([func_stripname], [dnl
+ # pdksh 5.2.14 does not do ${X%$Y} correctly if both X and Y are
+ # positional parameters, so assign one to ordinary parameter first.
+ func_stripname_result=${3}
+ func_stripname_result=${func_stripname_result#"${1}"}
+ func_stripname_result=${func_stripname_result%"${2}"}])
+
+ _LT_PROG_FUNCTION_REPLACE([func_split_long_opt], [dnl
+ func_split_long_opt_name=${1%%=*}
+ func_split_long_opt_arg=${1#*=}])
+
+ _LT_PROG_FUNCTION_REPLACE([func_split_short_opt], [dnl
+ func_split_short_opt_arg=${1#??}
+ func_split_short_opt_name=${1%"$func_split_short_opt_arg"}])
+
+ _LT_PROG_FUNCTION_REPLACE([func_lo2o], [dnl
+ case ${1} in
+ *.lo) func_lo2o_result=${1%.lo}.${objext} ;;
+ *) func_lo2o_result=${1} ;;
+ esac])
+
+ _LT_PROG_FUNCTION_REPLACE([func_xform], [ func_xform_result=${1%.*}.lo])
+
+ _LT_PROG_FUNCTION_REPLACE([func_arith], [ func_arith_result=$(( $[*] ))])
+
+ _LT_PROG_FUNCTION_REPLACE([func_len], [ func_len_result=${#1}])
+fi
+
+if test x"$lt_shell_append" = xyes; then
+ _LT_PROG_FUNCTION_REPLACE([func_append], [ eval "${1}+=\\${2}"])
+
+ _LT_PROG_FUNCTION_REPLACE([func_append_quoted], [dnl
+ func_quote_for_eval "${2}"
+dnl m4 expansion turns \\\\ into \\, and then the shell eval turns that into \
+ eval "${1}+=\\\\ \\$func_quote_for_eval_result"])
+
+ # Save a `func_append' function call where possible by direct use of '+='
+ sed -e 's%func_append \([[a-zA-Z_]]\{1,\}\) "%\1+="%g' $cfgfile > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+ test 0 -eq $? || _lt_function_replace_fail=:
+else
+ # Save a `func_append' function call even when '+=' is not available
+ sed -e 's%func_append \([[a-zA-Z_]]\{1,\}\) "%\1="$\1%g' $cfgfile > $cfgfile.tmp \
+ && mv -f "$cfgfile.tmp" "$cfgfile" \
+ || (rm -f "$cfgfile" && cp "$cfgfile.tmp" "$cfgfile" && rm -f "$cfgfile.tmp")
+ test 0 -eq $? || _lt_function_replace_fail=:
+fi
+
+if test x"$_lt_function_replace_fail" = x":"; then
+ AC_MSG_WARN([Unable to substitute extended shell functions in $ofile])
+fi
+])
+
+# _LT_PATH_CONVERSION_FUNCTIONS
+# -----------------------------
+# Determine which file name conversion functions should be used by
+# func_to_host_file (and, implicitly, by func_to_host_path). These are needed
+# for certain cross-compile configurations and native mingw.
+m4_defun([_LT_PATH_CONVERSION_FUNCTIONS],
+[AC_REQUIRE([AC_CANONICAL_HOST])dnl
+AC_REQUIRE([AC_CANONICAL_BUILD])dnl
+AC_MSG_CHECKING([how to convert $build file names to $host format])
+AC_CACHE_VAL(lt_cv_to_host_file_cmd,
+[case $host in
+ *-*-mingw* )
+ case $build in
+ *-*-mingw* ) # actually msys
+ lt_cv_to_host_file_cmd=func_convert_file_msys_to_w32
+ ;;
+ *-*-cygwin* )
+ lt_cv_to_host_file_cmd=func_convert_file_cygwin_to_w32
+ ;;
+ * ) # otherwise, assume *nix
+ lt_cv_to_host_file_cmd=func_convert_file_nix_to_w32
+ ;;
+ esac
+ ;;
+ *-*-cygwin* )
+ case $build in
+ *-*-mingw* ) # actually msys
+ lt_cv_to_host_file_cmd=func_convert_file_msys_to_cygwin
+ ;;
+ *-*-cygwin* )
+ lt_cv_to_host_file_cmd=func_convert_file_noop
+ ;;
+ * ) # otherwise, assume *nix
+ lt_cv_to_host_file_cmd=func_convert_file_nix_to_cygwin
+ ;;
+ esac
+ ;;
+ * ) # unhandled hosts (and "normal" native builds)
+ lt_cv_to_host_file_cmd=func_convert_file_noop
+ ;;
+esac
+])
+to_host_file_cmd=$lt_cv_to_host_file_cmd
+AC_MSG_RESULT([$lt_cv_to_host_file_cmd])
+_LT_DECL([to_host_file_cmd], [lt_cv_to_host_file_cmd],
+ [0], [convert $build file names to $host format])dnl
+
+AC_MSG_CHECKING([how to convert $build file names to toolchain format])
+AC_CACHE_VAL(lt_cv_to_tool_file_cmd,
+[#assume ordinary cross tools, or native build.
+lt_cv_to_tool_file_cmd=func_convert_file_noop
+case $host in
+ *-*-mingw* )
+ case $build in
+ *-*-mingw* ) # actually msys
+ lt_cv_to_tool_file_cmd=func_convert_file_msys_to_w32
+ ;;
+ esac
+ ;;
+esac
+])
+to_tool_file_cmd=$lt_cv_to_tool_file_cmd
+AC_MSG_RESULT([$lt_cv_to_tool_file_cmd])
+_LT_DECL([to_tool_file_cmd], [lt_cv_to_tool_file_cmd],
+ [0], [convert $build files to toolchain format])dnl
+])# _LT_PATH_CONVERSION_FUNCTIONS
diff --git a/m4/ltoptions.m4 b/m4/ltoptions.m4
new file mode 100644
index 0000000..17cfd51
--- /dev/null
+++ b/m4/ltoptions.m4
@@ -0,0 +1,369 @@
+# Helper functions for option handling. -*- Autoconf -*-
+#
+# Copyright (C) 2004, 2005, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# Written by Gary V. Vaughan, 2004
+#
+# This file is free software; the Free Software Foundation gives
+# unlimited permission to copy and/or distribute it, with or without
+# modifications, as long as this notice is preserved.
+
+# serial 7 ltoptions.m4
+
+# This is to help aclocal find these macros, as it can't see m4_define.
+AC_DEFUN([LTOPTIONS_VERSION], [m4_if([1])])
+
+
+# _LT_MANGLE_OPTION(MACRO-NAME, OPTION-NAME)
+# ------------------------------------------
+m4_define([_LT_MANGLE_OPTION],
+[[_LT_OPTION_]m4_bpatsubst($1__$2, [[^a-zA-Z0-9_]], [_])])
+
+
+# _LT_SET_OPTION(MACRO-NAME, OPTION-NAME)
+# ---------------------------------------
+# Set option OPTION-NAME for macro MACRO-NAME, and if there is a
+# matching handler defined, dispatch to it. Other OPTION-NAMEs are
+# saved as a flag.
+m4_define([_LT_SET_OPTION],
+[m4_define(_LT_MANGLE_OPTION([$1], [$2]))dnl
+m4_ifdef(_LT_MANGLE_DEFUN([$1], [$2]),
+ _LT_MANGLE_DEFUN([$1], [$2]),
+ [m4_warning([Unknown $1 option `$2'])])[]dnl
+])
+
+
+# _LT_IF_OPTION(MACRO-NAME, OPTION-NAME, IF-SET, [IF-NOT-SET])
+# ------------------------------------------------------------
+# Execute IF-SET if OPTION is set, IF-NOT-SET otherwise.
+m4_define([_LT_IF_OPTION],
+[m4_ifdef(_LT_MANGLE_OPTION([$1], [$2]), [$3], [$4])])
+
+
+# _LT_UNLESS_OPTIONS(MACRO-NAME, OPTION-LIST, IF-NOT-SET)
+# -------------------------------------------------------
+# Execute IF-NOT-SET unless all options in OPTION-LIST for MACRO-NAME
+# are set.
+m4_define([_LT_UNLESS_OPTIONS],
+[m4_foreach([_LT_Option], m4_split(m4_normalize([$2])),
+ [m4_ifdef(_LT_MANGLE_OPTION([$1], _LT_Option),
+ [m4_define([$0_found])])])[]dnl
+m4_ifdef([$0_found], [m4_undefine([$0_found])], [$3
+])[]dnl
+])
+
+
+# _LT_SET_OPTIONS(MACRO-NAME, OPTION-LIST)
+# ----------------------------------------
+# OPTION-LIST is a space-separated list of Libtool options associated
+# with MACRO-NAME. If any OPTION has a matching handler declared with
+# LT_OPTION_DEFINE, dispatch to that macro; otherwise complain about
+# the unknown option and exit.
+m4_defun([_LT_SET_OPTIONS],
+[# Set options
+m4_foreach([_LT_Option], m4_split(m4_normalize([$2])),
+ [_LT_SET_OPTION([$1], _LT_Option)])
+
+m4_if([$1],[LT_INIT],[
+ dnl
+ dnl Simply set some default values (i.e off) if boolean options were not
+ dnl specified:
+ _LT_UNLESS_OPTIONS([LT_INIT], [dlopen], [enable_dlopen=no
+ ])
+ _LT_UNLESS_OPTIONS([LT_INIT], [win32-dll], [enable_win32_dll=no
+ ])
+ dnl
+ dnl If no reference was made to various pairs of opposing options, then
+ dnl we run the default mode handler for the pair. For example, if neither
+ dnl `shared' nor `disable-shared' was passed, we enable building of shared
+ dnl archives by default:
+ _LT_UNLESS_OPTIONS([LT_INIT], [shared disable-shared], [_LT_ENABLE_SHARED])
+ _LT_UNLESS_OPTIONS([LT_INIT], [static disable-static], [_LT_ENABLE_STATIC])
+ _LT_UNLESS_OPTIONS([LT_INIT], [pic-only no-pic], [_LT_WITH_PIC])
+ _LT_UNLESS_OPTIONS([LT_INIT], [fast-install disable-fast-install],
+ [_LT_ENABLE_FAST_INSTALL])
+ ])
+])# _LT_SET_OPTIONS
+
+
+## --------------------------------- ##
+## Macros to handle LT_INIT options. ##
+## --------------------------------- ##
+
+# _LT_MANGLE_DEFUN(MACRO-NAME, OPTION-NAME)
+# -----------------------------------------
+m4_define([_LT_MANGLE_DEFUN],
+[[_LT_OPTION_DEFUN_]m4_bpatsubst(m4_toupper([$1__$2]), [[^A-Z0-9_]], [_])])
+
+
+# LT_OPTION_DEFINE(MACRO-NAME, OPTION-NAME, CODE)
+# -----------------------------------------------
+m4_define([LT_OPTION_DEFINE],
+[m4_define(_LT_MANGLE_DEFUN([$1], [$2]), [$3])[]dnl
+])# LT_OPTION_DEFINE
+
+
+# dlopen
+# ------
+LT_OPTION_DEFINE([LT_INIT], [dlopen], [enable_dlopen=yes
+])
+
+AU_DEFUN([AC_LIBTOOL_DLOPEN],
+[_LT_SET_OPTION([LT_INIT], [dlopen])
+AC_DIAGNOSE([obsolete],
+[$0: Remove this warning and the call to _LT_SET_OPTION when you
+put the `dlopen' option into LT_INIT's first parameter.])
+])
+
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_LIBTOOL_DLOPEN], [])
+
+
+# win32-dll
+# ---------
+# Declare package support for building win32 dll's.
+LT_OPTION_DEFINE([LT_INIT], [win32-dll],
+[enable_win32_dll=yes
+
+case $host in
+*-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-cegcc*)
+ AC_CHECK_TOOL(AS, as, false)
+ AC_CHECK_TOOL(DLLTOOL, dlltool, false)
+ AC_CHECK_TOOL(OBJDUMP, objdump, false)
+ ;;
+esac
+
+test -z "$AS" && AS=as
+_LT_DECL([], [AS], [1], [Assembler program])dnl
+
+test -z "$DLLTOOL" && DLLTOOL=dlltool
+_LT_DECL([], [DLLTOOL], [1], [DLL creation program])dnl
+
+test -z "$OBJDUMP" && OBJDUMP=objdump
+_LT_DECL([], [OBJDUMP], [1], [Object dumper program])dnl
+])# win32-dll
+
+AU_DEFUN([AC_LIBTOOL_WIN32_DLL],
+[AC_REQUIRE([AC_CANONICAL_HOST])dnl
+_LT_SET_OPTION([LT_INIT], [win32-dll])
+AC_DIAGNOSE([obsolete],
+[$0: Remove this warning and the call to _LT_SET_OPTION when you
+put the `win32-dll' option into LT_INIT's first parameter.])
+])
+
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_LIBTOOL_WIN32_DLL], [])
+
+
+# _LT_ENABLE_SHARED([DEFAULT])
+# ----------------------------
+# implement the --enable-shared flag, and supports the `shared' and
+# `disable-shared' LT_INIT options.
+# DEFAULT is either `yes' or `no'. If omitted, it defaults to `yes'.
+m4_define([_LT_ENABLE_SHARED],
+[m4_define([_LT_ENABLE_SHARED_DEFAULT], [m4_if($1, no, no, yes)])dnl
+AC_ARG_ENABLE([shared],
+ [AS_HELP_STRING([--enable-shared@<:@=PKGS@:>@],
+ [build shared libraries @<:@default=]_LT_ENABLE_SHARED_DEFAULT[@:>@])],
+ [p=${PACKAGE-default}
+ case $enableval in
+ yes) enable_shared=yes ;;
+ no) enable_shared=no ;;
+ *)
+ enable_shared=no
+ # Look at the argument we got. We use all the common list separators.
+ lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR,"
+ for pkg in $enableval; do
+ IFS="$lt_save_ifs"
+ if test "X$pkg" = "X$p"; then
+ enable_shared=yes
+ fi
+ done
+ IFS="$lt_save_ifs"
+ ;;
+ esac],
+ [enable_shared=]_LT_ENABLE_SHARED_DEFAULT)
+
+ _LT_DECL([build_libtool_libs], [enable_shared], [0],
+ [Whether or not to build shared libraries])
+])# _LT_ENABLE_SHARED
+
+LT_OPTION_DEFINE([LT_INIT], [shared], [_LT_ENABLE_SHARED([yes])])
+LT_OPTION_DEFINE([LT_INIT], [disable-shared], [_LT_ENABLE_SHARED([no])])
+
+# Old names:
+AC_DEFUN([AC_ENABLE_SHARED],
+[_LT_SET_OPTION([LT_INIT], m4_if([$1], [no], [disable-])[shared])
+])
+
+AC_DEFUN([AC_DISABLE_SHARED],
+[_LT_SET_OPTION([LT_INIT], [disable-shared])
+])
+
+AU_DEFUN([AM_ENABLE_SHARED], [AC_ENABLE_SHARED($@)])
+AU_DEFUN([AM_DISABLE_SHARED], [AC_DISABLE_SHARED($@)])
+
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AM_ENABLE_SHARED], [])
+dnl AC_DEFUN([AM_DISABLE_SHARED], [])
+
+
+
+# _LT_ENABLE_STATIC([DEFAULT])
+# ----------------------------
+# implement the --enable-static flag, and support the `static' and
+# `disable-static' LT_INIT options.
+# DEFAULT is either `yes' or `no'. If omitted, it defaults to `yes'.
+m4_define([_LT_ENABLE_STATIC],
+[m4_define([_LT_ENABLE_STATIC_DEFAULT], [m4_if($1, no, no, yes)])dnl
+AC_ARG_ENABLE([static],
+ [AS_HELP_STRING([--enable-static@<:@=PKGS@:>@],
+ [build static libraries @<:@default=]_LT_ENABLE_STATIC_DEFAULT[@:>@])],
+ [p=${PACKAGE-default}
+ case $enableval in
+ yes) enable_static=yes ;;
+ no) enable_static=no ;;
+ *)
+ enable_static=no
+ # Look at the argument we got. We use all the common list separators.
+ lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR,"
+ for pkg in $enableval; do
+ IFS="$lt_save_ifs"
+ if test "X$pkg" = "X$p"; then
+ enable_static=yes
+ fi
+ done
+ IFS="$lt_save_ifs"
+ ;;
+ esac],
+ [enable_static=]_LT_ENABLE_STATIC_DEFAULT)
+
+ _LT_DECL([build_old_libs], [enable_static], [0],
+ [Whether or not to build static libraries])
+])# _LT_ENABLE_STATIC
+
+LT_OPTION_DEFINE([LT_INIT], [static], [_LT_ENABLE_STATIC([yes])])
+LT_OPTION_DEFINE([LT_INIT], [disable-static], [_LT_ENABLE_STATIC([no])])
+
+# Old names:
+AC_DEFUN([AC_ENABLE_STATIC],
+[_LT_SET_OPTION([LT_INIT], m4_if([$1], [no], [disable-])[static])
+])
+
+AC_DEFUN([AC_DISABLE_STATIC],
+[_LT_SET_OPTION([LT_INIT], [disable-static])
+])
+
+AU_DEFUN([AM_ENABLE_STATIC], [AC_ENABLE_STATIC($@)])
+AU_DEFUN([AM_DISABLE_STATIC], [AC_DISABLE_STATIC($@)])
+
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AM_ENABLE_STATIC], [])
+dnl AC_DEFUN([AM_DISABLE_STATIC], [])
+
+
+
+# _LT_ENABLE_FAST_INSTALL([DEFAULT])
+# ----------------------------------
+# implement the --enable-fast-install flag, and support the `fast-install'
+# and `disable-fast-install' LT_INIT options.
+# DEFAULT is either `yes' or `no'. If omitted, it defaults to `yes'.
+m4_define([_LT_ENABLE_FAST_INSTALL],
+[m4_define([_LT_ENABLE_FAST_INSTALL_DEFAULT], [m4_if($1, no, no, yes)])dnl
+AC_ARG_ENABLE([fast-install],
+ [AS_HELP_STRING([--enable-fast-install@<:@=PKGS@:>@],
+ [optimize for fast installation @<:@default=]_LT_ENABLE_FAST_INSTALL_DEFAULT[@:>@])],
+ [p=${PACKAGE-default}
+ case $enableval in
+ yes) enable_fast_install=yes ;;
+ no) enable_fast_install=no ;;
+ *)
+ enable_fast_install=no
+ # Look at the argument we got. We use all the common list separators.
+ lt_save_ifs="$IFS"; IFS="${IFS}$PATH_SEPARATOR,"
+ for pkg in $enableval; do
+ IFS="$lt_save_ifs"
+ if test "X$pkg" = "X$p"; then
+ enable_fast_install=yes
+ fi
+ done
+ IFS="$lt_save_ifs"
+ ;;
+ esac],
+ [enable_fast_install=]_LT_ENABLE_FAST_INSTALL_DEFAULT)
+
+_LT_DECL([fast_install], [enable_fast_install], [0],
+ [Whether or not to optimize for fast installation])dnl
+])# _LT_ENABLE_FAST_INSTALL
+
+LT_OPTION_DEFINE([LT_INIT], [fast-install], [_LT_ENABLE_FAST_INSTALL([yes])])
+LT_OPTION_DEFINE([LT_INIT], [disable-fast-install], [_LT_ENABLE_FAST_INSTALL([no])])
+
+# Old names:
+AU_DEFUN([AC_ENABLE_FAST_INSTALL],
+[_LT_SET_OPTION([LT_INIT], m4_if([$1], [no], [disable-])[fast-install])
+AC_DIAGNOSE([obsolete],
+[$0: Remove this warning and the call to _LT_SET_OPTION when you put
+the `fast-install' option into LT_INIT's first parameter.])
+])
+
+AU_DEFUN([AC_DISABLE_FAST_INSTALL],
+[_LT_SET_OPTION([LT_INIT], [disable-fast-install])
+AC_DIAGNOSE([obsolete],
+[$0: Remove this warning and the call to _LT_SET_OPTION when you put
+the `disable-fast-install' option into LT_INIT's first parameter.])
+])
+
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_ENABLE_FAST_INSTALL], [])
+dnl AC_DEFUN([AM_DISABLE_FAST_INSTALL], [])
+
+
+# _LT_WITH_PIC([MODE])
+# --------------------
+# implement the --with-pic flag, and support the `pic-only' and `no-pic'
+# LT_INIT options.
+# MODE is either `yes' or `no'. If omitted, it defaults to `both'.
+m4_define([_LT_WITH_PIC],
+[AC_ARG_WITH([pic],
+ [AS_HELP_STRING([--with-pic],
+ [try to use only PIC/non-PIC objects @<:@default=use both@:>@])],
+ [pic_mode="$withval"],
+ [pic_mode=default])
+
+test -z "$pic_mode" && pic_mode=m4_default([$1], [default])
+
+_LT_DECL([], [pic_mode], [0], [What type of objects to build])dnl
+])# _LT_WITH_PIC
+
+LT_OPTION_DEFINE([LT_INIT], [pic-only], [_LT_WITH_PIC([yes])])
+LT_OPTION_DEFINE([LT_INIT], [no-pic], [_LT_WITH_PIC([no])])
+
+# Old name:
+AU_DEFUN([AC_LIBTOOL_PICMODE],
+[_LT_SET_OPTION([LT_INIT], [pic-only])
+AC_DIAGNOSE([obsolete],
+[$0: Remove this warning and the call to _LT_SET_OPTION when you
+put the `pic-only' option into LT_INIT's first parameter.])
+])
+
+dnl aclocal-1.4 backwards compatibility:
+dnl AC_DEFUN([AC_LIBTOOL_PICMODE], [])
+
+## ----------------- ##
+## LTDL_INIT Options ##
+## ----------------- ##
+
+m4_define([_LTDL_MODE], [])
+LT_OPTION_DEFINE([LTDL_INIT], [nonrecursive],
+ [m4_define([_LTDL_MODE], [nonrecursive])])
+LT_OPTION_DEFINE([LTDL_INIT], [recursive],
+ [m4_define([_LTDL_MODE], [recursive])])
+LT_OPTION_DEFINE([LTDL_INIT], [subproject],
+ [m4_define([_LTDL_MODE], [subproject])])
+
+m4_define([_LTDL_TYPE], [])
+LT_OPTION_DEFINE([LTDL_INIT], [installable],
+ [m4_define([_LTDL_TYPE], [installable])])
+LT_OPTION_DEFINE([LTDL_INIT], [convenience],
+ [m4_define([_LTDL_TYPE], [convenience])])
diff --git a/m4/ltsugar.m4 b/m4/ltsugar.m4
new file mode 100644
index 0000000..9000a05
--- /dev/null
+++ b/m4/ltsugar.m4
@@ -0,0 +1,123 @@
+# ltsugar.m4 -- libtool m4 base layer. -*-Autoconf-*-
+#
+# Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc.
+# Written by Gary V. Vaughan, 2004
+#
+# This file is free software; the Free Software Foundation gives
+# unlimited permission to copy and/or distribute it, with or without
+# modifications, as long as this notice is preserved.
+
+# serial 6 ltsugar.m4
+
+# This is to help aclocal find these macros, as it can't see m4_define.
+AC_DEFUN([LTSUGAR_VERSION], [m4_if([0.1])])
+
+
+# lt_join(SEP, ARG1, [ARG2...])
+# -----------------------------
+# Produce ARG1SEPARG2...SEPARGn, omitting [] arguments and their
+# associated separator.
+# Needed until we can rely on m4_join from Autoconf 2.62, since all earlier
+# versions in m4sugar had bugs.
+m4_define([lt_join],
+[m4_if([$#], [1], [],
+ [$#], [2], [[$2]],
+ [m4_if([$2], [], [], [[$2]_])$0([$1], m4_shift(m4_shift($@)))])])
+m4_define([_lt_join],
+[m4_if([$#$2], [2], [],
+ [m4_if([$2], [], [], [[$1$2]])$0([$1], m4_shift(m4_shift($@)))])])
+
+
+# lt_car(LIST)
+# lt_cdr(LIST)
+# ------------
+# Manipulate m4 lists.
+# These macros are necessary as long as will still need to support
+# Autoconf-2.59 which quotes differently.
+m4_define([lt_car], [[$1]])
+m4_define([lt_cdr],
+[m4_if([$#], 0, [m4_fatal([$0: cannot be called without arguments])],
+ [$#], 1, [],
+ [m4_dquote(m4_shift($@))])])
+m4_define([lt_unquote], $1)
+
+
+# lt_append(MACRO-NAME, STRING, [SEPARATOR])
+# ------------------------------------------
+# Redefine MACRO-NAME to hold its former content plus `SEPARATOR'`STRING'.
+# Note that neither SEPARATOR nor STRING are expanded; they are appended
+# to MACRO-NAME as is (leaving the expansion for when MACRO-NAME is invoked).
+# No SEPARATOR is output if MACRO-NAME was previously undefined (different
+# than defined and empty).
+#
+# This macro is needed until we can rely on Autoconf 2.62, since earlier
+# versions of m4sugar mistakenly expanded SEPARATOR but not STRING.
+m4_define([lt_append],
+[m4_define([$1],
+ m4_ifdef([$1], [m4_defn([$1])[$3]])[$2])])
+
+
+
+# lt_combine(SEP, PREFIX-LIST, INFIX, SUFFIX1, [SUFFIX2...])
+# ----------------------------------------------------------
+# Produce a SEP delimited list of all paired combinations of elements of
+# PREFIX-LIST with SUFFIX1 through SUFFIXn. Each element of the list
+# has the form PREFIXmINFIXSUFFIXn.
+# Needed until we can rely on m4_combine added in Autoconf 2.62.
+m4_define([lt_combine],
+[m4_if(m4_eval([$# > 3]), [1],
+ [m4_pushdef([_Lt_sep], [m4_define([_Lt_sep], m4_defn([lt_car]))])]]dnl
+[[m4_foreach([_Lt_prefix], [$2],
+ [m4_foreach([_Lt_suffix],
+ ]m4_dquote(m4_dquote(m4_shift(m4_shift(m4_shift($@)))))[,
+ [_Lt_sep([$1])[]m4_defn([_Lt_prefix])[$3]m4_defn([_Lt_suffix])])])])])
+
+
+# lt_if_append_uniq(MACRO-NAME, VARNAME, [SEPARATOR], [UNIQ], [NOT-UNIQ])
+# -----------------------------------------------------------------------
+# Iff MACRO-NAME does not yet contain VARNAME, then append it (delimited
+# by SEPARATOR if supplied) and expand UNIQ, else NOT-UNIQ.
+m4_define([lt_if_append_uniq],
+[m4_ifdef([$1],
+ [m4_if(m4_index([$3]m4_defn([$1])[$3], [$3$2$3]), [-1],
+ [lt_append([$1], [$2], [$3])$4],
+ [$5])],
+ [lt_append([$1], [$2], [$3])$4])])
+
+
+# lt_dict_add(DICT, KEY, VALUE)
+# -----------------------------
+m4_define([lt_dict_add],
+[m4_define([$1($2)], [$3])])
+
+
+# lt_dict_add_subkey(DICT, KEY, SUBKEY, VALUE)
+# --------------------------------------------
+m4_define([lt_dict_add_subkey],
+[m4_define([$1($2:$3)], [$4])])
+
+
+# lt_dict_fetch(DICT, KEY, [SUBKEY])
+# ----------------------------------
+m4_define([lt_dict_fetch],
+[m4_ifval([$3],
+ m4_ifdef([$1($2:$3)], [m4_defn([$1($2:$3)])]),
+ m4_ifdef([$1($2)], [m4_defn([$1($2)])]))])
+
+
+# lt_if_dict_fetch(DICT, KEY, [SUBKEY], VALUE, IF-TRUE, [IF-FALSE])
+# -----------------------------------------------------------------
+m4_define([lt_if_dict_fetch],
+[m4_if(lt_dict_fetch([$1], [$2], [$3]), [$4],
+ [$5],
+ [$6])])
+
+
+# lt_dict_filter(DICT, [SUBKEY], VALUE, [SEPARATOR], KEY, [...])
+# --------------------------------------------------------------
+m4_define([lt_dict_filter],
+[m4_if([$5], [], [],
+ [lt_join(m4_quote(m4_default([$4], [[, ]])),
+ lt_unquote(m4_split(m4_normalize(m4_foreach(_Lt_key, lt_car([m4_shiftn(4, $@)]),
+ [lt_if_dict_fetch([$1], _Lt_key, [$2], [$3], [_Lt_key ])])))))])[]dnl
+])
diff --git a/m4/ltversion.m4 b/m4/ltversion.m4
new file mode 100644
index 0000000..9c7b5d4
--- /dev/null
+++ b/m4/ltversion.m4
@@ -0,0 +1,23 @@
+# ltversion.m4 -- version numbers -*- Autoconf -*-
+#
+# Copyright (C) 2004 Free Software Foundation, Inc.
+# Written by Scott James Remnant, 2004
+#
+# This file is free software; the Free Software Foundation gives
+# unlimited permission to copy and/or distribute it, with or without
+# modifications, as long as this notice is preserved.
+
+# @configure_input@
+
+# serial 3293 ltversion.m4
+# This file is part of GNU Libtool
+
+m4_define([LT_PACKAGE_VERSION], [2.4])
+m4_define([LT_PACKAGE_REVISION], [1.3293])
+
+AC_DEFUN([LTVERSION_VERSION],
+[macro_version='2.4'
+macro_revision='1.3293'
+_LT_DECL(, macro_version, 0, [Which release of libtool.m4 was used?])
+_LT_DECL(, macro_revision, 0)
+])
diff --git a/m4/lt~obsolete.m4 b/m4/lt~obsolete.m4
new file mode 100644
index 0000000..c573da9
--- /dev/null
+++ b/m4/lt~obsolete.m4
@@ -0,0 +1,98 @@
+# lt~obsolete.m4 -- aclocal satisfying obsolete definitions. -*-Autoconf-*-
+#
+# Copyright (C) 2004, 2005, 2007, 2009 Free Software Foundation, Inc.
+# Written by Scott James Remnant, 2004.
+#
+# This file is free software; the Free Software Foundation gives
+# unlimited permission to copy and/or distribute it, with or without
+# modifications, as long as this notice is preserved.
+
+# serial 5 lt~obsolete.m4
+
+# These exist entirely to fool aclocal when bootstrapping libtool.
+#
+# In the past libtool.m4 has provided macros via AC_DEFUN (or AU_DEFUN)
+# which have later been changed to m4_define as they aren't part of the
+# exported API, or moved to Autoconf or Automake where they belong.
+#
+# The trouble is, aclocal is a bit thick. It'll see the old AC_DEFUN
+# in /usr/share/aclocal/libtool.m4 and remember it, then when it sees us
+# using a macro with the same name in our local m4/libtool.m4 it'll
+# pull the old libtool.m4 in (it doesn't see our shiny new m4_define
+# and doesn't know about Autoconf macros at all.)
+#
+# So we provide this file, which has a silly filename so it's always
+# included after everything else. This provides aclocal with the
+# AC_DEFUNs it wants, but when m4 processes it, it doesn't do anything
+# because those macros already exist, or will be overwritten later.
+# We use AC_DEFUN over AU_DEFUN for compatibility with aclocal-1.6.
+#
+# Anytime we withdraw an AC_DEFUN or AU_DEFUN, remember to add it here.
+# Yes, that means every name once taken will need to remain here until
+# we give up compatibility with versions before 1.7, at which point
+# we need to keep only those names which we still refer to.
+
+# This is to help aclocal find these macros, as it can't see m4_define.
+AC_DEFUN([LTOBSOLETE_VERSION], [m4_if([1])])
+
+m4_ifndef([AC_LIBTOOL_LINKER_OPTION], [AC_DEFUN([AC_LIBTOOL_LINKER_OPTION])])
+m4_ifndef([AC_PROG_EGREP], [AC_DEFUN([AC_PROG_EGREP])])
+m4_ifndef([_LT_AC_PROG_ECHO_BACKSLASH], [AC_DEFUN([_LT_AC_PROG_ECHO_BACKSLASH])])
+m4_ifndef([_LT_AC_SHELL_INIT], [AC_DEFUN([_LT_AC_SHELL_INIT])])
+m4_ifndef([_LT_AC_SYS_LIBPATH_AIX], [AC_DEFUN([_LT_AC_SYS_LIBPATH_AIX])])
+m4_ifndef([_LT_PROG_LTMAIN], [AC_DEFUN([_LT_PROG_LTMAIN])])
+m4_ifndef([_LT_AC_TAGVAR], [AC_DEFUN([_LT_AC_TAGVAR])])
+m4_ifndef([AC_LTDL_ENABLE_INSTALL], [AC_DEFUN([AC_LTDL_ENABLE_INSTALL])])
+m4_ifndef([AC_LTDL_PREOPEN], [AC_DEFUN([AC_LTDL_PREOPEN])])
+m4_ifndef([_LT_AC_SYS_COMPILER], [AC_DEFUN([_LT_AC_SYS_COMPILER])])
+m4_ifndef([_LT_AC_LOCK], [AC_DEFUN([_LT_AC_LOCK])])
+m4_ifndef([AC_LIBTOOL_SYS_OLD_ARCHIVE], [AC_DEFUN([AC_LIBTOOL_SYS_OLD_ARCHIVE])])
+m4_ifndef([_LT_AC_TRY_DLOPEN_SELF], [AC_DEFUN([_LT_AC_TRY_DLOPEN_SELF])])
+m4_ifndef([AC_LIBTOOL_PROG_CC_C_O], [AC_DEFUN([AC_LIBTOOL_PROG_CC_C_O])])
+m4_ifndef([AC_LIBTOOL_SYS_HARD_LINK_LOCKS], [AC_DEFUN([AC_LIBTOOL_SYS_HARD_LINK_LOCKS])])
+m4_ifndef([AC_LIBTOOL_OBJDIR], [AC_DEFUN([AC_LIBTOOL_OBJDIR])])
+m4_ifndef([AC_LTDL_OBJDIR], [AC_DEFUN([AC_LTDL_OBJDIR])])
+m4_ifndef([AC_LIBTOOL_PROG_LD_HARDCODE_LIBPATH], [AC_DEFUN([AC_LIBTOOL_PROG_LD_HARDCODE_LIBPATH])])
+m4_ifndef([AC_LIBTOOL_SYS_LIB_STRIP], [AC_DEFUN([AC_LIBTOOL_SYS_LIB_STRIP])])
+m4_ifndef([AC_PATH_MAGIC], [AC_DEFUN([AC_PATH_MAGIC])])
+m4_ifndef([AC_PROG_LD_GNU], [AC_DEFUN([AC_PROG_LD_GNU])])
+m4_ifndef([AC_PROG_LD_RELOAD_FLAG], [AC_DEFUN([AC_PROG_LD_RELOAD_FLAG])])
+m4_ifndef([AC_DEPLIBS_CHECK_METHOD], [AC_DEFUN([AC_DEPLIBS_CHECK_METHOD])])
+m4_ifndef([AC_LIBTOOL_PROG_COMPILER_NO_RTTI], [AC_DEFUN([AC_LIBTOOL_PROG_COMPILER_NO_RTTI])])
+m4_ifndef([AC_LIBTOOL_SYS_GLOBAL_SYMBOL_PIPE], [AC_DEFUN([AC_LIBTOOL_SYS_GLOBAL_SYMBOL_PIPE])])
+m4_ifndef([AC_LIBTOOL_PROG_COMPILER_PIC], [AC_DEFUN([AC_LIBTOOL_PROG_COMPILER_PIC])])
+m4_ifndef([AC_LIBTOOL_PROG_LD_SHLIBS], [AC_DEFUN([AC_LIBTOOL_PROG_LD_SHLIBS])])
+m4_ifndef([AC_LIBTOOL_POSTDEP_PREDEP], [AC_DEFUN([AC_LIBTOOL_POSTDEP_PREDEP])])
+m4_ifndef([LT_AC_PROG_EGREP], [AC_DEFUN([LT_AC_PROG_EGREP])])
+m4_ifndef([LT_AC_PROG_SED], [AC_DEFUN([LT_AC_PROG_SED])])
+m4_ifndef([_LT_CC_BASENAME], [AC_DEFUN([_LT_CC_BASENAME])])
+m4_ifndef([_LT_COMPILER_BOILERPLATE], [AC_DEFUN([_LT_COMPILER_BOILERPLATE])])
+m4_ifndef([_LT_LINKER_BOILERPLATE], [AC_DEFUN([_LT_LINKER_BOILERPLATE])])
+m4_ifndef([_AC_PROG_LIBTOOL], [AC_DEFUN([_AC_PROG_LIBTOOL])])
+m4_ifndef([AC_LIBTOOL_SETUP], [AC_DEFUN([AC_LIBTOOL_SETUP])])
+m4_ifndef([_LT_AC_CHECK_DLFCN], [AC_DEFUN([_LT_AC_CHECK_DLFCN])])
+m4_ifndef([AC_LIBTOOL_SYS_DYNAMIC_LINKER], [AC_DEFUN([AC_LIBTOOL_SYS_DYNAMIC_LINKER])])
+m4_ifndef([_LT_AC_TAGCONFIG], [AC_DEFUN([_LT_AC_TAGCONFIG])])
+m4_ifndef([AC_DISABLE_FAST_INSTALL], [AC_DEFUN([AC_DISABLE_FAST_INSTALL])])
+m4_ifndef([_LT_AC_LANG_CXX], [AC_DEFUN([_LT_AC_LANG_CXX])])
+m4_ifndef([_LT_AC_LANG_F77], [AC_DEFUN([_LT_AC_LANG_F77])])
+m4_ifndef([_LT_AC_LANG_GCJ], [AC_DEFUN([_LT_AC_LANG_GCJ])])
+m4_ifndef([AC_LIBTOOL_LANG_C_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_C_CONFIG])])
+m4_ifndef([_LT_AC_LANG_C_CONFIG], [AC_DEFUN([_LT_AC_LANG_C_CONFIG])])
+m4_ifndef([AC_LIBTOOL_LANG_CXX_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_CXX_CONFIG])])
+m4_ifndef([_LT_AC_LANG_CXX_CONFIG], [AC_DEFUN([_LT_AC_LANG_CXX_CONFIG])])
+m4_ifndef([AC_LIBTOOL_LANG_F77_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_F77_CONFIG])])
+m4_ifndef([_LT_AC_LANG_F77_CONFIG], [AC_DEFUN([_LT_AC_LANG_F77_CONFIG])])
+m4_ifndef([AC_LIBTOOL_LANG_GCJ_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_GCJ_CONFIG])])
+m4_ifndef([_LT_AC_LANG_GCJ_CONFIG], [AC_DEFUN([_LT_AC_LANG_GCJ_CONFIG])])
+m4_ifndef([AC_LIBTOOL_LANG_RC_CONFIG], [AC_DEFUN([AC_LIBTOOL_LANG_RC_CONFIG])])
+m4_ifndef([_LT_AC_LANG_RC_CONFIG], [AC_DEFUN([_LT_AC_LANG_RC_CONFIG])])
+m4_ifndef([AC_LIBTOOL_CONFIG], [AC_DEFUN([AC_LIBTOOL_CONFIG])])
+m4_ifndef([_LT_AC_FILE_LTDLL_C], [AC_DEFUN([_LT_AC_FILE_LTDLL_C])])
+m4_ifndef([_LT_REQUIRED_DARWIN_CHECKS], [AC_DEFUN([_LT_REQUIRED_DARWIN_CHECKS])])
+m4_ifndef([_LT_AC_PROG_CXXCPP], [AC_DEFUN([_LT_AC_PROG_CXXCPP])])
+m4_ifndef([_LT_PREPARE_SED_QUOTE_VARS], [AC_DEFUN([_LT_PREPARE_SED_QUOTE_VARS])])
+m4_ifndef([_LT_PROG_ECHO_BACKSLASH], [AC_DEFUN([_LT_PROG_ECHO_BACKSLASH])])
+m4_ifndef([_LT_PROG_F77], [AC_DEFUN([_LT_PROG_F77])])
+m4_ifndef([_LT_PROG_FC], [AC_DEFUN([_LT_PROG_FC])])
+m4_ifndef([_LT_PROG_CXX], [AC_DEFUN([_LT_PROG_CXX])])
diff --git a/qcdloop-1.9/ChangeLog b/qcdloop-1.9/ChangeLog
new file mode 100644
index 0000000..763bb93
--- /dev/null
+++ b/qcdloop-1.9/ChangeLog
@@ -0,0 +1,129 @@
+2008-01-12 Giulia Zanderighi <g.zanderighi1@physics.ox.ac.uk>
+
+ * qlinit.f:
+ set version number 1.1
+
+ * qlYcalc.f:
+ initialize Yalt to 0d0, not needed at the moment, but still
+
+ * qlLi2omx.f:
+ * qlbox15.f:
+ * qlbox16.f:
+ * qlcLi2omx2.f:
+ * qlcLi2omx3.f:
+ * qltri6.f:
+ changing prefix in name of some functions "qlcql" -> "qlc"
+
+ * qlLi2omx.f:
+ * qlLi2omx2.f:
+ * qlcLi2omx2.f:
+ * qlcLi2omx3.f:
+ fix special cases arg=0d0 and 1d0
+
+ * qltri3.f:
+ compute fac only if necessary
+
+2008-01-16 Keith Ellis <ellis@fnal.gov>
+
+ * qlinit.f:
+ set version number 1.2
+
+ * qlI1.f:
+ * qlI2.f:
+ corrected dependence on scale musq
+
+2008-02-20 Giulia Zanderighi <g.zanderighi1@physics.ox.ac.uk>
+
+ * qlboxdiv16.f
+ add treatment of special cases x2=x3=1 or x2=x3/=1
+
+ * qlkfn.f --- added
+ contains modified version of ff routine ffzkfn
+ with argument ier dropped and meaning of ieps changed
+
+ * qlboxdiv16.f
+ * qlboxdiv15.f
+ * qlboxdiv14.f
+ * qltri6.f
+ replace call to ffzkfn with call to qlkfn
+ (with modified arguments)
+
+2008-04-24 Keith Ellis <ellis@fnal.gov>
+
+ * qlinit.f:
+ set version number 1.4
+ * qlI1.f --- modified to remove call to ff routines
+ * qlI2.f --- modified to remove call to ff routines
+ * qlI2fin.f --- added
+ replaces call to ff routines in qlI2
+ * qlfndd.f --- added
+ auxiliary function needed in calculation of 2-point function.
+ * qlI4DNS41.f --- added
+ in order to handle the case with all internal masses=0
+ and all external lines with non-zero virtuality
+ using Eq.41 of Denner,Nierste,Sharf.
+ This case is not treated in ff.
+ * qlLi2omprod.f --- added
+ dilogarithm routine added to handle above
+ * qlI4sub0m.f --- modified
+ to call subroutine qlI4DNS41
+
+2008-06-23 Keith Ellis <ellis@fnal.gov>
+
+ * qlinit.f:
+ set version number 1.5
+ * qlxpicheck.f --- Added new routine which checks
+ that modified Cayleys Y(1,3) and Y(2,4) are non-zero
+ * qlI4sub0m.f --- added call to qlxpicheck
+ * qlI4sub1m.f --- added call to qlxpicheck
+ * qlI4sub2m.f --- added call to qlxpicheck
+ * qlI4sub3m.f --- added call to qlxpicheck
+
+2008-07-24 Keith Ellis <ellis@fnal.gov>
+
+ * qlinit.f:
+ set version number 1.6
+ * qlI2.f: ---- rescaled input invariants by the largest one,
+ so qlzero has an absolute meaning
+ * qlI3.f: ---- rescaled input invariants by the largest one,
+ so qlzero has an absolute meaning
+ added check that mu2 is unchanged before returning old value
+ * qlI4.f: ---- rescaled input invariants by the largest one,
+ so qlzero has an absolute meaning
+ * qlI4array.f ---- added check that mu2 is unchanged before returning old value
+ * qlbox3.f ---- corrected if statement so expansion is performed only where appropriate
+ * qlbox5.f ---- corrected if statement so expansion is performed only where appropriate
+
+
+2008-08-22 Keith Ellis <ellis@fnal.gov>
+
+ * qlinit.f:
+ set version number 1.7
+ * qlI2.f: ---- rescaled input invariants by the largest one including mu2
+ so that correct value is returned even for p1=m1=m2=0.
+ Routine now stops if called for mu2 .le. 0d0
+ * qlI1.f: ---- Routine now stops if called for mu2 .le. 0d0
+
+2008-10-30 Keith Ellis <ellis@fnal.gov>
+
+ * qlinit.f:
+ set version number 1.8
+ * qlI2fin.f: ---- dealt explicitly with special case p1sq=0,m0s=m1s,
+ * qlbox13.f: ---- corrected bug in implementation of p3sq-->0 limit
+
+2008-07-14 Keith Ellis <ellis@fnal.gov>
+
+ * qlinit.f:
+ set version number 1.9
+ * qlbox15.f: ---- corrected bug in implementation of limit when either
+ p2sq=m2sq or p3sq=m4sq. Formula in paper is correct
+
+
+
+
+
+
+
+
+
+
\ No newline at end of file
diff --git a/qcdloop-1.9/Makefile.am b/qcdloop-1.9/Makefile.am
new file mode 100644
index 0000000..03c80a0
--- /dev/null
+++ b/qcdloop-1.9/Makefile.am
@@ -0,0 +1,19 @@
+lib_LTLIBRARIES=libqcdloop.la
+
+noinst_HEADERS=qlconstants.f qlonshellcutoff.f
+
+libqcdloop_la_SOURCES= \
+ qlinit.f qlI4.f qlI3.f qlI2.f qlI1.f qlI4array.f qlzero.f qlI4fin.f \
+ qlI4DNS41.f qlI4sub0m.f qlI4sub1m.f qlI4sub2m.f qlI4sub2ma.f qlI4sub2mo.f \
+ qlI4sub3m.f qlI3fin.f qlI3sub.f qlI2fin.f qlfndd.f qlLi2omprod.f \
+ qlLi2omrat.f qllnomrat4.f qlLi2omx.f qlLi2omx2.f qltrisort.f qlsnglsort.f \
+ qltri1.f qltri2.f qltri3.f qltri4.f qltri5.f qltri6.f qlbox1.f qlbox2.f \
+ qlbox3.f qlbox4.f qlbox5.f qlbox6.f qlbox7.f qlbox8.f qlbox9.f qlbox10.f \
+ qlbox11.f qlbox12.f qlbox13.f qlbox14.f qlbox15.f qlbox16.f qlcLi2omx2.f \
+ qlcLi2omx3.f auxCD.f qlspencer.f qlratreal.f qlratgam.f ddilog.f qllnrat.f \
+ qlfunctions.f qlYcalc.f qlkfn.f qlxpicheck.f
+
+libqcdloop_la_LIBADD=-L$(builddir)/../ff-2.0 -lff
+AM_FFLAGS=-I$(srcdir) -I$(srcdir)/../ff-2.0
+
+include Makefile.dep
diff --git a/qcdloop-1.9/Makefile.dep b/qcdloop-1.9/Makefile.dep
new file mode 100644
index 0000000..4e1e014
--- /dev/null
+++ b/qcdloop-1.9/Makefile.dep
@@ -0,0 +1 @@
+# No dependencies
diff --git a/qcdloop-1.9/Makefile.in b/qcdloop-1.9/Makefile.in
new file mode 100644
index 0000000..32b4873
--- /dev/null
+++ b/qcdloop-1.9/Makefile.in
@@ -0,0 +1,563 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(noinst_HEADERS) $(srcdir)/Makefile.am \
+ $(srcdir)/Makefile.dep $(srcdir)/Makefile.in ChangeLog
+subdir = qcdloop-1.9
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(libdir)"
+LTLIBRARIES = $(lib_LTLIBRARIES)
+libqcdloop_la_DEPENDENCIES =
+am_libqcdloop_la_OBJECTS = qlinit.lo qlI4.lo qlI3.lo qlI2.lo qlI1.lo \
+ qlI4array.lo qlzero.lo qlI4fin.lo qlI4DNS41.lo qlI4sub0m.lo \
+ qlI4sub1m.lo qlI4sub2m.lo qlI4sub2ma.lo qlI4sub2mo.lo \
+ qlI4sub3m.lo qlI3fin.lo qlI3sub.lo qlI2fin.lo qlfndd.lo \
+ qlLi2omprod.lo qlLi2omrat.lo qllnomrat4.lo qlLi2omx.lo \
+ qlLi2omx2.lo qltrisort.lo qlsnglsort.lo qltri1.lo qltri2.lo \
+ qltri3.lo qltri4.lo qltri5.lo qltri6.lo qlbox1.lo qlbox2.lo \
+ qlbox3.lo qlbox4.lo qlbox5.lo qlbox6.lo qlbox7.lo qlbox8.lo \
+ qlbox9.lo qlbox10.lo qlbox11.lo qlbox12.lo qlbox13.lo \
+ qlbox14.lo qlbox15.lo qlbox16.lo qlcLi2omx2.lo qlcLi2omx3.lo \
+ auxCD.lo qlspencer.lo qlratreal.lo qlratgam.lo ddilog.lo \
+ qllnrat.lo qlfunctions.lo qlYcalc.lo qlkfn.lo qlxpicheck.lo
+libqcdloop_la_OBJECTS = $(am_libqcdloop_la_OBJECTS)
+DEFAULT_INCLUDES = -I.@am__isrc@
+F77COMPILE = $(F77) $(AM_FFLAGS) $(FFLAGS)
+LTF77COMPILE = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS)
+F77LD = $(F77)
+F77LINK = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(F77LD) $(AM_FFLAGS) $(FFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libqcdloop_la_SOURCES)
+DIST_SOURCES = $(libqcdloop_la_SOURCES)
+HEADERS = $(noinst_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+lib_LTLIBRARIES = libqcdloop.la
+noinst_HEADERS = qlconstants.f qlonshellcutoff.f
+libqcdloop_la_SOURCES = \
+ qlinit.f qlI4.f qlI3.f qlI2.f qlI1.f qlI4array.f qlzero.f qlI4fin.f \
+ qlI4DNS41.f qlI4sub0m.f qlI4sub1m.f qlI4sub2m.f qlI4sub2ma.f qlI4sub2mo.f \
+ qlI4sub3m.f qlI3fin.f qlI3sub.f qlI2fin.f qlfndd.f qlLi2omprod.f \
+ qlLi2omrat.f qllnomrat4.f qlLi2omx.f qlLi2omx2.f qltrisort.f qlsnglsort.f \
+ qltri1.f qltri2.f qltri3.f qltri4.f qltri5.f qltri6.f qlbox1.f qlbox2.f \
+ qlbox3.f qlbox4.f qlbox5.f qlbox6.f qlbox7.f qlbox8.f qlbox9.f qlbox10.f \
+ qlbox11.f qlbox12.f qlbox13.f qlbox14.f qlbox15.f qlbox16.f qlcLi2omx2.f \
+ qlcLi2omx3.f auxCD.f qlspencer.f qlratreal.f qlratgam.f ddilog.f qllnrat.f \
+ qlfunctions.f qlYcalc.f qlkfn.f qlxpicheck.f
+
+libqcdloop_la_LIBADD = -L$(builddir)/../ff-2.0 -lff
+AM_FFLAGS = -I$(srcdir) -I$(srcdir)/../ff-2.0
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu qcdloop-1.9/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu qcdloop-1.9/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+install-libLTLIBRARIES: $(lib_LTLIBRARIES)
+ @$(NORMAL_INSTALL)
+ test -z "$(libdir)" || $(MKDIR_P) "$(DESTDIR)$(libdir)"
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ list2=; for p in $$list; do \
+ if test -f $$p; then \
+ list2="$$list2 $$p"; \
+ else :; fi; \
+ done; \
+ test -z "$$list2" || { \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \
+ }
+
+uninstall-libLTLIBRARIES:
+ @$(NORMAL_UNINSTALL)
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ for p in $$list; do \
+ $(am__strip_dir) \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \
+ done
+
+clean-libLTLIBRARIES:
+ -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES)
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libqcdloop.la: $(libqcdloop_la_OBJECTS) $(libqcdloop_la_DEPENDENCIES)
+ $(F77LINK) -rpath $(libdir) $(libqcdloop_la_OBJECTS) $(libqcdloop_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f.o:
+ $(F77COMPILE) -c -o $@ $<
+
+.f.obj:
+ $(F77COMPILE) -c -o $@ `$(CYGPATH_W) '$<'`
+
+.f.lo:
+ $(LTF77COMPILE) -c -o $@ $<
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(libdir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libLTLIBRARIES clean-libtool \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am:
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am: install-libLTLIBRARIES
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-libLTLIBRARIES
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libLTLIBRARIES clean-libtool ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am \
+ install-libLTLIBRARIES install-man install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-libLTLIBRARIES
+
+
+# No dependencies
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/qcdloop-1.9/auxCD.f b/qcdloop-1.9/auxCD.f
new file mode 100644
index 0000000..13c1806
--- /dev/null
+++ b/qcdloop-1.9/auxCD.f
@@ -0,0 +1,134 @@
+* auxCD.F
+* auxiliary functions used by the three- and four-point integrals
+* these functions are adapted from Ansgar Denner's bcanew.f
+* to the conventions of LoopTools;
+* they are used for double-checking the results of FF
+* last modified 25 Oct 05 th
+
+ double complex function ln(x, isig)
+ implicit none
+ include 'qlconstants.f'
+ double precision x, isig
+ if( x .gt. 0 ) then
+ ln = DCMPLX(log(x),0d0)
+ else
+ ln = dcmplx(log(-x)) + DCMPLX(0D0, sign(pi, isig))
+ endif
+ end
+
+************************************************************************
+
+ double complex function cln(z, isig)
+ implicit none
+ include 'qlconstants.f'
+ double complex z
+ double precision isig
+
+ if( DIMAG(z) .eq. 0d0 .and. DBLE(z) .le. 0d0 ) then
+ cln = log(-z) + DCMPLX(0D0, sign(pi, isig))
+ else
+ cln = log(z)
+ endif
+ end
+
+************************************************************************
+
+ double complex function denspence(z, isig)
+ implicit none
+ double complex z
+ double precision isig
+
+ include 'qlconstants.f'
+ include 'qlonshellcutoff.f'
+
+ double complex z1
+ double precision az1,acc
+
+ double complex li2series, cln
+ external li2series, cln
+ acc=qlonshellcutoff
+
+ z1 = cone - z
+ az1 = abs(z1)
+
+ if( isig .eq. 0d0 .and.
+ & DIMAG(z) .eq. 0d0 .and. abs(DBLE(z1)) .lt. acc )
+ & print *, "denspence: argument on cut"
+
+ if( az1 .lt. 1D-15 ) then
+ denspence = dcmplx(pisqo6)
+ else if( DBLE(z) .lt. .5D0 ) then
+ if( abs(z) .lt. 1d0 ) then
+ denspence = li2series(z, isig)
+ else
+ denspence = -dcmplx(pisqo6) -
+ & .5D0*cln(-z, -isig)**2 - li2series(1d0/z, -isig)
+ endif
+ else
+ if( az1 .lt. 1d0 ) then
+ denspence = dcmplx(pisqo6) -
+ & cln(z, isig)*cln(z1, -isig) - li2series(z1, -isig)
+ else
+ denspence = 2d0*dcmplx(pisqo6) +
+ & .5D0*cln(-z1, -isig)**2 - cln(z, isig)*cln(z1, -isig) +
+ & li2series(1d0/z1, isig)
+ endif
+ endif
+ end
+
+************************************************************************
+
+ double complex function li2series(z, isig)
+ implicit none
+ include 'qlconstants.f'
+ double complex z
+ double precision isig
+
+ double complex xm, x2, new
+ integer j
+
+ double complex cln
+ external cln
+
+* these are the even-n Bernoulli numbers, already divided by (n + 1)!
+* as in Table[BernoulliB[n]/(n + 1)!, {n, 2, 50, 2}]
+ double precision b(25)
+ data b /
+ & 0.02777777777777777777777777777777777777777778774D0,
+ & -0.000277777777777777777777777777777777777777777778D0,
+ & 4.72411186696900982615268329554043839758125472D-6,
+ & -9.18577307466196355085243974132863021751910641D-8,
+ & 1.89788699889709990720091730192740293750394761D-9,
+ & -4.06476164514422552680590938629196667454705711D-11,
+ & 8.92169102045645255521798731675274885151428361D-13,
+ & -1.993929586072107568723644347793789705630694749D-14,
+ & 4.51898002961991819165047655285559322839681901D-16,
+ & -1.035651761218124701448341154221865666596091238D-17,
+ & 2.39521862102618674574028374300098038167894899D-19,
+ & -5.58178587432500933628307450562541990556705462D-21,
+ & 1.309150755418321285812307399186592301749849833D-22,
+ & -3.087419802426740293242279764866462431595565203D-24,
+ & 7.31597565270220342035790560925214859103339899D-26,
+ & -1.740845657234000740989055147759702545340841422D-27,
+ & 4.15763564461389971961789962077522667348825413D-29,
+ & -9.96214848828462210319400670245583884985485196D-31,
+ & 2.394034424896165300521167987893749562934279156D-32,
+ & -5.76834735536739008429179316187765424407233225D-34,
+ & 1.393179479647007977827886603911548331732410612D-35,
+ & -3.372121965485089470468473635254930958979742891D-37,
+ & 8.17820877756210262176477721487283426787618937D-39,
+ & -1.987010831152385925564820669234786567541858996D-40,
+ & 4.83577851804055089628705937311537820769430091D-42 /
+
+ xm = -cln(cone - z, -isig)
+ x2 = xm**2
+ li2series = xm - x2/4D0
+ do j = 1, 25
+ xm = xm*x2
+ new = li2series + xm*b(j)
+ if( new .eq. li2series ) return
+ li2series = new
+ enddo
+ print *, "li2series: bad convergence"
+ end
+
diff --git a/qcdloop-1.9/ddilog.f b/qcdloop-1.9/ddilog.f
new file mode 100644
index 0000000..faaabd9
--- /dev/null
+++ b/qcdloop-1.9/ddilog.f
@@ -0,0 +1,76 @@
+ DOUBLE PRECISION FUNCTION DDILOG(X)
+
+ DOUBLE PRECISION X,Y,T,S,A,PI3,PI6,ZERO,ONE,HALF,MALF,MONE,MTWO
+ DOUBLE PRECISION C(0:18),H,ALFA,B0,B1,B2
+
+ DATA ZERO /0.0D0/, ONE /1.0D0/
+ DATA HALF /0.5D0/, MALF /-0.5D0/, MONE /-1.0D0/, MTWO /-2.0D0/
+ DATA PI3 /3.289868133696453D0/, PI6 /1.644934066848226D0/
+
+ DATA C( 0) / 0.4299669356081370D0/
+ DATA C( 1) / 0.4097598753307711D0/
+ DATA C( 2) /-0.0185884366501460D0/
+ DATA C( 3) / 0.0014575108406227D0/
+ DATA C( 4) /-0.0001430418444234D0/
+ DATA C( 5) / 0.0000158841554188D0/
+ DATA C( 6) /-0.0000019078495939D0/
+ DATA C( 7) / 0.0000002419518085D0/
+ DATA C( 8) /-0.0000000319334127D0/
+ DATA C( 9) / 0.0000000043454506D0/
+ DATA C(10) /-0.0000000006057848D0/
+ DATA C(11) / 0.0000000000861210D0/
+ DATA C(12) /-0.0000000000124433D0/
+ DATA C(13) / 0.0000000000018226D0/
+ DATA C(14) /-0.0000000000002701D0/
+ DATA C(15) / 0.0000000000000404D0/
+ DATA C(16) /-0.0000000000000061D0/
+ DATA C(17) / 0.0000000000000009D0/
+ DATA C(18) /-0.0000000000000001D0/
+
+ IF(X .EQ. ONE) THEN
+ DDILOG=PI6
+ RETURN
+ ELSE IF(X .EQ. MONE) THEN
+ DDILOG=MALF*PI6
+ RETURN
+ END IF
+ T=-X
+ IF(T .LE. MTWO) THEN
+ Y=MONE/(ONE+T)
+ S=ONE
+ A=-PI3+HALF*(LOG(-T)**2-LOG(ONE+ONE/T)**2)
+ ELSE IF(T .LT. MONE) THEN
+ Y=MONE-T
+ S=MONE
+ A=LOG(-T)
+ A=-PI6+A*(A+LOG(ONE+ONE/T))
+ ELSE IF(T .LE. MALF) THEN
+ Y=(MONE-T)/T
+ S=ONE
+ A=LOG(-T)
+ A=-PI6+A*(MALF*A+LOG(ONE+T))
+ ELSE IF(T .LT. ZERO) THEN
+ Y=-T/(ONE+T)
+ S=MONE
+ A=HALF*LOG(ONE+T)**2
+ ELSE IF(T .LE. ONE) THEN
+ Y=T
+ S=ONE
+ A=ZERO
+ ELSE
+ Y=ONE/T
+ S=MONE
+ A=PI6+HALF*LOG(T)**2
+ END IF
+
+ H=Y+Y-ONE
+ ALFA=H+H
+ B1=ZERO
+ B2=ZERO
+ DO 1 I = 18,0,-1
+ B0=C(I)+ALFA*B1-B2
+ B2=B1
+ 1 B1=B0
+ DDILOG=-(S*(B0-H*B2)+A)
+ RETURN
+ END
diff --git a/qcdloop-1.9/qlI1.f b/qcdloop-1.9/qlI1.f
new file mode 100644
index 0000000..f161de2
--- /dev/null
+++ b/qcdloop-1.9/qlI1.f
@@ -0,0 +1,41 @@
+ double complex function qlI1(m1,mu2,ep)
+ implicit none
+ include 'qlconstants.f'
+ double precision m1,mu2
+ integer ep
+C m1=m(i)^2 is the square of the mass of the propagator 1
+C mu2 is the square of the scale mu
+C ep=-2,-1,0 chooses the appropriate coefficienrt in the Laurent series.
+ double precision m1o,mu2o
+ logical qlzero
+ double complex Ival(-2:0)
+ data m1o/0d0/
+ save Ival,m1o,mu2o
+
+ if (mu2 .le. 0d0) then
+ write(6,*) 'stopping because mu2 .le. 0d0 in qlI1, mu2=',mu2
+ write(6,*) 'Rerun with positive mu2'
+ stop
+ endif
+
+C--If we have already calculated, use the saved value
+C--else setup the arrays
+ if ((m1 .eq. m1o) .and. (mu2 .eq. mu2o)) then
+ qlI1=Ival(ep)
+ return
+ else
+ Ival(-2)=czip
+ Ival(-1)=czip
+ Ival(0)=czip
+ if (qlzero(m1)) then
+ qlI1=Ival(ep)
+ else
+ Ival(-1)=dcmplx(m1)
+ Ival( 0)=Ival(-1)*dcmplx(log(mu2/m1)+1d0)
+ qlI1=Ival(ep)
+ endif
+ m1o=m1
+ mu2o=mu2
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlI2.f b/qcdloop-1.9/qlI2.f
new file mode 100644
index 0000000..9611c5f
--- /dev/null
+++ b/qcdloop-1.9/qlI2.f
@@ -0,0 +1,54 @@
+ double complex function qlI2(p1,m1,m2,mu2,ep)
+ implicit none
+ include 'qlconstants.f'
+ double precision p1,m1,m2,mu2
+ integer ep
+C p1=p1(1) is the squared four-momentum of the external particle i
+C mi=m(i)^2, i=1,2 are the squares of the mass of the propagator i
+C mu2 is the square of the scale mu
+C ep=-2,-1,0 chooses the coefficient in the Laurent series.
+ double precision p1o,m1o,m2o,mu2o,pp1,mm1,mm2,newmu2,scalefac
+ logical qlzero
+ double complex Ival(-2:0),qlI2fin
+ data p1o,m1o,m2o,mu2o/3*0d0,-1d0/
+ save Ival,p1o,m1o,m2o,mu2o
+
+C--If we have already calculated, use the saved value
+C--else setup the arrays
+ if ((p1 .eq. p1o)
+ . .and. (m1 .eq. m1o)
+ . .and. (m2 .eq. m2o)
+ . .and. (mu2 .eq. mu2o)) then
+ qlI2=Ival(ep)
+ return
+ else
+ p1o=p1
+ m1o=m1
+ m2o=m2
+ mu2o=mu2
+ endif
+ if (mu2 .le. 0d0) then
+ write(6,*) 'stopping because mu2 .le. 0d0 in qlI2, mu2=',mu2
+ write(6,*) 'Rerun with positive mu2'
+ stop
+ endif
+
+ scalefac=max(abs(p1),abs(m1),abs(m2),abs(mu2))
+ pp1=p1/scalefac
+ mm1=m1/scalefac
+ mm2=m2/scalefac
+ newmu2=mu2/scalefac
+
+ Ival(-2)=czip
+ Ival(-1)=czip
+ Ival(0)=czip
+ if ((qlzero(pp1)).and.(qlzero(mm1)).and.(qlzero(mm2))) then
+ qlI2=Ival(ep)
+ else
+ Ival(-1)=cone
+ Ival(0)=qlI2fin(pp1,mm1,mm2,newmu2)
+ qlI2=Ival(ep)
+ endif
+
+ return
+ end
diff --git a/qcdloop-1.9/qlI2fin.f b/qcdloop-1.9/qlI2fin.f
new file mode 100644
index 0000000..2ef304b
--- /dev/null
+++ b/qcdloop-1.9/qlI2fin.f
@@ -0,0 +1,67 @@
+ double complex function qlI2fin(p1sq,m0s,m1s,musq)
+C---- Implementation of the formulae of Denner and Dittmaier
+C----%\cite{Denner:2005nn}
+C----\bibitem{Denner:2005nn}
+C---- A.~Denner and S.~Dittmaier,
+C---- %``Reduction schemes for one-loop tensor integrals,''
+C---- Nucl.\ Phys.\ B {\bf 734}, 62 (2006)
+C---- [arXiv:hep-ph/0509141].
+C---- %%CITATION = NUPHA,B734,62;%%
+ implicit none
+ include 'qlconstants.f'
+ double precision p1sq,m0s,m1s,m0sq,m1sq,musq
+ double complex xp,xm,b,rt,arg,arg1,qlfndd,cln
+ logical qlzero
+
+ m0sq=min(m0s,m1s)
+ m1sq=max(m0s,m1s)
+
+ if ((qlzero(abs(p1sq/musq)))
+ . .and. (qlzero(abs(m0sq/musq)))
+ . .and. (qlzero(abs(m1sq/musq)))) then
+ write(6,*) 'setting psq=m0sq=m1sq=0 self-energy to zero'
+ write(6,*) 'p1sq,m0sq,m1sq=',p1sq,m0sq,m1sq
+ qlI2fin=czip
+ return
+
+ elseif (qlzero(m0sq/musq)) then
+ arg=dcmplx(1d0-m1sq/p1sq)
+ arg1=dcmplx((m1sq-p1sq)/musq)
+
+C---deal with special cases for m0sq=0
+C----- (a,0,a) p1sq=m1sq, DD(4.13)
+ if (qlzero(abs(arg1))) then
+ qlI2fin=dcmplx(log(musq/m1sq))+ctwo
+C----- (0,0,a)
+ elseif (qlzero(abs(p1sq/musq))) then
+ qlI2fin=dcmplx(log(musq/m1sq))+cone
+C----- (a,0,0)
+ elseif (qlzero(abs(m1sq/musq))) then
+ qlI2fin=-cln(arg1,-1d0)+ctwo
+ else
+C----- (a,0,c)
+ qlI2fin=-cln(arg1,-1d0)+cone-qlfndd(0,arg,1d0)
+ endif
+ return
+ elseif (qlzero(abs(p1sq/musq))) then
+C---deal with special case, p1sq=0
+ if (qlzero(abs((m1sq-m0sq)/musq))) then ! (m1sq = m0sq)
+ qlI2fin=dcmplx(log(musq/m0sq))
+ else
+ xp=dcmplx(m0sq/(m0sq-m1sq)) ! other root is formally infinite
+ qlI2fin=dcmplx(log(musq/m0sq))-qlfndd(0,xp,1d0)
+ endif
+ else
+C----general case, DD (4.8)
+ b=dcmplx(m1sq-m0sq-p1sq)
+ rt=sqrt(dcmplx((m1sq-m0sq-p1sq)**2-4d0*p1sq*m0sq))
+ xp=0.5d0*(-b+rt)/p1sq
+ xm=0.5d0*(-b-rt)/p1sq
+
+ qlI2fin=dcmplx(log(musq/m0sq))-qlfndd(0,xp,1d0)-qlfndd(0,xm,-1d0)
+
+ endif
+ return
+
+ end
+
diff --git a/qcdloop-1.9/qlI3.f b/qcdloop-1.9/qlI3.f
new file mode 100644
index 0000000..30afa59
--- /dev/null
+++ b/qcdloop-1.9/qlI3.f
@@ -0,0 +1,71 @@
+ double complex function qlI3(p1,p2,p3,m1,m2,m3,mu2,ep)
+ implicit none
+ double precision p1,p2,p3,m1,m2,m3,mu2
+ integer ep
+C pi=p(i)^2, i=1,2,3 are the four-momentum squared of the external lines
+C mi=m(i)^2, i=1,2,3,are the squares of the masses of the internal lines
+C mu2 is the square of the scale mu
+C ep=-2,-1,0 chooses the coefficient in the Laurent series.
+
+ double precision psq(3),msq(3)
+ double precision p1o,p2o,p3o,m1o,m2o,m3o,mu2o,scalefac,newmu2
+ double complex Ival(-2:0)
+ integer epdum
+ logical qlzero
+ data p1o,p2o,p3o,m1o,m2o,m3o/6*0d0/
+ save Ival,p1o,p2o,p3o,m1o,m2o,m3o,mu2o
+
+
+C--If we have already calculated, use the saved value
+C--else setup the arrays
+ if ((p1 .eq. p1o)
+ . .and. (p2 .eq. p2o)
+ . .and. (p3 .eq. p3o)
+ . .and. (m1 .eq. m1o)
+ . .and. (m2 .eq. m2o)
+ . .and. (m3 .eq. m3o)
+ . .and. (mu2 .eq. mu2o)) then
+ qlI3=Ival(ep)
+ return
+ else
+C---recalculate
+ p1o=p1
+ p2o=p2
+ p3o=p3
+ m1o=m1
+ m2o=m2
+ m3o=m3
+ mu2o=mu2
+ endif
+
+ scalefac=max(abs(m1),abs(m2),abs(m3),abs(p1),abs(p2),abs(p3))
+
+ msq(1)=m1/scalefac
+ msq(2)=m2/scalefac
+ msq(3)=m3/scalefac
+ psq(1)=p1/scalefac
+ psq(2)=p2/scalefac
+ psq(3)=p3/scalefac
+ newmu2=mu2/scalefac
+C----sort msq in ascending order (and reorder psq correspondingly)
+ call qltrisort(psq,msq)
+
+C----If internal masses all qlzero, reorder abs(psq) in ascending order
+ if (qlzero(abs(msq(1)))
+ . .and. qlzero(abs(msq(2)))
+ . .and. qlzero(abs(msq(3)))) then
+ call qlsnglsort(3,psq)
+ endif
+
+C-----calculate value of integral
+ call qlI3sub(msq,psq,newmu2,Ival)
+
+C---apply the rescaling to the integral
+ do epdum=-2,0
+ Ival(epdum)=Ival(epdum)/scalefac
+ enddo
+
+ qlI3=Ival(ep)
+
+ return
+ end
diff --git a/qcdloop-1.9/qlI3fin.f b/qcdloop-1.9/qlI3fin.f
new file mode 100644
index 0000000..e962afe
--- /dev/null
+++ b/qcdloop-1.9/qlI3fin.f
@@ -0,0 +1,8 @@
+ subroutine qlI3fin(Ival0,xpi,ier)
+ implicit none
+ double complex Ival0
+ double precision xpi(6)
+ integer ier
+ ier = 0
+ call ffxc0(Ival0, xpi, ier)
+ end
diff --git a/qcdloop-1.9/qlI3sub.f b/qcdloop-1.9/qlI3sub.f
new file mode 100644
index 0000000..37f3f3e
--- /dev/null
+++ b/qcdloop-1.9/qlI3sub.f
@@ -0,0 +1,77 @@
+ subroutine qlI3sub(msq,psq,musq,Ival)
+C Calculates the general scalar triangle
+C assumes that the msq(i) are positive and ordered
+C so that msq(1) .le. msq(2) .le. msq(3)
+ implicit none
+ include 'qlconstants.f'
+ double precision msq(3),psq(3),musq,Y(3,3),xpi(6)
+ double complex Ival(-2:0)
+ integer j,massive,ier
+ logical qlzero, qlnonzero
+
+ do j=1,3
+ xpi(j)=msq(j)
+ xpi(j+3)=psq(j)
+ Y(j,j)=msq(j)
+ enddo
+ Y(1,2)=0.5d0*(msq(1)+msq(2)-psq(1))
+ Y(1,3)=0.5d0*(msq(1)+msq(3)-psq(3))
+ Y(2,3)=0.5d0*(msq(2)+msq(3)-psq(2))
+ Y(2,1)=Y(1,2)
+ Y(3,1)=Y(1,3)
+ Y(3,2)=Y(2,3)
+
+ massive=0
+ do j=1,3
+ if (qlnonzero(abs(msq(j)))) massive=massive+1
+ enddo
+
+ Ival(-2)=czip
+ Ival(-1)=czip
+
+C--------------three internal masses
+ if (massive .eq. 3) then
+ call qlI3fin(Ival(0),xpi,ier)
+
+C--------------two internal masses
+ elseif (massive .eq. 2) then
+ if (qlzero(abs(Y(1,2)))
+ . .and. qlzero(abs(Y(1,3)))) then
+ call qltri6(psq(2),msq(2),msq(3),musq,Ival)
+ else
+ call qlI3fin(Ival(0),xpi,ier)
+ endif
+
+C--------------one internal masses
+ elseif (massive .eq. 1) then
+ if (qlnonzero(abs(Y(1,2)))) then
+ call qlI3fin(Ival(0),xpi,ier)
+ else
+ if (qlzero(abs(Y(1,3))) .and.
+ . qlzero(abs(Y(2,3)))) then
+ call qltri5(msq(3),musq,Ival)
+ elseif (qlzero(abs(Y(1,3)))) then
+ call qltri4(psq(2),msq(3),musq,Ival)
+ elseif (qlzero(abs(Y(2,3)))) then
+ call qltri4(psq(3),msq(3),musq,Ival)
+ else
+ call qltri3(psq(2),psq(3),msq(3),musq,Ival)
+ endif
+ endif
+C--------------qlzero internal masses
+ elseif (massive .eq. 0) then
+ if (qlzero(abs(Y(1,2))) .and.
+ . qlzero(abs(Y(2,3)))) then
+ call qltri1(psq(3),musq,Ival)
+ elseif (qlzero(abs(Y(1,2)))) then
+ call qltri2(psq(2),psq(3),musq,Ival)
+ else
+ call qlI3fin(Ival(0),xpi,ier)
+ endif
+ endif
+ return
+ end
+
+
+
+
diff --git a/qcdloop-1.9/qlI4.f b/qcdloop-1.9/qlI4.f
new file mode 100644
index 0000000..adb774c
--- /dev/null
+++ b/qcdloop-1.9/qlI4.f
@@ -0,0 +1,44 @@
+ double complex function qlI4(p1,p2,p3,p4,s12,s23,
+ . m1,m2,m3,m4,mu2,ep)
+ implicit none
+ include 'ff.h'
+ double precision p1,p2,p3,p4,s12,s23,m1,m2,m3,m4,mu2,newmu2
+ integer ep,j
+C pi=p(i)^2, i=1,2,3,4 are momentum squared of the external lines
+C mi=m(i)^2 i=1,2,3,4 are masses squared of the internal lines
+C sij=(pi+pj)^2 are external invariants
+C mu2 is the square of the scale mu
+C ep=-2,-1,0 chooses the coefficient in the Laurent series.
+ double precision xpi(13),scalefac
+ double complex qlI4array
+
+C Uses the ordering for the routine xpi wanted by FF
+C psq(1) lies between msq(1) and msq(2) and so on
+C xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
+C xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
+C xpi(9-10) = s12,s23
+C xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+C xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+C xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+
+ xpi(1)=m1
+ xpi(2)=m2
+ xpi(3)=m3
+ xpi(4)=m4
+ xpi(5)=p1
+ xpi(6)=p2
+ xpi(7)=p3
+ xpi(8)=p4
+ xpi(9)=s12
+ xpi(10)=s23
+ xpi(11)=+xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+ xpi(12)=-xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+ xpi(13)=+xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+ scalefac=max(abs(s12),abs(s23),abs(p1),abs(p2),abs(p3),abs(p4))
+ do j=1,13
+ xpi(j)=xpi(j)/scalefac
+ enddo
+ newmu2=mu2/scalefac
+ qlI4=qlI4array(xpi,newmu2,ep)/scalefac**2
+ return
+ end
diff --git a/qcdloop-1.9/qlI4DNS41.f b/qcdloop-1.9/qlI4DNS41.f
new file mode 100644
index 0000000..a828ce8
--- /dev/null
+++ b/qcdloop-1.9/qlI4DNS41.f
@@ -0,0 +1,70 @@
+ subroutine qlI4DNS41(Y,musq,Ival0)
+ implicit none
+ include 'qlconstants.f'
+c-----Implementation of Eq.~(41) of
+c----- %\cite{Denner:1991qq}
+c----- %\cite{Denner:1991qq}
+c----- \bibitem{Denner:1991qq}
+c----- A.~Denner, U.~Nierste and R.~Scharf,
+c----- %``A Compact expression for the scalar one loop four point function,''
+c----- Nucl.\ Phys.\ B {\bf 367}, 637 (1991).
+c----- %%CITATION = NUPHA,B367,637;%%
+ double complex Ival0,discr,wlog(2),cln,z(2),k(4,4),lnsum,
+ . qlLi2omprod,a,b,c,d,bsq,fourac
+ double precision musq,Y(4,4),iep
+ integer i,j
+
+ do i=1,4
+ do j=1,4
+ k(i,j)=dcmplx(2d0*Y(i,j)/musq)
+ enddo
+ enddo
+
+ a=k(2,4)*k(3,4)
+ b=k(1,3)*k(2,4)+k(1,2)*k(3,4)-k(1,4)*k(2,3)
+ c=k(1,2)*k(1,3)
+ d=k(2,3)
+ bsq=b**2
+ fourac=4d0*a*c
+ discr=sqrt(bsq-fourac)
+
+ if (abs(discr) .lt. 1d-10*max(dble(bsq),dble(fourac))) then
+ z(1)=0.5d0*b/a
+ wlog(1)=dcmplx(dreal(cln(z(1),+1d0)))
+ Ival0=
+ . +k(3,4)*(cln(k(3,4),-1d0)+wlog(1)-cln(k(1,3),-1d0))
+ . /(k(3,4)*z(1)-k(1,3))
+ . +k(2,4)*(cln(k(2,4),-1d0)+wlog(1)-cln(k(1,2),-1d0))
+ . /(k(2,4)*z(1)-k(1,2))
+ . -(wlog(1)
+ . +cln(k(2,3),-1d0)+cln(k(1,4),-1d0)
+ . -cln(k(1,3),-1d0)-cln(k(1,2),-1d0))/z(1)
+
+ Ival0=Ival0/(musq**2*a)
+ return
+ else
+C----wlogi=log(-xi),zi=-xi
+ z(1)=0.5d0*(b-discr)/a
+ z(2)=0.5d0*(b+discr)/a
+ iep=sign(1d0,dreal(d))
+C-----z(1) comes with + i*ep*d
+C-----z(2) comes with - i*ep*d
+ wlog(1)=cln(z(1),+iep)
+ wlog(2)=cln(z(2),-iep)
+ lnsum=+cln(k(1,2),-1d0)+cln(k(1,3),-1d0)
+ . -cln(k(1,4),-1d0)-cln(k(2,3),-1d0)
+ Ival0=czip
+ do j=1,2
+ iep=-dfloat(2*j-3)*iep
+ Ival0=Ival0+dfloat(2*j-3)*(
+ . -0.5d0*wlog(j)**2+wlog(j)*lnsum
+ . -qlLi2omprod(k(3,4),k(1,3),z(j),iep)
+ . -qlLi2omprod(k(2,4),k(1,2),z(j),iep))
+
+
+ enddo
+
+ Ival0=Ival0/(musq**2*discr)
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlI4array.f b/qcdloop-1.9/qlI4array.f
new file mode 100644
index 0000000..4c7a575
--- /dev/null
+++ b/qcdloop-1.9/qlI4array.f
@@ -0,0 +1,60 @@
+ Double complex function qlI4array(xpi,musq,ep)
+ implicit none
+ include 'qlconstants.f'
+ logical qlnonzero
+ double precision xpi(13),xpio(13),musq,musqo
+ integer ep,j,massive,ier,Npt
+ double complex Ival(-2:0)
+ parameter(Npt=10)
+ data xpio/13*0d0/
+ save Ival,xpio,musqo
+
+C--If we have already calculated this qlI4, use the saved value
+C--else setup the arrays
+ if ((xpi(1) .eq. xpio(1))
+ . .and. (xpi(2) .eq. xpio(2))
+ . .and. (xpi(3) .eq. xpio(3))
+ . .and. (xpi(4) .eq. xpio(4))
+ . .and. (xpi(5) .eq. xpio(5))
+ . .and. (xpi(6) .eq. xpio(6))
+ . .and. (xpi(7) .eq. xpio(7))
+ . .and. (xpi(8) .eq. xpio(8))
+ . .and. (xpi(9) .eq. xpio(9))
+ . .and. (xpi(10) .eq. xpio(10))
+ . .and. (musq .eq. musqo)) then
+ qlI4array=Ival(ep)
+ return
+ else
+C-- save new array as old
+ do j=1,Npt
+ xpio(j)=xpi(j)
+ enddo
+ musqo=musq
+
+C--- count number of internal masses
+ massive=0
+ do j=1,4
+ if (qlnonzero(xpi(j))) massive=massive+1
+ enddo
+
+ if (massive .eq. 0) then
+ call qlI4sub0m(xpi,musq,Ival)
+ elseif (massive .eq. 1) then
+ call qlI4sub1m(xpi,musq,Ival)
+ elseif (massive .eq. 2) then
+ call qlI4sub2m(xpi,musq,Ival)
+ elseif (massive .eq. 3) then
+ call qlI4sub3m(xpi,musq,Ival)
+ elseif (massive .eq. 4) then
+ xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+ xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+ xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+ Ival(-2)=czip
+ Ival(-1)=czip
+ ier = 0
+ call qlI4fin(Ival(0),xpi,ier)
+ endif
+ endif
+ qlI4array=Ival(ep)
+ return
+ end
diff --git a/qcdloop-1.9/qlI4fin.f b/qcdloop-1.9/qlI4fin.f
new file mode 100644
index 0000000..c1e4fed
--- /dev/null
+++ b/qcdloop-1.9/qlI4fin.f
@@ -0,0 +1,8 @@
+ subroutine qlI4fin(Ival0,xpi,ier)
+ double complex Ival0
+ double precision xpi(13)
+ integer ier
+
+ ier = 0
+ call ffxd0(Ival0, xpi, ier)
+ end
diff --git a/qcdloop-1.9/qlI4sub0m.f b/qcdloop-1.9/qlI4sub0m.f
new file mode 100644
index 0000000..ed0ae5b
--- /dev/null
+++ b/qcdloop-1.9/qlI4sub0m.f
@@ -0,0 +1,110 @@
+ subroutine qlI4sub0m(xpi,musq,Ival)
+ implicit none
+C Uses the ordering for the routine xpi wanted by FF
+C psq(1) lies between msq(1) and msq(2) and so on
+C xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
+C xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
+C xpi(9-10) = s12,s23
+C xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+C xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+C xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+C Calculates the general box with qlzero masses
+ include 'qlconstants.f'
+ double precision xpi(13),xpiout(13),musq,Y(4,4),Yalt(4,4)
+ double complex Ival(-2:0)
+ integer j,offshell,swap(13,4),jsort1,jsort2,jsort0,jdiff,Npt,
+ . jsort(4)
+ logical qlnonzero,swapped
+ parameter(Npt=13)
+ data swap/
+ . 4,1,2,3,8,5,6,7,10,9,11,13,12,
+ . 3,4,1,2,7,8,5,6,9,10,11,12,13,
+ . 2,3,4,1,6,7,8,5,10,9,11,13,12,
+ . 1,2,3,4,5,6,7,8,9,10,11,12,13/
+ data jsort/4,1,2,3/
+ save swap
+
+ call qlxpicheck(xpi)
+
+ do j=1,4
+ if (qlnonzero(xpi(j))) then
+ write(6,*) 'qlI4sub0m called in error:j,xpi(j)',j,xpi(j)
+ stop
+ endif
+ enddo
+
+ offshell=0
+ jsort1=0
+ jsort2=0
+ do j=1,4
+ if (qlnonzero(xpi(j+4))) then
+ offshell=offshell+1
+ if (jsort1 .eq. 0) then
+ jsort1=j
+ else
+ jsort2=j
+ endif
+ else
+ jsort0=j
+ endif
+
+ enddo
+
+ jdiff=jsort2-jsort1
+ swapped=.true.
+ if ((offshell .eq. 1)) then
+ do j=1,Npt
+ xpiout(swap(j,jsort1))=xpi(j)
+ enddo
+ elseif ((offshell .eq. 2) .and. (jdiff .eq. 2)) then
+ do j=1,Npt
+ xpiout(swap(j,jsort2))=xpi(j)
+ enddo
+ elseif ((offshell .eq. 2) .and. (jdiff .eq. 1)) then
+ do j=1,Npt
+ xpiout(swap(j,jsort2))=xpi(j)
+ enddo
+ elseif ((offshell .eq. 2) .and. (jdiff .eq. 3)) then
+ do j=1,Npt
+ xpiout(swap(j,1))=xpi(j)
+ enddo
+ elseif (offshell .eq. 3) then
+ do j=1,Npt
+ xpiout(swap(j,jsort(jsort0)))=xpi(j)
+ enddo
+ else
+ swapped=.false.
+ endif
+
+C--if we performed a swap rename the array
+ if (swapped) then
+ do j=1,13
+ xpi(j)=xpiout(j)
+ enddo
+ endif
+
+ call qlYcalc(xpi,Y,Yalt)
+C--------------four offshell external lines
+ if (offshell .eq. 4) then
+ Ival(-2)=czip
+ Ival(-1)=czip
+ call qlI4DNS41(Y,musq,Ival(0))
+C--------------three offshell external lines
+ elseif (offshell .eq. 3) then
+ call qlbox5(Y,musq,Ival)
+C--------------two offshell external lines
+ elseif (offshell .eq. 2) then
+ if ((qlnonzero(xpi(6))).and.(qlnonzero(xpi(6)))) then
+c opposite-easy
+ call qlbox3(Y,musq,Ival)
+c adjacent-hard
+ elseif ((qlnonzero(xpi(7))).and.(qlnonzero(xpi(8)))) then
+ call qlbox4(Y,musq,Ival)
+ endif
+ elseif (offshell .eq. 1) then
+ call qlbox2(Y,musq,Ival)
+ elseif (offshell .eq. 0) then
+ call qlbox1(Y,musq,Ival)
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlI4sub1m.f b/qcdloop-1.9/qlI4sub1m.f
new file mode 100644
index 0000000..0da7363
--- /dev/null
+++ b/qcdloop-1.9/qlI4sub1m.f
@@ -0,0 +1,101 @@
+ subroutine qlI4sub1m(xpi,musq,Ival)
+ implicit none
+C Uses the ordering for the routine xpi wanted by FF
+C psq(1) lies between msq(1) and msq(2) and so on
+C xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
+C xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
+C xpi(9-10) = s12,s23
+C xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+C xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+C xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+C Calculates the general box with qlzero masses
+ include 'qlconstants.f'
+ logical qlnonzero,qlzero
+ double precision xpi(13),musq,xpiout(13),Y(4,4),Yalt(4,4)
+ double complex Ival(-2:0)
+ integer j,jsort,massive,swap(13,5),ier,Npt
+ parameter(Npt=13)
+ data swap/
+ . 4,1,2,3,8,5,6,7,10,9,11,13,12,
+ . 3,4,1,2,7,8,5,6,9,10,11,12,13,
+ . 2,3,4,1,6,7,8,5,10,9,11,13,12,
+ . 1,2,3,4,5,6,7,8,9,10,11,12,13,
+ . 3,2,1,4,6,5,8,7,9,10,11,12,13/
+
+ call qlxpicheck(xpi)
+
+ massive=0
+ do j=1,4
+ if (qlnonzero(xpi(j))) then
+ massive=massive+1
+ jsort=j
+ endif
+ enddo
+
+ do j=1,Npt
+ xpiout(swap(j,jsort))=xpi(j)
+ enddo
+
+ do j=1,Npt
+ xpi(j)=xpiout(j)
+ enddo
+
+ call qlYcalc(xpiout,Y,Yalt)
+ if ((qlnonzero(Y(1,1))).or.(qlnonzero(Y(2,2)))
+ . .or.(qlnonzero(Y(3,3)))) then
+ write(6,*) 'qlI4sub1m fails: wrong ordering'
+ stop
+ endif
+
+ if ((qlzero(Y(1,2)))
+ . .and.(qlzero(Y(2,3)))
+ . .and.(qlzero(Y(3,4)))
+ . .and.(qlzero(Y(4,1)))) then
+C box6 $I_4(0,0,m^2,m^2;s_{12},s_{23};0,0,0,m^2)$}
+ call qlbox6(Y,musq,Ival)
+
+ elseif((qlzero(Y(1,2)))
+ . .and.(qlzero(Y(2,3)))
+ . .and.(qlzero(Y(3,4)))) then
+C box7 $I_4(0,0,m^2,\pq^2;s_{12},s_{23};0,0,0,m^2)$}
+ call qlbox7(Y,musq,Ival)
+
+ elseif((qlzero(Y(1,2)))
+ . .and.(qlzero(Y(2,3)))
+ . .and.(qlzero(Y(1,4)))) then
+C box7a $I_4(0,0,\pt^2,m^2;s_{12},s_{23};0,0,0,m^2)$}
+ call qlbox7(Yalt,musq,Ival)
+
+ elseif((qlzero(Y(1,2)))
+ . .and.(qlzero(Y(2,3)))) then
+C box8 $I_4(0,0,\pt^2,\pq^2; s_{12},s_{23};0,0,0,m^2)$}
+ call qlbox8(Y,musq,Ival)
+
+ elseif((qlzero(Y(1,2)))
+ . .and.(qlzero(Y(1,4)))) then
+C box9 $I_4(0,p_2^2,p_3^2,m^2;s_{12},s_{23};0,0,0,m^2)$}
+ call qlbox9(Y,musq,Ival)
+
+ elseif((qlzero(Y(2,3)))
+ . .and.(qlzero(Y(3,4)))) then
+C box9a $I_4(0,p_2^2,p_3^2,m^2;s_{12},s_{23};0,0,0,m^2)$}
+ call qlbox9(Yalt,musq,Ival)
+
+ elseif (qlzero(Y(1,2))) then
+C box10 $I_4(0,p_2^2,p_3^2,p_4^2;s_{12},s_{23};0,0,0,m^2)$}
+ call qlbox10(Y,musq,Ival)
+
+C box10 $I_4(p_1^2,0,p_3^2,p_4^2;s_{12},s_{23};0,0,0,m^2)$}
+ elseif (qlzero(Y(2,3))) then
+ call qlbox10(Yalt,musq,Ival)
+ else
+ Ival(-2)=czip
+ Ival(-1)=czip
+ xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+ xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+ xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+ call qlI4fin(Ival(0),xpi,ier)
+ endif
+
+ return
+ end
diff --git a/qcdloop-1.9/qlI4sub2m.f b/qcdloop-1.9/qlI4sub2m.f
new file mode 100644
index 0000000..59cdd46
--- /dev/null
+++ b/qcdloop-1.9/qlI4sub2m.f
@@ -0,0 +1,64 @@
+ subroutine qlI4sub2m(xpi,musq,Ival)
+ implicit none
+C Uses the ordering for the routine xpi wanted by FF
+C psq(1) lies between msq(1) and msq(2) and so on
+C xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
+C xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
+C xpi(9-10) = s12,s23
+C xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+C xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+C xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+C Calculates the general box with qlzero masses
+ logical qlnonzero
+ double precision xpi(13),musq,xpiout(13)
+ double complex Ival(-2:0)
+ integer j,jsort1,jsort2,massive,swap(13,5),jdiff,Npt
+ parameter(Npt=13)
+ data swap/
+ . 4,1,2,3,8,5,6,7,10,9,11,12,13,
+ . 3,4,1,2,7,8,5,6,9,10,11,12,13,
+ . 2,3,4,1,6,7,8,5,10,9,11,12,13,
+ . 1,2,3,4,5,6,7,8,9,10,11,12,13,
+ . 3,2,1,4,6,5,8,7,9,10,11,12,13/
+
+ call qlxpicheck(xpi)
+
+ massive=0
+ jsort1=0
+ jsort2=0
+ do j=1,4
+ if (qlnonzero(xpi(j))) then
+ massive=massive+1
+ if (jsort1 .eq. 0) then
+ jsort1=j
+ else
+ jsort2=j
+ endif
+ endif
+ enddo
+ if (massive .ne. 2) then
+ write(6,*) 'Error in qlI4sum2m: not exactly two masses'
+ write(6,*) 'xpi(1-4)',xpi(1),xpi(2),xpi(3),xpi(4)
+ stop
+ endif
+
+ jdiff=jsort2-jsort1
+
+ if ((jdiff .eq. 1) .or. (jdiff .eq. 2)) then
+ do j=1,Npt
+ xpiout(swap(j,jsort2))=xpi(j)
+ enddo
+ elseif ((jdiff .eq. 3)) then
+ do j=1,Npt
+ xpiout(swap(j,1))=xpi(j)
+ enddo
+ endif
+
+ if (jdiff .eq. 2) then
+ call qlI4sub2mo(xpiout,musq,Ival)
+ else
+ call qlI4sub2ma(xpiout,musq,Ival)
+ endif
+
+ return
+ end
diff --git a/qcdloop-1.9/qlI4sub2ma.f b/qcdloop-1.9/qlI4sub2ma.f
new file mode 100644
index 0000000..7dfe6b7
--- /dev/null
+++ b/qcdloop-1.9/qlI4sub2ma.f
@@ -0,0 +1,50 @@
+ subroutine qlI4sub2ma(xpi,musq,Ival)
+ implicit none
+C--- Calculates the boxes with two adjacent internal mass
+
+C Uses the ordering for the routine xpi wanted by FF
+C psq(1) lies between msq(1) and msq(2) and so on
+C xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
+C xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
+C xpi(9-10) = s12,s23
+C xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+C xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+C xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+
+ include 'qlconstants.f'
+ double precision xpi(13),musq,Y(4,4),Yalt(4,4)
+ double complex Ival(-2:0)
+ integer ier
+ logical qlzero,qlnonzero
+
+ call qlYcalc(xpi,Y,Yalt)
+
+ if ((qlzero(Y(1,2)))
+ . .and. (qlzero(Y(2,3)))
+ . .and. (qlzero(Y(1,4)))) then
+ call qlbox11(Y,musq,Ival)
+
+ elseif((qlzero(Y(1,2)))
+ . .and. (qlzero(Y(2,3)))
+ . .and. (qlnonzero(Y(1,4)))) then
+ call qlbox12(Y,musq,Ival)
+
+ elseif((qlzero(Yalt(1,2)))
+ . .and. (qlzero(Yalt(2,3)))
+ . .and. (qlnonzero(Yalt(1,4)))) then
+ call qlbox12(Yalt,musq,Ival)
+
+ elseif((qlzero(Y(1,2)))
+ . .and. (qlnonzero(Y(2,3)))
+ . .and. (qlnonzero(Y(1,4)))) then
+ call qlbox13(Y,musq,Ival)
+ else
+ Ival(-2)=czip
+ Ival(-1)=czip
+ xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+ xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+ xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+ call qlI4fin(Ival(0),xpi,ier)
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlI4sub2mo.f b/qcdloop-1.9/qlI4sub2mo.f
new file mode 100644
index 0000000..6cc8a6b
--- /dev/null
+++ b/qcdloop-1.9/qlI4sub2mo.f
@@ -0,0 +1,58 @@
+ subroutine qlI4sub2mo(xpi,musq,Ival)
+ implicit none
+C--- Calculates the box with two opposite internal masses
+
+C Uses the ordering for the routine xpi wanted by FF
+C psq(1) lies between msq(1) and msq(2) and so on
+C xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
+C xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
+C xpi(9-10) = s12,s23
+C xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+C xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+C xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+
+ include 'qlconstants.f'
+ double precision xpi(13),musq,Y(4,4),Yalt(4,4)
+ double complex Ival(-2:0)
+ logical qlnonzero,qlzero
+ integer ier
+
+ If (qlnonzero(xpi(1)) .or. qlnonzero(xpi(3))) then
+ write(6,*) 'Error in qlI4sub2mo,qlnonzero m1sq or m3sq',xpi(1),xpi(3)
+ stop
+ endif
+
+ call qlYcalc(xpi,Y,Yalt)
+C----case 14
+ if ((qlzero(Y(1,1)))
+ . .and. (qlzero(Y(3,3)))
+ . .and. (qlzero(Y(1,2)))
+ . .and. (qlzero(Y(1,4)))
+ . .and. (qlzero(Y(2,3)))
+ . .and. (qlzero(Y(3,4)))) then
+ call qlbox14(Y,musq,Ival)
+
+C----case 15
+ elseif((qlzero(Y(1,1)))
+ . .and. (qlzero(Y(3,3)))
+ . .and. (qlzero(Y(1,2)))
+ . .and. (qlzero(Y(1,4))))then
+ call qlbox15(Y,musq,Ival)
+
+ elseif((qlzero(Y(1,1)))
+ . .and. (qlzero(Y(3,3)))
+ . .and. (qlzero(Y(2,3)))
+ . .and. (qlzero(Y(3,4))))then
+ call qlbox15(Yalt,musq,Ival)
+
+ else
+ Ival(-2)=czip
+ Ival(-1)=czip
+ xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+ xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+ xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+ call qlI4fin(Ival(0),xpi,ier)
+ endif
+
+ return
+ end
diff --git a/qcdloop-1.9/qlI4sub3m.f b/qcdloop-1.9/qlI4sub3m.f
new file mode 100644
index 0000000..f2babd6
--- /dev/null
+++ b/qcdloop-1.9/qlI4sub3m.f
@@ -0,0 +1,60 @@
+ subroutine qlI4sub3m(xpi,musq,Ival)
+ implicit none
+C Calculates divergent integral with three mass
+C I_4^{\{D=4-2 \e\}}(m_2^2,\pd^2,\pt^2,m_4^2;s_{12},s_{23};0,m_2^2,m_3^2,m_4^2)
+C as well as finite integrals using ff
+
+C Uses the ordering for the routine xpi wanted by FF
+C psq(1) lies between msq(1) and msq(2) and so on
+C xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
+C xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
+C xpi(9-10) = s12,s23
+C xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+C xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+C xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+ include 'qlconstants.f'
+ double precision xpi(13),musq,
+ . xpo(13),Y(4,4),Yalt(4,4)
+ double complex Ival(-2:0)
+ integer j,jsort,swap(13,4),ier,Npt
+ logical qlzero
+ parameter(Npt=13)
+ data swap/
+ . 1,2,3,4,5,6,7,8,9,10,11,12,13,
+ . 4,1,2,3,8,5,6,7,10,9,11,13,12,
+ . 3,4,1,2,7,8,5,6,9,10,11,12,13,
+ . 2,3,4,1,6,7,8,5,10,9,11,13,12
+ . /
+
+ save swap
+
+ call qlxpicheck(xpi)
+
+ jsort=0
+ do j=1,4
+ if (qlzero(xpi(j))) jsort=j
+ enddo
+
+ do j=1,Npt
+ xpo(swap(j,jsort))=xpi(j)
+ enddo
+
+ Ival(-2)=czip
+ Ival(-1)=czip
+
+ call qlYcalc(xpo,Y,Yalt)
+
+C--- divergent three mass box
+ if ((qlzero(Y(1,1)))
+ . .and.(qlzero(Y(1,2)))
+ . .and.(qlzero(Y(1,4)))) then
+ call qlbox16(Y,musq,Ival)
+C--- finite three mass box
+ else
+ xpo(11) = +xpo(5)+xpo(6)+xpo(7)+xpo(8)-xpo(9)-xpo(10)
+ xpo(12) = -xpo(5)+xpo(6)-xpo(7)+xpo(8)+xpo(9)+xpo(10)
+ xpo(13) = +xpo(5)-xpo(6)+xpo(7)-xpo(8)+xpo(9)+xpo(10)
+ call qlI4fin(Ival(0),xpo,ier)
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlLi2omprod.f b/qcdloop-1.9/qlLi2omprod.f
new file mode 100644
index 0000000..aa2a2b5
--- /dev/null
+++ b/qcdloop-1.9/qlLi2omprod.f
@@ -0,0 +1,53 @@
+ double complex function qlLi2omprod(v,w,z,iep)
+ implicit none
+ include 'qlconstants.f'
+c expression for dilog(1-(v-i*ep)/(w-i*ep)*(z+iep))
+C for real v,w and complex z
+ double precision v,w,y,ddilog,rarg,omrarg,iep
+ double complex qllnrat,lnarg,lnomarg,prod,arg,omarg,z,cln,
+ . denspence
+ if (abs(dimag(z)) .lt. 1d-15) then
+C----case for real z
+ y=dreal(z)
+ rarg=v*y/w
+ omrarg=1d0-rarg
+ if (rarg .le. 1d0) then
+ if (rarg .eq. 0d0 .or. rarg .eq. 1d0) then
+ prod=0d0
+ else
+ lnarg=qllnrat(v,w)+cln(z,iep)
+ lnomarg=dcmplx(log(omrarg))
+ prod=lnarg*lnomarg
+ endif
+ qlLi2omprod=dcmplx(pisqo6-ddilog(rarg))-prod
+ elseif (rarg .gt. 1d0) then
+ rarg=w/(y*v)
+ lnarg=-qllnrat(v,w)-cln(z,iep)
+ lnomarg=dcmplx(log(1d0-rarg))
+ qlLi2omprod=-dcmplx(pisqo6-ddilog(rarg))+lnarg*lnomarg
+ . -0.5d0*lnarg**2
+ endif
+ else
+C----case for complex z
+ arg=dcmplx(v/w)*z
+ omarg=cone-arg
+ if (abs(arg) .le. 1d0) then
+ if (abs(arg) .eq. 0d0 .or. abs(arg) .eq. 1d0) then
+ prod=0d0
+ else
+ lnarg=qllnrat(v,w)+cln(z,iep)
+ lnomarg=log(omarg)
+ prod=lnarg*lnomarg
+ endif
+ qlLi2omprod=dcmplx(pisqo6)-denspence(arg,1d0)-prod
+ elseif (abs(arg) .gt. 1d0) then
+ arg=w/(z*v)
+ lnarg=-qllnrat(v,w)-cln(z,iep)
+ lnomarg=log(cone-arg)
+ qlLi2omprod=-dcmplx(pisqo6)+denspence(arg,1d0)+lnarg*lnomarg
+ . -0.5d0*lnarg**2
+ endif
+
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlLi2omrat.f b/qcdloop-1.9/qlLi2omrat.f
new file mode 100644
index 0000000..bd04913
--- /dev/null
+++ b/qcdloop-1.9/qlLi2omrat.f
@@ -0,0 +1,18 @@
+ double complex function qlLi2omrat(x,y)
+ implicit none
+ include 'qlconstants.f'
+c expression for dilog(1-(x-i*ep)/(y-i*ep)) for real x and y
+c Hence arguments are typically negative invariants
+ double precision x,y,omarg,arg,ddilog
+ double complex qllnrat,wlog
+ omarg=x/y
+ arg=1d0-omarg
+ if (arg .gt. 1d0) then
+ wlog=qllnrat(x,y)
+ qlLi2omrat=dcmplx(pisqo6-ddilog(omarg))-log(arg)*wlog
+ else
+ qlLi2omrat=dcmplx(ddilog(arg))
+ endif
+
+ return
+ end
diff --git a/qcdloop-1.9/qlLi2omx.f b/qcdloop-1.9/qlLi2omx.f
new file mode 100644
index 0000000..7c3b876
--- /dev/null
+++ b/qcdloop-1.9/qlLi2omx.f
@@ -0,0 +1,28 @@
+ double complex function qlLi2omx(x1,x2,ieps1,ieps2)
+C Calculate Li[2](1-(x1+ieps1)*(x2+ieps2)) for real x1,x2
+C Using +Li2(1-x1*x2) for x1*x2<1
+C and -Li2(1-1/(x1*x2))-1/2*(ln(x1)+ln(x2))^2 for x1*x2>1
+ implicit none
+ include 'qlconstants.f'
+ double precision x1,x2,arg,ieps1,ieps2,ieps
+ double complex ln,lnarg,lnomarg,prod,denspence
+ arg=x1*x2
+ ieps=sign(one,x2*ieps1+x1*ieps2)
+ if (arg .le. 1d0) then
+ if (arg.eq. 1d0 .or. arg .eq.0d0) then
+ prod=0d0
+ else
+ lnarg=ln(x1,ieps1)+ln(x2,ieps2)
+ lnomarg=dcmplx(log(1d0-arg),0d0)
+ prod=lnarg*lnomarg
+ endif
+ qlLi2omx=dcmplx(pisqo6)-denspence(dcmplx(arg),ieps)-prod
+ elseif (arg .gt. 1d0) then
+ arg=1d0/(x1*x2)
+ lnarg=-ln(x1,ieps1)-ln(x2,ieps2)
+ lnomarg=dcmplx(log(1d0-arg),0d0)
+ qlLi2omx=-dcmplx(pisqo6)+denspence(dcmplx(arg),ieps)
+ . +lnarg*lnomarg-0.5d0*lnarg**2
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlLi2omx2.f b/qcdloop-1.9/qlLi2omx2.f
new file mode 100644
index 0000000..0714f53
--- /dev/null
+++ b/qcdloop-1.9/qlLi2omx2.f
@@ -0,0 +1,27 @@
+ double complex function qlLi2omx2(v,w,x,y)
+ implicit none
+ include 'qlconstants.f'
+c expression for dilog(1-(v-i*ep)*(w-i*ep)/(x-i*ep)/(y-i*ep))
+C for real v,w,x and y
+ double precision v,w,x,y,omarg,arg,ddilog
+ double complex qllnrat,lnarg,lnomarg,prod
+ arg=(v*w)/(x*y)
+ omarg=1d0-arg
+ if (arg .le. 1d0) then
+ if (arg .eq. 0d0 .or. arg .eq. 1d0) then
+ prod=0d0
+ else
+ lnarg=qllnrat(v,x)+qllnrat(w,y)
+ lnomarg=dcmplx(log(omarg))
+ prod=lnarg*lnomarg
+ endif
+ qlLi2omx2=dcmplx(pisqo6-ddilog(arg))-prod
+ elseif (arg .gt. 1d0) then
+ arg=(x*y)/(v*w)
+ lnarg=-qllnrat(v,x)-qllnrat(w,y)
+ lnomarg=dcmplx(log(1d0-arg))
+ qlLi2omx2=-dcmplx(pisqo6-ddilog(arg))+lnarg*lnomarg
+ . -0.5d0*lnarg**2
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlYcalc.f b/qcdloop-1.9/qlYcalc.f
new file mode 100644
index 0000000..68970cc
--- /dev/null
+++ b/qcdloop-1.9/qlYcalc.f
@@ -0,0 +1,99 @@
+ subroutine qlYcalc(xpi,Y,Yalt)
+C----Calculate Y from xpi
+C----Assumes, if we have 1 internal mass it is position 4
+C----Assumes, if we have 2 internal masses they are positions 3,4 or 2,4
+ implicit none
+ include 'qlconstants.f'
+ double precision xpi(13),Y(4,4),Yalt(4,4)
+ logical opposite,qlnonzero,qlzero
+ integer j,k,massive
+ massive=0
+ do j=1,4
+ if (qlnonzero(xpi(j))) massive=massive+1
+ do k=1,4
+ Yalt(j,k)=0d0
+ enddo
+ enddo
+ if (qlzero(xpi(3))) then
+ opposite=.true.
+ else
+ opposite=.false.
+ endif
+
+ Y(1,1)=xpi(1)
+ Y(2,2)=xpi(2)
+ Y(3,3)=xpi(3)
+ Y(4,4)=xpi(4)
+ Y(1,2)=half*(xpi(1)+xpi(2)-xpi(5))
+ Y(1,3)=half*(xpi(1)+xpi(3)-xpi(9))
+ Y(1,4)=half*(xpi(1)+xpi(4)-xpi(8))
+ Y(2,1)=Y(1,2)
+ Y(2,3)=half*(xpi(2)+xpi(3)-xpi(6))
+ Y(2,4)=half*(xpi(2)+xpi(4)-xpi(10))
+ Y(3,1)=Y(1,3)
+ Y(3,2)=Y(2,3)
+ Y(3,4)=half*(xpi(3)+xpi(4)-xpi(7))
+ Y(4,1)=Y(1,4)
+ Y(4,2)=Y(2,4)
+ Y(4,3)=Y(3,4)
+
+ if (massive .eq. 0) then
+ Yalt(1,1)=zip
+ Yalt(2,2)=zip
+ Yalt(3,3)=zip
+ Yalt(4,4)=zip
+ Yalt(1,2)=zip
+ Yalt(1,3)=zip
+ Yalt(1,4)=zip
+ Yalt(2,3)=zip
+ Yalt(2,4)=zip
+ Yalt(3,4)=zip
+ elseif (massive .eq. 1) then
+C---exchange (1<-->3)
+ Yalt(1,1)=Y(3,3)
+ Yalt(2,2)=Y(2,2)
+ Yalt(3,3)=Y(1,1)
+ Yalt(4,4)=Y(4,4)
+ Yalt(1,2)=Y(2,3)
+ Yalt(1,3)=Y(1,3)
+ Yalt(1,4)=Y(3,4)
+ Yalt(2,3)=Y(1,2)
+ Yalt(2,4)=Y(2,4)
+ Yalt(3,4)=Y(1,4)
+ elseif ((massive .eq. 2) .and. (opposite .eqv. .true.)) then
+C---exchange (2<-->4) .and (1<-->3)
+ Yalt(1,1)=Y(3,3)
+ Yalt(2,2)=Y(4,4)
+ Yalt(3,3)=Y(1,1)
+ Yalt(4,4)=Y(2,2)
+ Yalt(1,2)=Y(3,4)
+ Yalt(1,3)=Y(1,3)
+ Yalt(1,4)=Y(2,3)
+ Yalt(2,3)=Y(1,4)
+ Yalt(2,4)=Y(2,4)
+ Yalt(3,4)=Y(1,2)
+
+ elseif ((massive .eq. 2) .and. (opposite .eqv. .false.)) then
+C---exchange (1<-->2)and(3<-->4)
+ Yalt(1,1)=Y(2,2)
+ Yalt(2,2)=Y(1,1)
+ Yalt(3,3)=Y(4,4)
+ Yalt(4,4)=Y(3,3)
+ Yalt(1,2)=Y(1,2)
+ Yalt(3,4)=Y(3,4)
+ Yalt(1,3)=Y(2,4)
+ Yalt(1,4)=Y(2,3)
+ Yalt(2,3)=Y(1,4)
+ Yalt(2,4)=Y(1,3)
+ endif
+
+C----symmetrize Y
+ do j=1,4
+ do k=j+1,4
+ Y(k,j)=Y(j,k)
+ Yalt(k,j)=Yalt(j,k)
+ enddo
+ enddo
+
+ return
+ end
diff --git a/qcdloop-1.9/qlbox1.f b/qcdloop-1.9/qlbox1.f
new file mode 100644
index 0000000..a732188
--- /dev/null
+++ b/qcdloop-1.9/qlbox1.f
@@ -0,0 +1,42 @@
+ subroutine qlbox1(Y,musq,Ires)
+c $I_4^{D=4-2 \epsilon}(0,0,0,0;s_{12},s_{23};0,0,0,0)$}
+c----%\cite{Bern:1993kr}
+c----\bibitem{Bern:1993kr}
+c---- Z.~Bern, L.~J.~Dixon and D.~A.~Kosower,
+c---- %``Dimensionally regulated pentagon integrals,''
+c---- Nucl.\ Phys.\ B {\bf 412}, 751 (1994)
+c---- [arXiv:hep-ph/9306240].
+c---- %%CITATION = HEP-PH 9306240;%%
+c---- Eqn (I.11)
+c----Cayley matrix
+c [ s12 ]
+c [ 0 0 - --- 0 ]
+c [ 2 ]
+c [ ]
+c [ s23 ]
+c [ 0 0 0 - --- ]
+c [ 2 ]
+c Y1 = [ ]
+c [ s12 ]
+c [ - --- 0 0 0 ]
+c [ 2 ]
+c [ ]
+c [ s23 ]
+c [ 0 - --- 0 0 ]
+c [ 2 ]
+ implicit none
+ include 'qlconstants.f'
+ double precision musq,Y(4,4),si,ta
+ double complex Ires(-2:0),qllnrat,fac
+
+ si=two*Y(1,3)
+ ta=two*Y(2,4)
+ fac=dcmplx(1d0/(si*ta))
+ Ires(-2)=fac*ctwo*ctwo
+ Ires(-1)=fac*ctwo*(
+ . -qllnrat(ta,musq)-qllnrat(si,musq))
+ Ires( 0)=fac*(qllnrat(ta,musq)**2+qllnrat(si,musq)**2
+ . -qllnrat(ta,si)**2-dcmplx(pi**2))
+ return
+ end
+
diff --git a/qcdloop-1.9/qlbox10.f b/qcdloop-1.9/qlbox10.f
new file mode 100644
index 0000000..9cd3979
--- /dev/null
+++ b/qcdloop-1.9/qlbox10.f
@@ -0,0 +1,73 @@
+ subroutine qlbox10(Y,musq,Ires)
+ implicit none
+C I^{\{D=4-2 \epsilon\}}_4(0,p_2^2,p_3^2,p_4^2;s_{12},s_{23};0,0,0,m^2)
+
+c [ s12 msq - p4sq ]
+c [ 0 0 - --- ---------- ]
+c [ 2 2 ]
+c [ ]
+c [ p2sq msq - s23 ]
+c [ 0 0 - ---- --------- ]
+c [ 2 2 ]
+c y10 = [ ]
+c [ s12 p2sq msq - p3sq ]
+c [ - --- - ---- 0 ---------- ]
+c [ 2 2 2 ]
+c [ ]
+c [ msq - p4sq msq - s23 msq - p3sq ]
+c [ ---------- --------- ---------- msq ]
+c [ 2 2 2 ]
+
+ include 'qlconstants.f'
+ integer iep
+ double precision msq,musq,
+ . si,tabar,mean,fac,m3sqbar,m4sqbar,mp2sq,Y(4,4)
+ double complex qlLi2omrat,qlLi2omx2,dilog(5),Ires(-2:0),qllnrat,
+ . wlogtmu,wlogsmu,wlog2mu,wlog4mu
+
+ msq=Y(4,4)
+ si=2d0*Y(1,3)
+ tabar=2d0*Y(2,4)
+ m4sqbar=2d0*Y(1,4)
+ m3sqbar=2d0*Y(3,4)
+ mp2sq=2d0*Y(2,3)
+ mean=sqrt(musq*msq)
+
+ fac=si*tabar-mp2sq*m4sqbar
+ wlogsmu=qllnrat(si,musq)
+ wlogtmu=qllnrat(tabar,musq)
+ wlog2mu=qllnrat(mp2sq,musq)
+ wlog4mu=qllnrat(m4sqbar,musq)
+
+ dilog(1)=qlLi2omrat(mp2sq,si)
+ dilog(2)=qlLi2omrat(tabar,m4sqbar)
+ dilog(3)=qlLi2omx2(mp2sq,m4sqbar,si,tabar)
+ dilog(4)=qlLi2omx2(m3sqbar,tabar,mp2sq,msq)
+ dilog(5)=qlLi2omx2(m3sqbar,m4sqbar,si,msq)
+
+ Ires(-2)=czip
+ Ires(-1)=wlog2mu+wlog4mu-wlogsmu-wlogtmu
+ Ires( 0)=dilog(4)-dilog(5)
+ . -2d0*dilog(1)+2d0*dilog(2)+2d0*dilog(3)
+ . +2d0*Ires(-1)*qllnrat(mean,tabar)
+ do iep=-2,0
+ Ires(iep)=Ires(iep)/dcmplx(fac)
+ enddo
+ return
+ end
+
+
+ double precision function integrand1(ga)
+ implicit none
+ double precision ga,omga,p2sq,p3sq,p4sq,msq,musq
+ double precision m4sqbar,si,tabar
+ common/trans1/m4sqbar,si,tabar,p2sq,p3sq,p4sq,musq
+ omga=1d0-ga
+ msq=m4sqbar+p4sq
+ integrand1=
+ . (-(p2sq+tabar)/(omga*tabar-ga*p2sq)
+ . +(m4sqbar-si)/(ga*si+omga*m4sqbar))
+ . *log(1d0-ga*p3sq/msq)
+ return
+ end
+
diff --git a/qcdloop-1.9/qlbox11.f b/qcdloop-1.9/qlbox11.f
new file mode 100644
index 0000000..5b71b27
--- /dev/null
+++ b/qcdloop-1.9/qlbox11.f
@@ -0,0 +1,89 @@
+ subroutine qlbox11(Y,musq,Ires)
+ implicit none
+C I^{\{D=4-2 \epsilon\}}_4(0,m_3^2,\pt^2,m_4^2;s_{12},s_{23};0,0,m_3^2,m_4^2)
+
+c y11=
+c [ m3sq - s12 ]
+c [ 0 0 ---------- 0 ]
+c [ 2 ]
+c [ ]
+c [ m4sq - s23 ]
+c [ 0 0 0 ---------- ]
+c [ 2 ]
+c [ ]
+c [ m3sq - s12 - p3sq + m4sq + m3sq ]
+c [ ---------- 0 m3sq -------------------- ]
+c [ 2 2 ]
+c [ ]
+c [ m4sq - s23 - p3sq + m4sq + m3sq ]
+c [ 0 ---------- -------------------- m4sq ]
+c [ 2 2 ]
+ include 'qlconstants.f'
+ integer iep
+ logical qlzero
+ double precision Y(4,4),p3sq,m3sq,m4sq,musq,
+ . m3mu,m4mu,sibar,tabar,x43p,x43m,x43pm1,x43mm1,ieps2
+ double complex wlogt,wlogs,qllnrat,Ires(-2:0),Intbit,
+ . root,cln,ln43m,ln43p,ga43p,ga43pm1,ga43m,ga43mm1,rat2p,rat2m
+
+ m3sq=Y(3,3)
+ m4sq=Y(4,4)
+ sibar=2d0*Y(1,3)
+ tabar=2d0*Y(2,4)
+ p3sq=-(2d0*Y(3,4)-Y(3,3)-Y(4,4))
+
+ m3mu=sqrt(m3sq*musq)
+ m4mu=sqrt(m4sq*musq)
+ wlogt=qllnrat(tabar,m4mu)
+ wlogs=qllnrat(sibar,m3mu)
+
+C----evaluate gamma's for the case p3sq=0
+ if (qlzero(p3sq)) then
+ root=cone
+ x43p=-one
+ x43pm1=-one
+ x43m=m3sq
+ x43mm1=m4sq
+ else
+ root=dcmplx((p3sq+m3sq-m4sq)**2-4d0*m3sq*p3sq)
+ root=sqrt(root)
+ ga43p= dcmplx(+p3sq+m3sq-m4sq)+root
+ ga43pm1=dcmplx(-p3sq+m3sq-m4sq)+root
+ ga43m= dcmplx(+p3sq+m3sq-m4sq)-root
+ ga43mm1=dcmplx(-p3sq+m3sq-m4sq)-root
+
+ x43p= -dreal(ga43p)
+ x43pm1=-dreal(ga43pm1)
+ x43m= dreal(ga43m)
+ x43mm1= dreal(ga43mm1)
+ endif
+
+
+C----deal with real roots
+ if (qlzero(dimag(root))) then
+ ln43p=qllnrat(x43p,x43pm1)
+ ln43m=qllnrat(x43m,x43mm1)
+ else
+ call qlratgam(rat2p,rat2m,ieps2,p3sq,m4sq,m3sq)
+ ln43p=cln(rat2p,ieps2)
+ ln43m=cln(rat2m,ieps2)
+
+ endif
+
+ if (qlzero(p3sq)) then
+ Intbit=-chalf*log(m3sq/m4sq)**2
+ else
+ Intbit=-chalf*(ln43p**2+ln43m**2)
+ endif
+
+ Ires(-2)=cone
+ Ires(-1)=-wlogt-wlogs
+ Ires( 0)=Intbit
+ . +ctwo*wlogt*wlogs-dcmplx(0.5d0*pisq)
+ . +dcmplx(0.25d0*log(m3sq/m4sq)**2)
+ do iep=-2,0
+ Ires(iep)=Ires(iep)/dcmplx(sibar*tabar)
+ enddo
+ return
+ end
+
diff --git a/qcdloop-1.9/qlbox12.f b/qcdloop-1.9/qlbox12.f
new file mode 100644
index 0000000..dd6cfcd
--- /dev/null
+++ b/qcdloop-1.9/qlbox12.f
@@ -0,0 +1,99 @@
+ subroutine qlbox12(Y,musq,Ires)
+ implicit none
+C I^{\{D=4-2 \epsilon\}}_4(0,m_3^2,\pt^2,\pq^2;s_{12},s_{23};0,0,m_3^2,m_4^2)
+
+c[ m3sq - s12 m4sq - p4sq ]
+c[ 0 0 ---------- ----------- ]
+c[ 2 2 ]
+c[ ]
+c[ m4sq - s23 ]
+c[ 0 0 0 ---------- ]
+c[ 2 ]
+c[ ]
+c[ m3sq - s12 - p3sq + m4sq + m3sq ]
+c[ ---------- 0 m3sq -------------------- ]
+c[ 2 2 ]
+c[ ]
+c[ m4sq - p4sq m4sq - s23 - p3sq + m4sq + m3sq ]
+c[ ----------- ---------- -------------------- m4sq ]
+c[ 2 2 2 ]
+ include 'qlconstants.f'
+ integer iep
+ logical qlzero
+ double precision Y(4,4),p3sq,m3sq,m4sq,musq,
+ . sibar,tabar,m4sqbar,fac,mean,
+ . x43p,x43pm1,x43m,x43mm1,rat1,ieps1,ieps2
+ double complex Ires(-2:0),qllnrat,dilog(3),zrat1,
+ . ln43m,ln43p,cln,wlogtmu,wlogsmu,wlog4mu,wlog,qlLi2omrat,
+ . qlLi2omx2,rat2p,rat2m,root,ga43p,ga43pm1,ga43m,ga43mm1
+
+ m3sq=Y(3,3)
+ m4sq=Y(4,4)
+ sibar=2d0*Y(1,3)
+ tabar=2d0*Y(2,4)
+ m4sqbar=2d0*Y(1,4)
+ p3sq=-(2d0*Y(3,4)-Y(3,3)-Y(4,4))
+
+ mean=sqrt(musq*m3sq)
+ fac=sibar*tabar
+ wlogsmu=qllnrat(sibar,mean)
+ wlogtmu=qllnrat(tabar,mean)
+ wlog4mu=qllnrat(m4sqbar,mean)
+ wlog=wlogsmu+wlogtmu-wlog4mu
+
+
+C---- evaluate gamma's for the case p3sq=0
+ if (qlzero(p3sq)) then
+ root=cone
+ x43p=-1d0
+ x43pm1=-1d0
+ x43m=m3sq
+ x43mm1=m4sq
+ else
+ root=dcmplx((p3sq+m3sq-m4sq)**2-4d0*m3sq*p3sq)
+ root=sqrt(root)
+ ga43p= dcmplx(+p3sq+m3sq-m4sq)+root
+ ga43pm1=dcmplx(-p3sq+m3sq-m4sq)+root
+ ga43m= dcmplx(+p3sq+m3sq-m4sq)-root
+ ga43mm1=dcmplx(-p3sq+m3sq-m4sq)-root
+
+ x43p=-dreal(ga43p)
+ x43pm1=-dreal(ga43pm1)
+ x43m=dreal(ga43m)
+ x43mm1=dreal(ga43mm1)
+ endif
+
+
+ dilog(1)=qlLi2omrat(m4sqbar,tabar)
+
+C----deal with real roots
+ if (qlzero(dimag(root))) then
+ ln43p=qllnrat(x43p,x43pm1)
+ ln43m=qllnrat(x43m,x43mm1)
+ dilog(2)=qlLi2omx2(m4sqbar,x43p,sibar,x43pm1)
+ dilog(3)=qlLi2omx2(m4sqbar,x43m,sibar,x43mm1)
+ else
+ call qlratreal(m4sqbar,sibar,rat1,ieps1)
+ call qlratgam(rat2p,rat2m,ieps2,p3sq,m4sq,m3sq)
+ zrat1=dcmplx(rat1)
+ ln43p=cln(rat2p,ieps2)
+ ln43m=cln(rat2m,ieps2)
+
+ call qlspencer(zrat1,rat2p,ieps1,ieps2,dilog(2))
+ call qlspencer(zrat1,rat2m,ieps1,ieps2,dilog(3))
+
+ endif
+ Ires(-2)=dcmplx(0.5d0)
+ Ires(-1)=-wlog
+ Ires( 0)=-dcmplx(pisq/12d0)
+ . +2d0*wlogsmu*wlogtmu-wlog4mu**2
+ . +(wlog4mu-wlogsmu)*log(m4sq/m3sq)-0.5d0*(ln43p**2+ln43m**2)
+ . -2d0*dilog(1)-dilog(2)-dilog(3)
+
+
+ do iep=-2,0
+ Ires(iep)=Ires(iep)/dcmplx(fac)
+ enddo
+ return
+ end
+
diff --git a/qcdloop-1.9/qlbox13.f b/qcdloop-1.9/qlbox13.f
new file mode 100644
index 0000000..29f72ce
--- /dev/null
+++ b/qcdloop-1.9/qlbox13.f
@@ -0,0 +1,140 @@
+ subroutine qlbox13(Y,musq,Ires)
+ implicit none
+c I^{\{D=4-2 \epsilon\}}_4(0,\pd^2,\pt^2,\pq^2;s_{12},s_{23};0,0,m_3^2,m_4^2)
+c y13 =
+c m3sq - s12 m4sq - p4sq )
+c 0 0 ---------- ----------- )
+c 2 2 )
+c )
+c m3sq - p2sq m4sq - s23 )
+c 0 0 ----------- ---------- )
+c 2 2 )
+c )
+c m3sq - s12 m3sq - p2sq - p3sq + m4sq + m3sq )
+c ---------- ----------- m3sq -------------------- )
+c 2 2 2 )
+c )
+c m4sq - p4sq m4sq - s23 - p3sq + m4sq + m3sq )
+c ----------- ---------- -------------------- m4sq )
+c 2 2 2 )
+
+ include 'qlconstants.f'
+ integer iep
+ logical qlzero
+ double precision Y(4,4),p3sq,m3sq,m4sq,musq,
+ . sibar,tabar,m3sqbar,m4sqbar,fac,
+ . x34p,x34m,x34pm1,x34mm1,rat3t,rat4s,ieps3t,ieps4s,
+ . x43p,x43m,x43pm1,x43mm1,ieps34,ieps43
+ double complex Ires(-2:0),qllnrat,
+ . wlogtmu,wlogsmu,wlog3mu,wlog4mu,dilog(7),
+ . rat34p,rat34m,rat43p,rat43m,root,qlLi2omrat,qlLi2omx2,
+ . ga34p,ga34m,ga34pm1,ga34mm1,
+ . ga43p,ga43m,ga43pm1,ga43mm1,cln,ln43p,ln43m,zrat3t,zrat4s
+
+ m3sq=Y(3,3)
+ m4sq=Y(4,4)
+ sibar=2d0*Y(1,3)
+ tabar=2d0*Y(2,4)
+ m4sqbar=2d0*Y(1,4)
+ m3sqbar=2d0*Y(2,3)
+ p3sq=-(2d0*Y(3,4)-Y(3,3)-Y(4,4))
+
+ fac=sibar*tabar-m3sqbar*m4sqbar
+ wlogsmu=qllnrat(sibar,musq)
+ wlogtmu=qllnrat(tabar,musq)
+ wlog3mu=qllnrat(m3sqbar,musq)
+ wlog4mu=qllnrat(m4sqbar,musq)
+ dilog(1)=qlLi2omrat(m3sqbar,sibar)
+ dilog(4)=qlLi2omrat(m4sqbar,tabar)
+ dilog(7)=qlLi2omx2(m3sqbar,m4sqbar,sibar,tabar)
+
+
+C--- setup gammas for qlzero p3sq
+ if (qlzero(p3sq)) then
+ root=cone
+ x34p=-1d0
+ x34pm1=-1d0
+ x34m=m4sq
+ x34mm1=m3sq
+
+ x43p=m3sq
+ x43pm1=m4sq
+ x43m=-1d0
+ x43mm1=-1d0
+
+ else
+ root=dcmplx((p3sq-m3sq+m4sq)**2-4d0*m4sq*p3sq)
+ root=sqrt(root)
+
+ ga34p= dcmplx(+p3sq+m4sq-m3sq)+root
+ ga34pm1=dcmplx(-p3sq+m4sq-m3sq)+root
+ ga34m= dcmplx(+p3sq+m4sq-m3sq)-root
+ ga34mm1=dcmplx(-p3sq+m4sq-m3sq)-root
+
+ ga43p= dcmplx(+p3sq+m3sq-m4sq)+root
+ ga43pm1=dcmplx(-p3sq+m3sq-m4sq)+root
+ ga43m= dcmplx(+p3sq+m3sq-m4sq)-root
+ ga43mm1=dcmplx(-p3sq+m3sq-m4sq)-root
+
+ x34p=-dreal(ga34p)
+ x34pm1=-dreal(ga34pm1)
+ x34m=dreal(ga34m)
+ x34mm1=dreal(ga34mm1)
+
+ x43p=-dreal(ga43p)
+ x43pm1=-dreal(ga43pm1)
+ x43m=dreal(ga43m)
+ x43mm1=dreal(ga43mm1)
+
+ endif
+
+ if (qlzero(dimag(root))) then
+ ln43p=qllnrat(x43p,x43pm1)
+ ln43m=qllnrat(x43m,x43mm1)
+
+ dilog(2)=qlLi2omx2(m3sqbar,x34p,tabar,x34pm1)
+ dilog(3)=qlLi2omx2(m3sqbar,x34m,tabar,x34mm1)
+ dilog(5)=qlLi2omx2(m4sqbar,x43p,sibar,x43pm1)
+ dilog(6)=qlLi2omx2(m4sqbar,x43m,sibar,x43mm1)
+
+ else
+
+ call qlratreal(m3sqbar,tabar,rat3t,ieps3t)
+ call qlratreal(m4sqbar,sibar,rat4s,ieps4s)
+
+ call qlratgam(rat34p,rat34m,ieps34,p3sq,m3sq,m4sq)
+ call qlratgam(rat43p,rat43m,ieps43,p3sq,m4sq,m3sq)
+
+ zrat3t=dcmplx(rat3t)
+ zrat4s=dcmplx(rat4s)
+
+ call qlspencer(zrat3t,rat34p,ieps3t,ieps34,dilog(2))
+ call qlspencer(zrat3t,rat34m,ieps3t,ieps34,dilog(3))
+ call qlspencer(zrat4s,rat43p,ieps4s,ieps43,dilog(5))
+ call qlspencer(zrat4s,rat43m,ieps4s,ieps43,dilog(6))
+
+ ln43p=cln(rat43p,0d0)
+ ln43m=cln(rat43m,0d0)
+
+ endif
+
+ Ires(-2)=czip
+ Ires(-1)=wlog3mu+wlog4mu-wlogsmu-wlogtmu
+ Ires( 0)=
+ . -2d0*dilog(1)-dilog(2)-dilog(3)
+ . -2d0*dilog(4)-dilog(5)-dilog(6)
+ . +2d0*dilog(7)
+ . +2d0*wlogsmu*wlogtmu-wlog3mu**2-wlog4mu**2
+ . +(wlog3mu-wlogtmu)*log(m3sq/musq)
+ . +(wlog4mu-wlogsmu)*log(m4sq/musq)
+ . -0.5d0*(ln43p**2+ln43m**2)
+
+ do iep=-2,0
+ Ires(iep)=Ires(iep)/dcmplx(fac)
+ enddo
+
+ return
+ end
+
+
+
diff --git a/qcdloop-1.9/qlbox14.f b/qcdloop-1.9/qlbox14.f
new file mode 100644
index 0000000..01a3416
--- /dev/null
+++ b/qcdloop-1.9/qlbox14.f
@@ -0,0 +1,60 @@
+ subroutine qlbox14(Y,musq,Ires)
+ implicit none
+C 14:
+C I_4^{\{D=4-2 \epsilon\}}(m_2^2,m_2^2,m_4^2,m_4^2;s_{12},s_{23};0,m_2^2,0,m_4^2)
+
+c
+c y14 =
+c
+c [ s12 ]
+c [ 0 0 - --- 0 ]
+c [ 2 ]
+c [ ]
+c [ - s23 + m4sq + m2sq ]
+c [ 0 m2sq 0 ------------------- ]
+c [ 2 ]
+c [ ]
+c [ s12 ]
+c [ - --- 0 0 0 ]
+c [ 2 ]
+c [ ]
+c [ - s23 + m4sq + m2sq ]
+c [ 0 ------------------- 0 m4sq ]
+c [ 2 ]
+
+
+ include 'qlconstants.f'
+ logical qlzero
+ double precision Y(4,4),m2sq,m4sq,musq,m2,m4,ta,
+ . si,xs,imxs,ieps
+ double complex cxs(3),Ires(-2:0),qllnrat,xlog,wlogtmu,cln,fac
+
+ m2sq=Y(2,2)
+ m4sq=Y(4,4)
+C-----Assign s and t (si=-s23,ta=-s12) so as to agree with notation of BD
+ ta=2d0*Y(1,3)
+ si=2d0*Y(2,4)-Y(2,2)-Y(4,4)
+ m2=sqrt(m2sq)
+ m4=sqrt(m4sq)
+ wlogtmu=qllnrat(musq,ta)
+
+C ieps gives the sign of the imaginary part of cxs(1)
+ call qlkfn(cxs,ieps,-si,m2,m4)
+ xs=dreal(cxs(1))
+ imxs=dimag(cxs(1))
+
+ if ((qlzero(xs-1d0)) .and. (qlzero(imxs))) then
+ fac=dcmplx(-xs/(m2*m4*ta))
+ else
+ xlog=cln(cxs(1),ieps)
+ fac=dcmplx(2d0/(m2*m4*ta))*cxs(1)/(cxs(2)*cxs(3))*xlog
+ endif
+
+ Ires(-2)=czip
+ Ires(-1)=fac
+ Ires( 0)=fac*wlogtmu
+ return
+ end
+
+
+
diff --git a/qcdloop-1.9/qlbox15.f b/qcdloop-1.9/qlbox15.f
new file mode 100644
index 0000000..d963724
--- /dev/null
+++ b/qcdloop-1.9/qlbox15.f
@@ -0,0 +1,118 @@
+ subroutine qlbox15(Y,musq,Ires)
+ implicit none
+C 15:
+C I_4^({D=4-2\e})(m_1^2,\pd^2,\pt^2,m_4^2;s_{12},s_{23};0,m_2^2,0,m_4^2)
+
+c [ s12 ]
+c [ 0 0 - --- 0 ]
+c [ 2 ]
+c [ ]
+c [ m2sq - p2sq - s23 + m4sq + m2sq ]
+c [ 0 m2sq ----------- ------------------- ]
+c [ 2 2 ]
+c y15 = [ ]
+c [ s12 m2sq - p2sq m4sq - p3sq ]
+c [ - --- ---------- 0 ----------- ]
+c [ 2 2 2 ]
+c [ ]
+c [ - s23 + m4sq + m2sq m4sq - p3sq ]
+c [ 0 ------------------- ----------- m4sq ]
+c [ 2 2 ]
+
+C----Implementation of Bennakker-Denner Eq.2.11
+C----\bibitem{Beenakker:1988jr}
+C----W.~Beenakker and A.~Denner,
+C----%``INFRARED DIVERGENT SCALAR BOX INTEGRALS WITH APPLICATIONS IN THE
+C----%ELECTROWEAK STANDARD MODEL,''
+C----Nucl.\ Phys.\ B {\bf 338}, 349 (1990).
+
+ include 'qlconstants.f'
+ integer iep
+ logical qlzero,qlnonzero
+ double precision Y(4,4),m2sq,m4sq,musq,m2,m4,ta,
+ . si,m2sqbar,m4sqbar,ieps,iepyy,iepyi,yy,yi,imxs,rexs
+ double complex xs,cxs(3),qlcLi2omx2,fac,Ires(-2:0),qllnrat,xlog,
+ . cln,cyy,cyi
+
+ m2sq=Y(2,2)
+ m4sq=Y(4,4)
+ m2sqbar=2d0*Y(2,3)
+ m4sqbar=2d0*Y(3,4)
+C-----Assign s and t so as to agree with notation of BD
+ si=2d0*Y(2,4)-Y(2,2)-Y(4,4)
+ ta=2d0*Y(1,3)
+ m2=sqrt(m2sq)
+ m4=sqrt(m4sq)
+
+C iepsi gives the sign of the imaginary part of K
+ call qlkfn(cxs,ieps,-si,m2,m4)
+ xs=cxs(1)
+
+C Deal with non-singular special cases first
+ if (qlzero(m2sqbar) .and. qlnonzero(m4sqbar)) then
+ call qlratreal(m4*m2sqbar,m2*m4sqbar,yi,iepyi)
+ cyi = dcmplx(yi)
+ fac=xs/(cone-xs**2)/dcmplx((-m2*m4*ta))
+ xlog=cln(xs,ieps)
+ Ires(-2)=czip
+ Ires(-1)=-xlog
+ Ires( 0)=xlog*(-xlog-dcmplx(log(musq/m4sq))
+ . -2d0*qllnrat(m4sqbar,ta))
+ . -qlcLi2omx2(xs,xs,ieps,ieps)
+ . +qlcLi2omx2(xs,cyi,ieps,iepyi)
+ . -qlcLi2omx2(1d0/xs,cyi,-ieps,iepyi)
+ goto 20
+ elseif (qlzero(m4sqbar) .and. qlnonzero(m2sqbar)) then
+ call qlratreal(m2*m4sqbar,m4*m2sqbar,yy,iepyy)
+ cyy = dcmplx(yy)
+ fac=xs/(cone-xs**2)/dcmplx((-m2*m4*ta))
+ xlog=cln(xs,ieps)
+ Ires(-2)=czip
+ Ires(-1)=-xlog
+ Ires( 0)=xlog*(-xlog-dcmplx(log(musq/m2sq))
+ . -2d0*qllnrat(m2sqbar,ta))
+ . -qlcLi2omx2(xs,xs,ieps,ieps)
+ . +qlcLi2omx2(xs,cyy,ieps,iepyy)
+ . -qlcLi2omx2(1d0/xs,cyy,-ieps,iepyy)
+ goto 20
+ elseif (qlzero(m4sqbar) .and. qlzero(m2sqbar)) then
+ write(6,*) 'qlbox15:you got here in error'
+ write(6,*) 'This is really qlbox14'
+ write(6,*) 'qlbox15:m2sqbar,m4sqbar',m2sqbar,m4sqbar
+ stop
+ endif
+
+ call qlratreal(m2*m4sqbar,m4*m2sqbar,yy,iepyy)
+ rexs=dreal(xs)
+ imxs=dimag(xs)
+C----deal with s=(m2-m4)^2
+ if ((qlzero(rexs-1d0)) .and. (qlzero(imxs))) then
+ fac=dcmplx(-0.5d0/(m2*m4*ta))
+ Ires(-2)=czip
+ Ires(-1)=cone
+ Ires(0)=dcmplx(log(musq/(m2*m4)))
+ . -qllnrat(m2sqbar,ta)-qllnrat(m4sqbar,ta)-dcmplx(2d0)
+ . -dcmplx((one+yy)/(one-yy))*qllnrat(m2*m4sqbar,m4*m2sqbar)
+ else
+C----deal with s .ne. (m2-m4)^2
+ fac=xs/(cone-xs**2)/dcmplx((-m2*m4*ta))
+ xlog=cln(xs,ieps)
+ Ires(-2)=czip
+ Ires(-1)=-xlog
+ Ires( 0)=xlog*(-0.5d0*xlog-dcmplx(log(musq/(m2*m4)))
+ . -qllnrat(m2sqbar,ta)-qllnrat(m4sqbar,ta))
+ . -qlcLi2omx2(xs,xs,ieps,ieps)
+ . +chalf*qllnrat(m2*m4sqbar,m4*m2sqbar)**2
+ . +qlcLi2omx2(xs,dcmplx(yy),ieps,iepyy)
+ . +qlcLi2omx2(xs,dcmplx(1d0/yy),ieps,-iepyy)
+ endif
+
+ 20 continue
+ do iep=-2,0
+ Ires(iep)=Ires(iep)*dcmplx(fac)
+ enddo
+ return
+ end
+
+
+
diff --git a/qcdloop-1.9/qlbox16.f b/qcdloop-1.9/qlbox16.f
new file mode 100644
index 0000000..8db9939
--- /dev/null
+++ b/qcdloop-1.9/qlbox16.f
@@ -0,0 +1,105 @@
+ subroutine qlbox16(Y,musq,Ires)
+ implicit none
+
+C I_4^(4-2\e)(m_2^2,\pd^2,\pt^2,m_4^2;s_{12},s_{23};0,m_2^2,m_3^2,m_4^2)
+
+c [ m3sq-s12 ]
+c [0 , 0 , -------- , 0 ]
+c [ 2 ]
+c [ ]
+c [ -p2sq+m3sq+m2sq -s23+m4sq+m2sq]
+c [0 , m2sq ,----------------, --------------]
+c [ 2 2 ]
+c [ ]
+c [m3sq-s12 -p2sq+m3sq+m2sq -p3sq+m4sq+m3sq]
+c [--------, ---------------, m3sq ,---------------]
+c [ 2 2 2 ]
+c [ ]
+c [ -s23+m4sq+m2sq -p3sq+m4sq+m3sq ]
+c [0 , -------------- , ---------------, m4sq ]
+c [ 2 2 ]
+c [ ]
+
+C----Implementation of Bennakker-Denner Eq.2.9
+C----\bibitem{Beenakker:1988jr}
+C----W.~Beenakker and A.~Denner,
+C----%``INFRARED DIVERGENT SCALAR BOX INTEGRALS WITH APPLICATIONS IN THE
+C----%ELECTROWEAK STANDARD MODEL,''
+C----Nucl.\ Phys.\ B {\bf 338}, 349 (1990).
+
+ include 'qlconstants.f'
+ integer iep
+ logical qlzero
+ double precision Y(4,4),m2sq,m3sq,m4sq,musq,m2,m3,m4,
+ . si,tabar,ieps,iep2,iep3,mp2sq,mp3sq,mean,rexs,imxs
+ double complex fac,cxs(3),cx2(3),cx3(3),
+ . xs,Ires(-2:0),qllnrat,xlog,cln,qlcLi2omx2,qlcLi2omx3
+
+ m2sq=Y(2,2)
+ m3sq=Y(3,3)
+ m4sq=Y(4,4)
+C-----Assign s and t so as to agree with notation of BD
+ tabar=2d0*Y(1,3)
+ si=2d0*Y(2,4)-Y(2,2)-Y(4,4)
+ mp2sq=2d0*Y(2,3)-m3sq-m2sq
+ mp3sq=2d0*Y(3,4)-m3sq-m4sq
+ m2=sqrt(m2sq)
+ m3=sqrt(m3sq)
+ m4=sqrt(m4sq)
+ mean=sqrt(m3sq*musq)
+
+C iepsi gives the sign of the imaginary part of K
+ call qlkfn(cxs,ieps,-si,m2,m4)
+ call qlkfn(cx2,iep2,-mp2sq,m2,m3)
+ call qlkfn(cx3,iep3,-mp3sq,m3,m4)
+
+ xs=cxs(1)
+ rexs=dreal(xs)
+ imxs=dimag(xs)
+ if ((qlzero(rexs-1d0)) .and. (qlzero(imxs))) then
+ fac=dcmplx(-half/(m2*m4*tabar))
+ Ires(-2)=czip
+ Ires(-1)=cone
+
+ Ires(0)=2d0*qllnrat(mean,tabar)-dcmplx(2d0)
+C special case x2=x3=1
+ if ( qlzero(dreal(cx2(1)-cx3(1))) .and.
+ . qlzero(dimag(cx2(1)-cx3(1))) .and.
+ . qlzero(dreal(cx2(1))-1d0) .and.
+ . qlzero(dimag(cx2(1)))) then
+ Ires(0) = Ires(0) + dcmplx(4d0)
+C special case x2=x3 /= 1
+ elseif (qlzero(dreal(cx2(1)-cx3(1))) .and.
+ . qlzero(dimag(cx2(1)-cx3(1)))) then
+ Ires(0) = Ires(0) + ctwo
+ .+2d0*(cx2(1)**2+cone)*cln(cx2(1),iep2)/(cx2(1)**2-cone)
+ else
+ Ires(0)=Ires(0)
+ . -(cone+cx2(1)*cx3(1))/(cone-cx2(1)*cx3(1))
+ . *(cln(cx2(1),iep2)+cln(cx3(1),iep3))
+ . -(cone+cx2(1)/cx3(1))/(cone-cx2(1)/cx3(1))
+ . *(cln(cx2(1),iep2)-cln(cx3(1),iep3))
+ endif
+
+ else
+ fac=dcmplx(-1d0/(m2*m4*tabar))*cxs(1)/(cone-cxs(1)**2)
+ xlog=cln(xs,ieps)
+ Ires(-2)=czip
+ Ires(-1)=-xlog
+ Ires(0)=-2d0*xlog*qllnrat(mean,tabar)
+ . +cln(cx2(1),iep2)**2 +cln(cx3(1),iep3)**2
+ . -qlcLi2omx2(xs,xs,ieps,ieps)
+ . +qlcLi2omx3(cxs(1),cx2(1),cx3(1),ieps,iep2,iep3)
+ . +qlcLi2omx3(cxs(1),cone/cx2(1),cone/cx3(1),ieps,-iep2,-iep3)
+ . +qlcLi2omx3(cxs(1),cx2(1),cone/cx3(1),ieps,iep2,-iep3)
+ . +qlcLi2omx3(cxs(1),cone/cx2(1),cx3(1),ieps,-iep2,iep3)
+ endif
+
+ do iep=-2,0
+ Ires(iep)=Ires(iep)*fac
+ enddo
+ return
+ end
+
+
+
diff --git a/qcdloop-1.9/qlbox2.f b/qcdloop-1.9/qlbox2.f
new file mode 100644
index 0000000..2a51860
--- /dev/null
+++ b/qcdloop-1.9/qlbox2.f
@@ -0,0 +1,42 @@
+ subroutine qlbox2(Y,musq,Ires)
+C $I_4^{D=4-2 \epsilon}(0,0,0,\pq^2;s_{12},s_{23};0,0,0,0)$}
+C One mass integral as given in egz2, Eq.(A22).
+c [ s12 p4sq ]
+c [ 0 0 - --- - ---- ]
+c [ 2 2 ]
+c [ ]
+c [ s23 ]
+c [ 0 0 0 - --- ]
+c [ 2 ]
+c Y2 = [ ]
+c [ s12 ]
+c [ - --- 0 0 0 ]
+c [ 2 ]
+c [ ]
+c [ p4sq s23 ]
+c [ - ---- - --- 0 0 ]
+c [ 2 2 ]
+ implicit none
+ double precision musq,si,ta,mp4sq,Y(4,4)
+ double complex Ires(-2:0),qlLsm1,qllnrat,ctwo,fac
+ parameter(ctwo=(2d0,0d0))
+
+ si=2d0*Y(1,3)
+ ta=2d0*Y(2,4)
+ mp4sq=2d0*Y(1,4)
+ fac=dcmplx(1d0/(si*ta))
+ Ires(-2)=fac*ctwo
+ Ires(-1)=fac*ctwo
+ . *(qllnrat(mp4sq,musq)
+ . -qllnrat(ta,musq)
+ . -qllnrat(si,musq))
+ Ires( 0)=fac*(-qllnrat(mp4sq,musq)**2
+ . +qllnrat(ta,musq)**2
+ . +qllnrat(si,musq)**2
+ . +ctwo*(qlLsm1(ta,mp4sq,si,mp4sq)
+ . -qllnrat(ta,mp4sq)*qllnrat(si,mp4sq))
+ . +qllnrat(mp4sq,ta)**2+qllnrat(mp4sq,si)**2
+ . -qllnrat(ta,si)**2)
+
+ return
+ end
diff --git a/qcdloop-1.9/qlbox3.f b/qcdloop-1.9/qlbox3.f
new file mode 100644
index 0000000..f985004
--- /dev/null
+++ b/qcdloop-1.9/qlbox3.f
@@ -0,0 +1,65 @@
+ subroutine qlbox3(Y,musq,Ires)
+ implicit none
+c I_4^{D=4-2 \epsilon}(0,\pd^2,0,\pq^2;s_{12},s_{23};0,0,0,0)
+C ----%\cite{Bern:1993kr}
+c----\bibitem{Bern:1993kr}
+c---- Z.~Bern, L.~J.~Dixon and D.~A.~Kosower,
+c---- %``Dimensionally regulated pentagon integrals,''
+c---- Nucl.\ Phys.\ B {\bf 412}, 751 (1994)
+c---- [arXiv:hep-ph/9306240].
+c---- %%CITATION = HEP-PH 9306240;%%
+c---- Eqs. (I.13)
+c [ s12 p4sq ]
+c [ 0 0 - --- - ---- ]
+c [ 2 2 ]
+c [ ]
+c [ p2sq s23 ]
+c [ 0 0 - ---- - --- ]
+c [ 2 2 ]
+c Y3 = [ ]
+c [ s12 p2sq ]
+c [ - --- - ---- 0 0 ]
+c [ 2 2 ]
+c [ ]
+c [ p4sq s23 ]
+c [ - ---- - --- 0 0 ]
+c [ 2 2 ]
+ include 'qlconstants.f'
+ double precision si,ta,mp2sq,mp4sq,musq,r,Y(4,4)
+ double complex Ires(-2:0),qlLsm1_2me,qlL0,qlL1,qllnrat,fac
+ logical landau
+ si=2d0*Y(1,3)
+ ta=2d0*Y(2,4)
+ mp4sq=2d0*Y(1,4)
+ mp2sq=2d0*Y(2,3)
+ r=1d0-mp2sq*mp4sq/(si*ta)
+
+C Use expansion only in cases where signs (si,ta,mp2sq,mp4sq) are not
+C ++-- or --++
+ landau=((sign(1d0,si) .eq. sign(1d0,ta))
+ . .and. (sign(1d0,mp2sq) .eq. sign(1d0,mp4sq))
+ . .and. (sign(1d0,si) .ne. sign(1d0,mp2sq)))
+ if ((abs(r) .lt. 1d-6) .and. (landau .eqv. .false.)) then
+C---expanded case
+ fac=dcmplx(1d0/(si*ta))
+ Ires(-2)=czip
+ Ires(-1)=-dcmplx(2d0+r)*fac
+ Ires( 0)=fac*(dcmplx(2d0-0.5d0*r)
+ . +dcmplx(2d0+r)*(qllnrat(si,musq)+qllnrat(ta,mp4sq))
+ . +dcmplx(2d0)*(qlL0(mp4sq,ta)+qlL0(mp4sq,si))
+ . +dcmplx(r)*(qlL1(mp4sq,ta)+qlL1(mp4sq,si)))
+ else
+C---general case
+ fac=dcmplx(1d0/(si*ta-mp2sq*mp4sq))
+ Ires(-2)=czip
+ Ires(-1)=fac*2d0*(qllnrat(mp2sq,si)
+ . +qllnrat(mp4sq,ta))
+ Ires( 0)=fac*(+qllnrat(si,musq)**2+qllnrat(ta,musq)**2
+ . -qllnrat(mp2sq,musq)**2-qllnrat(mp4sq,musq)**2
+ . +2d0*qlLsm1_2me(-si,-ta,-mp2sq,-mp4sq))
+ endif
+
+ return
+ end
+
+
diff --git a/qcdloop-1.9/qlbox4.f b/qcdloop-1.9/qlbox4.f
new file mode 100644
index 0000000..4461e92
--- /dev/null
+++ b/qcdloop-1.9/qlbox4.f
@@ -0,0 +1,52 @@
+ subroutine qlbox4(Y,musq,Ires)
+ implicit none
+C $I_4^{D=4-2 \epsilon}(0,0,\pt^2,\pq^2;s_{12},s_{23};0,0,0,0)$}
+
+c----%\cite{Bern:1993kr}
+c----\bibitem{Bern:1993kr}
+c---- Z.~Bern, L.~J.~Dixon and D.~A.~Kosower,
+c---- %``Dimensionally regulated pentagon integrals,''
+c---- Nucl.\ Phys.\ B {\bf 412}, 751 (1994)
+c---- [arXiv:hep-ph/9306240].
+c---- %%CITATION = HEP-PH 9306240;%%
+c---- Eqs. (I.14)
+c [ s12 p4sq ]
+c [ 0 0 - --- - ---- ]
+c [ 2 2 ]
+c [ ]
+c [ s23 ]
+c [ 0 0 0 - --- ]
+c [ 2 ]
+c Y4 = [ ]
+c [ s12 p3sq ]
+c [ - --- 0 0 - ---- ]
+c [ 2 2 ]
+c [ ]
+c [ p4sq s23 p3sq ]
+c [ - ---- - --- - ---- 0 ]
+c [ 2 2 2 ]
+ include 'qlconstants.f'
+ double precision si,ta,mp3sq,mp4sq,musq,Y(4,4)
+ double complex Ires(-2:0),qlLsm1_2mht,qllnrat,fac
+
+ si=2d0*Y(1,3)
+ ta=2d0*Y(2,4)
+ mp4sq=2d0*Y(1,4)
+ mp3sq=2d0*Y(3,4)
+
+ fac=dcmplx(1d0/(si*ta))
+ Ires(-2)=fac
+ Ires(-1)=-fac
+ . *(qllnrat(si,mp3sq)
+ . +qllnrat(ta,mp4sq)
+ . +qllnrat(ta,musq))
+
+ Ires( 0)=fac*(qllnrat(ta,musq)**2
+ . +chalf*qllnrat(si,musq)**2
+ . -chalf*qllnrat(mp3sq,musq)**2
+ . -chalf*qllnrat(mp4sq,musq)**2
+ . +ctwo*qlLsm1_2mht(-si,-ta,-mp3sq,-mp4sq))
+ return
+ end
+
+
diff --git a/qcdloop-1.9/qlbox5.f b/qcdloop-1.9/qlbox5.f
new file mode 100644
index 0000000..65a3bec
--- /dev/null
+++ b/qcdloop-1.9/qlbox5.f
@@ -0,0 +1,78 @@
+ subroutine qlbox5(Y,musq,Ires)
+ implicit none
+C $I_4^{D=4-2 \epsilon}(0,\pd^2,\pt^2,\pq^2;s_{12},s_{23};0,0,0,0)$}
+
+c----%\cite{Bern:1993kr}
+c----\bibitem{Bern:1993kr}
+c---- Z.~Bern, L.~J.~Dixon and D.~A.~Kosower,
+c---- %``Dimensionally regulated pentagon integrals,''
+c---- Nucl.\ Phys.\ B {\bf 412}, 751 (1994)
+c---- [arXiv:hep-ph/9306240].
+c---- %%CITATION = HEP-PH 9306240;%%
+c---- Eqs. (I.15)
+C-----or from /hep-ph/0508308 v3 Eqn (A27)
+C-----v3 corrects previous versions.
+c [ s12 p4sq ]
+c [ 0 0 - --- - ---- ]
+c [ 2 2 ]
+c [ ]
+c [ p2sq s23 ]
+c [ 0 0 - ---- - --- ]
+c [ 2 2 ]
+c y5 = [ ]
+c [ s12 p2sq p3sq ]
+c [ - --- - ---- 0 - ---- ]
+c [ 2 2 2 ]
+c [ ]
+c [ p4sq s23 p3sq ]
+c [ - ---- - --- - ---- 0 ]
+c [ 2 2 2 ]
+ include 'qlconstants.f'
+ integer iep
+ double precision r,musq,Y(4,4),si,ta,mp2sq,mp3sq,mp4sq
+ double complex Ires(-2:0),qllnrat,qlL0,qlL1,fac,Li2(6),
+ . qlLi2omrat,qlLi2omx2
+ logical landau
+ si=2d0*Y(1,3)
+ ta=2d0*Y(2,4)
+ mp2sq=2d0*Y(2,3)
+ mp3sq=2d0*Y(3,4)
+ mp4sq=2d0*Y(1,4)
+
+ r=1d0-mp2sq*mp4sq/(si*ta)
+
+C Use expansion only in cases where signs (si,ta,mp2sq,mp4sq) are not
+C ++-- or --++
+ landau=((sign(1d0,si) .eq. sign(1d0,ta))
+ . .and. (sign(1d0,mp2sq) .eq. sign(1d0,mp4sq))
+ . .and. (sign(1d0,si) .ne. sign(1d0,mp2sq)))
+ if ((abs(r) .lt. 1d-6) .and. (landau .eqv. .false.)) then
+C---expanded case
+ Ires(-2)=czip
+ Ires(-1)=-dcmplx((1d0+0.5d0*r)/(si*ta))
+ Ires(0)=Ires(-1)*(qllnrat(musq,si)+qllnrat(mp3sq,ta)-dcmplx(2d0)
+ . -dcmplx(1d0+mp4sq/ta)*qlL0(mp4sq,ta))
+ . +dcmplx(r/(si*ta))*(qlL1(mp4sq,ta)-qlL0(mp4sq,ta)-cone)
+ else
+C---General case
+ fac=dcmplx(1d0/(si*ta-mp2sq*mp4sq))
+ Ires(-2)=czip
+ Ires(-1)=qllnrat(mp2sq,ta)+qllnrat(mp4sq,si)
+
+ Li2(1)=qlLi2omrat(mp2sq,si)
+ Li2(2)=qlLi2omrat(mp4sq,ta)
+ Li2(3)=qlLi2omx2(mp2sq,mp4sq,si,ta)
+ Ires(0)=
+ . -chalf*(qllnrat(ta,mp2sq)**2+qllnrat(si,mp4sq)**2)
+ . +(qllnrat(mp3sq,ta)+qllnrat(musq,ta))*qllnrat(mp2sq,ta)
+ . +(qllnrat(mp3sq,si)+qllnrat(musq,si))*qllnrat(mp4sq,si)
+ . -ctwo*(Li2(1)+Li2(2)-Li2(3))-qllnrat(si,ta)**2
+ do iep=-1,0
+ Ires(iep)=fac*Ires(iep)
+ enddo
+
+ endif
+
+ return
+ end
+
diff --git a/qcdloop-1.9/qlbox6.f b/qcdloop-1.9/qlbox6.f
new file mode 100644
index 0000000..9ab4417
--- /dev/null
+++ b/qcdloop-1.9/qlbox6.f
@@ -0,0 +1,39 @@
+ subroutine qlbox6(Y,musq,Ires)
+ implicit none
+c $I_4^{\{D=4-2 \e\}}(0,0,m^2,m^2;s_{12},s_{23};0,0,0,m^2)$}
+c [ s12 ]
+c [ 0 0 - --- 0 ]
+c [ 2 ]
+c [ ]
+c [ msq - s23 ]
+c [ 0 0 0 --------- ]
+c [ 2 ]
+c y6 = [ ]
+c [ s12 ]
+c [ - --- 0 0 0 ]
+c [ 2 ]
+c [ ]
+c [ msq - s23 ]
+c [ 0 --------- 0 msq ]
+c [ 2 ]
+
+ include 'qlconstants.f'
+ integer iep
+ double precision si,tabar,msq,musq,Y(4,4)
+ double complex Ires(-2:0),qllnrat,wlogt,wlogs,wlogm
+ si=2d0*Y(1,3)
+ tabar=2d0*Y(2,4)
+ msq=Y(4,4)
+ wlogs=qllnrat(si,msq)
+ wlogt=qllnrat(tabar,msq)
+ wlogm=qllnrat(musq,msq)
+ Ires(-2)=dcmplx(2d0)
+ Ires(-1)=2d0*(wlogm-wlogt)-wlogs
+ Ires( 0)=wlogm**2-wlogm*(2d0*wlogt+wlogs)
+ . +2d0*wlogt*wlogs-dcmplx(0.5d0*pisq)
+ do iep=-2,0
+ Ires(iep)=Ires(iep)/dcmplx(si*tabar)
+ enddo
+ return
+ end
+
diff --git a/qcdloop-1.9/qlbox7.f b/qcdloop-1.9/qlbox7.f
new file mode 100644
index 0000000..1f129e7
--- /dev/null
+++ b/qcdloop-1.9/qlbox7.f
@@ -0,0 +1,43 @@
+ subroutine qlbox7(Y,musq,Ires)
+ implicit none
+C $I_4^{\{D=4-2 \e\}}(0,0,m^2,\pq^2;s_{12},s_{23};0,0,0,m^2)$}
+c [ s12 msq - p4sq ]
+c [ 0 0 - --- ---------- ]
+c [ 2 2 ]
+c [ ]
+c [ msq - s23 ]
+c [ 0 0 0 --------- ]
+c [ 2 ]
+c y7 = [ ]
+c [ s12 ]
+c [ - --- 0 0 0 ]
+c [ 2 ]
+c [ ]
+c [ msq - p4sq msq - s23 ]
+c [ ---------- --------- 0 msq ]
+c [ 2 2 ]
+ include 'qlconstants.f'
+ integer iep
+ double precision si,tabar,msq,p4sqbar,musq,Y(4,4)
+ double complex Ires(-2:0),qllnrat,wlogt,wlogs,wlogm,wlogp,
+ . qlLi2omrat
+
+ tabar=2d0*Y(2,4)
+ p4sqbar=2d0*Y(1,4)
+ si=2d0*Y(1,3)
+ msq=Y(4,4)
+ wlogs=qllnrat(si,msq)
+ wlogt=qllnrat(tabar,msq)
+ wlogp=qllnrat(p4sqbar,msq)
+ wlogm=qllnrat(musq,msq)
+ Ires(-2)=dcmplx(1.5d0)
+ Ires(-1)=1.5d0*wlogm-2d0*wlogt-wlogs+wlogp
+ Ires( 0)=2d0*wlogs*wlogt-wlogp**2-dcmplx(5d0*pisq/12d0)
+ . +0.75d0*wlogm**2+wlogm*(-2d0*wlogt-wlogs+wlogp)
+ . -2d0*qlLi2omrat(p4sqbar,tabar)
+ do iep=-2,0
+ Ires(iep)=Ires(iep)/dcmplx(si*tabar)
+ enddo
+ return
+ end
+
diff --git a/qcdloop-1.9/qlbox8.f b/qcdloop-1.9/qlbox8.f
new file mode 100644
index 0000000..c6519b9
--- /dev/null
+++ b/qcdloop-1.9/qlbox8.f
@@ -0,0 +1,56 @@
+ subroutine qlbox8(Y,musq,Ires)
+ implicit none
+C $I_4^{\{D=4-2 \e\}}(0,0,\pt^2,\pq^2; s_{12},s_{23};0,0,0,m^2)$}
+
+c [ s12 msq - p4sq ]
+c [ 0 0 - --- ---------- ]
+c [ 2 2 ]
+c [ ]
+c [ msq - s23 ]
+c [ 0 0 0 --------- ]
+c [ 2 ]
+c y8 = [ ]
+c [ s12 msq - p3sq ]
+c [ - --- 0 0 ---------- ]
+c [ 2 2 ]
+c [ ]
+c [ msq - p4sq msq - s23 msq - p3sq ]
+c [ ---------- --------- ---------- msq ]
+c [ 2 2 2 ]
+ include 'qlconstants.f'
+ integer iep
+ double precision msq,si,p3sqbar,p4sqbar,tabar,musq,Y(4,4),
+ . r1,r2,ieps1,ieps2
+ double complex Ires(-2:0),qllnrat,wlogs,qlLi2omrat,qlLi2omx2,
+ . wlogp3,wlogp4,dilog34,dilog4,dilog3
+
+ msq=Y(4,4)
+ tabar=2d0*Y(2,4)
+ si=2d0*Y(1,3)
+ p3sqbar=2d0*Y(3,4)
+ p4sqbar=2d0*Y(1,4)
+ wlogs=qllnrat(si,musq)
+ wlogp3=qllnrat(p3sqbar,tabar)
+ wlogp4=qllnrat(p4sqbar,tabar)
+
+ dilog3=qlLi2omrat(p3sqbar,tabar)
+ dilog4=qlLi2omrat(p4sqbar,tabar)
+ dilog34=qlLi2omx2(p3sqbar,p4sqbar,si,msq)
+
+ call qlratreal(p3sqbar,si,r1,ieps1)
+ call qlratreal(p4sqbar,msq,r2,ieps2)
+
+ Ires(-2)=cone
+ Ires(-1)=wlogp3+wlogp4-wlogs
+
+ Ires( 0)=-2d0*dilog3-2d0*dilog4-dilog34
+ . -dcmplx(pisq/6d0)+0.5d0*(qllnrat(si,musq)**2-qllnrat(si,msq)**2)
+ . +2d0*qllnrat(si,musq)*qllnrat(tabar,msq)
+ . -qllnrat(p3sqbar,musq)*qllnrat(p3sqbar,msq)
+ . -qllnrat(p4sqbar,musq)*qllnrat(p4sqbar,msq)
+ do iep=-2,0
+ Ires(iep)=Ires(iep)/dcmplx(si*tabar)
+ enddo
+ return
+ end
+
diff --git a/qcdloop-1.9/qlbox9.f b/qcdloop-1.9/qlbox9.f
new file mode 100644
index 0000000..2a2c296
--- /dev/null
+++ b/qcdloop-1.9/qlbox9.f
@@ -0,0 +1,47 @@
+ subroutine qlbox9(Y,musq,Ires)
+ implicit none
+c $I^{\{D=4-2 \epsilon\}}_4(0,p_2^2,p_3^2,m^2;s_{12},s_{23};0,0,0,m^2)$}
+
+c [ s12 ]
+c [ 0 0 - --- 0 ]
+c [ 2 ]
+c [ ]
+c [ p2sq msq - s23 ]
+c [ 0 0 - ---- --------- ]
+c [ 2 2 ]
+c y9 = [ ]
+c [ s12 p2sq msq - p3sq ]
+c [ - --- - ---- 0 ---------- ]
+c [ 2 2 2 ]
+c [ ]
+c [ msq - s23 msq - p3sq ]
+c [ 0 --------- ---------- msq ]
+c [ 2 2 ]
+ include 'qlconstants.f'
+ integer iep
+ double complex Ires(-2:0),qllnrat,wlogt,wlog2,
+ . dilog1,dilog2,qlLi2omrat,qlLi2omx2
+ double precision Y(4,4),msq,musq,tabar,si,fac,mean,m3sqbar,mp2sq
+
+ msq=Y(4,4)
+ mean=sqrt(musq*msq)
+ tabar=2d0*Y(2,4)
+ si=2d0*Y(1,3)
+ m3sqbar=2d0*Y(3,4)
+ mp2sq=2d0*Y(2,3)
+ fac=si*tabar
+
+ wlogt=qllnrat(tabar,mean)
+ wlog2=qllnrat(si,mp2sq)
+
+ dilog1=qlLi2omx2(m3sqbar,tabar,mp2sq,msq)
+ dilog2=qlLi2omrat(si,mp2sq)
+ Ires(-2)=dcmplx(0.5d0)
+ Ires(-1)=-wlogt-wlog2
+ Ires( 0)=dilog1+2d0*dilog2+dcmplx(pisq/12d0)+(wlogt+wlog2)**2
+ do iep=-2,0
+ Ires(iep)=Ires(iep)/dcmplx(fac)
+ enddo
+ return
+ end
+
diff --git a/qcdloop-1.9/qlcLi2omx2.f b/qcdloop-1.9/qlcLi2omx2.f
new file mode 100644
index 0000000..129462f
--- /dev/null
+++ b/qcdloop-1.9/qlcLi2omx2.f
@@ -0,0 +1,28 @@
+ double complex function qlcLi2omx2(z1,z2,ieps1,ieps2)
+C Calculates Li[2](1-(z1+ieps1)*(z2+ieps2)) for complex z1,z2
+C Using +Li2(1-z1*z2) for z1*z2<1
+C and -Li2(1-1/(z1*z2))-1/2*(ln(z1)+ln(z2))^2 for z1*z2>1
+ implicit none
+ include 'qlconstants.f'
+ double precision ieps1,ieps2,ieps
+ double complex z1,z2,lnarg,lnomarg,prod,cln,denspence,arg
+ arg=z1*z2
+ ieps=sign(one,dreal(z2)*ieps1+dreal(z1)*ieps2)
+ if (abs(arg) .le. 1d0) then
+ if (arg .eq. 0d0 .or. arg .eq. 1d0) then
+ prod=0d0
+ else
+ lnarg=cln(z1,ieps1)+cln(z2,ieps2)
+ lnomarg=cln(cone-arg,-ieps)
+ prod = lnarg*lnomarg
+ endif
+ qlcLi2omx2=dcmplx(pisqo6)-denspence(arg,ieps)-prod
+ elseif (abs(arg) .gt. 1d0) then
+ arg=1d0/(z1*z2)
+ lnomarg=cln(cone-arg,-ieps)
+ lnarg=-cln(z1,ieps1)-cln(z2,ieps2)
+ qlcLi2omx2=-dcmplx(pisqo6)+denspence(arg,ieps)
+ . +lnarg*lnomarg-0.5d0*lnarg**2
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlcLi2omx3.f b/qcdloop-1.9/qlcLi2omx3.f
new file mode 100644
index 0000000..3c774a2
--- /dev/null
+++ b/qcdloop-1.9/qlcLi2omx3.f
@@ -0,0 +1,33 @@
+ double complex function qlcLi2omx3(z1,z2,z3,ieps1,ieps2,ieps3)
+C Calculate Li[2](1-(z1+ieps1)*(z2+ieps2)*(z3+ieps3))
+C Using +cLi2(1-z1*z2*z3)
+C --- for |z1*z2*z3|<1
+C and -cLi2(1-1/(z1*z2*z3))-1/2*(ln(z1)+ln(z2)+ln(z3))^2
+C---- for |z1*z2*z3|>1
+ implicit none
+ include 'qlconstants.f'
+ double precision ieps1,ieps2,ieps3,ieps
+ double complex arg,lnarg,lnomarg,prod,denspence,z1,z2,z3,cln
+ logical qlzero
+ arg=z1*z2*z3
+ if (qlzero(dimag(arg))) ieps=
+ .sign(one,dreal(z2*z3)*ieps1+dreal(z1*z3)*ieps2+dreal(z1*z2)*ieps3)
+
+ if (abs(arg) .le. 1d0) then
+ if (arg .eq. 0d0 .or. arg .eq. 1d0) then
+ prod=0d0
+ else
+ lnarg=cln(z1,ieps1)+cln(z2,ieps2)+cln(z3,ieps3)
+ lnomarg=cln(cone-arg,0d0)
+ prod = lnarg*lnomarg
+ endif
+ qlcLi2omx3=dcmplx(pisqo6)-denspence(dcmplx(arg),ieps)-prod
+ elseif (abs(arg) .gt. 1d0) then
+ arg=1d0/(z1*z2*z3)
+ lnarg=-cln(z1,ieps1)-cln(z2,ieps2)-cln(z3,ieps3)
+ lnomarg=cln(cone-arg,0d0)
+ qlcLi2omx3=-dcmplx(pisqo6)+denspence(dcmplx(arg),ieps)
+ . +lnarg*lnomarg-0.5d0*lnarg**2
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qlconstants.f b/qcdloop-1.9/qlconstants.f
new file mode 100644
index 0000000..f0d648e
--- /dev/null
+++ b/qcdloop-1.9/qlconstants.f
@@ -0,0 +1,16 @@
+ double precision pi,pisq,pisqo6
+ parameter(pi=3.14159265358979d0,pisq=pi*pi,pisqo6=pisq/6d0)
+
+ double precision zip,half,one,two,three,four,eight
+ parameter(zip=0d0,half=0.5d0,one=1d0,two=2d0)
+ parameter(three=3d0,four=4d0,eight=8d0)
+
+ double complex im,impi,czip,chalf,cone,ctwo,c2ipi
+ parameter(im=(0d0,1d0),impi=(0d0,3.14159265358979d0),
+ . czip=(0d0,0d0),chalf=(0.5d0,0d0),cone=(1d0,0d0),ctwo=(2d0,0d0),
+ . c2ipi=2d0*impi)
+
+ DOUBLE COMPLEX nan
+ parameter (nan = (1D123, 1D123))
+
+
diff --git a/qcdloop-1.9/qlfndd.f b/qcdloop-1.9/qlfndd.f
new file mode 100644
index 0000000..abc7545
--- /dev/null
+++ b/qcdloop-1.9/qlfndd.f
@@ -0,0 +1,37 @@
+ double complex function qlfndd(n,x,iep)
+C----Implementation of DD Eq. 4.11
+C----%\cite{Denner:2005nn}
+C----\bibitem{Denner:2005nn}
+C---- A.~Denner and S.~Dittmaier,
+C---- %``Reduction schemes for one-loop tensor integrals,''
+C---- Nucl.\ Phys.\ B {\bf 734}, 62 (2006)
+C---- [arXiv:hep-ph/0509141].
+C---- %%CITATION = NUPHA,B734,62;%%
+
+ implicit none
+ include 'qlconstants.f'
+ integer j,n,infty
+ double complex xm1,x,cln
+ double precision iep
+ logical qlzero
+ parameter(infty=16) ! number of terms in sum
+
+ xm1=x-cone
+ if (abs(x) .lt. 10d0) then
+ if (qlzero(abs(x-cone))) then
+ qlfndd=czip
+ else
+ qlfndd=(cone-dcmplx(x**(n+1)))*(cln(xm1,iep)-cln(x,iep))
+ endif
+ do j=0,n
+ qlfndd=qlfndd-dcmplx(x**(n-j))/dfloat(j+1)
+ enddo
+ elseif (abs(x) .ge. 10d0) then
+ qlfndd=cln(cone-cone/x,iep)
+ do j=n+1,n+infty
+ qlfndd=qlfndd+dcmplx(x**(n-j))/dfloat(j+1)
+ enddo
+ endif
+
+ return
+ end
diff --git a/qcdloop-1.9/qlfunctions.f b/qcdloop-1.9/qlfunctions.f
new file mode 100644
index 0000000..502d396
--- /dev/null
+++ b/qcdloop-1.9/qlfunctions.f
@@ -0,0 +1,90 @@
+************************************************************************
+* Author: R.K. Ellis & GZ *
+************************************************************************
+
+ double complex function qlL0(x,y)
+ implicit none
+ include 'qlconstants.f'
+ double complex qllnrat
+ double precision x,y,denom
+ denom=one-x/y
+ if (abs(denom) .lt. 1d-7) then
+ qlL0=-cone-dcmplx(denom*(half+denom/3d0))
+ else
+ qlL0=qllnrat(x,y)/dcmplx(denom)
+ endif
+ return
+ end
+
+ double complex function qlL1(x,y)
+ implicit none
+ include 'qlconstants.f'
+ double precision x,y,denom
+ double complex qlL0
+ denom=one-x/y
+ if (abs(denom) .lt. 1d-7) then
+ qlL1=-half*cone-dcmplx(denom/3d0*(one+0.75d0*denom))
+ else
+ qlL1=(qlL0(x,y)+cone)/dcmplx(denom)
+ endif
+ return
+ end
+
+ double complex function qlL2(x,y)
+ implicit none
+ include 'qlconstants.f'
+ double complex qllnrat
+ double precision x,y,r,denom
+ r=x/y
+ denom=one-r
+ if (abs(denom) .lt. 1d-7) then
+ qlL2=(dcmplx(10d0)+denom*(dcmplx(15d0)+dcmplx(18d0)*denom))
+ . /dcmplx(60d0)
+ else
+ qlL2=(qllnrat(x,y)-dcmplx(0.5d0*(r-1d0/r)))/dcmplx(denom)**3
+ endif
+ return
+ end
+
+ double complex function qlLsm1(x1,y1,x2,y2)
+ implicit none
+ include 'qlconstants.f'
+ double precision x1,x2,y1,y2
+ double complex qlLnrat,qlLi2omrat
+
+ qlLsm1=qlLi2omrat(x1,y1)+qlLi2omrat(x2,y2)
+ . +qllnrat(x1,y1)*qllnrat(x2,y2)-dcmplx(pisqo6)
+ return
+ end
+
+
+ double complex function qlLsm1_2mht(s,t,p1sq,p2sq)
+ implicit none
+ include 'qlconstants.f'
+ double precision s,t,p1sq,p2sq
+ double complex qlLnrat,qlLi2omrat
+
+ qlLsm1_2mht=
+ & -qlLi2omrat(-p1sq,-t)
+ & -qlLi2omrat(-p2sq,-t)
+ & +half*(qllnrat(-s,-p1sq)*qllnrat(-s,-p2sq)-qllnrat(-s,-t)**2)
+ return
+ end
+
+
+ double complex function qlLsm1_2me(s,t,p1sq,p3sq)
+ implicit none
+ include 'qlconstants.f'
+ double precision s,t,p1sq,p3sq
+ double complex qlLnrat,Li2(5),qlLi2omrat,qlLi2omx2
+
+ Li2(1)=qlLi2omrat(-p1sq,-s)
+ Li2(2)=qlLi2omrat(-p1sq,-t)
+ Li2(3)=qlLi2omrat(-p3sq,-s)
+ Li2(4)=qlLi2omrat(-p3sq,-t)
+ Li2(5)=qlLi2omx2(-p1sq,-p3sq,-s,-t)
+ qlLsm1_2me=Li2(5)-Li2(1)-Li2(2)-Li2(3)-Li2(4)
+ . -half*qlLnrat(-s,-t)**2
+ return
+ end
+
diff --git a/qcdloop-1.9/qlinit.f b/qcdloop-1.9/qlinit.f
new file mode 100644
index 0000000..ec3bc0c
--- /dev/null
+++ b/qcdloop-1.9/qlinit.f
@@ -0,0 +1,15 @@
+ subroutine qlinit
+ implicit none
+
+ write(*,*) '===================================================='
+ write(*,*) ' This is QCDLoop - version 1.9 '
+ write(*,*) ' Authors: Keith Ellis and Giulia Zanderighi '
+ write(*,*) ' (ellis@fnal.gov, g.zanderighi1@physics.ox.ac.uk) '
+ write(*,*) ' For details see FERMILAB-PUB-07-633-T,OUTP-07/16P '
+ write(*,*) ' arXiv:0712.1851 [hep-ph], published in '
+ write(*,*) ' JHEP 0802:002,2008. '
+ write(*,*) '===================================================='
+
+ call ffini
+
+ end
diff --git a/qcdloop-1.9/qlkfn.f b/qcdloop-1.9/qlkfn.f
new file mode 100644
index 0000000..7b9c3fc
--- /dev/null
+++ b/qcdloop-1.9/qlkfn.f
@@ -0,0 +1,51 @@
+ subroutine qlkfn(cx,ieps,xpi,xm,xmp)
+*************************************************************************
+* *
+* RKE & GZ: adapted from ffzkfn routine (19/02/2008)
+* Calculate the K-function given in Eq. 2.7 of *
+* %\cite{Beenakker:1988jr} *
+* \bibitem{Beenakker:1988jr} *
+* W.~Beenakker and A.~Denner, *
+* %``INFRARED DIVERGENT SCALAR BOX INTEGRALS WITH APPLICATIONS IN THE *
+* %ELECTROWEAK STANDARD MODEL,'' *
+* Nucl.\ Phys.\ B {\bf 338}, 349 (1990). *
+* %%CITATION = NUPHA,B338,349;%% *
+* *
+* 1-sqrt(1-4*m*mp/(z-(m-mp)^2)) *
+* K(p^2,m,mp) = ----------------------------- *
+* 1+sqrt(1-4*m*mp/(z-(m-mp)^2)) *
+* *
+* and fill x(1) = -K, x(2) = 1+K, x(3) = 1-K *
+* the roots are allowed to be imaginary *
+* ieps gives the sign of the imaginary part of -K: 1 -> +i*eps *
+* *
+*************************************************************************
+ implicit none
+ include 'qlconstants.f'
+ LOGICAL qlzero
+ DOUBLE PRECISION xpi,xm,xmp,xx1,ieps
+ DOUBLE COMPLEX root,invopr,cx(3),rat
+
+ if ((xm .eq. 0d0) .or. (xmp .eq. 0d0)) then
+ write(6,*) 'Error in qlkfn,xm,xmp=',xm,xmp
+ stop
+ endif
+
+ xx1 = xpi - (xm-xmp)**2
+ rat=dcmplx(xx1/(4d0*xm*xmp))
+
+ if (qlzero(dble(rat))) then
+ cx(2) = -2d0*im*sqrt(rat)+2d0*rat
+ cx(1) = cone-cx(2)
+ cx(3) = ctwo-cx(2)
+ else
+
+ root = sqrt((rat-cone)/rat)
+ invopr = cone/(cone+root)
+ cx(1) = -invopr**2/rat
+ cx(2) = ctwo*invopr
+ cx(3) = ctwo*root*invopr
+ endif
+ ieps = 1d0
+ return
+ end
diff --git a/qcdloop-1.9/qllnomrat4.f b/qcdloop-1.9/qllnomrat4.f
new file mode 100644
index 0000000..a4ed44b
--- /dev/null
+++ b/qcdloop-1.9/qllnomrat4.f
@@ -0,0 +1,22 @@
+ double complex function qllnomrat4(ms1,ms2,mt1,mt2)
+************************************************************************
+* Author: R.K. Ellis *
+* August, 2007. *
+* Lnomrat4(-s1,-s2,-t1,-t2)= *
+* ln(1-((ms1-i*ep)*(ms2-i*ep))/((mt1-i*ep)/(mt2-i*ep))) *
+* this function is hard-wired for sign of epsilon we must adjust *
+* sign of s1,s2,t1,t2 to get the right sign for epsilon *
+************************************************************************
+ implicit none
+ include 'qlconstants.f'
+ double precision ms1,ms2,mt1,mt2,prod,htheta
+C--- define Heaviside theta function (=1 for x>0) and (0 for x < 0)
+ htheta(ms1)=half+half*sign(one,ms1)
+ prod=1d0-(ms1*ms2)/(mt1*mt2)
+ qllnomrat4=dcmplx(dlog(abs(prod)))
+ . -half*impi*dcmplx(htheta(-prod))
+ . *dcmplx(htheta(-ms1)+htheta(-ms2)-htheta(-mt1)-htheta(-mt2))
+
+ return
+ end
+
diff --git a/qcdloop-1.9/qllnrat.f b/qcdloop-1.9/qllnrat.f
new file mode 100644
index 0000000..624633a
--- /dev/null
+++ b/qcdloop-1.9/qllnrat.f
@@ -0,0 +1,18 @@
+ double complex function qlLnrat(x,y)
+************************************************************************
+* Author: R.K. Ellis *
+* August, 1998. *
+c Lnrat(x,y)=log(x-i*ep)-log(y-i*ep) *
+c this function is hard-wired for sign of epsilon we must adjust *
+c sign of x and y to get the right sign for epsilon *
+************************************************************************
+ implicit none
+ include 'qlconstants.f'
+ double precision x,y,htheta
+C--- define Heaviside theta function (=1 for x>0) and (0 for x < 0)
+ htheta(x)=half+half*sign(one,x)
+ qlLnrat=dcmplx(dlog(abs(x/y)))
+ . -impi*dcmplx((htheta(-x)-htheta(-y)))
+ return
+ end
+
diff --git a/qcdloop-1.9/qlonshellcutoff.f b/qcdloop-1.9/qlonshellcutoff.f
new file mode 100644
index 0000000..3460bb4
--- /dev/null
+++ b/qcdloop-1.9/qlonshellcutoff.f
@@ -0,0 +1,2 @@
+ double precision qlonshellcutoff
+ parameter(qlonshellcutoff=1d-10)
diff --git a/qcdloop-1.9/qlratgam.f b/qcdloop-1.9/qlratgam.f
new file mode 100644
index 0000000..a1c02da
--- /dev/null
+++ b/qcdloop-1.9/qlratgam.f
@@ -0,0 +1,22 @@
+ subroutine qlratgam(ratp,ratm,ieps,p3sq,m3sq,m4sq)
+*****comment:************************************************************
+* *
+* Calculate the function *
+* *
+* +p3sq+m4sq-m3sq+sqrt((p3sq+m4sq-m3sq)^2-4*p3sq*m4sq) *
+* rat(p^2,m,mp) = -------------------------------------------------- *
+* -p3sq+m4sq-m3sq+sqrt((p3sq+m4sq-m3sq)^2-4*p3sq*m4sq) *
+* *
+* the roots are allowed to be imaginary *
+* *
+***comment:*************************************************************
+ implicit none
+ double precision p3sq,m3sq,m4sq,ieps
+ double complex root,ratp,ratm
+
+ root=dcmplx((p3sq-m3sq+m4sq)**2-4d0*m4sq*p3sq)
+ root=sqrt(root)
+ ratp=(dcmplx(+p3sq+m4sq-m3sq)+root)/(dcmplx(-p3sq+m4sq-m3sq)+root)
+ ratm=(dcmplx(+p3sq+m4sq-m3sq)-root)/(dcmplx(-p3sq+m4sq-m3sq)-root)
+ ieps=0d0
+ end
diff --git a/qcdloop-1.9/qlratreal.f b/qcdloop-1.9/qlratreal.f
new file mode 100644
index 0000000..344aa5c
--- /dev/null
+++ b/qcdloop-1.9/qlratreal.f
@@ -0,0 +1,30 @@
+ subroutine qlratreal(si,ta,rat,ieps)
+*****comment:************************************************************
+* *
+* Calculate the function *
+* *
+* sigma-i*ep *
+* rat = ---------- *
+* tau-i*ep *
+* *
+* where sigma and tau are real and ieps gives the sign if i*pi *
+* *
+***comment:*************************************************************
+ implicit none
+ include 'qlconstants.f'
+ double precision si,ta,ieps,rat
+ rat=si/ta
+ if (rat .gt. zip) then
+ ieps=0d0
+ return
+ elseif (si .lt. zip) then
+ ieps=-1d0
+ return
+ elseif (ta .lt. zip) then
+ ieps=+1d0
+ return
+ elseif (ta .eq. zip) then
+ write(6,*) 'error in qlratreal, ta=',ta
+ stop
+ endif
+ end
diff --git a/qcdloop-1.9/qlsnglsort.f b/qcdloop-1.9/qlsnglsort.f
new file mode 100644
index 0000000..4d67994
--- /dev/null
+++ b/qcdloop-1.9/qlsnglsort.f
@@ -0,0 +1,15 @@
+ subroutine qlsnglsort(n,arr)
+C---order on the basis of abs value
+ INTEGER n,i,j
+ DOUBLE PRECISION arr(n),a
+ do 12 j=2,n
+ a=arr(j)
+ do 11 i=j-1,1,-1
+ if(abs(arr(i)).le. abs(a))goto 10
+ arr(i+1)=arr(i)
+11 continue
+ i=0
+10 arr(i+1)=a
+12 continue
+ return
+ END
diff --git a/qcdloop-1.9/qlspencer.f b/qcdloop-1.9/qlspencer.f
new file mode 100644
index 0000000..931ff03
--- /dev/null
+++ b/qcdloop-1.9/qlspencer.f
@@ -0,0 +1,36 @@
+ subroutine qlspencer(zrat1,zrat2,ieps1,ieps2,res)
+ implicit none
+ include 'qlconstants.f'
+ double precision ieps1,ieps2,x1,x2,y1,y2,ieps
+ double complex zrat1,zrat2,res,
+ . lnarg,lnomarg,prod,denspence,qlLi2omx,arg,cln
+ logical qlzero
+
+ x1=dreal(zrat1)
+ x2=dreal(zrat2)
+ y1=dimag(zrat1)
+ y2=dimag(zrat2)
+ if (qlzero(y1) .and. qlzero(y2)) then
+ res=qlLi2omx(x1,x2,ieps1,ieps2)
+ else
+ arg=zrat1*zrat2
+ ieps=0d0
+ if (abs(arg) .le. 1d0) then
+ if (arg .eq. 0d0 .or. arg .eq. 1d0) then
+ prod=0d0
+ else
+ lnarg=cln(zrat1,ieps1)+cln(zrat2,ieps2)
+ lnomarg=log(cone-arg)
+ prod = lnarg*lnomarg
+ endif
+ res=dcmplx(pisqo6)-denspence(arg,ieps)-prod
+ elseif (abs(arg) .gt. 1d0) then
+ arg=cone/(zrat1*zrat2)
+ lnarg=-cln(zrat1,ieps1)-cln(zrat2,ieps2)
+ lnomarg=log(cone-arg)
+ res=-dcmplx(pisqo6)+denspence(arg,ieps)
+ . +lnarg*lnomarg-0.5d0*lnarg**2
+ endif
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qltri1.f b/qcdloop-1.9/qltri1.f
new file mode 100644
index 0000000..142a0ea
--- /dev/null
+++ b/qcdloop-1.9/qltri1.f
@@ -0,0 +1,10 @@
+ subroutine qltri1(psq,musq,Ival)
+ implicit none
+ double precision psq,musq
+ double complex qllnrat,Ival(-2:0),wlogm
+ wlogm=qllnrat(musq,-psq)
+ Ival(-2)=dcmplx(1d0/psq)
+ Ival(-1)=Ival(-2)*wlogm
+ Ival(0)=dcmplx(0.5d0)*Ival(-2)*wlogm**2
+ return
+ end
diff --git a/qcdloop-1.9/qltri2.f b/qcdloop-1.9/qltri2.f
new file mode 100644
index 0000000..6bca1f2
--- /dev/null
+++ b/qcdloop-1.9/qltri2.f
@@ -0,0 +1,20 @@
+ subroutine qltri2(p1sq,p2sq,musq,Ival)
+ implicit none
+ include 'qlconstants.f'
+ double precision p1sq,p2sq,musq,r
+ double complex qllnrat,Ival(-2:0),wlog1,wlog2
+
+ wlog1=qllnrat(musq,-p1sq)
+ wlog2=qllnrat(musq,-p2sq)
+ r = (p2sq-p1sq)/p1sq
+
+ Ival(-2)=czip
+ if (abs(r) .lt. 1d-6) then
+ Ival(-1)=dcmplx(1d0/p1sq)*(cone-dcmplx(r/2d0*musq/p1sq))
+ Ival(0)=dcmplx(1d0/p1sq)*(wlog1-dcmplx(r/2d0)*(cone+wlog1))
+ else
+ Ival(-1)=(wlog1-wlog2)/dcmplx(p1sq-p2sq)
+ Ival(0)=chalf*Ival(-1)*(wlog1+wlog2)
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qltri3.f b/qcdloop-1.9/qltri3.f
new file mode 100644
index 0000000..807e010
--- /dev/null
+++ b/qcdloop-1.9/qltri3.f
@@ -0,0 +1,33 @@
+ subroutine qltri3(p2sq,p3sq,msq,musq,Ival)
+ implicit none
+ include 'qlconstants.f'
+ double precision p2sq,p3sq,msq,musq,m2sqb,m3sqb,r
+ double complex fac,qllnrat,Ival(-2:0),wlog2,wlog3,wlogm,
+ . dilog2,dilog3,qlLi2omrat
+
+
+ m2sqb = msq-p2sq
+ m3sqb = msq-p3sq
+ dilog2= qlLi2omrat(m2sqb,msq)
+ dilog3= qlLi2omrat(m3sqb,msq)
+
+ wlog2=qllnrat(m2sqb,msq)
+ wlog3=qllnrat(m3sqb,msq)
+ wlogm=qllnrat(musq,msq)
+ r =(m3sqb-m2sqb)/m2sqb
+
+ Ival(-2)=czip
+ if (abs(r) .lt. 1d-6) then
+ Ival(-1)=dcmplx((1d0-r/2d0)/m2sqb)
+ Ival(0)=(wlogm-dcmplx((msq+p2sq)/p2sq*wlog2))
+ Ival(0)=Ival(0)-chalf*r*((msq**2-2d0*p2sq*msq-p2sq**2)*wlog2
+ .+p2sq*(dcmplx(msq+p2sq)+p2sq*wlogm))/p2sq**2
+ Ival(0)=Ival(0)/cmplx(m2sqb)
+ else
+ fac=dcmplx(1d0/(p2sq-p3sq))
+ Ival(-1)=fac*(wlog3-wlog2)
+ Ival(0)=Ival(-1)*wlogm
+ . +fac*(dilog2-dilog3+(wlog2**2-wlog3**2))
+ endif
+ return
+ end
diff --git a/qcdloop-1.9/qltri4.f b/qcdloop-1.9/qltri4.f
new file mode 100644
index 0000000..6e512b9
--- /dev/null
+++ b/qcdloop-1.9/qltri4.f
@@ -0,0 +1,24 @@
+ subroutine qltri4(p2sq,msq,musq,Ival)
+ implicit none
+ include 'qlconstants.f'
+ double precision p2sq,musq,msq,arg2,omarg2,ddilog
+ double complex fac,qllnrat,Ival(-2:0),wlog,wlogm,dilog2
+ wlog=qllnrat(msq,msq-p2sq)
+ wlogm=qllnrat(musq,msq)
+ fac=dcmplx(0.5d0/(p2sq-msq))
+ arg2=-p2sq/(msq-p2sq)
+ omarg2=1d0-arg2
+
+ if (omarg2 .lt. 0d0) then
+ dilog2=dcmplx(pisqo6-ddilog(omarg2))-log(arg2)*wlog
+ else
+ dilog2=dcmplx(ddilog(arg2))
+ endif
+
+ Ival(-2)=fac
+ Ival(-1)=Ival(-2)*wlogm+fac*2d0*wlog
+ Ival(0) =-Ival(-2)*0.5d0*wlogm**2+Ival(-1)*wlogm
+ . +fac*(wlog**2+dcmplx(pisqo6)-2d0*dilog2)
+
+ return
+ end
diff --git a/qcdloop-1.9/qltri5.f b/qcdloop-1.9/qltri5.f
new file mode 100644
index 0000000..71e5f4a
--- /dev/null
+++ b/qcdloop-1.9/qltri5.f
@@ -0,0 +1,12 @@
+ subroutine qltri5(msq,musq,Ival)
+ implicit none
+ include 'qlconstants.f'
+ double precision msq,musq
+ double complex fac,qllnrat,Ival(-2:0),wlogm
+ fac=dcmplx(1d0/msq)
+ wlogm=qllnrat(musq,msq)
+ Ival(-2)=czip
+ Ival(-1)=-0.5d0*fac
+ Ival(0)=Ival(-1)*wlogm+fac
+ return
+ end
diff --git a/qcdloop-1.9/qltri6.f b/qcdloop-1.9/qltri6.f
new file mode 100644
index 0000000..319181f
--- /dev/null
+++ b/qcdloop-1.9/qltri6.f
@@ -0,0 +1,47 @@
+ subroutine qltri6(s,m2sq,m3sq,musq,Ires)
+C-----calculate the IR divergent box in DIM reg
+C-----Note choosing the cutoff equal to musq, we exactly get
+C-----the e=0, dim reg result
+ implicit none
+ include 'qlconstants.f'
+ double precision s,m2sq,m3sq,musq,m2,m3,iepsd,rexs,imxs
+ double complex Ires(-2:0),cxs(3),fac,xlog,cln,qlcLi2omx2
+ logical qlzero
+
+ m2 = sqrt(m2sq)
+ m3 = sqrt(m3sq)
+
+C ieps gives the sign of the imaginary part of K
+ call qlkfn(cxs,iepsd,s,m2,m3)
+ fac=dcmplx(1d0/(m2*m3))*cxs(1)/(cxs(2)*cxs(3))
+ xlog = cln(cxs(1),iepsd)
+
+
+ rexs=dreal(cxs(1))
+ imxs=dimag(cxs(1))
+C----deal with s=(m2-m3)^2
+ if ((qlzero(rexs-1d0)) .and. (qlzero(imxs))) then
+ fac=dcmplx(0.5d0/(m2*m3))
+ Ires(-2)=czip
+ Ires(-1)=fac
+ if (qlzero(m2-m3)) then
+ Ires(0)=fac*dcmplx(log(musq/(m2*m3)))
+ else
+ Ires(0)=fac*(dcmplx(log(musq/(m2*m3)))-ctwo
+ . -dcmplx((m3+m2)/(m3-m2)*log(m2/m3)))
+ endif
+ else
+C----deal with s .ne. (m2-m3)^2
+ Ires(-2)= czip
+ Ires(-1)= -fac*xlog
+ Ires(0) = fac*(xlog*(-chalf*xlog
+ . +dcmplx(log(m2*m3/musq)))
+ . -qlcLi2omx2(cxs(1),cxs(1),iepsd,iepsd)
+ . +chalf*dcmplx(log(m2/m3)**2)
+ . +qlcLi2omx2(cxs(1),dcmplx(m2/m3),iepsd,0d0)
+ . +qlcLi2omx2(cxs(1),dcmplx(m3/m2),iepsd,0d0))
+ endif
+
+
+ return
+ end
diff --git a/qcdloop-1.9/qltrisort.f b/qcdloop-1.9/qltrisort.f
new file mode 100644
index 0000000..0c1f164
--- /dev/null
+++ b/qcdloop-1.9/qltrisort.f
@@ -0,0 +1,42 @@
+ subroutine qltrisort(psq,msq)
+C-----sort arguments of triangle so that the are ordered in mass
+C-----m1sq<m2sq<m3sq
+ implicit none
+ double precision msq(3),psq(3),msqtmp(3),psqtmp(3)
+ INTEGER j,x1(3),x2(3)
+ data x1/3,1,2/
+ data x2/2,3,1/
+ save x1,x2
+ do j=1,3
+ msqtmp(j)=msq(j)
+ psqtmp(j)=psq(j)
+ enddo
+
+ if (max(msqtmp(1),msqtmp(2),msqtmp(3)) .eq. msqtmp(1)) then
+ do j=1,3
+ msq(x1(j))=msqtmp(j)
+ psq(x1(j))=psqtmp(j)
+ enddo
+ endif
+
+ if (max(msqtmp(1),msqtmp(2),msqtmp(3)) .eq. msqtmp(2)) then
+ do j=1,3
+ msq(x2(j))=msqtmp(j)
+ psq(x2(j))=psqtmp(j)
+ enddo
+ endif
+
+ if (msq(1) .gt. msq(2)) then
+ do j=1,2
+ msqtmp(j)=msq(j)
+ psqtmp(j+1)=psq(j+1)
+ enddo
+
+ msq(1)=msqtmp(2)
+ msq(2)=msqtmp(1)
+ psq(2)=psqtmp(3)
+ psq(3)=psqtmp(2)
+ endif
+
+ return
+ END
diff --git a/qcdloop-1.9/qlxpicheck.f b/qcdloop-1.9/qlxpicheck.f
new file mode 100644
index 0000000..2fc0052
--- /dev/null
+++ b/qcdloop-1.9/qlxpicheck.f
@@ -0,0 +1,21 @@
+ subroutine qlxpicheck(xpi)
+ implicit none
+ double precision xpi(13),y13,y24
+ logical qlzero
+C Uses the ordering for the routine xpi wanted by FF
+C psq(1) lies between msq(1) and msq(2) and so on
+C xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
+C xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
+C xpi(9-10) = s12,s23
+C xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
+C xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
+C xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
+c y13=abs(m1+m3s-s12)
+c y24=abs(m2+m4s-s23)
+ y13=xpi(1)+xpi(3)-xpi(9)
+ y24=xpi(2)+xpi(4)-xpi(10)
+ if (qlzero(y13) .or. qlzero(y24)) then
+ write(6,*) 'Modified Cayley elements y13 or y24=0',y13,y24
+ stop
+ endif
+ end
diff --git a/qcdloop-1.9/qlzero.f b/qcdloop-1.9/qlzero.f
new file mode 100644
index 0000000..5a77486
--- /dev/null
+++ b/qcdloop-1.9/qlzero.f
@@ -0,0 +1,23 @@
+ logical function qlzero(psq)
+ implicit none
+ include 'qlonshellcutoff.f'
+ double precision psq
+ if (abs(psq) .lt. qlonshellcutoff) then
+ qlzero=.true.
+ else
+ qlzero=.false.
+ endif
+ return
+ end
+
+ logical function qlnonzero(psq)
+ implicit none
+ include 'qlonshellcutoff.f'
+ double precision psq
+ if (abs(psq) .gt. qlonshellcutoff) then
+ qlnonzero=.true.
+ else
+ qlnonzero=.false.
+ endif
+ return
+ end
diff --git a/samurai-2.1.1/Makefile.am b/samurai-2.1.1/Makefile.am
new file mode 100644
index 0000000..1ae3abe
--- /dev/null
+++ b/samurai-2.1.1/Makefile.am
@@ -0,0 +1,42 @@
+lib_LTLIBRARIES=libsamurai.la
+libsamurai_la_SOURCES=\
+ constants.f90 kinematic.f90 ltest.f90 madds.f90 mcgs.f90 mfunctions.f90 \
+ mgetbase.f90 mgetc1.f90 mgetc2.f90 mgetc3.f90 mgetc4.f90 mgetc5.f90 \
+ mgetqs.f90 mglobal.f90 mrestore.f90 msamurai.f90 mtens.f90 mtests.f90 \
+ ncuts.f90 notfirst.f90 options.f90 precision.f90 save.f90 maccu.f90
+nodist_pkginclude_HEADERS=\
+ constants.mod kinematic.mod ltest.mod madds.mod mcgs.mod mfunctions.mod \
+ mgetbase.mod mgetc1.mod mgetc2.mod mgetc3.mod mgetc4.mod mgetc5.mod \
+ mgetqs.mod mglobal.mod mrestore.mod msamurai.mod mtens.mod mtests.mod \
+ ncuts.mod notfirst.mod options.mod precision.mod save.mod maccu.mod
+
+AM_FCFLAGS= \
+ -I. \
+ -I$(top_builddir)/avh_olo-2.2.1 \
+ -I$(top_builddir)/golem95c-1.2.1/module
+
+libsamurai_la_LIBADD=\
+ $(LIBLOOPTOOLS)
+
+if COMPILE_QL
+libsamurai_la_LIBADD+=-L$(top_builddir)/qcdloop-1.9 -lqcdloop \
+ -L$(top_builddir)/ff-2.0 -lff
+else
+# nop
+endif
+
+if COMPILE_GOLEM95C
+libsamurai_la_LIBADD+=-L$(top_builddir)/golem95c-1.2.1 -lgolem
+else
+# nop
+endif
+
+libsamurai_la_LIBADD+=-L$(top_builddir)/avh_olo-2.2.1 -lavh_olo
+
+CLEANFILES=\
+ constants.mod kinematic.mod ltest.mod madds.mod mcgs.mod mfunctions.mod \
+ mgetbase.mod mgetc1.mod mgetc2.mod mgetc3.mod mgetc4.mod mgetc5.mod \
+ mgetqs.mod mglobal.mod mrestore.mod msamurai.mod mtens.mod mtests.mod \
+ ncuts.mod notfirst.mod options.mod precision.mod save.mod maccu.mod
+
+include Makefile.dep
diff --git a/samurai-2.1.1/Makefile.dep b/samurai-2.1.1/Makefile.dep
new file mode 100644
index 0000000..e024c5f
--- /dev/null
+++ b/samurai-2.1.1/Makefile.dep
@@ -0,0 +1,81 @@
+# Module dependencies
+options.o: precision.o
+options.lo: precision.lo
+options.obj: precision.obj
+constants.o: precision.o
+constants.lo: precision.lo
+constants.obj: precision.obj
+kinematic.o: precision.o
+kinematic.lo: precision.lo
+kinematic.obj: precision.obj
+ltest.o: precision.o
+ltest.lo: precision.lo
+ltest.obj: precision.obj
+maccu.o: precision.o
+maccu.lo: precision.lo
+maccu.obj: precision.obj
+madds.o: constants.o mfunctions.o notfirst.o options.o precision.o
+madds.lo: constants.lo mfunctions.lo notfirst.lo options.lo precision.lo
+madds.obj: constants.obj mfunctions.obj notfirst.obj options.obj precision.obj
+mcgs.o: precision.o
+mcgs.lo: precision.lo
+mcgs.obj: precision.obj
+mfunctions.o: constants.o precision.o
+mfunctions.lo: constants.lo precision.lo
+mfunctions.obj: constants.obj precision.obj
+mgetbase.o: constants.o mfunctions.o precision.o
+mgetbase.lo: constants.lo mfunctions.lo precision.lo
+mgetbase.obj: constants.obj mfunctions.obj precision.obj
+mgetc1.o: constants.o mfunctions.o mglobal.o mrestore.o options.o precision.o
+mgetc1.lo: constants.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo
+mgetc1.obj: constants.obj mfunctions.obj mglobal.obj mrestore.obj options.obj \
+ precision.obj
+mgetc2.o: constants.o mfunctions.o mglobal.o mrestore.o options.o precision.o
+mgetc2.lo: constants.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo
+mgetc2.obj: constants.obj mfunctions.obj mglobal.obj mrestore.obj options.obj \
+ precision.obj
+mgetc3.o: constants.o mfunctions.o mglobal.o mrestore.o options.o precision.o
+mgetc3.lo: constants.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo
+mgetc3.obj: constants.obj mfunctions.obj mglobal.obj mrestore.obj options.obj \
+ precision.obj
+mgetc4.o: constants.o mfunctions.o mglobal.o mrestore.o options.o precision.o
+mgetc4.lo: constants.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo
+mgetc4.obj: constants.obj mfunctions.obj mglobal.obj mrestore.obj options.obj \
+ precision.obj
+mgetc5.o: constants.o mfunctions.o options.o precision.o
+mgetc5.lo: constants.lo mfunctions.lo options.lo precision.lo
+mgetc5.obj: constants.obj mfunctions.obj options.obj precision.obj
+mgetqs.o: options.o constants.o mfunctions.o mglobal.o precision.o
+mgetqs.lo: options.lo constants.lo mfunctions.lo mglobal.lo precision.lo
+mgetqs.obj: options.obj constants.obj mfunctions.obj mglobal.obj precision.obj
+mglobal.o: precision.o
+mglobal.lo: precision.lo
+mglobal.obj: precision.obj
+mrestore.o: constants.o mfunctions.o precision.o save.o
+mrestore.lo: constants.lo mfunctions.lo precision.lo save.lo
+mrestore.obj: constants.obj mfunctions.obj precision.obj save.obj
+msamurai.o: constants.o ltest.o maccu.o madds.o mgetbase.o mgetc1.o mgetc2.o \
+ mgetc3.o mgetc4.o mgetc5.o mgetqs.o mrestore.o mtens.o mtests.o \
+ ncuts.o notfirst.o options.o precision.o
+msamurai.lo: constants.lo ltest.lo maccu.lo madds.lo mgetbase.lo mgetc1.lo \
+ mgetc2.lo mgetc3.lo mgetc4.lo mgetc5.lo mgetqs.lo mrestore.lo \
+ mtens.lo mtests.lo ncuts.lo notfirst.lo options.lo precision.lo
+msamurai.obj: constants.obj ltest.obj maccu.obj madds.obj mgetbase.obj mgetc1.obj \
+ mgetc2.obj mgetc3.obj mgetc4.obj mgetc5.obj mgetqs.obj mrestore.obj \
+ mtens.obj mtests.obj ncuts.obj notfirst.obj options.obj precision.obj
+mtens.o: constants.o mcgs.o mfunctions.o options.o precision.o
+mtens.lo: constants.lo mcgs.lo mfunctions.lo options.lo precision.lo
+mtens.obj: constants.obj mcgs.obj mfunctions.obj options.obj precision.obj
+mtests.o: constants.o ltest.o mfunctions.o mglobal.o mrestore.o options.o \
+ precision.o save.o
+mtests.lo: constants.lo ltest.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo save.lo
+mtests.obj: constants.obj ltest.obj mfunctions.obj mglobal.obj mrestore.obj \
+ options.obj precision.obj save.obj
+save.o: constants.o precision.o
+save.lo: constants.lo precision.lo
+save.obj: constants.obj precision.obj
diff --git a/samurai-2.1.1/Makefile.in b/samurai-2.1.1/Makefile.in
new file mode 100644
index 0000000..f096f80
--- /dev/null
+++ b/samurai-2.1.1/Makefile.in
@@ -0,0 +1,686 @@
+# Makefile.in generated by automake 1.11.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,
+# Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+@COMPILE_QL_TRUE@am__append_1 = -L$(top_builddir)/qcdloop-1.9 -lqcdloop \
+@COMPILE_QL_TRUE@ -L$(top_builddir)/ff-2.0 -lff
+
+# nop
+@COMPILE_GOLEM95C_TRUE@am__append_2 = -L$(top_builddir)/golem95c-1.2.1 -lgolem
+DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.dep \
+ $(srcdir)/Makefile.in $(srcdir)/madds.f90.in \
+ $(srcdir)/msamurai.f90.in $(srcdir)/precision.f90.in
+subdir = samurai-2.1.1
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \
+ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \
+ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES = madds.f90 msamurai.f90 precision.f90
+CONFIG_CLEAN_VPATH_FILES =
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__installdirs = "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgincludedir)"
+LTLIBRARIES = $(lib_LTLIBRARIES)
+am__DEPENDENCIES_1 =
+libsamurai_la_DEPENDENCIES = $(am__DEPENDENCIES_1) \
+ $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_1)
+am_libsamurai_la_OBJECTS = constants.lo kinematic.lo ltest.lo madds.lo \
+ mcgs.lo mfunctions.lo mgetbase.lo mgetc1.lo mgetc2.lo \
+ mgetc3.lo mgetc4.lo mgetc5.lo mgetqs.lo mglobal.lo mrestore.lo \
+ msamurai.lo mtens.lo mtests.lo ncuts.lo notfirst.lo options.lo \
+ precision.lo save.lo maccu.lo
+libsamurai_la_OBJECTS = $(am_libsamurai_la_OBJECTS)
+DEFAULT_INCLUDES = -I.@am__isrc@
+FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+LTFCCOMPILE = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS)
+FCLD = $(FC)
+FCLINK = $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+SOURCES = $(libsamurai_la_SOURCES)
+DIST_SOURCES = $(libsamurai_la_SOURCES)
+HEADERS = $(nodist_pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIR = @DATADIR@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+F77 = @F77@
+FC = @FC@
+FCFLAGS = @FCFLAGS@
+FCFLAGS_f90 = @FCFLAGS_f90@
+FCLIBS = @FCLIBS@
+FFLAGS = @FFLAGS@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBLOOPTOOLS = @LIBLOOPTOOLS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SAMURAIVERSION = @SAMURAIVERSION@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+ac_ct_F77 = @ac_ct_F77@
+ac_ct_FC = @ac_ct_FC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+avh_olo_real_kind = @avh_olo_real_kind@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+case_with_avh = @case_with_avh@
+case_with_ff = @case_with_ff@
+case_with_golem = @case_with_golem@
+case_with_lt = @case_with_lt@
+case_with_olo = @case_with_olo@
+case_with_ql = @case_with_ql@
+case_with_samurai = @case_with_samurai@
+case_wout_avh = @case_wout_avh@
+case_wout_ff = @case_wout_ff@
+case_wout_golem = @case_wout_golem@
+case_wout_lt = @case_wout_lt@
+case_wout_olo = @case_wout_olo@
+case_wout_ql = @case_wout_ql@
+case_wout_samurai = @case_wout_samurai@
+conf_with_ff = @conf_with_ff@
+conf_with_golem95 = @conf_with_golem95@
+conf_with_lt = @conf_with_lt@
+conf_with_olo = @conf_with_olo@
+conf_with_ql = @conf_with_ql@
+conf_with_samurai = @conf_with_samurai@
+conf_wout_ff = @conf_wout_ff@
+conf_wout_golem95 = @conf_wout_golem95@
+conf_wout_lt = @conf_wout_lt@
+conf_wout_olo = @conf_wout_olo@
+conf_wout_ql = @conf_wout_ql@
+conf_wout_samurai = @conf_wout_samurai@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fortran_real_kind = @fortran_real_kind@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+lt_real_kind = @lt_real_kind@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+lib_LTLIBRARIES = libsamurai.la
+libsamurai_la_SOURCES = \
+ constants.f90 kinematic.f90 ltest.f90 madds.f90 mcgs.f90 mfunctions.f90 \
+ mgetbase.f90 mgetc1.f90 mgetc2.f90 mgetc3.f90 mgetc4.f90 mgetc5.f90 \
+ mgetqs.f90 mglobal.f90 mrestore.f90 msamurai.f90 mtens.f90 mtests.f90 \
+ ncuts.f90 notfirst.f90 options.f90 precision.f90 save.f90 maccu.f90
+
+nodist_pkginclude_HEADERS = \
+ constants.mod kinematic.mod ltest.mod madds.mod mcgs.mod mfunctions.mod \
+ mgetbase.mod mgetc1.mod mgetc2.mod mgetc3.mod mgetc4.mod mgetc5.mod \
+ mgetqs.mod mglobal.mod mrestore.mod msamurai.mod mtens.mod mtests.mod \
+ ncuts.mod notfirst.mod options.mod precision.mod save.mod maccu.mod
+
+AM_FCFLAGS = \
+ -I. \
+ -I$(top_builddir)/avh_olo-2.2.1 \
+ -I$(top_builddir)/golem95c-1.2.1/module
+
+# nop
+libsamurai_la_LIBADD = $(LIBLOOPTOOLS) $(am__append_1) $(am__append_2) \
+ -L$(top_builddir)/avh_olo-2.2.1 -lavh_olo
+CLEANFILES = \
+ constants.mod kinematic.mod ltest.mod madds.mod mcgs.mod mfunctions.mod \
+ mgetbase.mod mgetc1.mod mgetc2.mod mgetc3.mod mgetc4.mod mgetc5.mod \
+ mgetqs.mod mglobal.mod mrestore.mod msamurai.mod mtens.mod mtests.mod \
+ ncuts.mod notfirst.mod options.mod precision.mod save.mod maccu.mod
+
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f90 .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(srcdir)/Makefile.dep $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu samurai-2.1.1/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu samurai-2.1.1/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+madds.f90: $(top_builddir)/config.status $(srcdir)/madds.f90.in
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
+msamurai.f90: $(top_builddir)/config.status $(srcdir)/msamurai.f90.in
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
+precision.f90: $(top_builddir)/config.status $(srcdir)/precision.f90.in
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
+install-libLTLIBRARIES: $(lib_LTLIBRARIES)
+ @$(NORMAL_INSTALL)
+ test -z "$(libdir)" || $(MKDIR_P) "$(DESTDIR)$(libdir)"
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ list2=; for p in $$list; do \
+ if test -f $$p; then \
+ list2="$$list2 $$p"; \
+ else :; fi; \
+ done; \
+ test -z "$$list2" || { \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \
+ }
+
+uninstall-libLTLIBRARIES:
+ @$(NORMAL_UNINSTALL)
+ @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \
+ for p in $$list; do \
+ $(am__strip_dir) \
+ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \
+ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \
+ done
+
+clean-libLTLIBRARIES:
+ -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES)
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+ test "$$dir" != "$$p" || dir=.; \
+ echo "rm -f \"$${dir}/so_locations\""; \
+ rm -f "$${dir}/so_locations"; \
+ done
+libsamurai.la: $(libsamurai_la_OBJECTS) $(libsamurai_la_DEPENDENCIES)
+ $(FCLINK) -rpath $(libdir) $(libsamurai_la_OBJECTS) $(libsamurai_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+.f90.o:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+.f90.obj:
+ $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'`
+
+.f90.lo:
+ $(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $<
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)"
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ test -n "$$files" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(pkgincludedir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(pkgincludedir)" && rm -f $$files
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libLTLIBRARIES clean-libtool \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-nodist_pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am: install-libLTLIBRARIES
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-libLTLIBRARIES \
+ uninstall-nodist_pkgincludeHEADERS
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \
+ clean-libLTLIBRARIES clean-libtool ctags distclean \
+ distclean-compile distclean-generic distclean-libtool \
+ distclean-tags distdir dvi dvi-am html html-am info info-am \
+ install install-am install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am \
+ install-libLTLIBRARIES install-man \
+ install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
+ install-ps install-ps-am install-strip installcheck \
+ installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags uninstall uninstall-am uninstall-libLTLIBRARIES \
+ uninstall-nodist_pkgincludeHEADERS
+
+
+# Module dependencies
+options.o: precision.o
+options.lo: precision.lo
+options.obj: precision.obj
+constants.o: precision.o
+constants.lo: precision.lo
+constants.obj: precision.obj
+kinematic.o: precision.o
+kinematic.lo: precision.lo
+kinematic.obj: precision.obj
+ltest.o: precision.o
+ltest.lo: precision.lo
+ltest.obj: precision.obj
+maccu.o: precision.o
+maccu.lo: precision.lo
+maccu.obj: precision.obj
+madds.o: constants.o mfunctions.o notfirst.o options.o precision.o
+madds.lo: constants.lo mfunctions.lo notfirst.lo options.lo precision.lo
+madds.obj: constants.obj mfunctions.obj notfirst.obj options.obj precision.obj
+mcgs.o: precision.o
+mcgs.lo: precision.lo
+mcgs.obj: precision.obj
+mfunctions.o: constants.o precision.o
+mfunctions.lo: constants.lo precision.lo
+mfunctions.obj: constants.obj precision.obj
+mgetbase.o: constants.o mfunctions.o precision.o
+mgetbase.lo: constants.lo mfunctions.lo precision.lo
+mgetbase.obj: constants.obj mfunctions.obj precision.obj
+mgetc1.o: constants.o mfunctions.o mglobal.o mrestore.o options.o precision.o
+mgetc1.lo: constants.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo
+mgetc1.obj: constants.obj mfunctions.obj mglobal.obj mrestore.obj options.obj \
+ precision.obj
+mgetc2.o: constants.o mfunctions.o mglobal.o mrestore.o options.o precision.o
+mgetc2.lo: constants.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo
+mgetc2.obj: constants.obj mfunctions.obj mglobal.obj mrestore.obj options.obj \
+ precision.obj
+mgetc3.o: constants.o mfunctions.o mglobal.o mrestore.o options.o precision.o
+mgetc3.lo: constants.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo
+mgetc3.obj: constants.obj mfunctions.obj mglobal.obj mrestore.obj options.obj \
+ precision.obj
+mgetc4.o: constants.o mfunctions.o mglobal.o mrestore.o options.o precision.o
+mgetc4.lo: constants.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo
+mgetc4.obj: constants.obj mfunctions.obj mglobal.obj mrestore.obj options.obj \
+ precision.obj
+mgetc5.o: constants.o mfunctions.o options.o precision.o
+mgetc5.lo: constants.lo mfunctions.lo options.lo precision.lo
+mgetc5.obj: constants.obj mfunctions.obj options.obj precision.obj
+mgetqs.o: options.o constants.o mfunctions.o mglobal.o precision.o
+mgetqs.lo: options.lo constants.lo mfunctions.lo mglobal.lo precision.lo
+mgetqs.obj: options.obj constants.obj mfunctions.obj mglobal.obj precision.obj
+mglobal.o: precision.o
+mglobal.lo: precision.lo
+mglobal.obj: precision.obj
+mrestore.o: constants.o mfunctions.o precision.o save.o
+mrestore.lo: constants.lo mfunctions.lo precision.lo save.lo
+mrestore.obj: constants.obj mfunctions.obj precision.obj save.obj
+msamurai.o: constants.o ltest.o maccu.o madds.o mgetbase.o mgetc1.o mgetc2.o \
+ mgetc3.o mgetc4.o mgetc5.o mgetqs.o mrestore.o mtens.o mtests.o \
+ ncuts.o notfirst.o options.o precision.o
+msamurai.lo: constants.lo ltest.lo maccu.lo madds.lo mgetbase.lo mgetc1.lo \
+ mgetc2.lo mgetc3.lo mgetc4.lo mgetc5.lo mgetqs.lo mrestore.lo \
+ mtens.lo mtests.lo ncuts.lo notfirst.lo options.lo precision.lo
+msamurai.obj: constants.obj ltest.obj maccu.obj madds.obj mgetbase.obj mgetc1.obj \
+ mgetc2.obj mgetc3.obj mgetc4.obj mgetc5.obj mgetqs.obj mrestore.obj \
+ mtens.obj mtests.obj ncuts.obj notfirst.obj options.obj precision.obj
+mtens.o: constants.o mcgs.o mfunctions.o options.o precision.o
+mtens.lo: constants.lo mcgs.lo mfunctions.lo options.lo precision.lo
+mtens.obj: constants.obj mcgs.obj mfunctions.obj options.obj precision.obj
+mtests.o: constants.o ltest.o mfunctions.o mglobal.o mrestore.o options.o \
+ precision.o save.o
+mtests.lo: constants.lo ltest.lo mfunctions.lo mglobal.lo mrestore.lo options.lo \
+ precision.lo save.lo
+mtests.obj: constants.obj ltest.obj mfunctions.obj mglobal.obj mrestore.obj \
+ options.obj precision.obj save.obj
+save.o: constants.o precision.o
+save.lo: constants.lo precision.lo
+save.obj: constants.obj precision.obj
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/samurai-2.1.1/constants.f90 b/samurai-2.1.1/constants.f90
new file mode 100644
index 0000000..5620a78
--- /dev/null
+++ b/samurai-2.1.1/constants.f90
@@ -0,0 +1,56 @@
+module constants
+use precision
+implicit none
+
+ private :: ki
+
+ real(ki), parameter :: pi = 3.14159265358979323846&
+ &2643383279502884197169399375105820974944592307816&
+ &4062862089986280348253421170679821480865132823066&
+ &47093844609550582231725359408128_ki
+ real(ki),parameter :: twopi = 2.0_ki*pi
+!-----------------------------------------------------
+ real(ki),parameter :: zip=0.0_ki
+ real(ki),parameter :: half=0.5_ki
+ real(ki),parameter :: one=1.0_ki
+ real(ki),parameter :: two=2.0_ki
+ real(ki),parameter :: three=3.0_ki
+ real(ki),parameter :: four=4.0_ki
+ real(ki),parameter :: six=6.0_ki
+ real(ki),parameter :: seven=7.0_ki
+ real(ki),parameter :: eight=8.0_ki
+ real(ki),parameter :: rt2 = 1.414213562373095048801&
+ &688724209698078569671875376948073176679737990732478&
+ &4621070388503875343276415727350138462309122970249248361_ki
+ real(ki),parameter :: rt3 = 1.732050807568877293527&
+ &446341505872366942805253810380628055806979451933016&
+ &9088000370811461867572485756756261414154067030299699451_ki
+!-----------------------------------------------------
+ complex(ki),parameter :: chaf=(0.5_ki,0.0_ki)
+ complex(ki),parameter :: im=(0.0_ki,1.0_ki)
+ complex(ki),parameter :: impi =(0.0_ki,pi)
+ complex(ki),parameter :: czip=(0.0_ki,0.0_ki)
+ complex(ki),parameter :: cone=(1.0_ki,0.0_ki)
+ complex(ki),parameter :: ctwo=(2.0_ki,0.0_ki)
+!-----------------------------------------------------
+! for nleg max = ! 8! 7! 6! 5! 4!
+! !--------------!
+ integer,parameter :: max5= 56 !56!21! 6! 1! 0!
+ integer,parameter :: max4= 70 !70!35!15! 5! 1!
+ integer,parameter :: max3= 56 !56!35!20!10! 4!
+ integer,parameter :: max2= 28 !28!21!15!10! 6!
+ integer,parameter :: max1= 8 ! 8! 7! 6! 5! 4!
+ integer,parameter :: maxleg= 8 ! 8! 7! 6! 5! 4!
+! !--------------!
+ integer,parameter :: nq5=1
+ integer,parameter :: nq4=5
+ integer,parameter :: nq3=10
+ integer,parameter :: nq2=10
+ integer,parameter :: nq1=5
+
+!-----------------------------------------------------
+ real(ki),parameter :: zip1 = 1.0e-14_ki
+
+end module constants
+
+
diff --git a/samurai-2.1.1/kinematic.f90 b/samurai-2.1.1/kinematic.f90
new file mode 100644
index 0000000..80e39b9
--- /dev/null
+++ b/samurai-2.1.1/kinematic.f90
@@ -0,0 +1,823 @@
+module kinematic
+ use precision, only: ki
+ implicit none
+ save
+
+ private
+
+ interface dotproduct
+ module procedure dotproduct_rr
+ module procedure dotproduct_rc
+ module procedure dotproduct_cr
+ module procedure dotproduct_cc
+ end interface dotproduct
+
+
+ interface zb
+ module procedure zb_rr
+ module procedure zb_rc
+ module procedure zb_cr
+ module procedure zb_cc
+ end interface zb
+
+ interface za
+ module procedure za_rr
+ module procedure za_rc
+ module procedure za_cr
+ module procedure za_cc
+ end interface za
+
+ interface zab
+ module procedure zab_rcr
+ module procedure zab_ccc
+ module procedure zab_ccr
+ module procedure zab_rcc
+ module procedure zab_rrr
+ module procedure zab_crc
+ module procedure zab_crr
+ module procedure zab_rrc
+ end interface zab
+
+ interface zba
+ module procedure zba_rcr
+ module procedure zba_ccc
+ module procedure zba_ccr
+ module procedure zba_rcc
+ module procedure zba_rrr
+ module procedure zba_crc
+ module procedure zba_crr
+ module procedure zba_rrc
+ end interface zba
+
+ interface zbb
+ module procedure zbb_rcrr
+ end interface zbb
+
+ public :: dotproduct, zb, za, zab, zbb, zba
+ public :: inspect_Vi, epsi, epso, gamma_6
+
+contains
+
+ subroutine inspect_Vi(Vi)
+ implicit none
+ real(ki), dimension(8,4), intent(in) :: Vi
+ integer :: k, i
+
+ do k = 1,8
+ do i = 1,4
+ write(*,'(A3,I1,A1,I1,A4,F24.15)') "Vi(", k, ",", i, ") = ", &
+ & Vi(k, i)
+ end do
+ end do
+ end subroutine
+
+
+! blocco epsi epso
+
+ pure function epsi(pol, vec, aux)
+ implicit none
+ integer, intent(in) :: pol
+ real(ki), dimension(4), intent(in) :: vec, aux
+ complex(ki), dimension(4) :: epsi
+
+ real(ki), dimension(4) :: e1, e2, p, k
+ real(ki) :: r, s, n
+ integer, dimension(1) :: dir
+
+ p(1:3) = aux(1:3) / aux(4)
+ p(4) = 1.0_ki
+
+ k(1:3) = vec(1:3) / vec(4)
+ k(4) = 1.0_ki
+
+ r = 1.0_ki - dotproduct(k, p)
+ s = sign(1.0_ki, real(pol, ki))
+
+ e1(4) = 0.0_ki
+ if (abs(r + 1.0_ki) > 1.0E+03_ki * epsilon(1.0_ki)) then
+ n = 1.0_ki / sqrt(2.0_ki * abs(1.0_ki - r*r))
+
+ e1(1) = k(2) * p(3) - k(3) * p(2)
+ e1(2) = k(3) * p(1) - k(1) * p(3)
+ e1(3) = k(1) * p(2) - k(2) * p(1)
+ e1(1:3) = n * e1(1:3)
+
+ e2(1:3) = k(1:3) + p(1:3)
+ e2(4) = 1.0_ki + r
+ e2(:) = n * e2(:)
+ else
+ dir = minloc(abs(k(1:3)))
+ if (dir(1) .eq. 1) then
+ n = sqrt(0.5_ki / (k(2)*k(2) + k(3)*k(3)))
+ e1(1) = 0.0_ki
+ e1(2) = - k(3) * n
+ e1(3) = k(2) * n
+ elseif (dir(1) .eq. 2) then
+ n = sqrt(0.5_ki / (k(1)*k(1) + k(3)*k(3)))
+ e1(2) = 0.0_ki
+ e1(3) = - k(1) * n
+ e1(1) = k(3) * n
+ else
+ n = sqrt(0.5_ki / (k(1)*k(1) + k(2)*k(2)))
+ e1(3) = 0.0_ki
+ e1(1) = - k(2) * n
+ e1(2) = k(1) * n
+ endif
+
+ e2(1) = k(2) * e1(3) - k(3) * e1(2)
+ e2(2) = k(3) * e1(1) - k(1) * e1(3)
+ e2(3) = k(1) * e1(2) - k(2) * e1(1)
+ e2(4) = 0.0_ki
+ end if
+ epsi(:) = e1(:) + cmplx(0.0_ki, s, ki) * e2(:)
+ end function epsi
+
+ pure function epso(pol, vec, aux)
+ implicit none
+ integer, intent(in) :: pol
+ real(ki), dimension(4), intent(in) :: vec, aux
+ complex(ki), dimension(4) :: epso
+
+ epso = conjg(epsi(pol, vec, aux))
+ end function epso
+
+
+! blocco dotproduct
+
+ pure function dotproduct_rr(p, q)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p, q
+ real(ki) :: dotproduct_rr
+ dotproduct_rr = p(4)*q(4) - p(1)*q(1) - p(2)*q(2) - p(3)*q(3)
+ end function dotproduct_rr
+
+ pure function dotproduct_cc(p, q)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p, q
+ complex(ki) :: dotproduct_cc
+ dotproduct_cc = p(4)*q(4) - p(1)*q(1) - p(2)*q(2) - p(3)*q(3)
+ end function dotproduct_cc
+
+ pure function dotproduct_rc(p, q)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p
+ complex(ki), dimension(4), intent(in) :: q
+ complex(ki) :: dotproduct_rc
+ dotproduct_rc = p(4)*q(4) - p(1)*q(1) - p(2)*q(2) - p(3)*q(3)
+ end function dotproduct_rc
+
+ pure function dotproduct_cr(p, q)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p
+ real(ki), dimension(4), intent(in) :: q
+ complex(ki) :: dotproduct_cr
+ dotproduct_cr = p(4)*q(4) - p(1)*q(1) - p(2)*q(2) - p(3)*q(3)
+ end function dotproduct_cr
+
+
+! blocco zab
+
+ pure function zab_ccc(p1, k, p2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p1
+ complex(ki), dimension(4), intent(in) :: p2
+ complex(ki), dimension(4), intent(in) :: k
+ complex(ki) :: zab_ccc
+
+ complex(ki) :: kp, km, im
+ complex(ki) :: kr, kl, pr1, pr2, pl1, pl2, rt1, rt2
+
+ im=(0.0_ki,1.0_ki)
+
+ kp=+k(4)+k(1)
+ km=+k(4)-k(1)
+ kr=+k(3)-im*k(2)
+ kl=+k(3)+im*k(2)
+
+ rt1=sqrt((p1(4)+p1(1)))
+ rt2=sqrt((p2(4)+p2(1)))
+ pr1=p1(3)-im*p1(2)
+ pr2=p2(3)-im*p2(2)
+ pl1=p1(3)+im*p1(2)
+ pl2=p2(3)+im*p2(2)
+
+ zab_ccc=&
+ & (+pr1*pl2*kp/(rt1*rt2)&
+ & -pr1*kl*rt2/rt1&
+ & -rt1/rt2*kr*pl2+rt1*rt2*km)
+
+ end function zab_ccc
+
+
+ pure function zab_ccr(p1, k, k2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p1
+ real(ki), dimension(4), intent(in) :: k2
+ complex(ki), dimension(4), intent(in) :: k
+ complex(ki) :: zab_ccr
+
+ complex(ki) :: kp, km, im
+ complex(ki) :: kr, kl, pr1, pr2, pl1, pl2, rt1, f2
+ real(ki) :: flip2, rt2
+
+ im=(0.0_ki,1.0_ki)
+
+ kp=+k(4)+k(1)
+ km=+k(4)-k(1)
+ kr=+k(3)-im*k(2)
+ kl=+k(3)+im*k(2)
+
+ rt1=sqrt((p1(4)+p1(1)))
+ pr1=p1(3)-im*p1(2)
+ pl1=p1(3)+im*p1(2)
+
+ if (k2(4) .gt. 0.0_ki) then
+ flip2=1.0_ki
+ f2=(1.0_ki, 0.0_ki)
+ else
+ flip2=-1.0_ki
+ f2=(0.0_ki, 1.0_ki)
+ endif
+ rt2=sqrt(flip2*(k2(4)+k2(1)))
+ pr2=cmplx(flip2*k2(3),-flip2*k2(2), ki)
+ pl2=conjg(pr2)
+
+ zab_ccr=f2*&
+ & (+pr1*pl2*kp/(rt1*rt2)&
+ & -pr1*kl*rt2/rt1&
+ & -rt1/rt2*kr*pl2+rt1*rt2*km)
+
+ end function zab_ccr
+
+ pure function zab_rcc(k1, k, p2)
+ implicit none
+ real(ki), dimension(4), intent(in) :: k1
+ complex(ki), dimension(4), intent(in) :: p2
+ complex(ki), dimension(4), intent(in) :: k
+ complex(ki) :: zab_rcc
+
+ complex(ki) :: kp, km, im
+ complex(ki) :: kr, kl, pr1, pr2, pl1, pl2, rt2, f1
+ real(ki) :: flip1, rt1
+
+ im=(0.0_ki,1.0_ki)
+
+ kp=+k(4)+k(1)
+ km=+k(4)-k(1)
+ kr=+k(3)-im*k(2)
+ kl=+k(3)+im*k(2)
+
+ if (k1(4) .gt. 0.0_ki) then
+ flip1=1.0_ki
+ f1=1.0_ki
+ else
+ flip1=-1.0_ki
+ f1=(0.0_ki, 1.0_ki)
+ endif
+ rt1=sqrt(flip1*(k1(4)+k1(1)))
+ pr1=cmplx(flip1*k1(3),-flip1*k1(2), ki)
+ pl1=conjg(pr1)
+
+ rt2=sqrt((p2(4)+p2(1)))
+ pr2=p2(3)-im*p2(2)
+ pl2=p2(3)+im*p2(2)
+
+ zab_rcc=f1*&
+ & (+pr1*pl2*kp/(rt1*rt2)&
+ & -pr1*kl*rt2/rt1&
+ & -rt1/rt2*kr*pl2+rt1*rt2*km)
+
+ end function zab_rcc
+
+
+
+ pure function zab_crc(p1, k, p2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p1
+ complex(ki), dimension(4), intent(in) :: p2
+ real(ki), dimension(4), intent(in) :: k
+ complex(ki) :: zab_crc
+
+ real(ki) :: kp, km
+ complex(ki) :: kr, kl, pr1, pr2, pl1, pl2, rt1, rt2, im
+
+ im=(0.0_ki,1.0_ki)
+
+ kp=+k(4)+k(1)
+ km=+k(4)-k(1)
+ kr=+k(3)-im*k(2)
+ kl=+k(3)+im*k(2)
+
+ rt1=sqrt((p1(4)+p1(1)))
+ rt2=sqrt((p2(4)+p2(1)))
+ pr1=p1(3)-im*p1(2)
+ pr2=p2(3)-im*p2(2)
+ pl1=p1(3)+im*p1(2)
+ pl2=p2(3)+im*p2(2)
+
+ zab_crc=&
+ & (+pr1*pl2*kp/(rt1*rt2)&
+ & -pr1*kl*rt2/rt1&
+ & -rt1/rt2*kr*pl2+rt1*rt2*km)
+
+ end function zab_crc
+
+
+
+ pure function zab_rrr(p1, Q, p2)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p1, p2, Q
+ real(ki), dimension(4) :: q1
+ real(ki) :: r2
+ complex(ki) :: zab_rrr
+
+!---- decomposing Q along p2
+
+ r2=dotproduct(Q,Q)/(2.0_ki*dotproduct(Q,p2))
+
+ q1(:) = Q(:) - r2*p2(:)
+
+ zab_rrr = za(p1,q1)*zb(q1,p2)
+ end function zab_rrr
+
+
+ pure function zabccc(p1, Q, p2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p1, p2, Q
+ complex(ki), dimension(4) :: q1
+ complex(ki) :: r2
+ complex(ki) :: zabccc
+
+!---- decomposing Q along p2
+
+ r2=dotproduct(Q,Q)/(2.0_ki*dotproduct(Q,p2))
+
+ q1(:) = Q(:) - r2*p2(:)
+
+ zabccc = za(p1,q1)*zb(q1,p2)
+ end function zabccc
+
+
+
+ pure function PMzab_rcr(p1, Q, p2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: Q
+ real(ki), dimension(4), intent(in) :: p1, p2
+ complex(ki), dimension(4) :: q1
+ complex(ki) :: r2
+ complex(ki) :: PMzab_rcr
+
+!---- decomposing Q along p2
+
+ r2=dotproduct(Q,Q)/(2.0_ki*dotproduct(Q,p2))
+
+ q1(:) = Q(:) - r2*p2(:)
+
+ PMzab_rcr = za(p1,q1)*zb(q1,p2)
+ end function PMzab_rcr
+
+
+
+ pure function zab_rcr(k1, k, k2)
+ implicit none
+ real(ki), dimension(4), intent(in) :: k1
+ real(ki), dimension(4), intent(in) :: k2
+ complex(ki), dimension(4), intent(in) :: k
+ complex(ki) :: zab_rcr
+ complex(ki) :: kp, km
+ complex(ki) :: kr, kl
+ complex(ki) :: pr1, pr2, pl1, pl2, im, f1, f2
+ real(ki) :: flip1, flip2, rt1, rt2
+
+ im=(0.0_ki,1.0_ki)
+
+ kp=+k(4)+k(1)
+ km=+k(4)-k(1)
+ kr=+k(3)-im*k(2)
+ kl=+k(3)+im*k(2)
+
+ if (k1(4) .gt. 0.0_ki) then
+ flip1=1.0_ki
+ f1=1.0_ki
+ else
+ flip1=-1.0_ki
+ f1=(0.0_ki, 1.0_ki)
+ endif
+ rt1=sqrt(flip1*(k1(4)+k1(1)))
+ pr1=cmplx(flip1*k1(3),-flip1*k1(2), ki)
+ pl1=conjg(pr1)
+
+ if (k2(4) .gt. 0.0_ki) then
+ flip2=1.0_ki
+ f2=(1.0_ki, 0.0_ki)
+ else
+ flip2=-1.0_ki
+ f2=(0.0_ki, 1.0_ki)
+ endif
+ rt2=sqrt(flip2*(k2(4)+k2(1)))
+ pr2=cmplx(flip2*k2(3),-flip2*k2(2), ki)
+ pl2=conjg(pr2)
+
+ zab_rcr=f1*f2*(&
+ & (+pr1*pl2*kp/(rt1*rt2)&
+ & -pr1*kl*rt2/rt1&
+ & -rt1/rt2*kr*pl2+rt1*rt2*km))
+
+ end function zab_rcr
+
+
+ pure function zab_crr(p1, k, k2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p1
+ real(ki), dimension(4), intent(in) :: k2
+ real(ki), dimension(4), intent(in) :: k
+ complex(ki) :: zab_crr
+
+ real(ki) :: kp, km
+ complex(ki) :: kr, kl, pr1, pr2, pl1, pl2, rt1, f2, im
+ real(ki) :: flip2, rt2
+
+ im=(0.0_ki,1.0_ki)
+
+ kp=+k(4)+k(1)
+ km=+k(4)-k(1)
+ kr=+k(3)-im*k(2)
+ kl=+k(3)+im*k(2)
+
+ rt1=sqrt((p1(4)+p1(1)))
+ pr1=p1(3)-im*p1(2)
+ pl1=p1(3)+im*p1(2)
+
+ if (k2(4) .gt. 0.0_ki) then
+ flip2=1.0_ki
+ f2=(1.0_ki, 0.0_ki)
+ else
+ flip2=-1.0_ki
+ f2=(0.0_ki, 1.0_ki)
+ endif
+ rt2=sqrt(flip2*(k2(4)+k2(1)))
+ pr2=cmplx(flip2*k2(3),-flip2*k2(2), ki)
+ pl2=conjg(pr2)
+
+ zab_crr=f2*&
+ & (+pr1*pl2*kp/(rt1*rt2)&
+ & -pr1*kl*rt2/rt1&
+ & -rt1/rt2*kr*pl2+rt1*rt2*km)
+
+ end function zab_crr
+
+ pure function zab_rrc(k1, k, p2)
+ implicit none
+ real(ki), dimension(4), intent(in) :: k1
+ complex(ki), dimension(4), intent(in) :: p2
+ real(ki), dimension(4), intent(in) :: k
+ complex(ki) :: zab_rrc
+
+ real(ki) :: kp, km
+ complex(ki) :: kr, kl, pr1, pr2, pl1, pl2, rt2, im, f1
+ real(ki) :: flip1, rt1
+
+ im=(0.0_ki,1.0_ki)
+
+ kp=+k(4)+k(1)
+ km=+k(4)-k(1)
+ kr=+k(3)-im*k(2)
+ kl=+k(3)+im*k(2)
+
+ if (k1(4) .gt. 0.0_ki) then
+ flip1=1.0_ki
+ f1=1.0_ki
+ else
+ flip1=-1.0_ki
+ f1=(0.0_ki, 1.0_ki)
+ endif
+ rt1=sqrt(flip1*(k1(4)+k1(1)))
+ pr1=cmplx(flip1*k1(3),-flip1*k1(2), ki)
+ pl1=conjg(pr1)
+
+ rt2=sqrt((p2(4)+p2(1)))
+ pr2=p2(3)-im*p2(2)
+ pl2=p2(3)+im*p2(2)
+
+ zab_rrc=f1*&
+ & (+pr1*pl2*kp/(rt1*rt2)&
+ & -pr1*kl*rt2/rt1&
+ & -rt1/rt2*kr*pl2+rt1*rt2*km)
+
+ end function zab_rrc
+
+
+! blocco zba
+
+ pure function zba_ccc(p,k,q) result(zba)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p,k,q
+ complex(ki) :: zba
+ zba = zab(q,k,p)
+ end function zba_ccc
+
+ pure function zba_rcc(p,k,q) result(zba)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p
+ complex(ki), dimension(4), intent(in) :: k,q
+ complex(ki) :: zba
+ zba = zab(q,k,p)
+ end function zba_rcc
+
+ pure function zba_crc(p,k,q) result(zba)
+ implicit none
+ real(ki), dimension(4), intent(in) :: k
+ complex(ki), dimension(4), intent(in) :: p,q
+ complex(ki) :: zba
+ zba = zab(q,k,p)
+ end function zba_crc
+
+ pure function zba_ccr(p,k,q) result(zba)
+ implicit none
+ real(ki), dimension(4), intent(in) :: q
+ complex(ki), dimension(4), intent(in) :: p,k
+ complex(ki) :: zba
+ zba = zab(q,k,p)
+ end function zba_ccr
+
+ pure function zba_rrc(p,k,q) result(zba)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p,k
+ complex(ki), dimension(4), intent(in) :: q
+ complex(ki) :: zba
+ zba = zab(q,k,p)
+ end function zba_rrc
+
+ pure function zba_rcr(p,k,q) result(zba)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p,q
+ complex(ki), dimension(4), intent(in) :: k
+ complex(ki) :: zba
+ zba = zab(q,k,p)
+ end function zba_rcr
+
+ pure function zba_crr(p,k,q) result(zba)
+ implicit none
+ real(ki), dimension(4), intent(in) :: k,q
+ complex(ki), dimension(4), intent(in) :: p
+ complex(ki) :: zba
+ zba = zab(q,k,p)
+ end function zba_crr
+
+ pure function zba_rrr(p,k,q) result(zba)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p,k,q
+ complex(ki) :: zba
+ zba = zab(q,k,p)
+ end function zba_rrr
+
+! blocco zb
+
+ pure function zb_rr(p, q)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p, q
+ complex(ki) :: zb_rr
+ zb_rr = 2.0_ki*dotproduct(p, q)/za(q, p)
+ end function zb_rr
+
+
+! blocco za
+
+ pure function za_rr(k1, k2)
+ implicit none
+ real(ki), dimension(4), intent(in) :: k1, k2
+ complex(ki) :: za_rr
+
+ real(ki) :: rt1, rt2
+ complex(ki) :: c231, c232, f1, f2
+!-----positive energy case
+ if (k1(4) .gt. 0.0_ki) then
+ rt1=sqrt(k1(4)+k1(1))
+ c231=cmplx(k1(3),-k1(2), ki)
+ f1=1.0_ki
+ else
+!-----negative energy case
+ rt1=sqrt(-k1(4)-k1(1))
+ c231=cmplx(-k1(3),k1(2), ki)
+ f1=(0.0_ki, 1.0_ki)
+ endif
+!-----positive energy case
+ if (k2(4) .gt. 0.0_ki) then
+ rt2=sqrt(k2(4)+k2(1))
+ c232=cmplx(k2(3),-k2(2), ki)
+ f2=1.0_ki
+ else
+!-----negative energy case
+ rt2=sqrt(-k2(4)-k2(1))
+ c232=cmplx(-k2(3),k2(2), ki)
+ f2=(0.0_ki, 1.0_ki)
+ endif
+
+ za_rr = -f2*f1*(c232*rt1/rt2-c231*rt2/rt1)
+
+ end function za_rr
+
+ pure function za_cc(p1, p2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p1, p2
+ complex(ki) :: za_cc
+
+ complex(ki) :: rt1, rt2, im
+ complex(ki) :: c231, c232
+
+ im=(0.0_ki,1.0_ki)
+
+ rt1=sqrt((p1(4)+p1(1)))
+ c231=p1(3)-im*p1(2)
+
+ rt2=sqrt((p2(4)+p2(1)))
+ c232=p2(3)-im*p2(2)
+
+ za_cc = -(c232*rt1/rt2-c231*rt2/rt1)
+
+ end function za_cc
+
+
+ pure function zb_cc(p1, p2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p1, p2
+ complex(ki) :: zb_cc
+
+ complex(ki) :: rt1, rt2, im
+ complex(ki) :: c231, c232
+
+ im=(0.0_ki,1.0_ki)
+
+ rt1=sqrt((p1(4)+p1(1)))
+ c231=p1(3)+im*p1(2)
+
+ rt2=sqrt((p2(4)+p2(1)))
+ c232=p2(3)+im*p2(2)
+
+ zb_cc = c232*rt1/rt2-c231*rt2/rt1
+
+ end function zb_cc
+
+
+ pure function za_rc(k1, p2)
+ implicit none
+ real(ki), dimension(4), intent(in) :: k1
+ complex(ki), dimension(4), intent(in) :: p2
+ complex(ki) :: za_rc
+ real(ki) :: rt1
+ complex(ki) :: c231, c232, f1, im, rt2
+
+ im=(0.0_ki,1.0_ki)
+
+!-----positive energy case
+ if (k1(4) .gt. 0.0_ki) then
+ rt1=sqrt(k1(4)+k1(1))
+ c231=cmplx(k1(3),-k1(2), ki)
+ f1=1.0_ki
+ else
+!-----negative energy case
+ rt1=sqrt(-k1(4)-k1(1))
+ c231=cmplx(-k1(3),k1(2), ki)
+ f1=(0.0_ki, 1.0_ki)
+ endif
+
+ rt2=sqrt((p2(4)+p2(1)))
+ c232=p2(3)-im*p2(2)
+
+ za_rc = -f1*(c232*rt1/rt2-c231*rt2/rt1)
+
+ end function za_rc
+
+
+ pure function zb_rc(k1, p2)
+ implicit none
+ real(ki), dimension(4), intent(in) :: k1
+ complex(ki), dimension(4), intent(in) :: p2
+ complex(ki) :: zb_rc
+ real(ki) :: rt1
+ complex(ki) :: c231, c232, f1, im, rt2
+
+ im=(0.0_ki,1.0_ki)
+
+!-----positive energy case
+ if (k1(4) .gt. 0.0_ki) then
+ rt1=sqrt(k1(4)+k1(1))
+ c231=cmplx(k1(3),k1(2), ki)
+ f1=1.0_ki
+ else
+!-----negative energy case
+ rt1=sqrt(-k1(4)-k1(1))
+ c231=cmplx(-k1(3),-k1(2), ki)
+ f1=(0.0_ki, 1.0_ki)
+ endif
+
+ rt2=sqrt((p2(4)+p2(1)))
+ c232=p2(3)+im*p2(2)
+
+ zb_rc = f1*(c232*rt1/rt2-c231*rt2/rt1)
+
+ end function zb_rc
+
+
+ pure function za_cr(p1, k2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p1
+ real(ki), dimension(4), intent(in) :: k2
+ complex(ki) :: za_cr
+
+ real(ki) :: rt2
+ complex(ki) :: c231, c232, f2, rt1, im
+
+ im=(0.0_ki,1.0_ki)
+ rt1=sqrt((p1(4)+p1(1)))
+ c231=p1(3)-im*p1(2)
+
+!-----positive energy case
+ if (k2(4) .gt. 0.0_ki) then
+ rt2=sqrt(k2(4)+k2(1))
+ c232=cmplx(k2(3),-k2(2), ki)
+ f2=1.0_ki
+ else
+!-----negative energy case
+ rt2=sqrt(-k2(4)-k2(1))
+ c232=cmplx(-k2(3),k2(2), ki)
+ f2=(0.0_ki, 1.0_ki)
+ endif
+
+ za_cr = -f2*(c232*rt1/rt2-c231*rt2/rt1)
+
+ end function za_cr
+
+ pure function zb_cr(p1, k2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p1
+ real(ki), dimension(4), intent(in) :: k2
+ complex(ki) :: zb_cr
+
+ real(ki) :: rt2
+ complex(ki) :: c231, c232, f2, rt1, im
+
+ im=(0.0_ki,1.0_ki)
+ rt1=sqrt((p1(4)+p1(1)))
+ c231=p1(3)+im*p1(2)
+
+!-----positive energy case
+ if (k2(4) .gt. 0.0_ki) then
+ rt2=sqrt(k2(4)+k2(1))
+ c232=cmplx(k2(3),k2(2), ki)
+ f2=1.0_ki
+ else
+!-----negative energy case
+ rt2=sqrt(-k2(4)-k2(1))
+ c232=cmplx(-k2(3),-k2(2), ki)
+ f2=(0.0_ki, 1.0_ki)
+ endif
+
+ zb_cr = f2*(c232*rt1/rt2-c231*rt2/rt1)
+
+ end function zb_cr
+
+
+ function zbb_rcrr(p1,P, Q,p2)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: P
+ real(ki), dimension(4), intent(in) :: p1, p2, Q
+ real(ki), dimension(4) :: q1
+ real(ki) :: r2
+ complex(ki) :: zbb_rcrr
+
+!---- decomposing Q along p2
+
+ r2=dotproduct(Q,Q)/(2.0_ki*dotproduct(Q,p2))
+
+ q1(:) = Q(:) - r2*p2(:)
+
+ zbb_rcrr = -zb(p2,q1)*zab(q1,P,p1)
+ end function zbb_rcrr
+
+ function gamma_6(a,b,c,d,e,f)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: a,b,c,d,e,f
+ complex(ki) gamma_6
+ gamma_6 = 4.0_ki*(&
+ & + dotproduct(a,b)*dotproduct(c,d)*dotproduct(e,f)&
+ & - dotproduct(a,b)*dotproduct(c,e)*dotproduct(d,f)&
+ & + dotproduct(a,b)*dotproduct(c,f)*dotproduct(d,e)&
+ & - dotproduct(a,c)*dotproduct(b,d)*dotproduct(e,f)&
+ & + dotproduct(a,c)*dotproduct(b,e)*dotproduct(d,f)&
+ & - dotproduct(a,c)*dotproduct(b,f)*dotproduct(d,e)&
+ & + dotproduct(a,d)*dotproduct(b,c)*dotproduct(e,f)&
+ & - dotproduct(a,d)*dotproduct(b,e)*dotproduct(c,f)&
+ & + dotproduct(a,d)*dotproduct(b,f)*dotproduct(c,e)&
+ & - dotproduct(a,e)*dotproduct(b,c)*dotproduct(d,f)&
+ & + dotproduct(a,e)*dotproduct(b,d)*dotproduct(c,f)&
+ & - dotproduct(a,e)*dotproduct(b,f)*dotproduct(c,d)&
+ & + dotproduct(a,f)*dotproduct(b,c)*dotproduct(d,e)&
+ & - dotproduct(a,f)*dotproduct(b,d)*dotproduct(c,e)&
+ & + dotproduct(a,f)*dotproduct(b,e)*dotproduct(c,d))
+ end function gamma_6
+
+
+end module kinematic
+
+
diff --git a/samurai-2.1.1/ltest.f90 b/samurai-2.1.1/ltest.f90
new file mode 100644
index 0000000..d08d627
--- /dev/null
+++ b/samurai-2.1.1/ltest.f90
@@ -0,0 +1,15 @@
+module ltest
+ use precision
+implicit none
+
+ private :: ki
+
+ real(ki) :: pwlimit
+ real(ki) :: nnlimit
+ real(ki) :: lnnlimit4
+ real(ki) :: lnnlimit3
+ real(ki) :: lnnlimit2
+ real(ki) :: lnnlimit1
+
+end module ltest
+
diff --git a/samurai-2.1.1/maccu.f90 b/samurai-2.1.1/maccu.f90
new file mode 100644
index 0000000..d6b1e98
--- /dev/null
+++ b/samurai-2.1.1/maccu.f90
@@ -0,0 +1,107 @@
+module maccu
+ !
+ ! Synopsis: routines for floating-point accumulation
+ ! of sums with small relative error
+ ! Author: Thomas Reiter <thomasr@nikhef.nl>
+ ! Date: 28 Jul. 2010
+ ! Language: Fortran 95
+ ! Description: Implementation of the algorithm presented in
+ ! ``AN ALGORITHM FOR FLOATING-POINT ACCUMULATION OF SUMS
+ ! WITH SMALL RELATIVE ERROR''
+ ! Michael Malcolm, STAN-CS-70-163, June 1970
+ !
+ ! Example:
+ ! arr = (/ 1.2345E+20_ki, 1.0_ki, -1.2345E+20_ki/)
+ ! print*, sum(arr), sorted_sum(arr)
+ ! ! output:
+ ! ! 0.0 1.0
+ !
+ use precision, only: ki
+ implicit none
+
+ private
+
+ integer, parameter, private :: min_ex_ki = minexponent(1.0_ki)
+ integer, parameter, private :: max_ex_ki = maxexponent(1.0_ki)
+
+ type accumulator_type
+ real(ki), dimension(min_ex_ki:max_ex_ki) :: a = 0.0_ki
+ end type accumulator_type
+
+ interface add_accu
+ module procedure add_accu_c
+ module procedure add_accu_r
+ end interface
+
+ interface reduce_accu
+ module procedure reduce_accu_c
+ module procedure reduce_accu_r
+ end interface
+
+ public :: accumulator_type, add_accu, reduce_accu
+
+contains
+ pure elemental subroutine add_accu_r(acc, t)
+ implicit none
+ type(accumulator_type), intent(inout) :: acc
+ real(ki), intent(in) :: t
+
+ real(ki) :: r, d
+ integer :: e, i
+ real(ki) :: radix_ki
+
+ radix_ki = scale(1.0_ki, 1)
+
+ r = fraction(t)
+ e = exponent(t)
+ i = e
+
+ do while (r .ne. 0.0_ki .and. i .gt. min_ex_ki)
+ r = scale(r, 1)
+ i = i - 1
+ ! The following two lines extract the first
+ ! digit from the number. Hence, d plays the
+ ! role of a_{ij} in the original publication.
+ d = aint(r)
+ r = r - d
+
+ ! This is step 3 of the original algorithm:
+ ! Add the digit to the according accummulator.
+ acc%a(i) = acc%a(i) + d
+ end do
+ end subroutine add_accu_r
+
+ pure elemental subroutine add_accu_c(acc_re, acc_im, t)
+ implicit none
+ type(accumulator_type), intent(inout) :: acc_re, acc_im
+ complex(ki), intent(in) :: t
+
+ call add_accu(acc_re, real(t, ki))
+ call add_accu(acc_im, aimag(t))
+ end subroutine add_accu_c
+
+ pure elemental function reduce_accu_r(acc) result(f)
+ ! This routine is step 4 of the original algorithm:
+ ! Sum in decreasing order.
+ implicit none
+ type(accumulator_type), intent(in) :: acc
+ real(ki) :: f
+
+ integer :: e
+
+ f = 0.0_ki
+
+ do e = max_ex_ki, min_ex_ki, -1
+ if (acc%a(e) .ne. 0.0_ki) f = f + scale(acc%a(e), e)
+ end do
+ end function reduce_accu_r
+
+ pure elemental function reduce_accu_c(acc_re, acc_im) result(f)
+ implicit none
+ type(accumulator_type), intent(in) :: acc_re, acc_im
+ complex(ki) :: f
+
+ f = cmplx(reduce_accu_r(acc_re), reduce_accu_r(acc_im), ki)
+ end function reduce_accu_c
+
+end module maccu
diff --git a/samurai-2.1.1/madds.f90.in b/samurai-2.1.1/madds.f90.in
new file mode 100644
index 0000000..efdd722
--- /dev/null
+++ b/samurai-2.1.1/madds.f90.in
@@ -0,0 +1,2137 @@
+module madds
+ use precision, only: ki, ki_ql, ki_lt
+@case_with_golem@use precision_golem, only: ki_gol => ki
+@case_with_avh@use avh_olo_kinds, only: ki_avh => kindr2
+ use constants
+ use options
+ use mfunctions
+ use notfirst
+ implicit none
+
+ private
+
+ interface add4
+ module procedure add4_rm
+ module procedure add4_cm
+ end interface add4
+
+ interface add3
+ module procedure add3_rm
+ module procedure add3_cm
+ end interface add3
+
+ interface add2
+ module procedure add2_rm
+ module procedure add2_cm
+ end interface add2
+
+ interface add1
+ module procedure add1_rm
+ module procedure add1_cm
+ end interface add1
+
+ ! If s_mat is allocated the addX routines will read their invariants
+ ! from the matrix rather than to recompute them.
+ !
+ ! The matrix should be initialized as follows:
+ !
+ ! s_mat(i, j) = Vi(i-1).Vi(j-1) - msq(i) - msq(j)
+ !
+ !
+ ! Example:
+ !
+ ! box diagram in gg>tt~
+ !
+ ! g(k1) ~~~~~~*~~~~~*====== t~(k4)
+ ! S I
+ ! S I
+ ! g(k2) ~~~~~~*~~~~~*====== t(k3)
+ !
+ ! allocate(s_mat(4,4))
+ ! s_mat(:,:) = 0.0_ki
+ ! s_mat(1,3) = s - 0.0_ki - 0.0_ki ! = s
+ ! s_mat(1,4) = mT**2 - 0.0_ki - mT**2 ! = 0.0_ki
+ ! s_mat(2,4) = t - 0.0_ki - mT**2 ! = t - mT**2
+ ! s_mat(3,4) = mT**2 - 0.0_ki - mT**2 ! = 0.0_ki
+ ! s_mat(4,4) = 0.0_ki - mT**2 - mT**2 ! = - 2.0_ki * mT**2
+ ! call samurai( .... )
+ ! deallocate(s_mat)
+
+ complex(ki), dimension(:,:), allocatable, public :: s_mat
+
+@case_with_ql@ interface
+@case_with_ql@ function qlI4(p1,p2,p3,p4,s12,s23,m1,m2,m3,m4,mu2,ep)
+@case_with_ql@ use precision, only: ki_ql
+@case_with_ql@ implicit none
+@case_with_ql@ real(ki_ql), intent(in) :: p1,p2,p3,p4,s12,s23
+@case_with_ql@ real(ki_ql), intent(in) :: m1,m2,m3,m4,mu2
+@case_with_ql@ integer, intent(in) :: ep
+@case_with_ql@ complex(ki_ql) :: qlI4
+@case_with_ql@ end function qlI4
+@case_with_ql@ end interface
+@case_with_ql@ interface
+@case_with_ql@ function qlI3(p1,p2,p3,m1,m2,m3,mu2,ep)
+@case_with_ql@ use precision, only: ki_ql
+@case_with_ql@ implicit none
+@case_with_ql@ real(ki_ql), intent(in) :: p1,p2,p3
+@case_with_ql@ real(ki_ql), intent(in) :: m1,m2,m3,mu2
+@case_with_ql@ integer, intent(in) :: ep
+@case_with_ql@ complex(ki_ql) :: qlI3
+@case_with_ql@ end function qlI3
+@case_with_ql@ end interface
+@case_with_ql@ interface
+@case_with_ql@ function qlI2(p1,m1,m2,mu2,ep)
+@case_with_ql@ use precision, only: ki_ql
+@case_with_ql@ implicit none
+@case_with_ql@ real(ki_ql), intent(in) :: p1
+@case_with_ql@ real(ki_ql), intent(in) :: m1,m2,mu2
+@case_with_ql@ integer, intent(in) :: ep
+@case_with_ql@ complex(ki_ql) :: qlI2
+@case_with_ql@ end function qlI2
+@case_with_ql@ end interface
+@case_with_ql@ interface
+@case_with_ql@ function qlI1(m1,mu2,ep)
+@case_with_ql@ use precision, only: ki_ql
+@case_with_ql@ implicit none
+@case_with_ql@ real(ki_ql), intent(in) :: m1,mu2
+@case_with_ql@ integer, intent(in) :: ep
+@case_with_ql@ complex(ki_ql) :: qlI1
+@case_with_ql@ end function qlI1
+@case_with_ql@ end interface
+
+@case_with_golem@ interface
+@case_with_golem@ function gD0(p1,p2,p3,p4,s12,s23,m1,m2,m3,m4,mu2,ep)
+@case_with_golem@ use precision_golem, only: ki
+@case_with_golem@ implicit none
+@case_with_golem@ real(ki), intent(in) :: p1,p2,p3,p4,s12,s23
+@case_with_golem@ real(ki), intent(in) :: m1,m2,m3,m4
+@case_with_golem@ real(ki), intent(in) :: mu2
+@case_with_golem@ integer, intent(in) :: ep
+@case_with_golem@ complex(ki) :: gD0
+@case_with_golem@ end function gD0
+@case_with_golem@ end interface
+@case_with_golem@ interface
+@case_with_golem@ function gC0(p1,p2,p3,m1,m2,m3,mu2,ep)
+@case_with_golem@ use precision_golem, only: ki
+@case_with_golem@ implicit none
+@case_with_golem@ real(ki), intent(in) :: p1,p2,p3
+@case_with_golem@ real(ki), intent(in) :: m1,m2,m3
+@case_with_golem@ real(ki), intent(in) :: mu2
+@case_with_golem@ integer, intent(in) :: ep
+@case_with_golem@ complex(ki) :: gC0
+@case_with_golem@ end function gC0
+@case_with_golem@ end interface
+@case_with_golem@ interface
+@case_with_golem@ function gB0(p1,m1,m2,mu2,ep)
+@case_with_golem@ use precision_golem, only: ki
+@case_with_golem@ implicit none
+@case_with_golem@ real(ki), intent(in) :: p1
+@case_with_golem@ real(ki), intent(in) :: m1,m2
+@case_with_golem@ real(ki), intent(in) :: mu2
+@case_with_golem@ integer, intent(in) :: ep
+@case_with_golem@ complex(ki) :: gB0
+@case_with_golem@ end function gB0
+@case_with_golem@ end interface
+@case_with_golem@ interface
+@case_with_golem@ function gD0C(p1,p2,p3,p4,s12,s23,m1,m2,m3,m4,mu2,ep)
+@case_with_golem@ use precision_golem, only: ki
+@case_with_golem@ implicit none
+@case_with_golem@ complex(ki), intent(in) :: p1,p2,p3,p4,s12,s23
+@case_with_golem@ complex(ki), intent(in) :: m1,m2,m3,m4
+@case_with_golem@ real(ki), intent(in) :: mu2
+@case_with_golem@ integer, intent(in) :: ep
+@case_with_golem@ complex(ki) :: gD0C
+@case_with_golem@ end function gD0C
+@case_with_golem@ end interface
+@case_with_golem@ interface
+@case_with_golem@ function gC0C(p1,p2,p3,m1,m2,m3,mu2,ep)
+@case_with_golem@ use precision_golem, only: ki
+@case_with_golem@ implicit none
+@case_with_golem@ complex(ki), intent(in) :: p1,p2,p3
+@case_with_golem@ complex(ki), intent(in) :: m1,m2,m3
+@case_with_golem@ real(ki), intent(in) :: mu2
+@case_with_golem@ integer, intent(in) :: ep
+@case_with_golem@ complex(ki) :: gC0C
+@case_with_golem@ end function gC0C
+@case_with_golem@ end interface
+@case_with_golem@ interface
+@case_with_golem@ function gB0C(p1,m1,m2,mu2,ep)
+@case_with_golem@ use precision_golem, only: ki
+@case_with_golem@ implicit none
+@case_with_golem@ complex(ki), intent(in) :: p1
+@case_with_golem@ complex(ki), intent(in) :: m1,m2
+@case_with_golem@ real(ki), intent(in) :: mu2
+@case_with_golem@ integer, intent(in) :: ep
+@case_with_golem@ complex(ki) :: gB0C
+@case_with_golem@ end function gB0C
+@case_with_golem@ end interface
+
+@case_with_lt@ interface
+@case_with_lt@ function D0(p1,p2,p3,p4,s12,s23,m1,m2,m3,m4)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt), intent(in) :: p1,p2,p3,p4,s12,s23
+@case_with_lt@ real(ki_lt), intent(in) :: m1,m2,m3,m4
+@case_with_lt@ complex(ki_lt) :: D0
+@case_with_lt@ end function D0
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function C0(p1,p2,p3,m1,m2,m3)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt), intent(in) :: p1,p2,p3
+@case_with_lt@ real(ki_lt), intent(in) :: m1,m2,m3
+@case_with_lt@ complex(ki_lt) :: C0
+@case_with_lt@ end function C0
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function B0(p1,m1,m2)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt), intent(in) :: p1
+@case_with_lt@ real(ki_lt), intent(in) :: m1,m2
+@case_with_lt@ complex(ki_lt) :: B0
+@case_with_lt@ end function B0
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function B1(p1,m1,m2)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt), intent(in) :: p1
+@case_with_lt@ real(ki_lt), intent(in) :: m1,m2
+@case_with_lt@ complex(ki_lt) :: B1
+@case_with_lt@ end function B1
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function B00(p1,m1,m2)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt), intent(in) :: p1
+@case_with_lt@ real(ki_lt), intent(in) :: m1,m2
+@case_with_lt@ complex(ki_lt) :: B00
+@case_with_lt@ end function B00
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function B11(p1,m1,m2)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt), intent(in) :: p1
+@case_with_lt@ real(ki_lt), intent(in) :: m1,m2
+@case_with_lt@ complex(ki_lt) :: B11
+@case_with_lt@ end function B11
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function A0(m1)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt), intent(in) :: m1
+@case_with_lt@ complex(ki_lt) :: A0
+@case_with_lt@ end function A0
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function D0C(p1,p2,p3,p4,s12,s23,m1,m2,m3,m4)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ complex(ki_lt), intent(in) :: p1,p2,p3,p4,s12,s23
+@case_with_lt@ complex(ki_lt), intent(in) :: m1,m2,m3,m4
+@case_with_lt@ complex(ki_lt) :: D0C
+@case_with_lt@ end function D0C
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function C0C(p1,p2,p3,m1,m2,m3)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ complex(ki_lt), intent(in) :: p1,p2,p3
+@case_with_lt@ complex(ki_lt), intent(in) :: m1,m2,m3
+@case_with_lt@ complex(ki_lt) :: C0C
+@case_with_lt@ end function C0C
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function B0C(p1,m1,m2)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ complex(ki_lt), intent(in) :: p1
+@case_with_lt@ complex(ki_lt), intent(in) :: m1,m2
+@case_with_lt@ complex(ki_lt) :: B0C
+@case_with_lt@ end function B0C
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function B1C(p1,m1,m2)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ complex(ki_lt), intent(in) :: p1
+@case_with_lt@ complex(ki_lt), intent(in) :: m1,m2
+@case_with_lt@ complex(ki_lt) :: B1C
+@case_with_lt@ end function B1C
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function B00C(p1,m1,m2)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ complex(ki_lt), intent(in) :: p1
+@case_with_lt@ complex(ki_lt), intent(in) :: m1,m2
+@case_with_lt@ complex(ki_lt) :: B00C
+@case_with_lt@ end function B00C
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function B11C(p1,m1,m2)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ complex(ki_lt), intent(in) :: p1
+@case_with_lt@ complex(ki_lt), intent(in) :: m1,m2
+@case_with_lt@ complex(ki_lt) :: B11C
+@case_with_lt@ end function B11C
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function A0C(m1)
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ complex(ki_lt), intent(in) :: m1
+@case_with_lt@ complex(ki_lt) :: A0C
+@case_with_lt@ end function A0C
+@case_with_lt@ end interface
+@case_with_lt@ interface
+@case_with_lt@ function getlambda()
+@case_with_lt@ use precision, only: ki_lt
+@case_with_lt@ implicit none
+@case_with_lt@ real(ki_lt) :: getlambda
+@case_with_lt@ end function getlambda
+@case_with_lt@ end interface
+
+ ! cache sizes depending on nleg and istop: cachedim<nleg>(<istop>)
+ ! These numbers are exactly the same as returned in calls
+ ! to cachedim
+ integer, dimension(1:1), parameter, public :: cachedim1 = (/1/)
+ integer, dimension(1:2), parameter, public :: cachedim2 = (/7,5/)
+ integer, dimension(1:3), parameter, public :: cachedim3 = (/19,16,1/)
+ integer, dimension(1:4), parameter, public :: cachedim4 = (/39,35,5,1/)
+ integer, dimension(1:4), parameter, public :: cachedim5 = (/70,65,15,5/)
+ integer, dimension(1:4), parameter, public :: cachedim6 = (/116,110,35,15/)
+ integer, dimension(1:4), parameter, public :: cachedim7 = (/182,175,70,35/)
+ integer, dimension(1:4), parameter, public :: cachedim8 = (/274,266,126,70/)
+ integer, dimension(1:4), parameter, public :: cachedim9 = &
+ & (/399,390,210,126/)
+ integer, dimension(1:4), parameter, public :: cachedim10 = &
+ & (/565,555,330,210/)
+ integer, dimension(1:4), parameter, public :: cachedim11 = &
+ & (/781,770,495,330/)
+ integer, dimension(1:4), parameter, public :: cachedim12 = &
+ & (/1057,1045,715,495/)
+
+ public :: add4, add3, add2, add1
+ public :: add4_rm, add3_rm, add2_rm, add1_rm
+ public :: add4_cm, add3_cm, add2_cm, add1_cm
+
+ public :: cachedim
+
+contains
+
+ pure subroutine cachedim(dim,nleg,istop)
+ implicit none
+ integer, intent(in) :: nleg,istop
+ integer, intent(out) :: dim
+ integer :: n4, n3, n2, n1, j1, j2, j3, j4, icut1, icut2, icut3, icut4
+
+ n1 = 0
+ n2 = 0
+ n3 = 0
+ n4 = 0
+
+ if (nleg.ge.4) then
+ goto 20
+ elseif (nleg.eq.3) then
+ goto 30
+ elseif (nleg.eq.2) then
+ goto 40
+ elseif ((nleg.eq.1).or.(nleg.le.0)) then
+ goto 50
+ endif
+
+ 20 continue
+
+ if (istop.ge.5) goto 99
+
+ n4 = nleg*(nleg-1)*(nleg-2)*(nleg-3)/24
+ if (istop.ge.4) goto 99
+
+ 30 continue
+
+ n3 = nleg*(nleg-1)*(nleg-2)/6
+ if (istop.ge.3) goto 99
+
+ 40 continue
+
+ n2 = nleg*(nleg-1)/2
+ if (istop.ge.2) goto 99
+
+ 50 continue
+
+ n1 = nleg
+
+ 99 continue
+
+ dim=n4+n3+5*n2+n1
+
+ end subroutine cachedim
+
+ subroutine add4_rm(nleg,c4,cut4,Vi,msq,tot4,tot4r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+@case_with_avh@ use avh_olo, only: olo_d0
+ implicit none
+ integer, intent(in) :: cut4,nleg
+ complex(ki), dimension(0:4), intent(in) :: c4
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), intent(in) :: scale2
+ complex(ki), dimension(-2:0), intent(out) :: tot4
+ complex(ki), intent(out) :: tot4r
+
+ logical, intent(in), optional :: cache_flag
+ integer, intent(inout), optional :: cache_offset
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+ real(ki), dimension(4):: Vi1, Vi2, Vi3, Vi21, Vi31, Vi32
+ real(ki) :: m0, m1, m2, m3, V1, V2, V3, V21, V31, V32
+ integer :: i,j1,j2,j3,j4
+ complex(ki) :: c40
+@case_with_avh@ complex(ki_avh), dimension(0:2) :: vald0
+ complex(ki) :: ctmp
+@case_with_golem@ complex(ki), dimension(-2:0) :: d0t
+ integer :: ep, cache_index
+
+ if (notfirsti.eqv.(.false.)) then
+ if (isca .eq. 2) then
+@case_with_avh@ call avh_olo_mu_set(real(sqrt(scale2),ki_avh))
+ elseif (isca .eq. 4) then
+@case_with_lt@ call setmudim(real(scale2, ki_lt))
+ endif
+ notfirsti=.true.
+ endif
+
+
+ j4=cut4/1000
+ j3=(cut4-j4*1000)/100
+ j2=(cut4-j4*1000-j3*100)/10
+ j1=cut4-j4*1000-j3*100-j2*10
+
+ m0=msq(j1)
+ m1=msq(j2)
+ m2=msq(j3)
+ m3=msq(j4)
+
+ if (allocated(s_mat)) then
+ ! s_mat(i+1, j+1) = (Vi(i,:) - Vi(j,:))**2 - msq(i) - msq(j)
+ V1 = s_mat(j2+1, j1+1) + msq(j2) + msq(j1)
+ V2 = s_mat(j3+1, j1+1) + msq(j3) + msq(j1)
+ V3 = s_mat(j4+1, j1+1) + msq(j4) + msq(j1)
+ V21 = s_mat(j3+1, j2+1) + msq(j3) + msq(j2)
+ V31 = s_mat(j4+1, j2+1) + msq(j4) + msq(j2)
+ V32 = s_mat(j4+1, j3+1) + msq(j4) + msq(j3)
+ else
+ Vi1(:)=Vi(j2,:)-Vi(j1,:)
+ Vi2(:)=Vi(j3,:)-Vi(j1,:)
+ Vi3(:)=Vi(j1,:)-Vi(j4,:)
+ Vi21(:)=Vi(j3,:)-Vi(j2,:)
+ Vi31(:)=Vi(j4,:)-Vi(j2,:)
+ Vi32(:)=Vi(j4,:)-Vi(j3,:)
+
+ V1=sdot(Vi1,Vi1)
+ V2=sdot(Vi2,Vi2)
+ V3=sdot(Vi3,Vi3)
+ V21=sdot(Vi21,Vi21)
+ V31=sdot(Vi31,Vi31)
+ V32=sdot(Vi32,Vi32)
+ end if
+
+ c40=c4(0)
+ tot4r=-c4(4)/six
+
+ 1 Format(A3,I4,A1,I2,A5,D24.15,A1,D24.15,A3)
+
+ if (present(cache_flag)) cache_index = lbound(scalar_cache,2)+cache_offset
+ if (isca.eq.1) then
+@case_with_ql@ do ep=-2,0
+@case_with_ql@ if (present(cache_flag)) then
+@case_with_ql@ if (cache_flag) then
+@case_with_ql@ ctmp = scalar_cache(ep,cache_index)
+@case_with_ql@ else
+@case_with_ql@ ctmp=qlI4(&
+@case_with_ql@ & real(V1,ki_ql),real(V21,ki_ql),real(V32,ki_ql),&
+@case_with_ql@ & real(V3,ki_ql),real(V2,ki_ql),real(V31,ki_ql),&
+@case_with_ql@ & real(m0,ki_ql),real(m1,ki_ql),real(m2,ki_ql),&
+@case_with_ql@ & real(m3,ki_ql),real(scale2,ki_ql),ep)
+@case_with_ql@ scalar_cache(ep,cache_index) = ctmp
+@case_with_ql@ end if
+@case_with_ql@ else
+@case_with_ql@ ctmp=qlI4(&
+@case_with_ql@ & real(V1,ki_ql),real(V21,ki_ql),real(V32,ki_ql),&
+@case_with_ql@ & real(V3,ki_ql),real(V2,ki_ql),real(V31,ki_ql),&
+@case_with_ql@ & real(m0,ki_ql),real(m1,ki_ql),real(m2,ki_ql),&
+@case_with_ql@ & real(m3,ki_ql),real(scale2,ki_ql),ep)
+@case_with_ql@ end if
+@case_with_ql@ tot4(ep)=c40*ctmp
+@case_with_ql@ if (verbosity.ge.2) write(iout,1) &
+@case_with_ql@ & 'I4(',cut4,',',ep,') = (',real(ctmp),',',aimag(ctmp),' )'
+@case_with_ql@ enddo
+@case_wout_ql@ print*, "isca=1: QCDLoop not available"
+@case_wout_ql@ stop
+ elseif (isca.eq.2) then
+@case_with_avh@ if (present(cache_flag)) then
+@case_with_avh@ if (cache_flag) then
+@case_with_avh@ vald0(0) = scalar_cache( 0,cache_index)
+@case_with_avh@ vald0(1) = scalar_cache(-1,cache_index)
+@case_with_avh@ vald0(2) = scalar_cache(-2,cache_index)
+@case_with_avh@ else
+@case_with_avh@ call olo_d0(vald0,&
+@case_with_avh@ & real(V1,ki_avh),real(V21,ki_avh),real(V32,ki_avh),&
+@case_with_avh@ & real(V3,ki_avh),real(V2,ki_avh),real(V31,ki_avh),&
+@case_with_avh@ & real(m0,ki_avh),real(m1,ki_avh),real(m2,ki_avh),&
+@case_with_avh@ & real(m3,ki_avh))
+@case_with_avh@ scalar_cache( 0,cache_index) = vald0(0)
+@case_with_avh@ scalar_cache(-1,cache_index) = vald0(1)
+@case_with_avh@ scalar_cache(-2,cache_index) = vald0(2)
+@case_with_avh@ end if
+@case_with_avh@ else
+@case_with_avh@ call olo_d0(vald0,&
+@case_with_avh@ & real(V1,ki_avh),real(V21,ki_avh),real(V32,ki_avh),&
+@case_with_avh@ & real(V3,ki_avh),real(V2,ki_avh),real(V31,ki_avh),&
+@case_with_avh@ & real(m0,ki_avh),real(m1,ki_avh),real(m2,ki_avh),&
+@case_with_avh@ & real(m3,ki_avh))
+@case_with_avh@ end if
+@case_with_avh@ do ep=-2,0
+@case_with_avh@ tot4(ep)= c40*vald0(-ep)
+@case_with_avh@ if (verbosity.ge.2) write(iout,1) &
+@case_with_avh@ & 'I4(',cut4,',',ep,') = (',real(vald0(-ep)),',',aimag(vald0(-ep)),' )'
+@case_with_avh@ enddo
+@case_wout_avh@ print*, "isca=2: OneLOop not available"
+@case_wout_avh@ stop
+ elseif (isca.eq.3) then
+@case_with_golem@ call gtrunc_rm(abs(V32)+abs(V31), &
+@case_with_golem@ & V1,V2,V3,V21,V32,V31,m0,m1,m2,m3)
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ if (present(cache_flag)) then
+@case_with_golem@ if (cache_flag) then
+@case_with_golem@ d0t(ep) = scalar_cache(ep,cache_index)
+@case_with_golem@ else
+@case_with_golem@ d0t(ep)=gD0(real(V1,ki_gol),real(V21,ki_gol),&
+@case_with_golem@ & real(V32,ki_gol),real(V3,ki_gol),&
+@case_with_golem@ & real(V2,ki_gol),real(V31,ki_gol),&
+@case_with_golem@ & real(m0,ki_gol),real(m1,ki_gol),&
+@case_with_golem@ & real(m2,ki_gol),real(m3,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ scalar_cache(ep,cache_index) = d0t(ep)
+@case_with_golem@ end if
+@case_with_golem@ else
+@case_with_golem@ d0t(ep)=gD0(real(V1,ki_gol),real(V21,ki_gol),&
+@case_with_golem@ & real(V32,ki_gol),real(V3,ki_gol),&
+@case_with_golem@ & real(V2,ki_gol),real(V31,ki_gol),&
+@case_with_golem@ & real(m0,ki_gol),real(m1,ki_gol),&
+@case_with_golem@ & real(m2,ki_gol),real(m3,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ end if
+@case_with_golem@ end do
+@case_with_golem@ !d0t( 0) = d0t(0) + log(scale2) * (d0t(-1) &
+@case_with_golem@ ! & + 0.5_ki * log(scale2) * d0t(-2))
+@case_with_golem@ !d0t(-1) = d0t(-1) + log(scale2) * d0t(-2)
+@case_with_golem@ if (verbosity.ge.2) then
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ write(iout,1) 'I4(',cut4,',',ep,&
+@case_with_golem@ & ') = (',real(d0t(ep)),',',aimag(d0t(ep)),' )'
+@case_with_golem@ end do
+@case_with_golem@ end if
+@case_with_golem@ tot4(:) = d0t(:) * c40
+@case_wout_golem@ print*, "isca=3: Golem95 not available"
+@case_wout_golem@ stop
+ elseif (isca.eq.4) then
+@case_with_lt@ tot4(-2) = 0
+@case_with_lt@ tot4(-1) = 0
+@case_with_lt@ tot4(0) = 0
+@case_with_lt@ ep = -dim(0, int(getlambda()))
+@case_with_lt@ if (present(cache_flag)) then
+@case_with_lt@ if (cache_flag) then
+@case_with_lt@ ctmp = scalar_cache(ep,cache_index)
+@case_with_lt@ else
+@case_with_lt@ call gtrunc_rm(abs(V32)+abs(V31), &
+@case_with_lt@ & V1,V2,V3,V21,V32,V31,m0,m1,m2,m3)
+@case_with_lt@ ctmp=D0(&
+@case_with_lt@ & real(V1,ki_lt),real(V21,ki_lt),real(V32,ki_lt),&
+@case_with_lt@ & real(V3,ki_lt),real(V2,ki_lt),real(V31,ki_lt),&
+@case_with_lt@ & real(m0,ki_lt),real(m1,ki_lt),real(m2,ki_lt),&
+@case_with_lt@ & real(m3,ki_lt))
+@case_with_lt@ scalar_cache(ep,cache_index) = ctmp
+@case_with_lt@ end if
+@case_with_lt@ else
+@case_with_lt@ call gtrunc_rm(abs(V32)+abs(V31), &
+@case_with_lt@ & V1,V2,V3,V21,V32,V31,m0,m1,m2,m3)
+@case_with_lt@ ctmp=D0(&
+@case_with_lt@ & real(V1,ki_lt),real(V21,ki_lt),real(V32,ki_lt),&
+@case_with_lt@ & real(V3,ki_lt),real(V2,ki_lt),real(V31,ki_lt),&
+@case_with_lt@ & real(m0,ki_lt),real(m1,ki_lt),real(m2,ki_lt),&
+@case_with_lt@ & real(m3,ki_lt))
+@case_with_lt@ end if
+@case_with_lt@ tot4(ep)=c40*ctmp
+@case_with_lt@ if (verbosity.ge.2) write(iout,1) &
+@case_with_lt@ & 'I4(',cut4,',',ep,') = (',real(ctmp),',',aimag(ctmp),' )'
+@case_wout_lt@ print*, "isca=4: LoopTools not available"
+@case_wout_lt@ stop
+ else
+ print*, 'error in add4'
+ stop
+ endif
+ if (present(cache_flag)) cache_offset = cache_offset + 1
+ tot4(0)=tot4(0) + tot4r
+ end subroutine add4_rm
+
+ subroutine add3_rm(nleg,c3,cut3,Vi,msq,tot3,tot3r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+@case_with_avh@ use avh_olo, only: olo_c0
+ implicit none
+
+ integer, intent(in) :: nleg, cut3
+ complex(ki), dimension(0:9), intent(in) :: c3
+ real(ki), dimension(0:nleg-1,4) ::Vi
+ real(ki), dimension(0:nleg-1):: msq
+ complex(ki), dimension(-2:0), intent(out) :: tot3
+ complex(ki), intent(out) :: tot3r
+ real(ki), intent(in) :: scale2
+
+ logical, intent(in), optional :: cache_flag
+ integer, intent(inout), optional :: cache_offset
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+ integer :: j1,j2,j3
+ real(ki) :: m0, m1, m2, V1, V2, V3
+ real(ki), dimension(4):: Vi1, Vi2, Vi3
+ complex(ki) :: c30
+@case_with_avh@ complex(ki_avh), dimension(0:2) :: valc0
+ complex(ki) :: ctmp
+@case_with_golem@ complex(ki), dimension(-2:0) :: c0t
+ integer :: ep, cache_index
+
+ if (notfirsti.eqv.(.false.)) then
+ if (isca .eq. 2) then
+@case_with_avh@ call avh_olo_mu_set(real(sqrt(scale2),ki_avh))
+ elseif (isca .eq. 4) then
+@case_with_lt@ call setmudim(real(scale2, ki_lt))
+ endif
+ notfirsti=.true.
+ endif
+
+
+ j3=cut3/100
+ j2=(cut3-j3*100)/10
+ j1=cut3-j3*100-j2*10
+
+ m0=msq(j1)
+ m1=msq(j2)
+ m2=msq(j3)
+
+ if (allocated(s_mat)) then
+ ! s_mat(i+1, j+1) = (Vi(i,:) - Vi(j,:))**2 - msq(i) - msq(j)
+ V1 = s_mat(j2+1, j1+1) + msq(j2) + msq(j1)
+ V2 = s_mat(j3+1, j2+1) + msq(j3) + msq(j2)
+ V3 = s_mat(j3+1, j1+1) + msq(j3) + msq(j1)
+ else
+ Vi1(:)=Vi(j2,:)-Vi(j1,:)
+ Vi2(:)=Vi(j3,:)-Vi(j2,:)
+ Vi3(:)=Vi(j1,:)-Vi(j3,:)
+
+ V1=sdot(Vi1,Vi1)
+ V2=sdot(Vi2,Vi2)
+ V3=sdot(Vi3,Vi3)
+ end if
+
+ c30=c3(0)
+
+ tot3r=+c3(7)/two
+
+ 1 Format(A3,I3,A1,I2,A5,D24.15,A1,D24.15,A3)
+
+ if (present(cache_flag)) cache_index = lbound(scalar_cache,2)+cache_offset
+ if (isca.eq.1) then
+@case_with_ql@ do ep=-2,0
+@case_with_ql@ if (present(cache_flag)) then
+@case_with_ql@ if (cache_flag) then
+@case_with_ql@ ctmp = scalar_cache(ep,cache_index)
+@case_with_ql@ else
+@case_with_ql@ ctmp=qlI3(&
+@case_with_ql@ real(V1,ki_ql),real(V2,ki_ql),real(V3,ki_ql),&
+@case_with_ql@ & real(m0,ki_ql),real(m1,ki_ql),real(m2,ki_ql),&
+@case_with_ql@ & real(scale2,ki_ql),ep)
+@case_with_ql@ scalar_cache(ep,cache_index) = ctmp
+@case_with_ql@ end if
+@case_with_ql@ else
+@case_with_ql@ ctmp=qlI3(&
+@case_with_ql@ real(V1,ki_ql),real(V2,ki_ql),real(V3,ki_ql),&
+@case_with_ql@ & real(m0,ki_ql),real(m1,ki_ql),real(m2,ki_ql),&
+@case_with_ql@ & real(scale2,ki_ql),ep)
+@case_with_ql@ end if
+@case_with_ql@ tot3(ep)=c30*ctmp
+@case_with_ql@ if (verbosity.ge.2) write(iout,1) &
+@case_with_ql@ &'I3(',cut3,',',ep,') = (',real(ctmp),&
+@case_with_ql@ &',',aimag(ctmp),' )'
+@case_with_ql@ enddo
+@case_wout_ql@ print*, "isca=1: QCDLoop not available"
+@case_wout_ql@ stop
+ elseif (isca.eq.2) then
+@case_with_avh@ if (present(cache_flag)) then
+@case_with_avh@ if (cache_flag) then
+@case_with_avh@ valc0(0) = scalar_cache( 0,cache_index)
+@case_with_avh@ valc0(1) = scalar_cache(-1,cache_index)
+@case_with_avh@ valc0(2) = scalar_cache(-2,cache_index)
+@case_with_avh@ else
+@case_with_avh@ call olo_c0(valc0,&
+@case_with_avh@ & real(V1,ki_avh),real(V2,ki_avh),real(V3,ki_avh),&
+@case_with_avh@ & real(m0,ki_avh),real(m1,ki_avh),real(m2,ki_avh))
+@case_with_avh@ scalar_cache( 0,cache_index) = valc0(0)
+@case_with_avh@ scalar_cache(-1,cache_index) = valc0(1)
+@case_with_avh@ scalar_cache(-2,cache_index) = valc0(2)
+@case_with_avh@ end if
+@case_with_avh@ else
+@case_with_avh@ call olo_c0(valc0,&
+@case_with_avh@ & real(V1,ki_avh),real(V2,ki_avh),real(V3,ki_avh),&
+@case_with_avh@ & real(m0,ki_avh),real(m1,ki_avh),real(m2,ki_avh))
+@case_with_avh@ end if
+@case_with_avh@ do ep=-2,0
+@case_with_avh@ tot3(ep)= c30*valc0(-ep)
+@case_with_avh@ if (verbosity.ge.2) write(iout,1) &
+@case_with_avh@ &'I3(',cut3,',',ep,') = (',real(valc0(-ep)),',',aimag(valc0(-ep)),' )'
+@case_with_avh@ enddo
+@case_wout_avh@ print*, "isca=2: OneLOop not available"
+@case_wout_avh@ stop
+ elseif (isca.eq.3) then
+@case_with_golem@ call gtrunc_rm(abs(V1)+abs(V2)+abs(V3), &
+@case_with_golem@ & V1,V2,V3,m0,m1,m2)
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ if (present(cache_flag)) then
+@case_with_golem@ if (cache_flag) then
+@case_with_golem@ c0t(ep) = scalar_cache(ep,cache_index)
+@case_with_golem@ else
+@case_with_golem@ c0t(ep)=gC0(real(V1,ki_gol),real(V2,ki_gol),&
+@case_with_golem@ & real(V3,ki_gol),real(m0,ki_gol),&
+@case_with_golem@ & real(m1,ki_gol),real(m2,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ scalar_cache(ep,cache_index) = c0t(ep)
+@case_with_golem@ end if
+@case_with_golem@ else
+@case_with_golem@ c0t(ep)=gC0(real(V1,ki_gol),real(V2,ki_gol),&
+@case_with_golem@ & real(V3,ki_gol),real(m0,ki_gol),&
+@case_with_golem@ & real(m1,ki_gol),real(m2,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ end if
+@case_with_golem@ end do
+@case_with_golem@ !c0t( 0) = c0t(0) + log(scale2) * (c0t(-1) &
+@case_with_golem@ ! & + 0.5_ki * log(scale2) * c0t(-2))
+@case_with_golem@ !c0t(-1) = c0t(-1) + log(scale2) * c0t(-2)
+@case_with_golem@ if (verbosity.ge.2) then
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ write(iout,1) 'I3(',cut3,',',ep,&
+@case_with_golem@ & ') = (',real(c0t(ep)),',',aimag(c0t(ep)),' )'
+@case_with_golem@ end do
+@case_with_golem@ end if
+@case_with_golem@ tot3(:) = c0t(:) * c30
+@case_wout_golem@ print*, "isca=3: Golem95 not available"
+@case_wout_golem@ stop
+ elseif (isca.eq.4) then
+@case_with_lt@ tot3(-2) = 0
+@case_with_lt@ tot3(-1) = 0
+@case_with_lt@ tot3( 0) = 0
+@case_with_lt@ call gtrunc_rm(abs(V1)+abs(V2)+abs(V3), &
+@case_with_lt@ & V1,V2,V3,m0,m1,m2)
+@case_with_lt@ ep = -dim(0, int(getlambda()))
+@case_with_lt@ if (present(cache_flag)) then
+@case_with_lt@ if (cache_flag) then
+@case_with_lt@ ctmp = scalar_cache(ep,cache_index)
+@case_with_lt@ else
+@case_with_lt@ ctmp=C0(&
+@case_with_lt@ & real(V1,ki_lt),real(V2,ki_lt),real(V3,ki_lt),&
+@case_with_lt@ & real(m0,ki_lt),real(m1,ki_lt),real(m2,ki_lt))
+@case_with_lt@ scalar_cache(ep,cache_index) = ctmp
+@case_with_lt@ end if
+@case_with_lt@ else
+@case_with_lt@ ctmp=C0(&
+@case_with_lt@ & real(V1,ki_lt),real(V2,ki_lt),real(V3,ki_lt),&
+@case_with_lt@ & real(m0,ki_lt),real(m1,ki_lt),real(m2,ki_lt))
+@case_with_lt@ end if
+@case_with_lt@ tot3(ep)=c30*ctmp
+@case_with_lt@ if (verbosity.ge.2) write(iout,1) &
+@case_with_lt@ &'I3(',cut3,',',ep,') = (',real(ctmp),',',aimag(ctmp),' )'
+@case_wout_lt@ print*, "isca=4: LoopTools not available"
+@case_wout_lt@ stop
+ else
+ print*, 'error in add3'
+ stop
+ endif
+ tot3(0)=tot3(0) + tot3r
+ if (present(cache_flag)) cache_offset = cache_offset + 1
+ end subroutine add3_rm
+
+ subroutine add2_rm(nleg,c2,cut2,k1,k2,msq,tot2,tot2r,scale2, &
+ cache_flag, cache_offset, scalar_cache)
+@case_with_avh@ use avh_olo, only: olo_b11
+ implicit none
+
+ integer, intent(in) :: nleg, cut2
+ complex(ki), dimension(0:9), intent(in) :: c2
+ real(ki), dimension(4), intent(in) :: k1, k2
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(-2:0), intent(out) :: tot2
+ complex(ki), intent(out) :: tot2r
+ real(ki), intent(in) :: scale2
+
+ logical, intent(in), optional :: cache_flag
+ integer, intent(inout), optional :: cache_offset
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+ real(ki) :: m0, m1, K11, K12, B06
+ integer :: ep, cache_index
+ integer :: i1,i2
+ complex(ki), dimension(-2:0) :: J0, J1, J00, J01, J11
+@case_with_avh@ complex(ki_avh), dimension(0:2) :: scf2, scf1, scf0, scf
+@case_with_avh@ complex(ki) :: xbb, xb0, xb00
+@case_with_avh@ real(ki) :: bkv
+@case_with_avh@ integer :: i
+
+ if (notfirsti.eqv.(.false.)) then
+ if (isca .eq. 2) then
+@case_with_avh@ call avh_olo_mu_set(real(sqrt(scale2),ki_avh))
+ elseif (isca .eq. 4) then
+@case_with_lt@ call setmudim(real(scale2, ki_lt))
+ endif
+ notfirsti=.true.
+ endif
+
+ i2=cut2/10
+ i1=cut2-i2*10
+
+ m0=msq(i1)
+ m1=msq(i2)
+
+ if (allocated(s_mat)) then
+ K11 = s_mat(i2+1, i1+1) + msq(i1) + msq(i2)
+ else
+ K11 = sdot(K1,K1)
+ end if
+ K12=sdot(K1,K2)
+
+
+ B06=-(K11-three*(m0+m1))/six
+
+ tot2r= + B06*c2(9)
+
+ if (present(cache_flag)) cache_index = lbound(scalar_cache,2)+cache_offset
+ if (isca.eq.1) then
+@case_with_ql@ if (present(cache_flag)) then
+@case_with_ql@ if (cache_flag) then
+@case_with_ql@ J0(:) = scalar_cache(:,cache_index+0)
+@case_with_ql@ J1(:) = scalar_cache(:,cache_index+1)
+@case_with_ql@ J01(:) = scalar_cache(:,cache_index+2)
+@case_with_ql@ J11(:) = scalar_cache(:,cache_index+3)
+@case_with_ql@ J00(:) = scalar_cache(:,cache_index+4)
+@case_with_ql@ else
+@case_with_ql@ do ep=-2,0
+@case_with_ql@ J00(ep) = qlI2(&
+@case_with_ql@ & real(K11,ki_ql),real(m0,ki_ql),real(m0,ki_ql),&
+@case_with_ql@ & real(scale2,ki_ql),ep)
+@case_with_ql@ J11(ep) = qlI2(&
+@case_with_ql@ & real(K11,ki_ql),real(m1,ki_ql),real(m1,ki_ql),&
+@case_with_ql@ & real(scale2,ki_ql),ep)
+@case_with_ql@ J01(ep)=qlI2(&
+@case_with_ql@ & real(K11,ki_ql),real(m0,ki_ql),real(m1,ki_ql),&
+@case_with_ql@ & real(scale2,ki_ql),ep)
+@case_with_ql@ J0(ep) = qlI1(real(m0,ki_ql),real(scale2,ki_ql),ep)
+@case_with_ql@ J1(ep) = qlI1(real(m1,ki_ql),real(scale2,ki_ql),ep)
+@case_with_ql@ end do
+@case_with_ql@ scalar_cache(:,cache_index+0) = J0(:)
+@case_with_ql@ scalar_cache(:,cache_index+1) = J1(:)
+@case_with_ql@ scalar_cache(:,cache_index+2) = J01(:)
+@case_with_ql@ scalar_cache(:,cache_index+3) = J11(:)
+@case_with_ql@ scalar_cache(:,cache_index+4) = J00(:)
+@case_with_ql@ end if
+@case_with_ql@ else
+@case_with_ql@ do ep=-2,0
+@case_with_ql@ J00(ep) = qlI2(&
+@case_with_ql@ & real(K11,ki_ql),real(m0,ki_ql),real(m0,ki_ql),&
+@case_with_ql@ & real(scale2,ki_ql),ep)
+@case_with_ql@ J11(ep) = qlI2(&
+@case_with_ql@ & real(K11,ki_ql),real(m1,ki_ql),real(m1,ki_ql),&
+@case_with_ql@ & real(scale2,ki_ql),ep)
+@case_with_ql@ J01(ep)=qlI2(&
+@case_with_ql@ & real(K11,ki_ql),real(m0,ki_ql),real(m1,ki_ql),&
+@case_with_ql@ & real(scale2,ki_ql),ep)
+@case_with_ql@ J0(ep) = qlI1(real(m0,ki_ql),real(scale2,ki_ql),ep)
+@case_with_ql@ J1(ep) = qlI1(real(m1,ki_ql),real(scale2,ki_ql),ep)
+@case_with_ql@ end do
+@case_with_ql@ end if
+@case_with_ql@ ! The remaining steps come in another if-statement
+@case_wout_ql@ print*, "isca=1: QCDLoop not available"
+@case_wout_ql@ stop
+ elseif (isca.eq.2) then
+@case_with_avh@ xbb=c2(0)
+@case_with_avh@ xb0=c2(1)
+@case_with_avh@ xb00=c2(2)
+@case_with_avh@ bkv=K12
+@case_with_avh@ if (present(cache_flag)) then
+@case_with_avh@ if (cache_flag) then
+@case_with_avh@ scf(:) = scalar_cache(:,cache_index+0)
+@case_with_avh@ scf0(:) = scalar_cache(:,cache_index+1)
+@case_with_avh@ scf1(:) = scalar_cache(:,cache_index+2)
+@case_with_avh@ scf2(:) = scalar_cache(:,cache_index+3)
+@case_with_avh@ else
+@case_with_avh@ call olo_b11(scf2,scf0,scf1,scf,&
+@case_with_avh@ & real(K11,ki_avh),real(m0,ki_avh),real(m1,ki_avh))
+@case_with_avh@ scalar_cache(:,cache_index+0) = scf(:)
+@case_with_avh@ scalar_cache(:,cache_index+1) = scf0(:)
+@case_with_avh@ scalar_cache(:,cache_index+2) = scf1(:)
+@case_with_avh@ scalar_cache(:,cache_index+3) = scf2(:)
+@case_with_avh@ end if
+@case_with_avh@ else
+@case_with_avh@ call olo_b11(scf2,scf0,scf1,scf,&
+@case_with_avh@ & real(K11,ki_avh),real(m0,ki_avh),real(m1,ki_avh))
+@case_with_avh@ end if
+@case_with_avh@ tot2(0)=xbb*scf(0)+xb0*bkv*scf1(0)+xb00*bkv*bkv*scf2(0)
+@case_with_avh@ tot2(0)=tot2(0)+ B06*c2(9)
+@case_with_avh@ tot2(-1)=xbb*scf(1)+xb0*bkv*scf1(1)+xb00*bkv*bkv*scf2(1)
+@case_with_avh@ tot2(-2)=xbb*scf(2)+xb0*bkv*scf1(2)+xb00*bkv*bkv*scf2(2)
+@case_with_avh@ if (verbosity.ge.2) then
+@case_with_avh@ do i=0,2
+@case_with_avh@ write(iout,903) 'B_0 (',cut2,',',-i,') = ',scf(i)
+@case_with_avh@ write(iout,903) 'B_1 (',cut2,',',-i,') =',scf1(i)
+@case_with_avh@ write(iout,903) 'B_11(',cut2,',',-i,') =',scf2(i)
+@case_with_avh@ enddo
+@case_with_avh@ endif
+@case_wout_avh@ print*, "isca=2: OneLOop not available"
+@case_wout_avh@ stop
+ elseif (isca.eq.3) then
+@case_with_golem@ if (present(cache_flag)) then
+@case_with_golem@ if (cache_flag) then
+@case_with_golem@ J0(:) = scalar_cache(:,cache_index+0)
+@case_with_golem@ J1(:) = scalar_cache(:,cache_index+1)
+@case_with_golem@ J01(:) = scalar_cache(:,cache_index+2)
+@case_with_golem@ J11(:) = scalar_cache(:,cache_index+3)
+@case_with_golem@ J00(:) = scalar_cache(:,cache_index+4)
+@case_with_golem@ else
+@case_with_golem@ call gtrunc_rm(abs(K11)+1.0_ki, K11,m0,m1)
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ J00(ep)= gB0(real(K11,ki_gol),&
+@case_with_golem@ & real(m0,ki_gol),real(m0,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J11(ep)= gB0(real(K11,ki_gol),&
+@case_with_golem@ & real(m1,ki_gol),real(m1,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J01(ep)= gB0(real(K11,ki_gol),&
+@case_with_golem@ & real(m0,ki_gol),real(m1,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J0(ep) = gA0(real(m0,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J1(ep) = gA0(real(m1,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ end do
+@case_with_golem@ scalar_cache(:,cache_index+0) = J0(:)
+@case_with_golem@ scalar_cache(:,cache_index+1) = J1(:)
+@case_with_golem@ scalar_cache(:,cache_index+2) = J01(:)
+@case_with_golem@ scalar_cache(:,cache_index+3) = J11(:)
+@case_with_golem@ scalar_cache(:,cache_index+4) = J00(:)
+@case_with_golem@ end if
+@case_with_golem@ else
+@case_with_golem@ call gtrunc_rm(abs(K11)+1.0_ki, K11,m0,m1)
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ J00(ep)= gB0(real(K11,ki_gol),&
+@case_with_golem@ & real(m0,ki_gol),real(m0,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J11(ep)= gB0(real(K11,ki_gol),&
+@case_with_golem@ & real(m1,ki_gol),real(m1,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J01(ep)= gB0(real(K11,ki_gol),&
+@case_with_golem@ & real(m0,ki_gol),real(m1,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J0(ep) = gA0(real(m0,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J1(ep) = gA0(real(m1,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ end do
+@case_with_golem@ end if
+@case_wout_golem@ print*, "isca=3: Golem95 not available"
+@case_wout_golem@ stop
+ elseif (isca.eq.4) then
+@case_with_lt@ ep = -dim(0, int(getlambda()))
+@case_with_lt@ J00(:) = 0.0_ki_lt
+@case_with_lt@ J11(:) = 0.0_ki_lt
+@case_with_lt@ J0(:) = 0.0_ki_lt
+@case_with_lt@ J1(:) = 0.0_ki_lt
+@case_with_lt@ if (present(cache_flag)) then
+@case_with_lt@ if (cache_flag) then
+@case_with_lt@ J0(:) = scalar_cache(:,cache_index+0)
+@case_with_lt@ J1(:) = scalar_cache(:,cache_index+1)
+@case_with_lt@ J01(:) = scalar_cache(:,cache_index+2)
+@case_with_lt@ J11(:) = scalar_cache(:,cache_index+3)
+@case_with_lt@ J00(:) = scalar_cache(:,cache_index+4)
+@case_with_lt@ else
+@case_with_lt@ call gtrunc_rm(abs(K11)+1.0_ki, K11,m0,m1)
+@case_with_lt@ J00(ep) = B0(real(K11,ki_lt),&
+@case_with_lt@ & real(m0,ki_lt),real(m0,ki_lt))
+@case_with_lt@ J11(ep) = B0(real(K11,ki_lt),&
+@case_with_lt@ & real(m1,ki_lt),real(m1,ki_lt))
+@case_with_lt@ J01(ep) = B0(real(K11,ki_lt),&
+@case_with_lt@ & real(m0,ki_lt),real(m1,ki_lt))
+@case_with_lt@ J0(ep) = A0(real(m0,ki_lt))
+@case_with_lt@ J1(ep) = A0(real(m1,ki_lt))
+@case_with_lt@ scalar_cache(:,cache_index+0) = J0(:)
+@case_with_lt@ scalar_cache(:,cache_index+1) = J1(:)
+@case_with_lt@ scalar_cache(:,cache_index+2) = J01(:)
+@case_with_lt@ scalar_cache(:,cache_index+3) = J11(:)
+@case_with_lt@ scalar_cache(:,cache_index+4) = J00(:)
+@case_with_lt@ end if
+@case_with_lt@ else
+@case_with_lt@ call gtrunc_rm(abs(K11)+1.0_ki, K11,m0,m1)
+@case_with_lt@ J00(ep) = B0(real(K11,ki_lt),&
+@case_with_lt@ & real(m0,ki_lt),real(m0,ki_lt))
+@case_with_lt@ J11(ep) = B0(real(K11,ki_lt),&
+@case_with_lt@ & real(m1,ki_lt),real(m1,ki_lt))
+@case_with_lt@ J01(ep) = B0(real(K11,ki_lt),&
+@case_with_lt@ & real(m0,ki_lt),real(m1,ki_lt))
+@case_with_lt@ J0(ep) = A0(real(m0,ki_lt))
+@case_with_lt@ J1(ep) = A0(real(m1,ki_lt))
+@case_with_lt@ end if
+@case_wout_lt@ print*, "isca=4: LoopTools not available"
+@case_wout_lt@ stop
+ else
+ print*, 'error in add2'
+ stop
+ endif
+
+ if (isca.eq.1 .or. isca.eq.3 .or. isca.eq.4) then
+ if (abs(K11).gt.zip1) then
+ do ep=-2,0
+ tot2(ep)=-(K12*(two*K12*(m0 - m1)*c2(2) + &
+ & K11*(-three*c2(1) + two*K12*c2(2)))*J0(ep))/(six*K11**2) &
+ & + ((two*K12**2*(m0 - m1)**2*c2(2) + &
+ & K11*K12*(-three*m0*c2(1) + three*m1*c2(1) + &
+ & two*K12*m0*c2(2) - four*K12*m1*c2(2)) + &
+ & K11**2*(6*c2(0) + K12*(-three*c2(1) + two*K12*c2(2))))* &
+ & J01(ep))/(six*K11**2) + &
+ & (K12*(two*K12*(m0 - m1)*c2(2) + &
+ & K11*(-three*c2(1) + four*K12*c2(2)))*J1(ep))/(six*K11**2)
+ enddo
+ tot2(0)=tot2(0)+(K12**2*c2(2))/18.0_ki &
+ & - (K12**2*m0*c2(2))/(six*K11) - &
+ & (K12**2*m1*c2(2))/(six*K11) + B06*c2(9)
+ else
+ if (m1.eq.m0) then
+ do ep=-2,0
+ tot2(ep)=(c2(0) + (K12*(-three*c2(1) &
+ & + two*K12*c2(2)))/six)*J00(ep)
+ enddo
+ tot2(0)=tot2(0)+B06*c2(9)
+ else
+ do ep=-2,0
+ tot2(ep)=(K12*m0**2*(-three*m0*c2(1) + three*m1*c2(1) &
+ & + two*K12*m0*c2(2))* &
+ & J00(ep))/(six*(m0 - m1)**3) + c2(0)*J01(ep) - &
+ & (K12*m1*(m0*m1*(9*c2(1) - 6*K12*c2(2)) - &
+ & 6*m0**2*(c2(1) - K12*c2(2)) + &
+ & m1**2*(-three*c2(1) + two*K12*c2(2)))*J11(ep))/ &
+ & (six*(m0 - m1)**3)
+ enddo
+ tot2(0)=tot2(0) + (-three*K12*m0*c2(1))/(four*(m0 - m1)) + &
+ & (K12*m1*c2(1))/(four*m0 - four*m1) + &
+ & (11.0_ki*K12**2*m0**2*c2(2))/(18.0_ki*(m0 - m1)**2) - &
+ & (7.0_ki*K12**2*m0*m1*c2(2))/(18.0_ki*(m0 - m1)**2) + &
+ & (K12**2*m1**2*c2(2))/(9.0_ki*(m0 - m1)**2) + B06*c2(9)
+ endif
+ endif
+ if (verbosity.ge.2) then
+ do ep=0,2
+ write(iout,903) 'B0 (',cut2,',',-ep,') = ',J0(-ep)
+ write(iout,903) 'B1 (',cut2,',',-ep,') =',J1(-ep)
+ write(iout,903) 'B00(',cut2,',',-ep,') =',J00(-ep)
+ write(iout,903) 'B11(',cut2,',',-ep,') =',J11(-ep)
+ end do
+ endif
+ end if
+ if (present(cache_flag)) cache_offset = cache_offset + 5
+
+ 903 format(a5,I2,a1,I2,a4,2(D24.15))
+
+ end subroutine add2_rm
+
+ subroutine add1_rm(nleg,c1,cut1,msq,tot1,scale2, &
+ cache_flag, cache_offset, scalar_cache)
+@case_with_avh@ use avh_olo, only: olo_a0
+ implicit none
+ integer, intent(in) :: nleg, cut1
+ complex(ki), dimension(0:4), intent(in) :: c1
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(-2:0), intent(out) :: tot1
+ real(ki), intent(in) :: scale2
+
+ logical, intent(in), optional :: cache_flag
+ integer, intent(inout), optional :: cache_offset
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+ integer ::j1
+ real(ki) :: m0
+@case_with_avh@ complex(ki_avh), dimension(0:2) :: vala0
+ complex(ki) :: ctmp
+ integer :: ep, cache_index
+
+ if (notfirsti.eqv.(.false.)) then
+ if (isca .eq. 2) then
+@case_with_avh@ call avh_olo_mu_set(real(sqrt(scale2),ki_avh))
+ elseif (isca .eq. 4) then
+@case_with_lt@ call setmudim(real(scale2, ki_lt))
+ endif
+ notfirsti=.true.
+ endif
+
+ j1=cut1
+
+ m0=msq(j1)
+
+ 1 Format(A3,I2,A1,I2,A5,D24.15,A1,D24.15,A3)
+
+ if (present(cache_flag)) cache_index = lbound(scalar_cache,2)+cache_offset
+ if (isca.eq.1) then
+@case_with_ql@ do ep=-2,0
+@case_with_ql@ if (present(cache_flag)) then
+@case_with_ql@ if (cache_flag) then
+@case_with_ql@ ctmp = scalar_cache(ep,cache_index)
+@case_with_ql@ else
+@case_with_ql@ ctmp = qlI1(real(m0,ki_ql),real(scale2,ki_ql),ep)
+@case_with_ql@ scalar_cache(ep,cache_index) = ctmp
+@case_with_ql@ end if
+@case_with_ql@ else
+@case_with_ql@ ctmp = qlI1(real(m0,ki_ql),real(scale2,ki_ql),ep)
+@case_with_ql@ end if
+@case_with_ql@ tot1(ep)=c1(0)*ctmp
+@case_with_ql@ if (verbosity.ge.2) write(iout,1) &
+@case_with_ql@ & 'I1(',cut1,',',ep,') = (',real(ctmp),',',aimag(ctmp),' )'
+@case_with_ql@ enddo
+@case_wout_ql@ print*, "isca=1: QCDLoop not available"
+@case_wout_ql@ stop
+ elseif (isca.eq.2) then
+@case_with_avh@ if (present(cache_flag)) then
+@case_with_avh@ if (cache_flag) then
+@case_with_avh@ vala0(0) = scalar_cache( 0,cache_index)
+@case_with_avh@ vala0(1) = scalar_cache(-1,cache_index)
+@case_with_avh@ vala0(2) = scalar_cache(-2,cache_index)
+@case_with_avh@ else
+@case_with_avh@ call olo_a0(vala0,real(m0,ki_avh))
+@case_with_avh@ scalar_cache( 0,cache_index) = vala0(0)
+@case_with_avh@ scalar_cache(-1,cache_index) = vala0(1)
+@case_with_avh@ scalar_cache(-2,cache_index) = vala0(2)
+@case_with_avh@ end if
+@case_with_avh@ else
+@case_with_avh@ call olo_a0(vala0,real(m0,ki_avh))
+@case_with_avh@ end if
+@case_with_avh@ do ep=-2,0
+@case_with_avh@ tot1(ep)= c1(0)*vala0(-ep)
+@case_with_avh@ if (verbosity.ge.2) write(iout,1) &
+@case_with_avh@ & 'I1(',cut1,',',ep,') = (',&
+@case_with_avh@ & real(vala0(-ep)),',',aimag(vala0(-ep)),' )'
+@case_with_avh@ enddo
+@case_wout_avh@ print*, "isca=2: OneLOop not available"
+@case_wout_avh@ stop
+ elseif (isca.eq.3) then
+@case_with_golem@ if (verbosity.ge.2) write(iout,1) &
+@case_with_golem@ & 'I1(',cut1,',',-2,') = (',0.0_ki,',',0.0_ki,' )'
+@case_with_golem@ tot1(-2) = (0.0_ki,0.0_ki)
+@case_with_golem@ if (present(cache_flag)) then
+@case_with_golem@ if (cache_flag) then
+@case_with_golem@ do ep=-1,0
+@case_with_golem@ ctmp = scalar_cache(ep,cache_index)
+@case_with_golem@ tot1(ep) = c1(0)*ctmp
+@case_with_golem@ if (verbosity.ge.2) write(iout,1) &
+@case_with_golem@ & 'I1(',cut1,',',ep,') = (',&
+@case_with_golem@ & real(ctmp),',',aimag(ctmp),' )'
+@case_with_golem@ enddo
+@case_with_golem@ else
+@case_with_golem@ scalar_cache(-2,cache_index) = czip
+@case_with_golem@ call gtrunc_rm(1.0_ki, m0)
+@case_with_golem@ do ep=-1,0
+@case_with_golem@ ctmp = gA0(real(m0,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ scalar_cache(ep,cache_index) = ctmp
+@case_with_golem@ tot1(ep) = c1(0)*ctmp
+@case_with_golem@ if (verbosity.ge.2) write(iout,1) &
+@case_with_golem@ & 'I1(',cut1,',',ep,') = (',&
+@case_with_golem@ & real(ctmp),',',aimag(ctmp),' )'
+@case_with_golem@ enddo
+@case_with_golem@ end if
+@case_with_golem@ else
+@case_with_golem@ call gtrunc_rm(1.0_ki, m0)
+@case_with_golem@ do ep=-1,0
+@case_with_golem@ ctmp = gA0(real(m0,ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ tot1(ep) = c1(0)*ctmp
+@case_with_golem@ if (verbosity.ge.2) write(iout,1) &
+@case_with_golem@ & 'I1(',cut1,',',ep,') = (',&
+@case_with_golem@ & real(ctmp),',',aimag(ctmp),' )'
+@case_with_golem@ enddo
+@case_with_golem@ end if
+@case_wout_golem@ print*, "isca=3: Golem95 not available"
+@case_wout_golem@ stop
+ elseif (isca.eq.4) then
+@case_with_lt@ tot1(-2) = 0
+@case_with_lt@ tot1(-1) = 0
+@case_with_lt@ tot1( 0) = 0
+@case_with_lt@ ep = -dim(0, int(getlambda()))
+@case_with_lt@ if (present(cache_flag)) then
+@case_with_lt@ if (cache_flag) then
+@case_with_lt@ ctmp = scalar_cache(ep,cache_index)
+@case_with_lt@ else
+@case_with_lt@ ctmp = A0(real(m0,ki_lt))
+@case_with_lt@ scalar_cache(ep,cache_index) = ctmp
+@case_with_lt@ end if
+@case_with_lt@ else
+@case_with_lt@ ctmp = A0(real(m0,ki_lt))
+@case_with_lt@ end if
+@case_with_lt@ tot1(ep)=c1(0)*ctmp
+@case_with_lt@ if (verbosity.ge.2) write(iout,1) &
+@case_with_lt@ & 'I1(',cut1,',',ep,') = (',real(ctmp),',',aimag(ctmp),' )'
+@case_wout_lt@ print*, "isca=4: LoopTools not available"
+@case_wout_lt@ stop
+ else
+ print*, 'error in add1'
+ stop
+ endif
+
+ if (present(cache_flag)) cache_offset = cache_offset + 1
+ end subroutine add1_rm
+
+ subroutine add4_cm(nleg,c4,cut4,Vi,msq,tot4,tot4r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+@case_with_avh@ use avh_olo, only: olo_d0
+ implicit none
+ integer, intent(in) :: cut4,nleg
+ complex(ki), dimension(0:4), intent(in) :: c4
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), intent(in) :: scale2
+ complex(ki), dimension(-2:0), intent(out) :: tot4
+ complex(ki), intent(out) :: tot4r
+
+ logical, intent(in), optional :: cache_flag
+ integer, intent(inout), optional :: cache_offset
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+ integer :: i,j1,j2,j3,j4
+
+ real(ki) :: V1, V2, V3, V21, V31, V32
+ complex(ki) :: m0, m1, m2, m3
+ real(ki), dimension(4):: Vi1, Vi2, Vi3, Vi21, Vi31, Vi32
+ complex(ki) :: c40
+@case_with_avh@ complex(ki_avh), dimension(0:2) :: vald0
+ complex(ki) :: ctmp
+@case_with_golem@ complex(ki), dimension(-2:0) :: d0t
+ integer :: ep, cache_index
+
+ if (notfirsti.eqv.(.false.)) then
+ if (isca .eq. 2) then
+@case_with_avh@ call avh_olo_mu_set(real(sqrt(scale2),ki_avh))
+ elseif (isca .eq. 4) then
+@case_with_lt@ call setmudim(real(scale2, ki_lt))
+ endif
+ notfirsti=.true.
+ endif
+
+ j4=cut4/1000
+ j3=(cut4-j4*1000)/100
+ j2=(cut4-j4*1000-j3*100)/10
+ j1=cut4-j4*1000-j3*100-j2*10
+
+ m0=msq(j1)
+ m1=msq(j2)
+ m2=msq(j3)
+ m3=msq(j4)
+
+ if (allocated(s_mat)) then
+ ! s_mat(i+1, j+1) = (Vi(i,:) - Vi(j,:))**2 - msq(i) - msq(j)
+ V1 = s_mat(j2+1, j1+1) + msq(j2) + msq(j1)
+ V2 = s_mat(j3+1, j1+1) + msq(j3) + msq(j1)
+ V3 = s_mat(j4+1, j1+1) + msq(j4) + msq(j1)
+ V21 = s_mat(j3+1, j2+1) + msq(j3) + msq(j2)
+ V31 = s_mat(j4+1, j2+1) + msq(j4) + msq(j2)
+ V32 = s_mat(j4+1, j3+1) + msq(j4) + msq(j3)
+ else
+ Vi1(:)=Vi(j2,:)-Vi(j1,:)
+ Vi2(:)=Vi(j3,:)-Vi(j1,:)
+ Vi3(:)=Vi(j1,:)-Vi(j4,:)
+ Vi21(:)=Vi(j3,:)-Vi(j2,:)
+ Vi31(:)=Vi(j4,:)-Vi(j2,:)
+ Vi32(:)=Vi(j4,:)-Vi(j3,:)
+
+ V1=sdot(Vi1,Vi1)
+ V2=sdot(Vi2,Vi2)
+ V3=sdot(Vi3,Vi3)
+ V21=sdot(Vi21,Vi21)
+ V31=sdot(Vi31,Vi31)
+ V32=sdot(Vi32,Vi32)
+ end if
+
+ c40=c4(0)
+ tot4r=-c4(4)/six
+
+ 1 Format(A3,I4,A1,I2,A5,D24.15,A1,D24.15,A3)
+
+ if (present(cache_flag)) cache_index = lbound(scalar_cache,2)+cache_offset
+ if (isca.eq.1) then
+@case_with_ql@ print*, "isca=1: QCDLoop does not support complex masses."
+@case_wout_ql@ print*, "isca=1: QCDLoop not available"
+ stop
+ elseif (isca.eq.2) then
+@case_with_avh@ if (present(cache_flag)) then
+@case_with_avh@ if (cache_flag) then
+@case_with_avh@ vald0(0) = scalar_cache( 0,cache_index)
+@case_with_avh@ vald0(1) = scalar_cache(-1,cache_index)
+@case_with_avh@ vald0(2) = scalar_cache(-2,cache_index)
+@case_with_avh@ else
+@case_with_avh@ call olo_d0(vald0,&
+@case_with_avh@ & cmplx(V1,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V21,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V32,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V3,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V2,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V31,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(real(m0,ki_avh),aimag(m0),ki_avh),&
+@case_with_avh@ & cmplx(real(m1,ki_avh),aimag(m1),ki_avh),&
+@case_with_avh@ & cmplx(real(m2,ki_avh),aimag(m2),ki_avh),&
+@case_with_avh@ & cmplx(real(m3,ki_avh),aimag(m3),ki_avh))
+@case_with_avh@ scalar_cache( 0,cache_index) = vald0(0)
+@case_with_avh@ scalar_cache(-1,cache_index) = vald0(1)
+@case_with_avh@ scalar_cache(-2,cache_index) = vald0(2)
+@case_with_avh@ end if
+@case_with_avh@ else
+@case_with_avh@ call olo_d0(vald0,&
+@case_with_avh@ & cmplx(V1,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V21,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V32,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V3,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V2,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V31,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(real(m0,ki_avh),aimag(m0),ki_avh),&
+@case_with_avh@ & cmplx(real(m1,ki_avh),aimag(m1),ki_avh),&
+@case_with_avh@ & cmplx(real(m2,ki_avh),aimag(m2),ki_avh),&
+@case_with_avh@ & cmplx(real(m3,ki_avh),aimag(m3),ki_avh))
+@case_with_avh@ end if
+@case_with_avh@ do ep=-2,0
+@case_with_avh@ tot4(ep)= c40*vald0(-ep)
+@case_with_avh@ if (verbosity.ge.2) write(iout,1) &
+@case_with_avh@ & 'I4(',cut4,',',ep,') = (',real(vald0(-ep)),',',&
+@case_with_avh@ & aimag(vald0(-ep)),' )'
+@case_with_avh@ enddo
+@case_wout_avh@ print*, "isca=2: OneLOop not available"
+@case_wout_avh@ stop
+ elseif (isca.eq.3) then
+@case_with_golem@ call gtrunc_rm(abs(V32)+abs(V31), V1,V2,V3,V21,V32,V31)
+@case_with_golem@ call gtrunc_cm(abs(V32)+abs(V31), m0,m1,m2,m3)
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ if (present(cache_flag)) then
+@case_with_golem@ if (cache_flag) then
+@case_with_golem@ d0t(ep) = scalar_cache(ep,cache_index)
+@case_with_golem@ else
+@case_with_golem@ d0t(ep)=gD0C(&
+@case_with_golem@ & cmplx(V1,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V21,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V32,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V3,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V2,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V31,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & cmplx(real(m2,ki_gol),aimag(m2),ki_gol),&
+@case_with_golem@ & cmplx(real(m3,ki_gol),aimag(m3),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ scalar_cache(ep,cache_index) = d0t(ep)
+@case_with_golem@ end if
+@case_with_golem@ else
+@case_with_golem@ d0t(ep)=gD0C(&
+@case_with_golem@ & cmplx(V1,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V21,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V32,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V3,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V2,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V31,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & cmplx(real(m2,ki_gol),aimag(m2),ki_gol),&
+@case_with_golem@ & cmplx(real(m3,ki_gol),aimag(m3),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ end if
+@case_with_golem@ end do
+@case_with_golem@ !d0t( 0) = d0t(0) + log(scale2) * (d0t(-1) &
+@case_with_golem@ ! & + 0.5_ki * log(scale2) * d0t(-2))
+@case_with_golem@ !d0t(-1) = d0t(-1) + log(scale2) * d0t(-2)
+@case_with_golem@ if (verbosity.ge.2) then
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ write(iout,1) 'I4(',cut4,',',ep,&
+@case_with_golem@ & ') = (',real(d0t(ep)),',',aimag(d0t(ep)),' )'
+@case_with_golem@ end do
+@case_with_golem@ end if
+@case_with_golem@ tot4(:) = d0t(:) * c40
+@case_wout_golem@ print*, "isca=3: Golem95 not available"
+@case_wout_golem@ stop
+ elseif (isca.eq.4) then
+@case_with_lt@ tot4(-2) = 0
+@case_with_lt@ tot4(-1) = 0
+@case_with_lt@ tot4(0) = 0
+@case_with_lt@ ep = -dim(0, int(getlambda()))
+@case_with_lt@ if (present(cache_flag)) then
+@case_with_lt@ if (cache_flag) then
+@case_with_lt@ ctmp = scalar_cache(ep,cache_index)
+@case_with_lt@ else
+@case_with_lt@ call gtrunc_rm(abs(V32)+abs(V31), V1,V2,V3,V21,V32,V31)
+@case_with_lt@ call gtrunc_cm(abs(V32)+abs(V31), m0,m1,m2,m3)
+@case_with_lt@ ctmp=D0C(&
+@case_with_lt@ & cmplx(V1,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V21,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V32,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V3,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V2,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V31,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt),&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt),&
+@case_with_lt@ & cmplx(real(m2,ki_lt),aimag(m2),ki_lt),&
+@case_with_lt@ & cmplx(real(m3,ki_lt),aimag(m3),ki_lt))
+@case_with_lt@ scalar_cache(ep,cache_index) = ctmp
+@case_with_lt@ end if
+@case_with_lt@ else
+@case_with_lt@ call gtrunc_rm(abs(V32)+abs(V31), V1,V2,V3,V21,V32,V31)
+@case_with_lt@ call gtrunc_cm(abs(V32)+abs(V31), m0,m1,m2,m3)
+@case_with_lt@ ctmp=D0C(&
+@case_with_lt@ & cmplx(V1,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V21,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V32,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V3,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V2,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V31,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt),&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt),&
+@case_with_lt@ & cmplx(real(m2,ki_lt),aimag(m2),ki_lt),&
+@case_with_lt@ & cmplx(real(m3,ki_lt),aimag(m3),ki_lt))
+@case_with_lt@ end if
+@case_with_lt@ tot4(ep)=c40*ctmp
+@case_with_lt@ if (verbosity.ge.2) write(iout,1) &
+@case_with_lt@ & 'I4(',cut4,',',ep,') = (',real(ctmp),',',aimag(ctmp),' )'
+@case_wout_lt@ print*, "isca=4: LoopTools not available"
+@case_wout_lt@ stop
+ else
+ print*, 'error in add4'
+ stop
+ endif
+ if (present(cache_flag)) cache_offset = cache_offset + 1
+ tot4(0)=tot4(0) + tot4r
+ end subroutine add4_cm
+
+ subroutine add3_cm(nleg,c3,cut3,Vi,msq,tot3,tot3r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+@case_with_avh@ use avh_olo, only: olo_c0
+ implicit none
+
+ integer, intent(in) :: nleg, cut3
+ complex(ki), dimension(0:9), intent(in) :: c3
+ real(ki), dimension(0:nleg-1,4) ::Vi
+ complex(ki), dimension(0:nleg-1):: msq
+ complex(ki), dimension(-2:0), intent(out) :: tot3
+ complex(ki), intent(out) :: tot3r
+ real(ki), intent(in) :: scale2
+
+ logical, intent(in), optional :: cache_flag
+ integer, intent(inout), optional :: cache_offset
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+ integer :: i,j1,j2,j3
+ real(ki) :: V1, V2, V3
+ complex(ki) :: m0, m1, m2
+ real(ki), dimension(4):: Vi1, Vi2, Vi3
+ complex(ki) :: c30
+@case_with_avh@ complex(ki_avh), dimension(0:2) :: valc0
+ complex(ki) :: ctmp
+@case_with_golem@ complex(ki), dimension(-2:0) :: c0t
+ integer :: ep, cache_index
+
+ if (notfirsti.eqv.(.false.)) then
+ if (isca .eq. 2) then
+@case_with_avh@ call avh_olo_mu_set(real(sqrt(scale2),ki_avh))
+ elseif (isca .eq. 4) then
+@case_with_lt@ call setmudim(real(scale2, ki_lt))
+ endif
+ notfirsti=.true.
+ endif
+
+ j3=cut3/100
+ j2=(cut3-j3*100)/10
+ j1=cut3-j3*100-j2*10
+
+ m0=msq(j1)
+ m1=msq(j2)
+ m2=msq(j3)
+
+ if (allocated(s_mat)) then
+ ! s_mat(i+1, j+1) = (Vi(i,:) - Vi(j,:))**2 - msq(i) - msq(j)
+ V1 = s_mat(j2+1, j1+1) + msq(j2) + msq(j1)
+ V2 = s_mat(j3+1, j2+1) + msq(j3) + msq(j2)
+ V3 = s_mat(j3+1, j1+1) + msq(j3) + msq(j1)
+ else
+ Vi1(:)=Vi(j2,:)-Vi(j1,:)
+ Vi2(:)=Vi(j3,:)-Vi(j2,:)
+ Vi3(:)=Vi(j1,:)-Vi(j3,:)
+
+ V1=sdot(Vi1,Vi1)
+ V2=sdot(Vi2,Vi2)
+ V3=sdot(Vi3,Vi3)
+ end if
+
+ c30=c3(0)
+
+ tot3r=+c3(7)/two
+
+ 1 Format(A3,I3,A1,I2,A5,D24.15,A1,D24.15,A3)
+
+ if (present(cache_flag)) cache_index = lbound(scalar_cache,2)+cache_offset
+ if (isca.eq.1) then
+@case_with_ql@ print*, "isca=1: QCDLoop does not support complex masses."
+@case_wout_ql@ print*, "isca=1: QCDLoop not available"
+ stop
+ elseif (isca.eq.2) then
+@case_with_avh@ if (present(cache_flag)) then
+@case_with_avh@ if (cache_flag) then
+@case_with_avh@ valc0(0) = scalar_cache( 0,cache_index)
+@case_with_avh@ valc0(1) = scalar_cache(-1,cache_index)
+@case_with_avh@ valc0(2) = scalar_cache(-2,cache_index)
+@case_with_avh@ else
+@case_with_avh@ call olo_c0(valc0,&
+@case_with_avh@ & cmplx(V1,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V2,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V3,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(real(m0,ki_avh),aimag(m0),ki_avh),&
+@case_with_avh@ & cmplx(real(m1,ki_avh),aimag(m1),ki_avh),&
+@case_with_avh@ & cmplx(real(m2,ki_avh),aimag(m2),ki_avh))
+@case_with_avh@ scalar_cache( 0,cache_index) = valc0(0)
+@case_with_avh@ scalar_cache(-1,cache_index) = valc0(1)
+@case_with_avh@ scalar_cache(-2,cache_index) = valc0(2)
+@case_with_avh@ end if
+@case_with_avh@ else
+@case_with_avh@ call olo_c0(valc0,&
+@case_with_avh@ & cmplx(V1,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V2,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(V3,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(real(m0,ki_avh),aimag(m0),ki_avh),&
+@case_with_avh@ & cmplx(real(m1,ki_avh),aimag(m1),ki_avh),&
+@case_with_avh@ & cmplx(real(m2,ki_avh),aimag(m2),ki_avh))
+@case_with_avh@ end if
+@case_with_avh@ do ep=-2,0
+@case_with_avh@ tot3(ep)= c30*valc0(-ep)
+@case_with_avh@ if (verbosity.ge.2) write(iout,1) &
+@case_with_avh@ &'I3(',cut3,',',ep,') = (',real(valc0(-ep)),',',aimag(valc0(-ep)),' )'
+@case_with_avh@ enddo
+@case_wout_avh@ print*, "isca=2: OneLOop not available"
+@case_wout_avh@ stop
+ elseif (isca.eq.3) then
+@case_with_golem@ call gtrunc_rm(abs(V1)+abs(V2)+abs(V3), V1,V2,V3)
+@case_with_golem@ call gtrunc_cm(abs(V1)+abs(V2)+abs(V3), m0,m1,m2)
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ if (present(cache_flag)) then
+@case_with_golem@ if (cache_flag) then
+@case_with_golem@ c0t(ep) = scalar_cache(ep,cache_index)
+@case_with_golem@ else
+@case_with_golem@ c0t(ep)=gC0C(&
+@case_with_golem@ & cmplx(V1,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V2,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V3,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & cmplx(real(m2,ki_gol),aimag(m2),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ scalar_cache(ep,cache_index) = c0t(ep)
+@case_with_golem@ end if
+@case_with_golem@ else
+@case_with_golem@ c0t(ep)=gC0C(&
+@case_with_golem@ & cmplx(V1,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V2,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(V3,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & cmplx(real(m2,ki_gol),aimag(m2),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ end if
+@case_with_golem@ end do
+@case_with_golem@ !c0t( 0) = c0t(0) + log(scale2) * (c0t(-1) &
+@case_with_golem@ ! & + 0.5_ki * log(scale2) * c0t(-2))
+@case_with_golem@ !c0t(-1) = c0t(-1) + log(scale2) * c0t(-2)
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ if (verbosity.ge.2) write(iout,1) 'I3(',cut3,',',ep,&
+@case_with_golem@ & ') = (',real(c0t(ep)),',',aimag(c0t(ep)),' )'
+@case_with_golem@ end do
+@case_with_golem@ tot3(:) = c0t(:) * c30
+@case_wout_golem@ print*, "isca=3: Golem95 not available"
+@case_wout_golem@ stop
+ elseif (isca.eq.4) then
+@case_with_lt@ tot3(-2) = 0
+@case_with_lt@ tot3(-1) = 0
+@case_with_lt@ tot3(0) = 0
+@case_with_lt@ call gtrunc_rm(abs(V1)+abs(V2)+abs(V3), V1,V2,V3)
+@case_with_lt@ call gtrunc_cm(abs(V1)+abs(V2)+abs(V3), m0,m1,m2)
+@case_with_lt@ ep = -dim(0, int(getlambda()))
+@case_with_lt@ if (present(cache_flag)) then
+@case_with_lt@ if (cache_flag) then
+@case_with_lt@ ctmp = scalar_cache(ep,cache_index)
+@case_with_lt@ else
+@case_with_lt@ ctmp=C0C(&
+@case_with_lt@ & cmplx(V1,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V2,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V3,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt),&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt),&
+@case_with_lt@ & cmplx(real(m2,ki_lt),aimag(m2),ki_lt))
+@case_with_lt@ scalar_cache(ep,cache_index) = ctmp
+@case_with_lt@ end if
+@case_with_lt@ else
+@case_with_lt@ ctmp=C0C(&
+@case_with_lt@ & cmplx(V1,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V2,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(V3,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt),&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt),&
+@case_with_lt@ & cmplx(real(m2,ki_lt),aimag(m2),ki_lt))
+@case_with_lt@ end if
+@case_with_lt@ tot3(ep)=c30*ctmp
+@case_with_lt@ if (verbosity.ge.2) write(iout,1) &
+@case_with_lt@ &'I3(',cut3,',',ep,') = (',real(ctmp),',',aimag(ctmp),' )'
+@case_wout_lt@ print*, "isca=4: LoopTools not available"
+@case_wout_lt@ stop
+ else
+ print*, 'error in add3'
+ stop
+ endif
+ tot3(0)=tot3(0) + tot3r
+ if (present(cache_flag)) cache_offset = cache_offset + 1
+ end subroutine add3_cm
+
+ subroutine add2_cm(nleg,c2,cut2,k1,k2,msq,tot2,tot2r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+@case_with_avh@ use avh_olo, only: olo_b11
+ implicit none
+
+ integer, intent(in) :: nleg, cut2
+ complex(ki), dimension(0:9), intent(in) :: c2
+ real(ki), dimension(4), intent(in) :: k1, k2
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(-2:0), intent(out) :: tot2
+ complex(ki), intent(out) :: tot2r
+ real(ki), intent(in) :: scale2
+
+ logical, intent(in), optional :: cache_flag
+ integer, intent(inout), optional :: cache_offset
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+ integer :: i1,i2
+ real(ki) :: K11, K12
+ complex(ki) :: B06
+ complex(ki) :: m0, m1
+ integer :: ep, cache_index
+
+ complex(ki), dimension(-2:0) :: J0, J1, J00, J01, J11
+@case_with_avh@ complex(ki_avh), dimension(0:2) :: scf2, scf1, scf0, scf
+@case_with_avh@ complex(ki) :: xbb, xb0, xb00
+@case_with_avh@ real(ki) :: bkv
+@case_with_avh@ integer :: i
+
+ if (notfirsti.eqv.(.false.)) then
+ if (isca .eq. 2) then
+@case_with_avh@ call avh_olo_mu_set(real(sqrt(scale2),ki_avh))
+ elseif (isca .eq. 4) then
+@case_with_lt@ call setmudim(real(scale2, ki_lt))
+ endif
+ notfirsti=.true.
+ endif
+
+ i2=cut2/10
+ i1=cut2-i2*10
+
+ m0=msq(i1)
+ m1=msq(i2)
+
+ if (allocated(s_mat)) then
+ K11 = s_mat(i2+1, i1+1) + msq(i1) + msq(i2)
+ else
+ K11 = sdot(K1,K1)
+ end if
+ K12=sdot(K1,K2)
+
+ B06=-(K11-three*(m0+m1))/six
+
+ tot2r= + B06*c2(9)
+
+ if (present(cache_flag)) cache_index = lbound(scalar_cache,2)+cache_offset
+ if (isca.eq.1) then
+@case_with_ql@ print*, "isca=1: QCDLoop does not support complex masses."
+@case_wout_ql@ print*, "isca=1: QCDLoop not available"
+ stop
+ elseif (isca.eq.2) then
+@case_with_avh@ xbb=c2(0)
+@case_with_avh@ xb0=c2(1)
+@case_with_avh@ xb00=c2(2)
+@case_with_avh@ bkv=K12
+@case_with_avh@ if (present(cache_flag)) then
+@case_with_avh@ if (cache_flag) then
+@case_with_avh@ scf(:) = scalar_cache(:,cache_index+0)
+@case_with_avh@ scf0(:) = scalar_cache(:,cache_index+1)
+@case_with_avh@ scf1(:) = scalar_cache(:,cache_index+2)
+@case_with_avh@ scf2(:) = scalar_cache(:,cache_index+3)
+@case_with_avh@ else
+@case_with_avh@ call olo_b11(scf2,scf0,scf1,scf,&
+@case_with_avh@ & cmplx(K11,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(real(m0,ki_avh),aimag(m0),ki_avh),&
+@case_with_avh@ & cmplx(real(m1,ki_avh),aimag(m1),ki_avh))
+@case_with_avh@ scalar_cache(:,cache_index+0) = scf(:)
+@case_with_avh@ scalar_cache(:,cache_index+1) = scf0(:)
+@case_with_avh@ scalar_cache(:,cache_index+2) = scf1(:)
+@case_with_avh@ scalar_cache(:,cache_index+3) = scf2(:)
+@case_with_avh@ end if
+@case_with_avh@ else
+@case_with_avh@ call olo_b11(scf2,scf0,scf1,scf,&
+@case_with_avh@ & cmplx(K11,0.0_ki_avh,ki_avh), &
+@case_with_avh@ & cmplx(real(m0,ki_avh),aimag(m0),ki_avh),&
+@case_with_avh@ & cmplx(real(m1,ki_avh),aimag(m1),ki_avh))
+@case_with_avh@ end if
+@case_with_avh@ tot2(0)=xbb*scf(0)+xb0*bkv*scf1(0)+xb00*bkv*bkv*scf2(0)
+@case_with_avh@ tot2(0)=tot2(0)+ B06*c2(9)
+@case_with_avh@ tot2(-1)=xbb*scf(1)+xb0*bkv*scf1(1)+xb00*bkv*bkv*scf2(1)
+@case_with_avh@ tot2(-2)=xbb*scf(2)+xb0*bkv*scf1(2)+xb00*bkv*bkv*scf2(2)
+@case_with_avh@ if (verbosity.ge.2) then
+@case_with_avh@ do i=0,2
+@case_with_avh@ write(iout,903) 'B_0 (',cut2,',',-i,') = ',scf(i)
+@case_with_avh@ write(iout,903) 'B_1 (',cut2,',',-i,') =',scf1(i)
+@case_with_avh@ write(iout,903) 'B_11(',cut2,',',-i,') =',scf2(i)
+@case_with_avh@ enddo
+@case_with_avh@ endif
+@case_wout_avh@ print*, "isca=2: OneLOop not available"
+@case_wout_avh@ stop
+ elseif (isca.eq.3) then
+@case_with_golem@ if (present(cache_flag)) then
+@case_with_golem@ if (cache_flag) then
+@case_with_golem@ J0(:) = scalar_cache(:,cache_index+0)
+@case_with_golem@ J1(:) = scalar_cache(:,cache_index+1)
+@case_with_golem@ J01(:) = scalar_cache(:,cache_index+2)
+@case_with_golem@ J11(:) = scalar_cache(:,cache_index+3)
+@case_with_golem@ J00(:) = scalar_cache(:,cache_index+4)
+@case_with_golem@ else
+@case_with_golem@ call gtrunc_rm(abs(K11)+1.0_ki, K11)
+@case_with_golem@ call gtrunc_cm(abs(K11)+1.0_ki, m0,m1)
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ J00(ep)= gB0C(&
+@case_with_golem@ & cmplx(K11,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J11(ep)= gB0C(&
+@case_with_golem@ & cmplx(K11,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J01(ep)= gB0C(&
+@case_with_golem@ & cmplx(K11,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J0(ep) = gA0C(&
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J1(ep) = gA0C(&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ end do
+@case_with_golem@ scalar_cache(:,cache_index+0) = J0(:)
+@case_with_golem@ scalar_cache(:,cache_index+1) = J1(:)
+@case_with_golem@ scalar_cache(:,cache_index+2) = J01(:)
+@case_with_golem@ scalar_cache(:,cache_index+3) = J11(:)
+@case_with_golem@ scalar_cache(:,cache_index+4) = J00(:)
+@case_with_golem@ end if
+@case_with_golem@ else
+@case_with_golem@ call gtrunc_rm(abs(K11)+1.0_ki, K11)
+@case_with_golem@ call gtrunc_cm(abs(K11)+1.0_ki, m0,m1)
+@case_with_golem@ do ep=-2,0
+@case_with_golem@ J00(ep)= gB0C(&
+@case_with_golem@ & cmplx(K11,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J11(ep)= gB0C(&
+@case_with_golem@ & cmplx(K11,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J01(ep)= gB0C(&
+@case_with_golem@ & cmplx(K11,0.0_ki_gol,ki_gol), &
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J0(ep) = gA0C(&
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ J1(ep) = gA0C(&
+@case_with_golem@ & cmplx(real(m1,ki_gol),aimag(m1),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ end do
+@case_with_golem@ end if
+@case_wout_golem@ print*, "isca=3: Golem95 not available"
+@case_wout_golem@ stop
+ elseif (isca.eq.4) then
+@case_with_lt@ J00(:) = 0.0_ki_lt
+@case_with_lt@ J11(:) = 0.0_ki_lt
+@case_with_lt@ J0(:) = 0.0_ki_lt
+@case_with_lt@ J1(:) = 0.0_ki_lt
+@case_with_lt@ ep = -dim(0, int(getlambda()))
+@case_with_lt@ if (present(cache_flag)) then
+@case_with_lt@ if (cache_flag) then
+@case_with_lt@ J0(:) = scalar_cache(:,cache_index+0)
+@case_with_lt@ J1(:) = scalar_cache(:,cache_index+1)
+@case_with_lt@ J01(:) = scalar_cache(:,cache_index+2)
+@case_with_lt@ J11(:) = scalar_cache(:,cache_index+3)
+@case_with_lt@ J00(:) = scalar_cache(:,cache_index+4)
+@case_with_lt@ else
+@case_with_lt@ call gtrunc_rm(abs(K11)+1.0_ki, K11)
+@case_with_lt@ call gtrunc_cm(abs(K11)+1.0_ki, m0,m1)
+@case_with_lt@ J00(ep) = B0C(&
+@case_with_lt@ & cmplx(K11,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt),&
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt))
+@case_with_lt@ J11(ep) = B0C(&
+@case_with_lt@ & cmplx(K11,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt),&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt))
+@case_with_lt@ J01(ep) = B0C(&
+@case_with_lt@ & cmplx(K11,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt),&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt))
+@case_with_lt@ J0(ep) = A0C(&
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt))
+@case_with_lt@ J1(ep) = A0C(&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt))
+@case_with_lt@ scalar_cache(:,cache_index+0) = J0(:)
+@case_with_lt@ scalar_cache(:,cache_index+1) = J1(:)
+@case_with_lt@ scalar_cache(:,cache_index+2) = J01(:)
+@case_with_lt@ scalar_cache(:,cache_index+3) = J11(:)
+@case_with_lt@ scalar_cache(:,cache_index+4) = J00(:)
+@case_with_lt@ end if
+@case_with_lt@ else
+@case_with_lt@ call gtrunc_rm(abs(K11)+1.0_ki, K11)
+@case_with_lt@ call gtrunc_cm(abs(K11)+1.0_ki, m0,m1)
+@case_with_lt@ J00(ep) = B0C(&
+@case_with_lt@ & cmplx(K11,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt),&
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt))
+@case_with_lt@ J11(ep) = B0C(&
+@case_with_lt@ & cmplx(K11,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt),&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt))
+@case_with_lt@ J01(ep) = B0C(&
+@case_with_lt@ & cmplx(K11,0.0_ki_lt,ki_lt), &
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt),&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt))
+@case_with_lt@ J0(ep) = A0C(&
+@case_with_lt@ & cmplx(real(m0,ki_lt),aimag(m0),ki_lt))
+@case_with_lt@ J1(ep) = A0C(&
+@case_with_lt@ & cmplx(real(m1,ki_lt),aimag(m1),ki_lt))
+@case_with_lt@ end if
+@case_wout_lt@ print*, "isca=4: LoopTools not available"
+@case_wout_lt@ stop
+ else
+ print*, 'error in add2'
+ stop
+ endif
+
+ if (isca.eq.1 .or. isca.eq.3 .or. isca.eq.4) then
+ if (abs(K11).gt.zip1) then
+ do ep=-2,0
+ tot2(ep)=-(K12*(two*K12*(m0 - m1)*c2(2) + &
+ & K11*(-three*c2(1) + two*K12*c2(2)))*J0(ep))/(six*K11**2) &
+ & + ((two*K12**2*(m0 - m1)**2*c2(2) + &
+ & K11*K12*(-three*m0*c2(1) + three*m1*c2(1) + &
+ & two*K12*m0*c2(2) - four*K12*m1*c2(2)) + &
+ & K11**2*(6*c2(0) + K12*(-three*c2(1) + two*K12*c2(2))))* &
+ & J01(ep))/(six*K11**2) + &
+ & (K12*(two*K12*(m0 - m1)*c2(2) + &
+ & K11*(-three*c2(1) + four*K12*c2(2)))*J1(ep))/(six*K11**2)
+ enddo
+ tot2(0)=tot2(0)+(K12**2*c2(2))/18.0_ki &
+ & - (K12**2*m0*c2(2))/(six*K11) - &
+ & (K12**2*m1*c2(2))/(six*K11) + B06*c2(9)
+ else
+ if (m1.eq.m0) then
+ do ep=-2,0
+ tot2(ep)=(c2(0) + (K12*(-three*c2(1) &
+ & + two*K12*c2(2)))/six)*J00(ep)
+ enddo
+ tot2(0)=tot2(0)+B06*c2(9)
+ else
+ do ep=-2,0
+ tot2(ep)=(K12*m0**2*(-three*m0*c2(1) + three*m1*c2(1) &
+ & + two*K12*m0*c2(2))* &
+ & J00(ep))/(six*(m0 - m1)**3) + c2(0)*J01(ep) - &
+ & (K12*m1*(m0*m1*(9*c2(1) - 6*K12*c2(2)) - &
+ & 6*m0**2*(c2(1) - K12*c2(2)) + &
+ & m1**2*(-three*c2(1) + two*K12*c2(2)))*J11(ep))/ &
+ & (six*(m0 - m1)**3)
+ enddo
+ tot2(0)=tot2(0) + (-three*K12*m0*c2(1))/(four*(m0 - m1)) + &
+ & (K12*m1*c2(1))/(four*m0 - four*m1) + &
+ & (11.0_ki*K12**2*m0**2*c2(2))/(18.0_ki*(m0 - m1)**2) - &
+ & (7.0_ki*K12**2*m0*m1*c2(2))/(18.0_ki*(m0 - m1)**2) + &
+ & (K12**2*m1**2*c2(2))/(9.0_ki*(m0 - m1)**2) + B06*c2(9)
+ endif
+ endif
+ if (verbosity.ge.2) then
+ do ep=0,2
+ write(iout,903) 'B0 (',cut2,',',-ep,') = ',J0(-ep)
+ write(iout,903) 'B1 (',cut2,',',-ep,') =',J1(-ep)
+ write(iout,903) 'B00(',cut2,',',-ep,') =',J00(-ep)
+ write(iout,903) 'B11(',cut2,',',-ep,') =',J11(-ep)
+ end do
+ endif
+ end if
+ if (present(cache_flag)) cache_offset = cache_offset + 5
+
+ 903 format(a5,I2,a1,I2,a4,2(D24.15))
+ end subroutine add2_cm
+
+ subroutine add1_cm(nleg,c1,cut1,msq,tot1,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+@case_with_avh@ use avh_olo, only: olo_a0
+ implicit none
+ integer, intent(in) :: nleg, cut1
+ complex(ki), dimension(0:4), intent(in) :: c1
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(-2:0), intent(out) :: tot1
+ real(ki), intent(in) :: scale2
+
+ logical, intent(in), optional :: cache_flag
+ integer, intent(inout), optional :: cache_offset
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+
+ integer ::j1
+ complex(ki) :: m0
+@case_with_avh@ complex(ki_avh), dimension(0:2) :: vala0
+ complex(ki) :: ctmp
+ integer :: ep, cache_index
+
+ if (notfirsti.eqv.(.false.)) then
+ if (isca .eq. 2) then
+@case_with_avh@ call avh_olo_mu_set(real(sqrt(scale2),ki_avh))
+ elseif (isca .eq. 4) then
+@case_with_lt@ call setmudim(real(scale2, ki_lt))
+ endif
+ notfirsti=.true.
+ endif
+
+ j1=cut1
+
+ m0=msq(j1)
+
+ 1 Format(A3,I2,A1,I2,A5,D24.15,A1,D24.15,A3)
+
+ if (present(cache_flag)) cache_index = lbound(scalar_cache,2)+cache_offset
+ if (isca.eq.1) then
+@case_with_ql@ print*, "isca=1: QCDLoop does not support complex masses."
+@case_wout_ql@ print*, "isca=1: QCDLoop not available"
+ stop
+ elseif (isca.eq.2) then
+@case_with_avh@ if (present(cache_flag)) then
+@case_with_avh@ if (cache_flag) then
+@case_with_avh@ vala0(0) = scalar_cache( 0,cache_index)
+@case_with_avh@ vala0(1) = scalar_cache(-1,cache_index)
+@case_with_avh@ vala0(2) = scalar_cache(-2,cache_index)
+@case_with_avh@ else
+@case_with_avh@ call olo_a0(vala0,&
+@case_with_avh@ & cmplx(real(m0,ki_avh),aimag(m0),ki_avh))
+@case_with_avh@ scalar_cache( 0,cache_index) = vala0(0)
+@case_with_avh@ scalar_cache(-1,cache_index) = vala0(1)
+@case_with_avh@ scalar_cache(-2,cache_index) = vala0(2)
+@case_with_avh@ end if
+@case_with_avh@ else
+@case_with_avh@ call olo_a0(vala0,&
+@case_with_avh@ & cmplx(real(m0,ki_avh),aimag(m0),ki_avh))
+@case_with_avh@ end if
+@case_with_avh@ do ep=-2,0
+@case_with_avh@ tot1(ep)= c1(0)*vala0(-ep)
+@case_with_avh@ if (verbosity.ge.2) write(iout,1) &
+@case_with_avh@ & 'I1(',cut1,',',ep,') = (',real(vala0(-ep)),',',&
+@case_with_avh@ & aimag(vala0(-ep)),' )'
+@case_with_avh@ enddo
+@case_wout_avh@ print*, "isca=2: OneLOop not available"
+@case_wout_avh@ stop
+ elseif (isca.eq.3) then
+@case_with_golem@ tot1(-2) = (0.0_ki,0.0_ki)
+@case_with_golem@ if (verbosity.ge.2) write(iout,1) &
+@case_with_golem@ & 'I1(',cut1,',',-2,') = (',0.0_ki,',',0.0_ki,' )'
+@case_with_golem@ if (present(cache_flag)) then
+@case_with_golem@ if (cache_flag) then
+@case_with_golem@ do ep=-1,0
+@case_with_golem@ ctmp = scalar_cache(ep,cache_index)
+@case_with_golem@ tot1(ep) = c1(0)*ctmp
+@case_with_golem@ if (verbosity.ge.2) write(iout,1) &
+@case_with_golem@ & 'I1(',cut1,',',ep,') = (',&
+@case_with_golem@ & real(ctmp),',',aimag(ctmp),' )'
+@case_with_golem@ enddo
+@case_with_golem@ else
+@case_with_golem@ scalar_cache(-2,cache_index) = czip
+@case_with_golem@ call gtrunc_cm(1.0_ki, m0)
+@case_with_golem@ do ep=-1,0
+@case_with_golem@ ctmp = gA0C(&
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ scalar_cache(ep,cache_index) = ctmp
+@case_with_golem@ tot1(ep) = c1(0)*ctmp
+@case_with_golem@ if (verbosity.ge.2) write(iout,1) &
+@case_with_golem@ & 'I1(',cut1,',',ep,') = (',&
+@case_with_golem@ & real(ctmp),',',aimag(ctmp),' )'
+@case_with_golem@ enddo
+@case_with_golem@ end if
+@case_with_golem@ else
+@case_with_golem@ call gtrunc_cm(1.0_ki, m0)
+@case_with_golem@ do ep=-1,0
+@case_with_golem@ ctmp = gA0C(&
+@case_with_golem@ & cmplx(real(m0,ki_gol),aimag(m0),ki_gol),&
+@case_with_golem@ & real(scale2,ki_gol),ep)
+@case_with_golem@ tot1(ep) = c1(0)*ctmp
+@case_with_golem@ if (verbosity.ge.2) write(iout,1) &
+@case_with_golem@ & 'I1(',cut1,',',ep,') = (',&
+@case_with_golem@ & real(ctmp),',',aimag(ctmp),' )'
+@case_with_golem@ enddo
+@case_with_golem@ end if
+@case_wout_golem@ print*, "isca=3: Golem95 not available"
+@case_wout_golem@ stop
+ elseif (isca.eq.4) then
+@case_with_lt@ tot1(-2) = 0
+@case_with_lt@ tot1(-1) = 0
+@case_with_lt@ tot1(0) = 0
+@case_with_lt@ ep = -dim(0, int(getlambda()))
+@case_with_lt@ if (present(cache_flag)) then
+@case_with_lt@ if (cache_flag) then
+@case_with_lt@ ctmp = scalar_cache(ep,cache_index)
+@case_with_lt@ else
+@case_with_lt@ ctmp = A0C(cmplx(real(m0,ki_lt),aimag(m0),ki_lt))
+@case_with_lt@ scalar_cache(ep,cache_index) = ctmp
+@case_with_lt@ end if
+@case_with_lt@ else
+@case_with_lt@ ctmp = A0C(cmplx(real(m0,ki_lt),aimag(m0),ki_lt))
+@case_with_lt@ end if
+@case_with_lt@ tot1(ep)=c1(0)*ctmp
+@case_with_lt@ if (verbosity.ge.2) write(iout,1) &
+@case_with_lt@ & 'I1(',cut1,',',ep,') = (',real(ctmp),',',aimag(ctmp),' )'
+@case_wout_lt@ print*, "isca=4: LoopTools not available"
+@case_wout_lt@ stop
+ else
+ print*, 'error in add1'
+ stop
+ endif
+ if (present(cache_flag)) cache_offset = cache_offset + 1
+ end subroutine add1_cm
+
+@case_with_golem@function gA0(m0,mu2,ep)
+@case_with_golem@ implicit none
+@case_with_golem@ real(ki_gol), intent(in) :: m0, mu2
+@case_with_golem@ integer, intent(in) :: ep
+@case_with_golem@ complex(ki_gol) :: gA0
+@case_with_golem@ if(ep.eq.(-2) .or. m0.eq.0.0_ki_gol) then
+@case_with_golem@ gA0 = (0.0_ki_gol, 0.0_ki_gol)
+@case_with_golem@ elseif(ep.eq.(-1)) then
+@case_with_golem@ gA0 = m0 * gB0(0.0_ki_gol,m0,m0,mu2,-1)
+@case_with_golem@ else
+@case_with_golem@ gA0 = m0 * (gB0(0.0_ki_gol,m0,m0,mu2,0) &
+@case_with_golem@ & + gB0(0.0_ki_gol,m0,m0,mu2,-1))
+@case_with_golem@ end if
+@case_with_golem@end function gA0
+@case_with_golem@function gA0C(m0,mu2,ep)
+@case_with_golem@ implicit none
+@case_with_golem@ complex(ki_gol), intent(in) :: m0
+@case_with_golem@ real(ki_gol), intent(in) :: mu2
+@case_with_golem@ integer, intent(in) :: ep
+@case_with_golem@ complex(ki_gol) :: gA0C
+@case_with_golem@ if(ep.eq.(-2) .or. m0.eq.(0.0_ki_gol,0.0_ki_gol)) then
+@case_with_golem@ gA0C = (0.0_ki_gol, 0.0_ki_gol)
+@case_with_golem@ elseif(ep.eq.(-1)) then
+@case_with_golem@ gA0C = m0 * gB0C((0.0_ki_gol,0.0_ki_gol),m0,m0,mu2,-1)
+@case_with_golem@ else
+@case_with_golem@ gA0C = m0 * (gB0C((0.0_ki_gol,0.0_ki_gol),m0,m0,mu2,0) &
+@case_with_golem@ & + gB0C((0.0_ki_gol,0.0_ki_gol),m0,m0,mu2,-1))
+@case_with_golem@ end if
+@case_with_golem@end function gA0C
+
+@case_with_golem@pure subroutine gtrunc_rm(ref,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10)
+@case_with_golem@ implicit none
+@case_with_golem@ real(ki), intent(in) :: ref
+@case_with_golem@ real(ki), intent(inout), optional :: s1,s2,s3,s4,s5,s6,s7,s8,s9,s10
+@case_with_golem@ real(ki), parameter :: small = 1.0E-08_ki
+@case_with_golem@ if(present(s1)) then
+@case_with_golem@ if(abs(s1/ref) .lt. small) s1 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@ if(present(s2)) then
+@case_with_golem@ if(abs(s2/ref) .lt. small) s2 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@ if(present(s3)) then
+@case_with_golem@ if(abs(s3/ref) .lt. small) s3 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@ if(present(s4)) then
+@case_with_golem@ if(abs(s4/ref) .lt. small) s4 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@ if(present(s5)) then
+@case_with_golem@ if(abs(s5/ref) .lt. small) s5 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@ if(present(s6)) then
+@case_with_golem@ if(abs(s6/ref) .lt. small) s6 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@ if(present(s7)) then
+@case_with_golem@ if(abs(s7/ref) .lt. small) s7 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@ if(present(s8)) then
+@case_with_golem@ if(abs(s8/ref) .lt. small) s8 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@ if(present(s9)) then
+@case_with_golem@ if(abs(s9/ref) .lt. small) s9 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@ if(present(s10)) then
+@case_with_golem@ if(abs(s10/ref) .lt. small) s10 = 0.0_ki
+@case_with_golem@ end if
+@case_with_golem@end subroutine gtrunc_rm
+@case_with_golem@pure subroutine gtrunc_cm(ref,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10)
+@case_with_golem@ implicit none
+@case_with_golem@ real(ki), intent(in) :: ref
+@case_with_golem@ complex(ki), intent(inout), optional :: s1,s2,s3,s4,s5,s6,s7,s8,s9,s10
+@case_with_golem@ real(ki), parameter :: small = 1.0E-08_ki
+@case_with_golem@ if(present(s1)) then
+@case_with_golem@ if(abs(s1/ref) .lt. small) s1 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@ if(present(s2)) then
+@case_with_golem@ if(abs(s2/ref) .lt. small) s2 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@ if(present(s3)) then
+@case_with_golem@ if(abs(s3/ref) .lt. small) s3 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@ if(present(s4)) then
+@case_with_golem@ if(abs(s4/ref) .lt. small) s4 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@ if(present(s5)) then
+@case_with_golem@ if(abs(s5/ref) .lt. small) s5 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@ if(present(s6)) then
+@case_with_golem@ if(abs(s6/ref) .lt. small) s6 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@ if(present(s7)) then
+@case_with_golem@ if(abs(s7/ref) .lt. small) s7 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@ if(present(s8)) then
+@case_with_golem@ if(abs(s8/ref) .lt. small) s8 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@ if(present(s9)) then
+@case_with_golem@ if(abs(s9/ref) .lt. small) s9 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@ if(present(s10)) then
+@case_with_golem@ if(abs(s10/ref) .lt. small) s10 = (0.0_ki, 0.0_ki)
+@case_with_golem@ end if
+@case_with_golem@end subroutine gtrunc_cm
+
+end module madds
+
diff --git a/samurai-2.1.1/mcgs.f90 b/samurai-2.1.1/mcgs.f90
new file mode 100644
index 0000000..90fd591
--- /dev/null
+++ b/samurai-2.1.1/mcgs.f90
@@ -0,0 +1,9 @@
+module mcgs
+use precision
+implicit none
+ private
+
+ complex(ki), dimension(0:209), public :: cg
+ complex(ki), dimension(1:10), public :: cgx
+
+endmodule mcgs
diff --git a/samurai-2.1.1/mfunctions.f90 b/samurai-2.1.1/mfunctions.f90
new file mode 100644
index 0000000..9ef2b78
--- /dev/null
+++ b/samurai-2.1.1/mfunctions.f90
@@ -0,0 +1,209 @@
+module mfunctions
+ use precision
+ use constants
+ implicit none
+
+ private
+
+ interface sdot
+ module procedure sdot_rr
+ module procedure sdot_rc
+ module procedure sdot_cr
+ module procedure sdot_cc
+ end interface sdot
+
+ interface denevalmu2
+ module procedure denevalmu2_rr
+ module procedure denevalmu2_cr
+ module procedure denevalmu2_rm
+ module procedure denevalmu2_cm
+ end interface denevalmu2
+
+ public :: sdot, denevalmu2, effe, poly1, poly2, poly3, poly4
+contains
+
+ pure function sdot_rr(p, q)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p, q
+ real(ki) :: sdot_rr
+ sdot_rr = p(4)*q(4) - p(1)*q(1) - p(2)*q(2) - p(3)*q(3)
+ end function sdot_rr
+
+ pure function sdot_cc(p, q)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p, q
+ complex(ki) :: sdot_cc
+ sdot_cc = p(4)*q(4) - p(1)*q(1) - p(2)*q(2) - p(3)*q(3)
+ end function sdot_cc
+
+ pure function sdot_rc(p, q)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p
+ complex(ki), dimension(4), intent(in) :: q
+ complex(ki) :: sdot_rc
+ sdot_rc = p(4)*q(4) - p(1)*q(1) - p(2)*q(2) - p(3)*q(3)
+ end function sdot_rc
+
+ pure function sdot_cr(p, q)
+ implicit none
+ complex(ki), dimension(4), intent(in) :: p
+ real(ki), dimension(4), intent(in) :: q
+ complex(ki) :: sdot_cr
+ sdot_cr = p(4)*q(4) - p(1)*q(1) - p(2)*q(2) - p(3)*q(3)
+ end function sdot_cr
+
+ pure function denevalmu2_cm(nleg,j,q,Vi,msq,mu2)
+ implicit none
+ integer, intent(in) :: nleg, j
+ integer :: i
+ complex(ki), intent(in) :: q(4)
+ complex(ki) :: L(4), denevalmu2_cm
+ complex(ki), intent(in) :: mu2
+ complex(ki), intent(in) :: msq(0:nleg-1)
+ real(ki), intent(in) :: Vi(0:nleg-1,4)
+ do i=1,4
+ L(i)=q(i)+Vi(j,i)*cone
+ enddo
+ denevalmu2_cm=sdot(L,L)-msq(j)-mu2
+ end function denevalmu2_cm
+
+ pure function denevalmu2_rm(nleg,j,q,Vi,msq,mu2)
+ implicit none
+ integer, intent(in) :: nleg, j
+ integer :: i
+ complex(ki), intent(in) :: q(4)
+ complex(ki) :: L(4), denevalmu2_rm
+ complex(ki), intent(in) :: mu2
+ real(ki), intent(in) :: msq(0:nleg-1)
+ real(ki), intent(in) :: Vi(0:nleg-1,4)
+ do i=1,4
+ L(i)=q(i)+Vi(j,i)*cone
+ enddo
+ denevalmu2_rm=sdot(L,L)-msq(j)-mu2*cone
+ end function denevalmu2_rm
+
+ pure function denevalmu2_cr(nleg,j,q,Vi,msq,mu2)
+ implicit none
+ integer, intent(in) :: nleg, j
+ integer :: i
+ complex(ki), intent(in) :: q(4)
+ complex(ki) :: L(4), denevalmu2_cr
+ real(ki), intent(in) :: mu2
+ complex(ki), intent(in) :: msq(0:nleg-1)
+ real(ki), intent(in) :: Vi(0:nleg-1,4)
+ do i=1,4
+ L(i)=q(i)+Vi(j,i)*cone
+ enddo
+ denevalmu2_cr=sdot(L,L)-msq(j)-mu2
+ end function denevalmu2_cr
+
+ pure function denevalmu2_rr(nleg,j,q,Vi,msq,mu2)
+ implicit none
+ integer, intent(in) :: nleg, j
+ integer :: i
+ complex(ki), intent(in) :: q(4)
+ complex(ki) :: L(4), denevalmu2_rr
+ real(ki), intent(in) :: mu2
+ real(ki), intent(in) :: msq(0:nleg-1)
+ real(ki), intent(in) :: Vi(0:nleg-1,4)
+ do i=1,4
+ L(i)=q(i)+Vi(j,i)*cone
+ enddo
+ denevalmu2_rr=sdot(L,L)-msq(j)-mu2*cone
+ end function denevalmu2_rr
+
+ pure function effe(known,nk,ns,m)
+ implicit none
+ complex(ki),intent(in) :: known(10)
+ complex(ki) :: temp, effe
+ real(ki) :: teta
+ integer, intent(in) :: nk,ns,m
+ integer :: k
+ teta=twopi/ns
+ temp=czip
+ do k=0,ns-1
+ temp=temp+known(k+nk)*&
+ & (cos(teta*real(m*k, ki))+im*sin(teta*real(m*k, ki)))
+ enddo
+ effe=temp/ns
+ end function effe
+
+
+ pure function poly4(c4,pm,mu2,L3,e3,e4)
+ implicit none
+ complex(ki), dimension(0:4), intent(in) :: c4
+ complex(ki), dimension(4), intent(in) :: pm, e3, e4
+ real(ki), dimension(4), intent(in) :: L3
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: poly4
+
+ poly4=c4(0) &
+ & +mu2*(c4(2)+c4(4)*mu2) &
+ & +(c4(1)+c4(3)*mu2) &
+ & *(+sdot(pm,e3)*sdot(L3,e4) &
+ & -sdot(pm,e4)*sdot(L3,e3))
+ end function poly4
+
+ pure function poly3(c3,pm,mu2,e3,e4)
+ implicit none
+ complex(ki), dimension(0:9), intent(in) :: c3
+ complex(ki), dimension(4), intent(in) :: pm, e3, e4
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: poly3
+
+ complex(ki) :: pme3, pme4
+
+ pme3=sdot(pm,e3)
+ pme4=sdot(pm,e4)
+
+ poly3=+c3(0) &
+ & +pme3*(c3(1)+pme3*(c3(2)+c3(3)*pme3)) &
+ & +pme4*(c3(4)+pme4*(c3(5)+c3(6)*pme4)) &
+ & +mu2*(c3(7)+c3(8)*pme3+c3(9)*pme4)
+ end function poly3
+
+ pure function poly2(c2,pm,mu2,e2,e3,e4)
+ implicit none
+ complex(ki), dimension(0:9), intent(in) :: c2
+ real(ki), dimension(4), intent(in) :: e2
+ complex(ki), dimension(4), intent(in) :: e3,e4,pm
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: poly2
+
+ complex(ki) :: pme2, pme3, pme4
+
+ pme2=sdot(e2,pm)
+ pme3=sdot(pm,e3)
+ pme4=sdot(pm,e4)
+
+ poly2=+c2(0) &
+ & +pme2*(c2(1)+c2(2)*pme2+c2(7)*pme3+c2(8)*pme4) &
+ & +pme3*(c2(3)+c2(4)*pme3) &
+ & +pme4*(c2(5)+c2(6)*pme4) &
+ & +c2(9)*mu2
+ end function poly2
+
+
+ pure function poly1(c1,pm,e1,e2,e3,e4)
+ implicit none
+ complex(ki), dimension(0:4), intent(in) :: c1
+ real(ki), dimension(4), intent(in) :: e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4, pm
+ complex(ki) :: poly1
+
+ complex(ki) :: pme1,pme2,pme3,pme4
+
+ pme1=sdot(e1,pm)
+ pme2=sdot(e2,pm)
+ pme3=sdot(pm,e3)
+ pme4=sdot(pm,e4)
+
+ poly1=+c1(0) &
+ & +c1(1)*pme1 &
+ & +c1(2)*pme2 &
+ & +c1(3)*pme3 &
+ & +c1(4)*pme4
+ end function poly1
+
+end module mfunctions
+
diff --git a/samurai-2.1.1/mgetbase.f90 b/samurai-2.1.1/mgetbase.f90
new file mode 100644
index 0000000..6f7ceb0
--- /dev/null
+++ b/samurai-2.1.1/mgetbase.f90
@@ -0,0 +1,49 @@
+module mgetbase
+ use precision
+ use constants
+ use mfunctions, only: sdot
+ use kinematic, only: epsi
+ implicit none
+
+ private
+
+ public :: getbase
+
+contains
+
+ subroutine getbase(p1,p2,r1,r2,e1,e2,e3,e4)
+ implicit none
+
+ real(ki), dimension(4), intent(in) :: p1, p2
+ real(ki), dimension(4), intent(out) :: e1, e2
+
+ real(ki) :: gamma, MP12, MP11, MP22, den
+ real(ki), intent(out) :: r1, r2
+ complex(ki), intent(out) :: e3(4), e4(4)
+
+ MP11=sdot(p1,p1)
+ MP12=sdot(p1,p2)
+ MP22=sdot(p2,p2)
+
+ gamma=MP12+sign(+1.0_ki,MP12)*sqrt(MP12**2-MP11*MP22)
+
+!--- Warning: if p1 ~ p2 and massless this formula brakes down
+ if ( abs(gamma) .lt. zip1 ) then
+ write(6,*) 'getbase: small gamma'
+ write(6,*) 'gamma=', gamma
+ write(6,*) ' MP11=', MP11
+ write(6,*) ' MP12=', MP12
+ write(6,*) ' MP22=', MP22
+ endif
+
+ r1=MP11/gamma
+ r2=MP22/gamma
+ den=1.0_ki-r1*r2
+
+ e1(:)=(p1(:)-r1*p2(:))/den
+ e2(:)=(p2(:)-r2*p1(:))/den
+ e3 = sqrt(abs(sdot(e1,e2))) * epsi(+1, e1, e2)
+ e4 = conjg(e3)*sign(1.0_ki,e1(4)*e2(4))
+ end subroutine getbase
+end module mgetbase
+
diff --git a/samurai-2.1.1/mgetc1.f90 b/samurai-2.1.1/mgetc1.f90
new file mode 100644
index 0000000..6eb9813
--- /dev/null
+++ b/samurai-2.1.1/mgetc1.f90
@@ -0,0 +1,983 @@
+module mgetc1
+ use precision, only: ki
+ use constants
+ use options
+ use mfunctions
+ use mrestore
+ implicit none
+
+ private
+
+ interface getc1
+ module procedure getc1_rm
+ module procedure getc1_cm
+ end interface getc1
+
+ public :: getc1
+
+contains
+
+ subroutine getc1_cm(numeval,nleg,rank,c1,cut1,q1,qt,Vi,msq)
+ use mglobal, only: G0c, mu2g, MP12, mu2t, resit, denst, mu2test
+ implicit none
+ integer, intent(in) :: nleg, rank, cut1
+ complex(ki), dimension(0:4), intent(out) :: c1
+ complex(ki), dimension(5,4), intent(in) :: q1
+ complex(ki), dimension(4), intent(in) :: qt
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+
+ integer :: i,m,n,j1,i1,i2,i3,i4,i5
+ integer :: dicut5,dicut4,dicut3,dicut2,diff
+ complex(ki), dimension(5) :: dens1,dens2,dens3,dens4,dens5,xneval
+ complex(ki), dimension(0:4) :: f1
+ complex(ki), dimension(5) :: resi5, resi4, resi3, resi2, known
+ complex(ki) :: dens2t,dens3t,dens4t,dens5t
+ logical evalres
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ mu2test(1)=mu2t(1)
+
+ j1=cut1
+
+ resi2(:)=czip
+ resi3(:)=czip
+ resi4(:)=czip
+ resi5(:)=czip
+ known(:)=czip
+ xneval(:)=czip
+ dens1(:)=cone
+
+ !--- for lnntest
+ resit(1)=czip
+ denst(1)=cone
+
+ !--- for simplified sampling
+ diff = nleg-rank
+
+ if (diff.eq.1) then
+ c1(1)=czip
+ c1(2)=czip
+ c1(3)=czip
+ c1(4)=czip
+
+ if (nleg.eq.5) then
+ resi5(1)=res5(1,mu2g(1))
+ resit(1)=res5(1,mu2t(1))
+ goto 11
+ elseif (nleg.eq.4) then
+ resi4(1)=Res4(1,q1(1,:),mu2g(1))
+ resit(1)=Res4(1,qt,mu2t(1))
+ goto 21
+ elseif (nleg.eq.3) then
+ resi3(1)=Res3(1,q1(1,:),mu2g(1))
+ resit(1)=Res3(1,qt,mu2t(1))
+ goto 31
+ elseif (nleg.eq.2) then
+ resi2(1)=Res2(1,q1(1,:),mu2g(1))
+ resit(1)=Res2(1,qt,mu2t(1))
+ goto 41
+ else
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(1)=cone
+ dens5t=cone
+ evalres=.false.
+
+ loop_10: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)&
+ &.and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i).eq.(j1)) then
+ dens5(1)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_10
+ else
+ dens5(1)=dens5(1)*denevalmu2(nleg,i,&
+ &q1(1,:),Vi,msq,mu2g(1))
+ dens5t=dens5t*denevalmu2(nleg,i,qt,Vi,msq,&
+ &mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_10
+
+ if (evalres) then
+ resi5(1)=resi5(1)+dens5(1)*res5(dicut5,mu2g(1))
+ resit(1)=resit(1)+dens5(1)*res5(dicut5,mu2t(1))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ endif
+
+ 11 continue
+
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4(1)=cone
+ dens4t=cone
+ evalres=.false.
+
+ loop_20: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)) then
+ if (i.eq.j1) then
+ dens4(1)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_20
+ else
+ dens4(1)=dens4(1)*denevalmu2(nleg,i,q1(1,:),&
+ &Vi,msq,mu2g(1))
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,&
+ &mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_20
+
+ if (evalres) then
+ resi4(1)=resi4(1)+dens4(1)*Res4(dicut4,q1(1,:),mu2g(1))
+ resit(1)=resit(1)+dens4t*Res4(dicut4,qt,mu2t(1))
+ endif
+
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+ 21 continue
+
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens3(1)=cone
+ dens3t=cone
+ evalres=.false.
+
+ loop_30: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ if (i.eq.j1) then
+ dens3(1)=czip
+ dens3t=czip
+ evalres=.false.
+ exit loop_30
+ else
+ dens3(1)=dens3(1)*denevalmu2(nleg,i,q1(1,:),&
+ &Vi,msq,mu2g(1))
+ dens3t=dens3t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_30
+
+ if (evalres) then
+ resi3(1)=resi3(1)+dens3(1)*Res3(dicut3,q1(1,:),mu2g(1))
+ resit(1)=resit(1)+dens3t*Res3(dicut3,qt,mu2t(1))
+ endif
+
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei Triple cuts:
+
+ 31 continue
+
+ !---#[ Contributo dei Double cuts:
+ dicut2=1
+ do i2=1,nleg-1
+ do i1=0,i2-1
+ dens2(1)=cone
+ dens2t=cone
+ evalres=.false.
+
+ loop_40: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2)) then
+ if (i.eq.j1) then
+ dens2(1)=czip
+ dens2t=czip
+ evalres=.false.
+ exit loop_40
+ else
+ dens2(1)=dens2(1)*denevalmu2(nleg,i,q1(1,:),&
+ &Vi,msq,mu2g(1))
+ dens2t=dens2t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_40
+
+ if (evalres) then
+ resi2(1)=resi2(1)+dens2(1)*Res2(dicut2,q1(1,:),mu2g(1))
+ resit(1)=resit(1)+dens2t*Res2(dicut2,qt,mu2t(1))
+ endif
+
+ dicut2=dicut2+1
+ enddo
+ enddo
+ !---#] Contributo dei Double cuts:
+
+ 41 continue
+
+ !---
+ do i=0,nleg-1
+ if (i.ne.j1) then
+ dens1(1)=dens1(1)*denevalmu2(nleg,i,q1(1,:),Vi,msq,mu2g(1))
+ denst(1)=denst(1)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ endif
+ enddo
+
+ xneval(1)=numeval(cut1,q1(1,:),mu2g(1))
+
+ if (imeth.eq.'diag') then
+ known(1)=(xneval(1)-resi5(1)-resi4(1)-resi3(1)-resi2(1))/dens1(1)
+ elseif (imeth.eq.'tree') then
+ known(1)=xneval(1)-(resi5(1)+resi4(1)+resi3(1)+resi2(1))/dens1(1)
+ endif
+
+ c1(0) = known(1)
+ else
+ !--- Decomposizione standard
+
+ if (nleg.eq.5) then
+ resi5(:)=res5(1,mu2g(1))
+ resit(1)=res5(1,mu2t(1))
+ goto 111
+ elseif (nleg.eq.4) then
+ do n=1,5
+ resi4(n)=Res4(1,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=Res4(1,qt,mu2t(1))
+ goto 121
+ elseif (nleg.eq.3) then
+ do n=1,5
+ resi3(n)=Res3(1,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=Res3(1,qt,mu2t(1))
+ goto 131
+ elseif (nleg.eq.2) then
+ do n=1,5
+ resi2(n)=Res2(1,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=Res2(1,qt,mu2t(1))
+ goto 141
+ else
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(:)=cone
+ dens5t=cone
+ evalres=.false.
+
+ loop_110: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)&
+ &.and.(i.ne.i4).and.(i.ne.i5)) then
+ if (i.eq.j1) then
+ dens5(:)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_110
+ else
+ do n=1,5
+ dens5(n)=dens5(n)*denevalmu2(nleg,i,&
+ &q1(n,:),Vi,msq,mu2g(1))
+ enddo
+ dens5t=dens5t*denevalmu2(nleg,&
+ &i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_110
+
+ if (evalres) then
+ resi5(:)=resi5(:)+dens5(:)*res5(dicut5,mu2g(1))
+ resit(1)=resit(1)+dens5t*res5(dicut5,mu2t(1))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ endif
+
+ 111 continue
+
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4(:)=cone
+ dens4t=cone
+ evalres=.false.
+
+ loop_120: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)) then
+ if (i.eq.j1) then
+ dens4(:)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_120
+ else
+ do n=1,5
+ dens4(n)=dens4(n)*denevalmu2(nleg,i,&
+ &q1(n,:),Vi,msq,mu2g(1))
+ enddo
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_120
+
+ if (evalres) then
+ do n=1,5
+ resi4(n)=resi4(n)+dens4(n)*&
+ &Res4(dicut4,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=resit(1)+dens4t*Res4(dicut4,qt,mu2t(1))
+ endif
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+
+ 121 continue
+
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens3(:)=cone
+ dens3t=cone
+ evalres=.false.
+
+ loop_130: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ if (i.eq.j1) then
+ dens3(:)=czip
+ dens3t=czip
+ evalres=.false.
+ exit loop_130
+ else
+ do n=1,5
+ dens3(n)=dens3(n)*denevalmu2(nleg,i,q1(n,:),&
+ &Vi,msq,mu2g(1))
+ enddo
+ dens3t=dens3t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_130
+
+ if (evalres) then
+ do n=1,5
+ resi3(n)=resi3(n)+dens3(n)*Res3(dicut3,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=resit(1)+dens3t*Res3(dicut3,qt,mu2t(1))
+ endif
+
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei Triple cuts:
+
+ 131 continue
+
+ !---#[ Contributo dei Double cuts:
+ dicut2=1
+ do i2=1,nleg-1
+ do i1=0,i2-1
+ dens2(:)=cone
+ dens2t=cone
+ evalres=.false.
+
+ loop_140: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2)) then
+ if (i.eq.j1) then
+ dens2(:)=czip
+ dens2t=czip
+ evalres=.false.
+ exit loop_140
+ else
+ do n=1,5
+ dens2(n)=dens2(n)*denevalmu2(nleg,i,q1(n,:),&
+ &Vi,msq,mu2g(1))
+ enddo
+ dens2t=dens2t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_140
+
+ if (evalres) then
+ do n=1,5
+ resi2(n)=resi2(n)+dens2(n)*Res2(dicut2,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=resit(1)+dens2t*Res2(dicut2,qt,mu2t(1))
+ endif
+ dicut2=dicut2+1
+ enddo
+ enddo
+
+ !---#] Contributo dei Double cuts:
+ 141 continue
+
+ !---
+
+ do i=0,nleg-1
+ if (i.ne.j1) then
+ do n=1,5
+ dens1(n)=dens1(n)*denevalmu2(nleg,i,q1(n,:),Vi,msq,mu2g(1))
+ enddo
+ denst(1)=denst(1)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ endif
+ enddo
+
+ do n=1,5
+ xneval(n)=numeval(cut1,q1(n,:),mu2g(1))
+ enddo
+
+ if (imeth.eq.'diag') then
+ known(:)=(xneval(:)-resi5(:)-resi4(:)-resi3(:)-resi2(:))/dens1(:)
+ elseif (imeth.eq.'tree') then
+ known(:)=xneval(:)-(resi5(:)+resi4(:)+resi3(:)+resi2(:))/dens1(:)
+ endif
+
+ do m=0,4
+ f1(m)=known(m+1)
+ enddo
+
+ !--- Coefficienti
+ c1(0) = (f1(0)+f1(1))/2.0_ki
+ c1(1) = (-f1(0)-f1(1)+f1(3)+f1(4))/(2.0_ki*MP12(1))
+ c1(2) = -(-2.0_ki*f1(0) + f1(3) + f1(4))/(2.0_ki*G0c*MP12(1))
+ c1(3) = (2.0_ki*f1(0)-2.0_ki*f1(2)-f1(3)+f1(4))/(2.0_ki*G0c*MP12(1))
+ c1(4) = (f1(0)-f1(2))/MP12(1)
+ endif
+ end subroutine getc1_cm
+
+ subroutine getc1_rm(numeval,nleg,rank,c1,cut1,q1,qt,Vi,msq)
+ use mglobal, only: G0, mu2g, MP12, mu2t, resit, denst, mu2test
+ implicit none
+ integer, intent(in) :: nleg, rank, cut1
+ complex(ki), dimension(0:4), intent(out) :: c1
+ complex(ki), dimension(5,4), intent(in) :: q1
+ complex(ki), dimension(4), intent(in) :: qt
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+
+ integer :: i,m,n,j1,i1,i2,i3,i4,i5
+ integer :: dicut5,dicut4,dicut3,dicut2,diff
+ complex(ki), dimension(5) :: dens1,dens2,dens3,dens4,dens5,xneval
+ complex(ki), dimension(0:4) :: f1
+ complex(ki), dimension(5) :: resi5, resi4, resi3, resi2, known
+ complex(ki) :: dens2t,dens3t,dens4t,dens5t
+ logical evalres
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ mu2test(1)=mu2t(1)
+
+ j1=cut1
+
+ resi2(:)=czip
+ resi3(:)=czip
+ resi4(:)=czip
+ resi5(:)=czip
+ known(:)=czip
+ xneval(:)=czip
+ dens1(:)=cone
+
+ !--- for lnntest
+ resit(1)=czip
+ denst(1)=cone
+
+ !--- for simplified sampling
+ diff = nleg-rank
+
+ if (diff.eq.1) then
+ c1(1)=czip
+ c1(2)=czip
+ c1(3)=czip
+ c1(4)=czip
+
+ if (nleg.eq.5) then
+ resi5(1)=res5(1,mu2g(1))
+ resit(1)=res5(1,mu2t(1))
+ goto 11
+ elseif (nleg.eq.4) then
+ resi4(1)=Res4(1,q1(1,:),mu2g(1))
+ resit(1)=Res4(1,qt,mu2t(1))
+ goto 21
+ elseif (nleg.eq.3) then
+ resi3(1)=Res3(1,q1(1,:),mu2g(1))
+ resit(1)=Res3(1,qt,mu2t(1))
+ goto 31
+ elseif (nleg.eq.2) then
+ resi2(1)=Res2(1,q1(1,:),mu2g(1))
+ resit(1)=Res2(1,qt,mu2t(1))
+ goto 41
+ else
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(1)=cone
+ dens5t=cone
+ evalres=.false.
+
+ loop_10: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)&
+ &.and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i).eq.(j1)) then
+ dens5(1)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_10
+ else
+ dens5(1)=dens5(1)*denevalmu2(nleg,i,&
+ &q1(1,:),Vi,msq,mu2g(1))
+ dens5t=dens5t*denevalmu2(nleg,i,qt,Vi,msq,&
+ &mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_10
+
+ if (evalres) then
+ resi5(1)=resi5(1)+dens5(1)*res5(dicut5,mu2g(1))
+ resit(1)=resit(1)+dens5(1)*res5(dicut5,mu2t(1))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ endif
+
+ 11 continue
+
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4(1)=cone
+ dens4t=cone
+ evalres=.false.
+
+ loop_20: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)) then
+ if (i.eq.j1) then
+ dens4(1)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_20
+ else
+ dens4(1)=dens4(1)*denevalmu2(nleg,i,q1(1,:),&
+ &Vi,msq,mu2g(1))
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,&
+ &mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_20
+
+ if (evalres) then
+ resi4(1)=resi4(1)+dens4(1)*Res4(dicut4,q1(1,:),mu2g(1))
+ resit(1)=resit(1)+dens4t*Res4(dicut4,qt,mu2t(1))
+ endif
+
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+ 21 continue
+
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens3(1)=cone
+ dens3t=cone
+ evalres=.false.
+
+ loop_30: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ if (i.eq.j1) then
+ dens3(1)=czip
+ dens3t=czip
+ evalres=.false.
+ exit loop_30
+ else
+ dens3(1)=dens3(1)*denevalmu2(nleg,i,q1(1,:),&
+ &Vi,msq,mu2g(1))
+ dens3t=dens3t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_30
+
+ if (evalres) then
+ resi3(1)=resi3(1)+dens3(1)*Res3(dicut3,q1(1,:),mu2g(1))
+ resit(1)=resit(1)+dens3t*Res3(dicut3,qt,mu2t(1))
+ endif
+
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei Triple cuts:
+
+ 31 continue
+
+ !---#[ Contributo dei Double cuts:
+ dicut2=1
+ do i2=1,nleg-1
+ do i1=0,i2-1
+ dens2(1)=cone
+ dens2t=cone
+ evalres=.false.
+
+ loop_40: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2)) then
+ if (i.eq.j1) then
+ dens2(1)=czip
+ dens2t=czip
+ evalres=.false.
+ exit loop_40
+ else
+ dens2(1)=dens2(1)*denevalmu2(nleg,i,q1(1,:),&
+ &Vi,msq,mu2g(1))
+ dens2t=dens2t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_40
+
+ if (evalres) then
+ resi2(1)=resi2(1)+dens2(1)*Res2(dicut2,q1(1,:),mu2g(1))
+ resit(1)=resit(1)+dens2t*Res2(dicut2,qt,mu2t(1))
+ endif
+
+ dicut2=dicut2+1
+ enddo
+ enddo
+ !---#] Contributo dei Double cuts:
+
+ 41 continue
+
+ !---
+ do i=0,nleg-1
+ if (i.ne.j1) then
+ dens1(1)=dens1(1)*denevalmu2(nleg,i,q1(1,:),Vi,msq,mu2g(1))
+ denst(1)=denst(1)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ endif
+ enddo
+
+ xneval(1)=numeval(cut1,q1(1,:),mu2g(1))
+
+ if (imeth.eq.'diag') then
+ known(1)=(xneval(1)-resi5(1)-resi4(1)-resi3(1)-resi2(1))/dens1(1)
+ elseif (imeth.eq.'tree') then
+ known(1)=xneval(1)-(resi5(1)+resi4(1)+resi3(1)+resi2(1))/dens1(1)
+ endif
+
+ c1(0) = known(1)
+ else
+ !--- Decomposizione standard
+
+ if (nleg.eq.5) then
+ resi5(:)=res5(1,mu2g(1))
+ resit(1)=res5(1,mu2t(1))
+ goto 111
+ elseif (nleg.eq.4) then
+ do n=1,5
+ resi4(n)=Res4(1,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=Res4(1,qt,mu2t(1))
+ goto 121
+ elseif (nleg.eq.3) then
+ do n=1,5
+ resi3(n)=Res3(1,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=Res3(1,qt,mu2t(1))
+ goto 131
+ elseif (nleg.eq.2) then
+ do n=1,5
+ resi2(n)=Res2(1,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=Res2(1,qt,mu2t(1))
+ goto 141
+ else
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(:)=cone
+ dens5t=cone
+ evalres=.false.
+
+ loop_110: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)&
+ &.and.(i.ne.i4).and.(i.ne.i5)) then
+ if (i.eq.j1) then
+ dens5(:)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_110
+ else
+ do n=1,5
+ dens5(n)=dens5(n)*denevalmu2(nleg,i,&
+ &q1(n,:),Vi,msq,mu2g(1))
+ enddo
+ dens5t=dens5t*denevalmu2(nleg,&
+ &i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_110
+
+ if (evalres) then
+ resi5(:)=resi5(:)+dens5(:)*res5(dicut5,mu2g(1))
+ resit(1)=resit(1)+dens5t*res5(dicut5,mu2t(1))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ endif
+
+ 111 continue
+
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4(:)=cone
+ dens4t=cone
+ evalres=.false.
+
+ loop_120: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)) then
+ if (i.eq.j1) then
+ dens4(:)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_120
+ else
+ do n=1,5
+ dens4(n)=dens4(n)*denevalmu2(nleg,i,&
+ &q1(n,:),Vi,msq,mu2g(1))
+ enddo
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_120
+
+ if (evalres) then
+ do n=1,5
+ resi4(n)=resi4(n)+dens4(n)*&
+ &Res4(dicut4,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=resit(1)+dens4t*Res4(dicut4,qt,mu2t(1))
+ endif
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+
+ 121 continue
+
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens3(:)=cone
+ dens3t=cone
+ evalres=.false.
+
+ loop_130: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ if (i.eq.j1) then
+ dens3(:)=czip
+ dens3t=czip
+ evalres=.false.
+ exit loop_130
+ else
+ do n=1,5
+ dens3(n)=dens3(n)*denevalmu2(nleg,i,q1(n,:),&
+ &Vi,msq,mu2g(1))
+ enddo
+ dens3t=dens3t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_130
+
+ if (evalres) then
+ do n=1,5
+ resi3(n)=resi3(n)+dens3(n)*Res3(dicut3,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=resit(1)+dens3t*Res3(dicut3,qt,mu2t(1))
+ endif
+
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei Triple cuts:
+
+ 131 continue
+
+ !---#[ Contributo dei Double cuts:
+ dicut2=1
+ do i2=1,nleg-1
+ do i1=0,i2-1
+ dens2(:)=cone
+ dens2t=cone
+ evalres=.false.
+
+ loop_140: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2)) then
+ if (i.eq.j1) then
+ dens2(:)=czip
+ dens2t=czip
+ evalres=.false.
+ exit loop_140
+ else
+ do n=1,5
+ dens2(n)=dens2(n)*denevalmu2(nleg,i,q1(n,:),&
+ &Vi,msq,mu2g(1))
+ enddo
+ dens2t=dens2t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_140
+
+ if (evalres) then
+ do n=1,5
+ resi2(n)=resi2(n)+dens2(n)*Res2(dicut2,q1(n,:),mu2g(1))
+ enddo
+ resit(1)=resit(1)+dens2t*Res2(dicut2,qt,mu2t(1))
+ endif
+ dicut2=dicut2+1
+ enddo
+ enddo
+
+ !---#] Contributo dei Double cuts:
+ 141 continue
+
+ !---
+
+ do i=0,nleg-1
+ if (i.ne.j1) then
+ do n=1,5
+ dens1(n)=dens1(n)*denevalmu2(nleg,i,q1(n,:),Vi,msq,mu2g(1))
+ enddo
+ denst(1)=denst(1)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(1))
+ endif
+ enddo
+
+ do n=1,5
+ xneval(n)=numeval(cut1,q1(n,:),mu2g(1))
+ enddo
+
+ if (imeth.eq.'diag') then
+ known(:)=(xneval(:)-resi5(:)-resi4(:)-resi3(:)-resi2(:))/dens1(:)
+ elseif (imeth.eq.'tree') then
+ known(:)=xneval(:)-(resi5(:)+resi4(:)+resi3(:)+resi2(:))/dens1(:)
+ endif
+
+ do m=0,4
+ f1(m)=known(m+1)
+ enddo
+
+ !--- Coefficienti
+ c1(0) = (f1(0)+f1(1))/2.0_ki
+ c1(1) = (-f1(0)-f1(1)+f1(3)+f1(4))/(2.0_ki*MP12(1))
+ c1(2) = -(-2.0_ki*f1(0) + f1(3) + f1(4))/(2.0_ki*G0*MP12(1))
+ c1(3) = (2.0_ki*f1(0)-2.0_ki*f1(2)-f1(3)+f1(4))/(2.0_ki*G0*MP12(1))
+ c1(4) = (f1(0)-f1(2))/MP12(1)
+ endif
+ end subroutine getc1_rm
+
+end module mgetc1
+
diff --git a/samurai-2.1.1/mgetc2.f90 b/samurai-2.1.1/mgetc2.f90
new file mode 100644
index 0000000..5936967
--- /dev/null
+++ b/samurai-2.1.1/mgetc2.f90
@@ -0,0 +1,1361 @@
+module mgetc2
+ use precision, only: ki
+ use constants
+ use options
+ use mfunctions
+ use mrestore
+ implicit none
+
+ private
+
+ interface getc2
+ module procedure getc2_rm
+ module procedure getc2_cm
+ end interface getc2
+
+ public :: getc2
+
+contains
+
+ subroutine getc2_rm(numeval,nleg,rank,c2,cut2,q2,qt,Vi,msq)
+ use mglobal, only: Fp,Fz,Fm,F1z,KB,mu2g,KK,MP12,mu2t,&
+ & resit,denst,mu2test
+ implicit none
+ integer, intent(in) :: nleg,rank,cut2
+ complex(ki), dimension(0:9), intent(out) :: c2
+ complex(ki), dimension(10,4), intent(in) :: q2
+ complex(ki), dimension(4), intent(in) :: qt
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+
+ integer :: i,m,n,j1,j2,i1,i2,i3,i4,i5
+ integer :: dicut5,dicut4,dicut3,mx,diff,nsol
+ complex(ki), dimension(10) :: dens2,dens3,dens4,dens5,xneval
+ complex(ki), dimension(10) :: resi5,resi4,resi3,known
+ complex(ki), dimension(0:9) :: f2
+ complex(ki) :: dens3t,dens4t,dens5t
+ logical evalres
+ !real(ki) :: Fppow2, Fppow3, Fppow4
+ !real(ki) :: Fzpow2, Fzpow3, Fzpow4, Fzpow5, Fzpow6, tmp1
+ !---#[ HAGGIES:
+ complex(ki) :: t1
+ complex(ki) :: t2
+ complex(ki) :: t3
+ complex(ki) :: t4
+ complex(ki) :: t5
+ complex(ki) :: t6
+ complex(ki) :: t7
+ complex(ki) :: t8
+ complex(ki) :: t9
+ complex(ki) :: t10
+ complex(ki) :: t11
+ complex(ki) :: t12
+ complex(ki) :: t13
+ complex(ki) :: t14
+ complex(ki) :: t15
+ complex(ki) :: t16
+ complex(ki) :: t17
+ complex(ki) :: t18
+ complex(ki) :: t19
+ complex(ki) :: t20
+ complex(ki) :: t21
+ complex(ki) :: t22
+ complex(ki) :: t23
+ complex(ki) :: t24
+ complex(ki) :: t25
+ complex(ki) :: t26
+ complex(ki) :: t27
+ complex(ki) :: t28
+ complex(ki) :: t29
+ complex(ki) :: t30
+ complex(ki) :: t31
+ complex(ki) :: t32
+ complex(ki) :: t33
+ complex(ki) :: t34
+ complex(ki) :: t35
+ complex(ki) :: t36
+ complex(ki) :: t37
+ complex(ki) :: t38
+ complex(ki) :: t39
+ complex(ki) :: t40
+ complex(ki) :: t41
+ complex(ki) :: t42
+ complex(ki) :: t43
+ complex(ki) :: t44
+ complex(ki) :: t45
+ !---#] HAGGIES:
+ complex(ki), dimension(10) :: mu2vec
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ mu2test(2) = mu2t(2)
+
+ j2=cut2/10
+ j1=cut2-j2*10
+
+ resi3(:)=czip
+ resi4(:)=czip
+ resi5(:)=czip
+ known(:)=czip
+ xneval(:)=czip
+ dens2(:)=cone
+
+!--- for lnntest
+ resit(2)=czip
+ denst(2)=cone
+
+
+!--- for simplified sampling
+ diff = nleg-rank
+
+ if (diff.eq.2) then
+ !---#[ simplified sampling -- only c2(0):
+ if (nleg.eq.5) then
+ resi5(1)=res5(1,czip)
+ resit(2)=res5(1,mu2t(2))
+ goto 11
+ elseif (nleg.eq.4) then
+ resi4(1)=Res4(1,q2(1,:),czip)
+ resit(2) =res4(1,qt,mu2t(2))
+ goto 21
+ elseif (nleg.eq.3) then
+ resi3(1)=Res3(1,q2(1,:),czip)
+ resit(2)=Res3(1,qt,mu2t(2))
+ goto 31
+ elseif (nleg.eq.2) then
+ goto 36
+ else
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(1)=cone
+ dens5t=cone
+ evalres=.false.
+ loop_10: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)&
+ & .and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens5(1)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_10
+ else
+ dens5(1)=dens5(1)&
+ &*denevalmu2(nleg,i,q2(1,:),Vi,msq,czip)
+ dens5t=dens5t&
+ &*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_10
+
+ if (evalres) then
+ resi5(1)=resi5(1)+dens5(1)*res5(dicut5,czip)
+ resit(2)=resit(2)+dens5t*res5(dicut5,mu2t(2))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ endif
+
+ 11 continue
+
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4(1)=cone
+ dens4t=cone
+
+ evalres=.false.
+
+ loop_20: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.&
+ &(i.ne.i3).and.(i.ne.i4)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens4(1)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_20
+ else
+ dens4(1)=dens4(1)*denevalmu2(nleg,i,q2(1,:),&
+ &Vi,msq,czip)
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_20
+
+
+ if (evalres) then
+ resi4(1)=resi4(1)+dens4(1)*Res4(dicut4,q2(1,:),czip)
+ resit(2)=resit(2)+dens4t*Res4(dicut4,qt,mu2t(2))
+ endif
+
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+
+ 21 continue
+
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+
+ dens3(1)=cone
+ dens3t=cone
+ evalres=.false.
+
+ loop_30: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens3(1)=czip
+ dens3t=czip
+ evalres=.false.
+ exit loop_30
+ else
+ dens3(1)=dens3(1)*denevalmu2(nleg,i,q2(1,:),&
+ &Vi,msq,czip)
+ dens3t=dens3t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_30
+
+ if (evalres) then
+ resi3(1)=resi3(1)+dens3(1)*Res3(dicut3,q2(1,:),czip)
+ resit(2)=resit(2)+dens3t*Res3(dicut3,qt,mu2t(2))
+ endif
+
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei Triple cuts:
+
+ 31 continue
+
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2)) then
+ dens2(1)=dens2(1)*denevalmu2(nleg,i,q2(1,:),Vi,msq,czip)
+ denst(2)=denst(2)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ endif
+ enddo
+
+ 36 continue
+
+ xneval(1)=numeval(cut2,q2(1,:),czip)
+
+ if (imeth.eq.'diag') then
+ known(1)=(xneval(1)-resi5(1)-resi4(1)-resi3(1))/dens2(1)
+ elseif (imeth.eq.'tree') then
+ known(1)=xneval(1)-(resi5(1)+resi4(1)+resi3(1))/dens2(1)
+ endif
+
+ c2(0)=known(1)
+ do m=1,9
+ c2(m)=czip
+ enddo
+
+ !---#] simplified sampling -- only c2(0):
+ else
+ !---#[ Decomposizione standard:
+ if (diff.eq.1) then
+ ! rank1 c-system: 4 coefficients
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,czip,czip,czip/)
+ nsol=4
+
+ else
+ ! traditional system
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,czip,czip,mu2g(2)/)
+ nsol=10
+ endif
+
+ if (nleg.eq.5) then
+ do n=1,nsol
+ resi5(n)=Res5(1,mu2vec(n))
+ enddo
+ resit(2)=Res5(1,mu2t(2))
+ goto 111
+ elseif (nleg.eq.4) then
+ do n=1,nsol
+ resi4(n)=Res4(1,q2(n,:),mu2vec(n))
+ enddo
+ resit(2)=Res4(1,qt,mu2t(2))
+ goto 121
+ elseif (nleg.eq.3) then
+ do n=1,nsol
+ resi3(n)=Res3(1,q2(n,:),mu2vec(n))
+ enddo
+ resit(2)=Res3(1,qt,mu2t(2))
+ goto 131
+ elseif (nleg.eq.2) then
+ goto 136
+ else
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(:)=cone
+ dens5t=cone
+ evalres=.false.
+
+ loop_110: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens5(:)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_110
+ else
+ do n=1,nsol
+ dens5(n)=dens5(n)*denevalmu2(nleg,i,&
+ &q2(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens5t=dens5t*denevalmu2(nleg,i,qt,Vi,msq,&
+ &mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_110
+
+ if (evalres) then
+ do n=1,nsol
+ resi5(n)=resi5(n)+dens5(n)*res5(dicut5,mu2vec(n))
+ enddo
+ resit(2)=resit(2)+dens5t*res5(dicut5,mu2t(2))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ endif
+
+ 111 continue
+
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4(:)=cone
+ dens4t=cone
+ evalres=.false.
+
+ loop_120: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3).and.&
+ &(i.ne.i4)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens4(:)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_120
+ else
+ do n=1,nsol
+ dens4(n)=dens4(n)*denevalmu2(nleg,i,&
+ &q2(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,&
+ &mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_120
+
+ if (evalres) then
+ do n=1,nsol
+ resi4(n)=resi4(n)+dens4(n)*Res4(dicut4,q2(n,:),&
+ &mu2vec(n))
+ enddo
+ resit(2)=resit(2)+dens4t*Res4(dicut4,qt,mu2t(2))
+ endif
+
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+
+ 121 continue
+
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ loop_dicut3: do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens3(:)=cone
+ dens3t=cone
+ evalres=.false.
+ loop_130: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens3(:)=czip
+ dens3t=czip
+ evalres=.false.
+ exit loop_130
+ else
+ do n=1,nsol
+ dens3(n)=dens3(n)&
+ & *denevalmu2(nleg,i,q2(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens3t=dens3t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_130
+
+ if (evalres) then
+ do n=1,nsol
+ resi3(n)=resi3(n)+dens3(n)*Res3(dicut3,q2(n,:),&
+ &mu2vec(n))
+ enddo
+ resit(2)=resit(2)+dens3t*Res3(dicut3,qt,mu2t(2))
+ endif
+
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo loop_dicut3
+ !---#] Contributo dei Triple cuts:
+
+ 131 continue
+
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2)) then
+ do n=1,nsol
+ dens2(n)=dens2(n)*denevalmu2(nleg,i,q2(n,:),Vi,msq,mu2vec(n))
+ enddo
+ denst(2)=denst(2)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ endif
+ enddo
+
+ 136 continue
+
+ do n=1,nsol
+ xneval(n)=numeval(cut2,q2(n,:),mu2vec(n))
+ enddo
+
+ if (imeth.eq.'diag') then
+ known(:)=(xneval(:)-resi5(:)-resi4(:)-resi3(:))/dens2(:)
+ elseif (imeth.eq.'tree') then
+ known(:)=xneval(:)-(resi5(:)+resi4(:)+resi3(:))/dens2(:)
+ endif
+
+ if (diff.eq.1) then
+ ! rank1 c-system: 4 coefficients
+
+ do m=0,1
+ f2(m)=effe(known,1,2,m)
+ enddo
+
+ do m=2,3
+ mx=m-2
+ f2(m)=effe(known,3,2,mx)
+ enddo
+
+ !---#[ getc2_S1:
+ !----#[ original code:
+! c2(0) = f2(0)
+! c2(1) = (-f2(0) + f2(2))/(KB*MP12(2))
+! c2(3) = (KK(2)*(f2(1) - Fz*f2(3)))/((-one + Fp*Fz)*MP12(2))
+! c2(5) = (-(Fp*MP12(2)*c2(3)) - KK(2)*f2(3))/(KK(2)**2*MP12(2))
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = f2(0)
+ c2(0) = t1
+ c2(1) = ((f2(2)-t1)/(KB*MP12(2)))
+ t1 = f2(3)
+ c2(3) = ((f2(1)-t1*Fz)/((Fp*Fz-one)*MP12(2))*KK(2))
+ c2(5) = ((-(Fp*MP12(2)*c2(3)+t1*KK(2)))/(KK(2)*KK(2)*MP12(2)))
+ !----#] HAGGIES:
+ !---#] getc2_S1:
+ else
+ ! traditional system
+ do m=0,2
+ f2(m)=effe(known,1,3,m)
+ enddo
+ do m=3,4
+ mx=m-3
+ f2(m)=effe(known,4,2,mx)
+ enddo
+ do m=5,6
+ mx=m-5
+ f2(m)=effe(known,6,2,mx)
+ enddo
+ f2(7)=known(8)
+ f2(8)=known(9)
+ f2(9)=known(10)
+
+ !---#[ getc2_S2:
+ !----#[ original code:
+! !--- coefficienti
+! Fppow2 = Fp*Fp
+! Fppow3 = Fppow2*Fp
+! Fppow4 = Fppow3*Fp
+! Fzpow2 = Fz*Fz
+! Fzpow3 = Fzpow2*Fz
+! Fzpow4 = Fzpow3*Fz
+! Fzpow5 = Fzpow4*Fz
+! Fzpow6 = Fzpow5*Fz
+! tmp1 = one - Fppow2
+! c2(2) = (0.5_ki*(Fppow3*((one + Fzpow4)*f2(0) + f2(1) - f2(3) + Fz*&
+! &(Fz*(f2(1) + (one + Fzpow2)*f2(2) + Fz*(-Fz*f2(3) - f2(4))) - f2(4)))&
+! &+ Fppow4*(-f2(0) - Fzpow2*f2(1) - Fzpow4*f2(2) + f2(3) + Fzpow3*f2(4))&
+! &+ Fm**2*(tmp1*f2(0) + tmp1*Fzpow2*f2(1) + tmp1*Fzpow4*f2(2) + (-tmp1)&
+! &*f2(3) + (-tmp1)*Fzpow3*f2(4)) + two*((-one - Fzpow2 - Fzpow4 + Fzpow6)&
+! &*f2(0) + (-one - Fzpow4)*f2(1) - f2(2) + Fz*(-Fz*f2(2) + Fz*f2(3)&
+! &+ Fzpow3*f2(3) + f2(4) + Fzpow4*f2(4))) + f2(5) + f2(6) + Fm*((one&
+! &+ Fzpow4 + Fzpow3*two + Fppow2*(-one - Fzpow4 - Fzpow3*two))*f2(0)&
+! &+ (one + Fzpow2 + Fzpow5*two + Fppow2*(-one - Fzpow2 - Fzpow5*two))*f2(1)&
+! &+ tmp1*Fzpow2*f2(2) + (-tmp1)*f2(3) + Fzpow4*(tmp1*f2(2) + (-tmp1)*f2(3))&
+! &- two*f2(4) + Fppow2*two*f2(4) - tmp1*Fzpow3*(two*f2(3) + f2(4)) + Fz&
+! &*(tmp1*two*f2(2) - tmp1*f2(4)) - f2(5) - Fp*f2(6) + Fzpow6*(f2(5) + Fp&
+! &*f2(6) - f2(7)) + f2(7)) + Fp*((-one - Fzpow4)*f2(0) - f2(1) + f2(3)&
+! &+ f2(5) - f2(7) + Fz*(f2(4) + Fz*(-f2(1) - (one + Fzpow2)*f2(2) + Fz&
+! &*(Fz*f2(3) + f2(4) + Fzpow3*(-f2(5) + f2(7)))))) + Fzpow6*(-f2(5) - f2(6)&
+! &- f2(8)) + f2(8) + Fppow2*((three + Fzpow2*(one + Fzpow2 - Fzpow4)*two)&
+! &*f2(0) + two*f2(1) + two*f2(2) - f2(3) + Fzpow4*(two*f2(1) + f2(2) - two&
+! &*f2(3)) + Fzpow2*(f2(1) + two*f2(2) - two*f2(3)) - Fzpow3*f2(4) - Fz*two&
+! &*f2(4) - Fzpow5*two*f2(4) - f2(5) - f2(8) + Fzpow6*(f2(5) + f2(8)))))/&
+! &((-tmp1)*(-one + Fzpow6)*MP12(2)**2)
+! c2(7) = (KK(2)*(f2(2) + Fppow2*(-(Fzpow4*f2(1)) - f2(2) + Fzpow2*(-f2(0)&
+! &+ f2(3)) + Fzpow5*f2(4)) + Fppow3*(-((one + Fzpow4)*f2(0))&
+! &- (one + Fzpow2)*(f2(1) + Fzpow2*f2(2)) + (one + Fzpow4)*f2(3) &
+! &+ (Fz + Fzpow3)*f2(4)) - f2(6) + Fzpow2*(f2(0) - f2(3) +&
+! &Fzpow2*(f2(1) + Fz*(-f2(4) + Fz*f2(6)))) +&
+! &Fp*((one + Fzpow4)*f2(0) + f2(1) - f2(3) - f2(5) +&
+! &Fz*(Fz*(f2(1) + f2(2)) + Fzpow3*(f2(2) - f2(3)) -&
+! &f2(4) - Fzpow2*f2(4) + Fzpow5*(f2(5) - f2(7))) +&
+! &f2(7))))/((-tmp1)*(-one + Fzpow6)*MP12(2)**2)
+! c2(8) = ((-tmp1)*(one + Fzpow3 + Fzpow4)*f2(0) +&
+! &(-tmp1)*(one + Fzpow2 + Fzpow5)*f2(1) + (-tmp1)*Fzpow2*f2(2) +&
+! &(-tmp1)*Fzpow4*(f2(2) - f2(3)) + f2(3) + (-tmp1)*Fz*(f2(2) - f2(4))&
+! &+ f2(4) - (-tmp1)*Fzpow3*(f2(3) + f2(4)) + f2(5) +&
+! &Fp*(-(Fp*(f2(3) + f2(4))) + f2(6)) - Fzpow6*(f2(5) + Fp*f2(6) - f2(7))&
+! &- f2(7))/ ((-tmp1)*(-one + Fzpow6)*KK(2)*MP12(2)**2)
+! c2(4) = -((KK(2)**2*(f2(1) + Fzpow2*f2(2) + Fzpow4*(f2(0) - f2(3)) -&
+! &Fz*f2(4)))/((-one + Fzpow6)*MP12(2)**2))
+! c2(5) = (Fzpow3*f2(0) + Fzpow5*f2(1) + Fz*f2(2) - Fzpow3*f2(3) -&
+! &f2(4))/(KK(2)*MP12(2) - Fzpow6*KK(2)*MP12(2))
+! c2(3) = (KK(2)*(f2(2) + Fzpow2*(f2(0) - f2(3) + Fzpow2*(f2(1)&
+! - Fz*f2(4)))))/((-one + Fzpow6)*MP12(2))
+! c2(6) = (f2(0) - f2(3) + Fzpow2*(f2(1) + Fz*(Fz*f2(2) - f2(4))))/&
+! &((-one + Fzpow6)*KK(2)**2*MP12(2)**2)
+! c2(0) = f2(0)
+! c2(9) = (KK(2)*MP12(2)*c2(3) - MP12(2)**2*c2(4)&
+! &+ F1z*KK(2)**3*MP12(2)*c2(5) - F1z**2*KK(2)**4*MP12(2)**2*c2(6) &
+! &+ KK(2)**2*(-c2(0) + f2(9)))/(KK(2)**2*mu2g(2))
+! c2(1) = -(c2(3)/KK(2)) - Fm*KK(2)*c2(5) + (MP12(2)*(c2(4) + KK(2)*(c2(7)&
+! &+ KK(2)*(c2(2) + Fm*KK(2)*(Fm*KK(2)*c2(6) + c2(8))))))/KK(2)**2&
+! &+ (c2(0) - f2(8))/MP12(2)
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = (1.0_ki)+Fp
+ t2 = Fz*Fz
+ t3 = t2*Fz
+ t4 = t3-(1.0_ki)
+ t5 = (1.0_ki)+t3
+ t6 = f2(2)
+ t7 = t2*t2
+ t8 = -(t7+(1.0_ki))
+ t9 = f2(1)
+ t10 = t3*t3
+ t11 = f2(0)
+ t12 = f2(4)
+ t13 = t6*Fz
+ t14 = f2(3)
+ t15 = t14*Fz
+ t16 = t15*t2
+ t17 = f2(5)
+ t18 = f2(6)
+ t19 = f2(8)
+ t20 = t9-t14
+ t21 = (1.0_ki)+t7
+ t22 = t11*t21
+ t23 = (1.0_ki)+t2
+ t24 = t23*t6
+ t25 = Fp*Fp
+ t26 = t14-t11
+ t27 = t12*Fz
+ t28 = t2*t27
+ t29 = ((1.0_ki)-Fp)*t1
+ t30 = t14*t29
+ t31 = t29*t6
+ t32 = t12*t29
+ t33 = f2(7)
+ t34 = t6+t9
+ t35 = t27*t7
+ t36 = t6-t14
+ t37 = t17-t33
+ t38 = t18*Fp
+ t39 = (t37+t38)*t10
+ t40 = t7*Fz
+ t41 = (2.0_ki)*t40
+ t42 = (2.0_ki)*t3
+ t43 = t2*t31
+ t44 = MP12(2)*MP12(2)
+ t45 = t29*t4*t44*t5
+ c2(2) = (-1.0_ki)*((2.0_ki)*((t10-(t7+t2+(1.0_ki)))*t11+(t12+t15+t&
+ &16+t12*t7-t13)*Fz+t8*t9-t6)+t17+t18+t19+(-(t19+t18+t17))*t10+(t26&
+ &+t28-(t6*t7+t2*t9))*t25*t25+(t11*t29+t31*t7+t2*t29*t9-(t2*t32*Fz+&
+ &t30))*Fm*Fm+(t14+t17+(t12+((t12+t15+(t33-t17)*t2*Fz)*Fz-(t9+t24))&
+ &*Fz)*Fz+t11*t8-(t9+t33))*Fp+((2.0_ki)*(t34-(t35+t27))+((3.0_ki)+(&
+ &2.0_ki)*((1.0_ki)+t2-t7)*t2)*t11+(t17+t19)*t10+((2.0_ki)*t20+t6)*&
+ &t7+((2.0_ki)*t36+t9)*t2-(t28+t19+t17+t14))*t25+((2.0_ki)*(t12*t25&
+ &-t12)+t33+t39+t43+(t31-t30)*t7+((2.0_ki)*t31-t32)*Fz+((1.0_ki)+t2&
+ &+t41+(-(t41+t2+(1.0_ki)))*t25)*t9+((1.0_ki)+t42+t7+(-(t7+t42+(1.0&
+ &_ki)))*t25)*t11-((t12+(2.0_ki)*t14)*t2*t29*Fz+t38+t30+t17))*Fm+(t&
+ &20+t22+((t24+t9+(-(t15+t12))*Fz)*Fz-t12)*Fz)*t25*Fp)/t45*0.5_ki
+ t8 = t11-t14
+ t10 = t2*t6
+ c2(7) = (-1.0_ki)*(t6+(t8+(t9+(t18*Fz-t12)*Fz)*t2)*t2+(t35+t2*t26-&
+ &(t7*t9+t6))*t25+(t20+t22+t33+(t34*Fz+t2*t36*Fz+t37*t7*Fz-(t12*t2+&
+ &t12))*Fz-t17)*Fp+((t3+Fz)*t12+t14*t21-((t10+t9)*t23+t22))*t25*Fp-&
+ &t18)/t45*KK(2)
+ t14 = t12+t14
+ c2(8) = ((t14+t17+(t18-t14*Fp)*Fp+t14*t2*t29*Fz-(t29*t36*t7+((1.0_&
+ &ki)+t3+t7)*t11*t29+((1.0_ki)+t2+t40)*t29*t9+(t6-t12)*t29*Fz+t43+t&
+ &39+t33))/((Fp-(1.0_ki))*t1*t4*t44*t5*KK(2)))
+ t1 = KK(2)*KK(2)
+ t3 = t4*t5
+ c2(4) = (-1.0_ki)*(t10+t9+t7*t8-t27)/(t3*t44)*t1
+ c2(5) = (-1.0_ki)*(t13+t11*t2*Fz+t7*t9*Fz-(t16+t12))/(t3*KK(2)*MP1&
+ &2(2))
+ c2(3) = ((t6+(t8+(t9-t27)*t2)*t2)/(t3*MP12(2))*KK(2))
+ t4 = KK(2)*MP12(2)
+ c2(6) = ((t8+(t9+(t13-t12)*Fz)*t2)/(t3*t4*t4))
+ c2(0) = t11
+ t2 = t1*F1z*MP12(2)
+ c2(9) = (((f2(9)-c2(0))*t1+t4*c2(3)+t1*F1z*KK(2)*MP12(2)*c2(5)-(t4&
+ &4*c2(4)+t2*t2*c2(6)))/(t1*mu2g(2)))
+ t2 = Fm*KK(2)
+ c2(1) = ((c2(0)-t19)/MP12(2)+(c2(4)+(c2(7)+(c2(2)+(c2(8)+t2*c2(6))&
+ &*Fm*KK(2))*KK(2))*KK(2))/t1*MP12(2)-(c2(3)/KK(2)+t2*c2(5)))
+ !----#] HAGGIES:
+ !---#] getc2_S2:
+ endif
+ !---#] Decomposizione standard:
+ endif
+
+ if (diff.ge.1) then
+ c2(2)=czip
+ c2(4)=czip
+ c2(6)=czip
+ c2(7)=czip
+ c2(8)=czip
+ c2(9)=czip
+ if (diff.ge.2) then
+ c2(1)=czip
+ c2(3)=czip
+ c2(5)=czip
+ endif
+ endif
+ end subroutine getc2_rm
+
+ subroutine getc2_cm(numeval,nleg,rank,c2,cut2,q2,qt,Vi,msq)
+ use mglobal, only: Fpc,Fzc,Fmc,F1zc,KB,mu2g,KK,MP12,mu2t,&
+ & resit,denst,mu2test
+ implicit none
+ integer, intent(in) :: nleg,rank,cut2
+ complex(ki), dimension(0:9), intent(out) :: c2
+ complex(ki), dimension(10,4), intent(in) :: q2
+ complex(ki), dimension(4), intent(in) :: qt
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+
+ integer :: i,m,n,j1,j2,i1,i2,i3,i4,i5
+ integer :: dicut5,dicut4,dicut3,mx,diff,nsol
+ complex(ki), dimension(10) :: dens2,dens3,dens4,dens5,xneval
+ complex(ki), dimension(10) :: resi5,resi4,resi3,known
+ complex(ki), dimension(0:9) :: f2
+ complex(ki) :: dens3t,dens4t,dens5t
+ logical evalres
+ !real(ki) :: Fpcpow2, Fpcpow3, Fpcpow4
+ !real(ki) :: Fzcpow2, Fzcpow3, Fzcpow4, Fzcpow5, Fzcpow6, tmp1
+ !---#[ HAGGIES:
+ complex(ki) :: t1
+ complex(ki) :: t2
+ complex(ki) :: t3
+ complex(ki) :: t4
+ complex(ki) :: t5
+ complex(ki) :: t6
+ complex(ki) :: t7
+ complex(ki) :: t8
+ complex(ki) :: t9
+ complex(ki) :: t10
+ complex(ki) :: t11
+ complex(ki) :: t12
+ complex(ki) :: t13
+ complex(ki) :: t14
+ complex(ki) :: t15
+ complex(ki) :: t16
+ complex(ki) :: t17
+ complex(ki) :: t18
+ complex(ki) :: t19
+ complex(ki) :: t20
+ complex(ki) :: t21
+ complex(ki) :: t22
+ complex(ki) :: t23
+ complex(ki) :: t24
+ complex(ki) :: t25
+ complex(ki) :: t26
+ complex(ki) :: t27
+ complex(ki) :: t28
+ complex(ki) :: t29
+ complex(ki) :: t30
+ complex(ki) :: t31
+ complex(ki) :: t32
+ complex(ki) :: t33
+ complex(ki) :: t34
+ complex(ki) :: t35
+ complex(ki) :: t36
+ complex(ki) :: t37
+ complex(ki) :: t38
+ complex(ki) :: t39
+ complex(ki) :: t40
+ complex(ki) :: t41
+ complex(ki) :: t42
+ complex(ki) :: t43
+ complex(ki) :: t44
+ complex(ki) :: t45
+ !---#] HAGGIES:
+ complex(ki), dimension(10) :: mu2vec
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ mu2test(2) = mu2t(2)
+
+ j2=cut2/10
+ j1=cut2-j2*10
+
+ resi3(:)=czip
+ resi4(:)=czip
+ resi5(:)=czip
+ known(:)=czip
+ xneval(:)=czip
+ dens2(:)=cone
+
+!--- for lnntest
+ resit(2)=czip
+ denst(2)=cone
+
+
+!--- for simplified sampling
+ diff = nleg-rank
+
+ if (diff.eq.2) then
+ !---#[ simplified sampling -- only c2(0):
+ if (nleg.eq.5) then
+ resi5(1)=res5(1,czip)
+ resit(2)=res5(1,mu2t(2))
+ goto 11
+ elseif (nleg.eq.4) then
+ resi4(1)=Res4(1,q2(1,:),czip)
+ resit(2) =res4(1,qt,mu2t(2))
+ goto 21
+ elseif (nleg.eq.3) then
+ resi3(1)=Res3(1,q2(1,:),czip)
+ resit(2)=Res3(1,qt,mu2t(2))
+ goto 31
+ elseif (nleg.eq.2) then
+ goto 36
+ else
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(1)=cone
+ dens5t=cone
+ evalres=.false.
+ loop_10: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)&
+ & .and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens5(1)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_10
+ else
+ dens5(1)=dens5(1)&
+ &*denevalmu2(nleg,i,q2(1,:),Vi,msq,czip)
+ dens5t=dens5t&
+ &*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_10
+
+ if (evalres) then
+ resi5(1)=resi5(1)+dens5(1)*res5(dicut5,czip)
+ resit(2)=resit(2)+dens5t*res5(dicut5,mu2t(2))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ endif
+
+ 11 continue
+
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4(1)=cone
+ dens4t=cone
+
+ evalres=.false.
+
+ loop_20: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.&
+ &(i.ne.i3).and.(i.ne.i4)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens4(1)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_20
+ else
+ dens4(1)=dens4(1)*denevalmu2(nleg,i,q2(1,:),&
+ &Vi,msq,czip)
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_20
+
+
+ if (evalres) then
+ resi4(1)=resi4(1)+dens4(1)*Res4(dicut4,q2(1,:),czip)
+ resit(2)=resit(2)+dens4t*Res4(dicut4,qt,mu2t(2))
+ endif
+
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+
+ 21 continue
+
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+
+ dens3(1)=cone
+ dens3t=cone
+ evalres=.false.
+
+ loop_30: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens3(1)=czip
+ dens3t=czip
+ evalres=.false.
+ exit loop_30
+ else
+ dens3(1)=dens3(1)*denevalmu2(nleg,i,q2(1,:),&
+ &Vi,msq,czip)
+ dens3t=dens3t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_30
+
+ if (evalres) then
+ resi3(1)=resi3(1)+dens3(1)*Res3(dicut3,q2(1,:),czip)
+ resit(2)=resit(2)+dens3t*Res3(dicut3,qt,mu2t(2))
+ endif
+
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei Triple cuts:
+
+ 31 continue
+
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2)) then
+ dens2(1)=dens2(1)*denevalmu2(nleg,i,q2(1,:),Vi,msq,czip)
+ denst(2)=denst(2)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ endif
+ enddo
+
+ 36 continue
+
+ xneval(1)=numeval(cut2,q2(1,:),czip)
+
+ if (imeth.eq.'diag') then
+ known(1)=(xneval(1)-resi5(1)-resi4(1)-resi3(1))/dens2(1)
+ elseif (imeth.eq.'tree') then
+ known(1)=xneval(1)-(resi5(1)+resi4(1)+resi3(1))/dens2(1)
+ endif
+
+ c2(0)=known(1)
+ do m=1,9
+ c2(m)=czip
+ enddo
+
+ !---#] simplified sampling -- only c2(0):
+ else
+ !---#[ Decomposizione standard:
+ if (diff.eq.1) then
+ ! rank1 c-system: 4 coefficients
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,czip,czip,czip/)
+ nsol=4
+
+ else
+ ! traditional system
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,czip,czip,mu2g(2)/)
+ nsol=10
+ endif
+
+ if (nleg.eq.5) then
+ do n=1,nsol
+ resi5(n)=Res5(1,mu2vec(n))
+ enddo
+ resit(2)=Res5(1,mu2t(2))
+ goto 111
+ elseif (nleg.eq.4) then
+ do n=1,nsol
+ resi4(n)=Res4(1,q2(n,:),mu2vec(n))
+ enddo
+ resit(2)=Res4(1,qt,mu2t(2))
+ goto 121
+ elseif (nleg.eq.3) then
+ do n=1,nsol
+ resi3(n)=Res3(1,q2(n,:),mu2vec(n))
+ enddo
+ resit(2)=Res3(1,qt,mu2t(2))
+ goto 131
+ elseif (nleg.eq.2) then
+ goto 136
+ else
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(:)=cone
+ dens5t=cone
+ evalres=.false.
+
+ loop_110: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens5(:)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_110
+ else
+ do n=1,nsol
+ dens5(n)=dens5(n)*denevalmu2(nleg,i,&
+ &q2(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens5t=dens5t*denevalmu2(nleg,i,qt,Vi,msq,&
+ &mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_110
+
+ if (evalres) then
+ do n=1,nsol
+ resi5(n)=resi5(n)+dens5(n)*res5(dicut5,mu2vec(n))
+ enddo
+ resit(2)=resit(2)+dens5t*res5(dicut5,mu2t(2))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ endif
+
+ 111 continue
+
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4(:)=cone
+ dens4t=cone
+ evalres=.false.
+
+ loop_120: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3).and.&
+ &(i.ne.i4)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens4(:)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_120
+ else
+ do n=1,nsol
+ dens4(n)=dens4(n)*denevalmu2(nleg,i,&
+ &q2(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,&
+ &mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_120
+
+ if (evalres) then
+ do n=1,nsol
+ resi4(n)=resi4(n)+dens4(n)*Res4(dicut4,q2(n,:),&
+ &mu2vec(n))
+ enddo
+ resit(2)=resit(2)+dens4t*Res4(dicut4,qt,mu2t(2))
+ endif
+
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+
+ 121 continue
+
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ loop_dicut3: do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens3(:)=cone
+ dens3t=cone
+ evalres=.false.
+ loop_130: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ if ((i.eq.j1).or.(i.eq.j2)) then
+ dens3(:)=czip
+ dens3t=czip
+ evalres=.false.
+ exit loop_130
+ else
+ do n=1,nsol
+ dens3(n)=dens3(n)&
+ & *denevalmu2(nleg,i,q2(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens3t=dens3t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_130
+
+ if (evalres) then
+ do n=1,nsol
+ resi3(n)=resi3(n)+dens3(n)*Res3(dicut3,q2(n,:),&
+ &mu2vec(n))
+ enddo
+ resit(2)=resit(2)+dens3t*Res3(dicut3,qt,mu2t(2))
+ endif
+
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo loop_dicut3
+ !---#] Contributo dei Triple cuts:
+
+ 131 continue
+
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2)) then
+ do n=1,nsol
+ dens2(n)=dens2(n)*denevalmu2(nleg,i,q2(n,:),Vi,msq,mu2vec(n))
+ enddo
+ denst(2)=denst(2)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(2))
+ endif
+ enddo
+
+ 136 continue
+
+ do n=1,nsol
+ xneval(n)=numeval(cut2,q2(n,:),mu2vec(n))
+ enddo
+
+ if (imeth.eq.'diag') then
+ known(:)=(xneval(:)-resi5(:)-resi4(:)-resi3(:))/dens2(:)
+ elseif (imeth.eq.'tree') then
+ known(:)=xneval(:)-(resi5(:)+resi4(:)+resi3(:))/dens2(:)
+ endif
+
+ if (diff.eq.1) then
+ ! rank1 c-system: 4 coefficients
+
+ do m=0,1
+ f2(m)=effe(known,1,2,m)
+ enddo
+
+ do m=2,3
+ mx=m-2
+ f2(m)=effe(known,3,2,mx)
+ enddo
+
+ !---#[ getc2_S1:
+ !----#[ original code:
+! c2(0) = f2(0)
+! c2(1) = (-f2(0) + f2(2))/(KB*MP12(2))
+! c2(3) = (KK(2)*(f2(1) - Fzc*f2(3)))/((-one + Fpc*Fzc)*MP12(2))
+! c2(5) = (-(Fpc*MP12(2)*c2(3)) - KK(2)*f2(3))/(KK(2)**2*MP12(2))
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = f2(0)
+ c2(0) = t1
+ c2(1) = ((f2(2)-t1)/(KB*MP12(2)))
+ t1 = f2(3)
+ c2(3) = ((f2(1)-t1*Fzc)/((Fpc*Fzc-one)*MP12(2))*KK(2))
+ c2(5) = ((-(Fpc*MP12(2)*c2(3)+t1*KK(2)))/(KK(2)*KK(2)*MP12(2)))
+ !----#] HAGGIES:
+ !---#] getc2_S1:
+ else
+ ! traditional system
+ do m=0,2
+ f2(m)=effe(known,1,3,m)
+ enddo
+ do m=3,4
+ mx=m-3
+ f2(m)=effe(known,4,2,mx)
+ enddo
+ do m=5,6
+ mx=m-5
+ f2(m)=effe(known,6,2,mx)
+ enddo
+ f2(7)=known(8)
+ f2(8)=known(9)
+ f2(9)=known(10)
+
+ !---#[ getc2_S2:
+ !----#[ original code:
+! !--- coefficienti
+! Fpcpow2 = Fpc*Fpc
+! Fpcpow3 = Fpcpow2*Fpc
+! Fpcpow4 = Fpcpow3*Fpc
+! Fzcpow2 = Fzc*Fzc
+! Fzcpow3 = Fzcpow2*Fzc
+! Fzcpow4 = Fzcpow3*Fzc
+! Fzcpow5 = Fzcpow4*Fzc
+! Fzcpow6 = Fzcpow5*Fzc
+! tmp1 = one - Fpcpow2
+! c2(2) = (0.5_ki*(Fpcpow3*((one + Fzcpow4)*f2(0) + f2(1) - f2(3) + Fzc*&
+! &(Fzc*(f2(1) + (one + Fzcpow2)*f2(2) + Fzc*(-Fzc*f2(3) - f2(4))) - f2(4)))&
+! &+ Fpcpow4*(-f2(0) - Fzcpow2*f2(1) - Fzcpow4*f2(2) + f2(3) + Fzcpow3*f2(4))&
+! &+ Fmc**2*(tmp1*f2(0) + tmp1*Fzcpow2*f2(1) + tmp1*Fzcpow4*f2(2) + (-tmp1)&
+! &*f2(3) + (-tmp1)*Fzcpow3*f2(4)) + two*((-one - Fzcpow2 - Fzcpow4 + Fzcpow6)&
+! &*f2(0) + (-one - Fzcpow4)*f2(1) - f2(2) + Fzc*(-Fzc*f2(2) + Fzc*f2(3)&
+! &+ Fzcpow3*f2(3) + f2(4) + Fzcpow4*f2(4))) + f2(5) + f2(6) + Fmc*((one&
+! &+ Fzcpow4 + Fzcpow3*two + Fpcpow2*(-one - Fzcpow4 - Fzcpow3*two))*f2(0)&
+! &+ (one + Fzcpow2 + Fzcpow5*two + Fpcpow2*(-one - Fzcpow2 - Fzcpow5*two))*f2(1)&
+! &+ tmp1*Fzcpow2*f2(2) + (-tmp1)*f2(3) + Fzcpow4*(tmp1*f2(2) + (-tmp1)*f2(3))&
+! &- two*f2(4) + Fpcpow2*two*f2(4) - tmp1*Fzcpow3*(two*f2(3) + f2(4)) + Fzc&
+! &*(tmp1*two*f2(2) - tmp1*f2(4)) - f2(5) - Fpc*f2(6) + Fzcpow6*(f2(5) + Fpc&
+! &*f2(6) - f2(7)) + f2(7)) + Fpc*((-one - Fzcpow4)*f2(0) - f2(1) + f2(3)&
+! &+ f2(5) - f2(7) + Fzc*(f2(4) + Fzc*(-f2(1) - (one + Fzcpow2)*f2(2) + Fzc&
+! &*(Fzc*f2(3) + f2(4) + Fzcpow3*(-f2(5) + f2(7)))))) + Fzcpow6*(-f2(5) - f2(6)&
+! &- f2(8)) + f2(8) + Fpcpow2*((three + Fzcpow2*(one + Fzcpow2 - Fzcpow4)*two)&
+! &*f2(0) + two*f2(1) + two*f2(2) - f2(3) + Fzcpow4*(two*f2(1) + f2(2) - two&
+! &*f2(3)) + Fzcpow2*(f2(1) + two*f2(2) - two*f2(3)) - Fzcpow3*f2(4) - Fzc*two&
+! &*f2(4) - Fzcpow5*two*f2(4) - f2(5) - f2(8) + Fzcpow6*(f2(5) + f2(8)))))/&
+! &((-tmp1)*(-one + Fzcpow6)*MP12(2)**2)
+! c2(7) = (KK(2)*(f2(2) + Fpcpow2*(-(Fzcpow4*f2(1)) - f2(2) + Fzcpow2*(-f2(0)&
+! &+ f2(3)) + Fzcpow5*f2(4)) + Fpcpow3*(-((one + Fzcpow4)*f2(0))&
+! &- (one + Fzcpow2)*(f2(1) + Fzcpow2*f2(2)) + (one + Fzcpow4)*f2(3) &
+! &+ (Fzc + Fzcpow3)*f2(4)) - f2(6) + Fzcpow2*(f2(0) - f2(3) +&
+! &Fzcpow2*(f2(1) + Fzc*(-f2(4) + Fzc*f2(6)))) +&
+! &Fpc*((one + Fzcpow4)*f2(0) + f2(1) - f2(3) - f2(5) +&
+! &Fzc*(Fzc*(f2(1) + f2(2)) + Fzcpow3*(f2(2) - f2(3)) -&
+! &f2(4) - Fzcpow2*f2(4) + Fzcpow5*(f2(5) - f2(7))) +&
+! &f2(7))))/((-tmp1)*(-one + Fzcpow6)*MP12(2)**2)
+! c2(8) = ((-tmp1)*(one + Fzcpow3 + Fzcpow4)*f2(0) +&
+! &(-tmp1)*(one + Fzcpow2 + Fzcpow5)*f2(1) + (-tmp1)*Fzcpow2*f2(2) +&
+! &(-tmp1)*Fzcpow4*(f2(2) - f2(3)) + f2(3) + (-tmp1)*Fzc*(f2(2) - f2(4))&
+! &+ f2(4) - (-tmp1)*Fzcpow3*(f2(3) + f2(4)) + f2(5) +&
+! &Fpc*(-(Fpc*(f2(3) + f2(4))) + f2(6)) - Fzcpow6*(f2(5) + Fpc*f2(6) - f2(7))&
+! &- f2(7))/ ((-tmp1)*(-one + Fzcpow6)*KK(2)*MP12(2)**2)
+! c2(4) = -((KK(2)**2*(f2(1) + Fzcpow2*f2(2) + Fzcpow4*(f2(0) - f2(3)) -&
+! &Fzc*f2(4)))/((-one + Fzcpow6)*MP12(2)**2))
+! c2(5) = (Fzcpow3*f2(0) + Fzcpow5*f2(1) + Fzc*f2(2) - Fzcpow3*f2(3) -&
+! &f2(4))/(KK(2)*MP12(2) - Fzcpow6*KK(2)*MP12(2))
+! c2(3) = (KK(2)*(f2(2) + Fzcpow2*(f2(0) - f2(3) + Fzcpow2*(f2(1)&
+! - Fzc*f2(4)))))/((-one + Fzcpow6)*MP12(2))
+! c2(6) = (f2(0) - f2(3) + Fzcpow2*(f2(1) + Fzc*(Fzc*f2(2) - f2(4))))/&
+! &((-one + Fzcpow6)*KK(2)**2*MP12(2)**2)
+! c2(0) = f2(0)
+! c2(9) = (KK(2)*MP12(2)*c2(3) - MP12(2)**2*c2(4)&
+! &+ F1zc*KK(2)**3*MP12(2)*c2(5) - F1zc**2*KK(2)**4*MP12(2)**2*c2(6) &
+! &+ KK(2)**2*(-c2(0) + f2(9)))/(KK(2)**2*mu2g(2))
+! c2(1) = -(c2(3)/KK(2)) - Fmc*KK(2)*c2(5) + (MP12(2)*(c2(4) + KK(2)*(c2(7)&
+! &+ KK(2)*(c2(2) + Fmc*KK(2)*(Fmc*KK(2)*c2(6) + c2(8))))))/KK(2)**2&
+! &+ (c2(0) - f2(8))/MP12(2)
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = (1.0_ki)+Fpc
+ t2 = Fzc*Fzc
+ t3 = t2*Fzc
+ t4 = t3-(1.0_ki)
+ t5 = (1.0_ki)+t3
+ t6 = f2(2)
+ t7 = t2*t2
+ t8 = -(t7+(1.0_ki))
+ t9 = f2(1)
+ t10 = t3*t3
+ t11 = f2(0)
+ t12 = f2(4)
+ t13 = t6*Fzc
+ t14 = f2(3)
+ t15 = t14*Fzc
+ t16 = t15*t2
+ t17 = f2(5)
+ t18 = f2(6)
+ t19 = f2(8)
+ t20 = t9-t14
+ t21 = (1.0_ki)+t7
+ t22 = t11*t21
+ t23 = (1.0_ki)+t2
+ t24 = t23*t6
+ t25 = Fpc*Fpc
+ t26 = t14-t11
+ t27 = t12*Fzc
+ t28 = t2*t27
+ t29 = ((1.0_ki)-Fpc)*t1
+ t30 = t14*t29
+ t31 = t29*t6
+ t32 = t12*t29
+ t33 = f2(7)
+ t34 = t6+t9
+ t35 = t27*t7
+ t36 = t6-t14
+ t37 = t17-t33
+ t38 = t18*Fpc
+ t39 = (t37+t38)*t10
+ t40 = t7*Fzc
+ t41 = (2.0_ki)*t40
+ t42 = (2.0_ki)*t3
+ t43 = t2*t31
+ t44 = MP12(2)*MP12(2)
+ t45 = t29*t4*t44*t5
+ c2(2) = (-1.0_ki)*((2.0_ki)*((t10-(t7+t2+(1.0_ki)))*t11+(t12+t15+t&
+ &16+t12*t7-t13)*Fzc+t8*t9-t6)+t17+t18+t19+(-(t19+t18+t17))*t10+(t26&
+ &+t28-(t6*t7+t2*t9))*t25*t25+(t11*t29+t31*t7+t2*t29*t9-(t2*t32*Fzc+&
+ &t30))*Fmc*Fmc+(t14+t17+(t12+((t12+t15+(t33-t17)*t2*Fzc)*Fzc-(t9+t24))&
+ &*Fzc)*Fzc+t11*t8-(t9+t33))*Fpc+((2.0_ki)*(t34-(t35+t27))+((3.0_ki)+(&
+ &2.0_ki)*((1.0_ki)+t2-t7)*t2)*t11+(t17+t19)*t10+((2.0_ki)*t20+t6)*&
+ &t7+((2.0_ki)*t36+t9)*t2-(t28+t19+t17+t14))*t25+((2.0_ki)*(t12*t25&
+ &-t12)+t33+t39+t43+(t31-t30)*t7+((2.0_ki)*t31-t32)*Fzc+((1.0_ki)+t2&
+ &+t41+(-(t41+t2+(1.0_ki)))*t25)*t9+((1.0_ki)+t42+t7+(-(t7+t42+(1.0&
+ &_ki)))*t25)*t11-((t12+(2.0_ki)*t14)*t2*t29*Fzc+t38+t30+t17))*Fmc+(t&
+ &20+t22+((t24+t9+(-(t15+t12))*Fzc)*Fzc-t12)*Fzc)*t25*Fpc)/t45*0.5_ki
+ t8 = t11-t14
+ t10 = t2*t6
+ c2(7) = (-1.0_ki)*(t6+(t8+(t9+(t18*Fzc-t12)*Fzc)*t2)*t2+(t35+t2*t26-&
+ &(t7*t9+t6))*t25+(t20+t22+t33+(t34*Fzc+t2*t36*Fzc+t37*t7*Fzc-(t12*t2+&
+ &t12))*Fzc-t17)*Fpc+((t3+Fzc)*t12+t14*t21-((t10+t9)*t23+t22))*t25*Fpc-&
+ &t18)/t45*KK(2)
+ t14 = t12+t14
+ c2(8) = ((t14+t17+(t18-t14*Fpc)*Fpc+t14*t2*t29*Fzc-(t29*t36*t7+((1.0_&
+ &ki)+t3+t7)*t11*t29+((1.0_ki)+t2+t40)*t29*t9+(t6-t12)*t29*Fzc+t43+t&
+ &39+t33))/((Fpc-(1.0_ki))*t1*t4*t44*t5*KK(2)))
+ t1 = KK(2)*KK(2)
+ t3 = t4*t5
+ c2(4) = (-1.0_ki)*(t10+t9+t7*t8-t27)/(t3*t44)*t1
+ c2(5) = (-1.0_ki)*(t13+t11*t2*Fzc+t7*t9*Fzc-(t16+t12))/(t3*KK(2)*MP1&
+ &2(2))
+ c2(3) = ((t6+(t8+(t9-t27)*t2)*t2)/(t3*MP12(2))*KK(2))
+ t4 = KK(2)*MP12(2)
+ c2(6) = ((t8+(t9+(t13-t12)*Fzc)*t2)/(t3*t4*t4))
+ c2(0) = t11
+ t2 = t1*F1zc*MP12(2)
+ c2(9) = (((f2(9)-c2(0))*t1+t4*c2(3)+t1*F1zc*KK(2)*MP12(2)*c2(5)-(t4&
+ &4*c2(4)+t2*t2*c2(6)))/(t1*mu2g(2)))
+ t2 = Fmc*KK(2)
+ c2(1) = ((c2(0)-t19)/MP12(2)+(c2(4)+(c2(7)+(c2(2)+(c2(8)+t2*c2(6))&
+ &*Fmc*KK(2))*KK(2))*KK(2))/t1*MP12(2)-(c2(3)/KK(2)+t2*c2(5)))
+ !----#] HAGGIES:
+ !---#] getc2_S2:
+ endif
+ !---#] Decomposizione standard:
+ endif
+
+ if (diff.ge.1) then
+ c2(2)=czip
+ c2(4)=czip
+ c2(6)=czip
+ c2(7)=czip
+ c2(8)=czip
+ c2(9)=czip
+ if (diff.ge.2) then
+ c2(1)=czip
+ c2(3)=czip
+ c2(5)=czip
+ endif
+ endif
+ end subroutine getc2_cm
+
+end module mgetc2
+
diff --git a/samurai-2.1.1/mgetc3.f90 b/samurai-2.1.1/mgetc3.f90
new file mode 100644
index 0000000..58b5c53
--- /dev/null
+++ b/samurai-2.1.1/mgetc3.f90
@@ -0,0 +1,1286 @@
+module mgetc3
+ use precision, only: ki
+ use constants
+ use options
+ use mfunctions
+ use mrestore
+ implicit none
+
+ private
+
+ interface getc3
+ module procedure getc3_rm
+ module procedure getc3_cm
+ end interface getc3
+
+
+ public :: getc3
+
+contains
+
+ subroutine getc3_cm(numeval,nleg,rank,c3,cut3,q3,qt,Vi,msq)
+ use mglobal, only: C0c,C1c,mu2g,MP12,KK,mu2t,resit,denst,mu2test
+ implicit none
+ integer, intent(in) :: nleg, rank, cut3
+ complex(ki), dimension(0:9), intent(out) :: c3
+ complex(ki), dimension(10,4), intent(in) :: q3
+ complex(ki), dimension(4), intent(in) :: qt
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(10) :: mu2vec
+
+ integer :: i,m,n,i1,i2,i3,i4,i5,dicut5,dicut4,mx,j1,j2,j3,diff
+ integer :: nsol, acc
+ complex(ki), dimension(10) :: dens3,dens4,dens5,xneval
+ complex(ki), dimension(10) :: resi5,resi4,known
+ complex(ki), dimension(0:9) :: f3
+ complex(ki) :: dens4t,dens5t
+ logical evalres
+
+ !!! TR: I have used haggies to rewrite the systems.
+ !---#[ HAGGIES:
+ complex(ki) :: t1
+ complex(ki) :: t2
+ complex(ki) :: t3
+ complex(ki) :: t4
+ complex(ki) :: t5
+ complex(ki) :: t6
+ complex(ki) :: t7
+ complex(ki) :: t8
+ complex(ki) :: t9
+ complex(ki) :: t10
+ complex(ki) :: t11
+ complex(ki) :: t12
+ complex(ki) :: t13
+ complex(ki) :: t14
+ complex(ki) :: t15
+ complex(ki) :: t16
+ complex(ki) :: t17
+ complex(ki) :: t18
+ complex(ki) :: t19
+ complex(ki) :: t20
+ complex(ki) :: t21
+ complex(ki) :: t22
+ complex(ki) :: t23
+ complex(ki) :: t24
+ complex(ki) :: t25
+ complex(ki) :: t26
+ complex(ki) :: t27
+ !---#] HAGGIES:
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ mu2test(3) = mu2t(3)
+
+ j3=cut3/100
+ acc = j3*100
+ j2=(cut3-acc)/10
+ j1=cut3-acc-j2*10
+
+ resi5(:)=czip
+ resi4(:)=czip
+ known(:)=czip
+ xneval(:)=czip
+ dens3(:)=cone
+
+ !--- for lnntest
+ resit(3)=czip
+ denst(3)=cone
+
+ !--- for simplified sampling
+ diff = nleg-rank
+
+ if_diff: if (diff.ge.3) then
+ ! simplified sampling -- only c3(0)
+
+ select case(nleg)
+ case(5)
+ resi5(1)=res5(1,czip)
+ resit(3)=res5(1,mu2t(3))
+ goto 11
+ case(4)
+ resi4(1)=Res4(1,q3(1,:),czip)
+ resit(3) =res4(1,qt,mu2t(3))
+ goto 21
+ case(3)
+ goto 26
+ case default
+ dicut5=1
+ loop_i5: do i5=4,nleg-1
+ loop_i4: do i4=3,i5-1
+ loop_i3: do i3=2,i4-1
+ loop_i2: do i2=1,i3-1
+ loop_i1: do i1=0,i2-1
+
+ dens5(1)=cone
+ dens5t=cone
+
+ evalres=.false.
+
+ loop_10: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3)&
+ & .and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2).or.(i.eq.j3)) then
+ dens5(1)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_10
+ else
+ dens5(1)=dens5(1)&
+ &*denevalmu2(nleg,i,q3(1,:),Vi,msq,czip)
+ dens5t=dens5t&
+ &*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_10
+
+ if (evalres) then
+ resi5(1)=resi5(1)+dens5(1)*res5(dicut5,czip)
+ resit(3)=resit(3)+dens5t*Res5(dicut5,mu2t(3))
+ endif
+
+ dicut5=dicut5+1
+ enddo loop_i1
+ enddo loop_i2
+ enddo loop_i3
+ enddo loop_i4
+ enddo loop_i5
+
+ end select
+
+ 11 continue
+
+ dicut4=1
+ loop_21: do i4=3,nleg-1
+ loop_21_i3: do i3=2,i4-1
+ loop_21_i2: do i2=1,i3-1
+ loop_21_i1: do i1=0,i2-1
+
+ dens4(1)=cone
+ dens4t=cone
+ evalres=.false.
+
+ loop_20: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)) then
+ if ((i.ne.j1).and.(i.ne.j2).and.(i.ne.j3)) then
+ dens4(1)=dens4(1)&
+ &*denevalmu2(nleg,i,q3(1,:),Vi,msq,czip)
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ evalres=.true.
+ else
+ dens4(1)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_20
+ endif
+ endif
+ enddo loop_20
+
+ if (evalres) then
+ resi4(1)=resi4(1)+dens4(1)*Res4(dicut4,q3(1,:),czip)
+ resit(3)=resit(3)+dens4t*Res4(dicut4,qt,mu2t(3))
+ endif
+
+ dicut4=dicut4+1
+ enddo loop_21_i1
+ enddo loop_21_i2
+ enddo loop_21_i3
+ enddo loop_21
+
+ 21 continue
+
+ loop_26: do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2).and.(i.ne.j3)) then
+ dens3(1)=dens3(1)*denevalmu2(nleg,i,q3(1,:),Vi,msq,czip)
+ denst(3)=denst(3)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ endif
+ enddo loop_26
+
+ 26 continue
+
+ xneval(1)=numeval(cut3,q3(1,:),czip)
+ if (imeth.eq.'diag') then
+ known(1)=(xneval(1)-resi5(1)-resi4(1))/dens3(1)
+ elseif (imeth.eq.'tree') then
+ known(1)=xneval(1)-(resi5(1)+resi4(1))/dens3(1)
+ endif
+
+ c3(0)=known(1)
+ do m=1,9
+ c3(m)=czip
+ enddo
+
+ else
+ if (abs(C0c-1.0_ki) .lt. C0_thrs) then
+ !---#[ New Sampling:
+ ! The new sampling is the one that is safe around C0=1
+ ! but not around C0=0
+
+ ! traditional system
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,mu2g(3),mu2g(3),mu2g(3)/)
+ nsol=10
+ !---#] New Sampling:
+ else
+ !---#[ Old Sampling:
+ ! The old sampling is the one that is safe around C0=0
+ ! but not around C0=1
+ if (diff.eq.2) then
+ ! rank1 c-system: 3 coefficients
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,czip,czip,czip/)
+ nsol=3
+ elseif (diff.eq.1) then
+ ! rank1 c-system: 3 coefficients
+ mu2vec=(/czip,czip,czip,czip,czip,mu2g(3),czip,czip,czip,czip/)
+ nsol=6
+ else
+ ! traditional system
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,mu2g(3),mu2g(3),mu2g(3)/)
+ nsol=10
+ endif
+ !---#] Old Sampling:
+ endif
+
+
+ if_nleg: if (nleg.eq.5) then
+ do n=1,nsol
+ resi5(n)=Res5(1,mu2vec(n))
+ enddo
+ resit(3)=Res5(1,mu2t(3))
+ goto 111
+ elseif (nleg.eq.4) then
+ do n=1,nsol
+ resi4(n)=Res4(1,q3(n,:),mu2vec(n))
+ enddo
+ resit(3)=Res4(1,qt,mu2t(3))
+ goto 121
+ elseif (nleg.eq.3) then
+ goto 126
+ else
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(:)=cone
+ dens5t=cone
+
+ evalres=.false.
+
+ loop_110: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.&
+ &(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2).or.(i.eq.j3)) then
+ dens5(:)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_110
+ else
+ do n=1,nsol
+ dens5(n)=dens5(n)*denevalmu2(nleg,i,&
+ &q3(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens5t=dens5t&
+ &*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_110
+
+ if (evalres) then
+ do n=1,nsol
+ resi5(n)=resi5(n)&
+ &+dens5(n)*res5(dicut5,mu2vec(n))
+ enddo
+ resit(3)=resit(3)+dens5t*res5(dicut5,mu2t(3))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ endif if_nleg
+
+ 111 continue
+
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+
+ dens4(:)=cone
+ dens4t=cone
+
+ evalres=.false.
+
+ loop_120: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)) then
+ if ((i.eq.j1).or.(i.eq.j2).or.(i.eq.j3)) then
+ dens4(:)=czip
+ dens4t=czip
+
+ evalres=.false.
+ exit loop_120
+ else
+ do n=1,nsol
+ dens4(n)=dens4(n)&
+ &*denevalmu2(nleg,i,q3(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens4t=dens4t&
+ &*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_120
+
+ if (evalres) then
+ do n=1,nsol
+ resi4(n)=resi4(n)&
+ & +dens4(n)*Res4(dicut4,q3(n,:),mu2vec(n))
+ enddo
+ resit(3)=resit(3)+dens4t*Res4(dicut4,qt,mu2t(3))
+ endif
+
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+
+ 121 continue
+
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2).and.(i.ne.j3)) then
+ do n=1,nsol
+ dens3(n)=dens3(n)*denevalmu2(nleg,i,q3(n,:),Vi,msq,mu2vec(n))
+ enddo
+ denst(3)=denst(3)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ endif
+ enddo
+
+ 126 continue
+
+ do n=1,nsol
+ xneval(n)=numeval(cut3,q3(n,:),mu2vec(n))
+ enddo
+
+ if (imeth.eq.'diag') then
+ known(:)=(xneval(:)-resi5(:)-resi4(:))/dens3(:)
+ elseif (imeth.eq.'tree') then
+ known(:)=xneval(:)-(resi5(:)+resi4(:))/dens3(:)
+ endif
+
+ if (abs(C0c-1.0_ki) .lt. C0_thrs) then
+ !---#[ New Sampling:
+ ! The new sampling is the one that is safe around C0=1
+ ! but not around C0=0
+
+ ! traditional system
+
+ do m=0,6
+ f3(m)=effe(known,1,7,m)
+ enddo
+
+ do m=7,9
+ mx=m-7
+ f3(m)=effe(known,8,3,mx)
+ enddo
+
+ !---#[ getc3_S3:
+ c3(0) = f3(0)
+ c3(1) = -(f3(6)/(C0c*MP12(3)))
+ c3(2) = f3(5)/(C0c**2*MP12(3)**2)
+ c3(3) = -(f3(4)/(C0c**3*MP12(3)**3))
+ c3(4) = -(f3(1)/MP12(3))
+ c3(5) = f3(2)/MP12(3)**2
+ c3(6) = -(f3(3)/MP12(3)**3)
+ c3(7) = (-f3(0) + MP12(3)**3*(-((C1c**3*f3(3))/MP12(3)**3) -&
+ &f3(4)/(C0c**3*MP12(3)**3)) + f3(7))/mu2g(3)
+ c3(8) = (C1c**2*f3(2) + f3(6)/C0c - f3(9))/(MP12(3)*mu2g(3))
+ c3(9) = (C1c*f3(1) + f3(5)/C0c**2 - f3(8))/(C1c*MP12(3)*mu2g(3))
+ !---#] getc3_S3:
+
+ !---#] New Sampling:
+ else
+ !---#[ Old Sampling:
+ ! The old sampling is the one that is safe around C0=0
+ ! but not around C0=1
+ select case(diff)
+ case(2)
+ ! rank1 c-system: 3 coefficients
+ f3(0:2)=known(1:3)
+ !---#[ getc3_S1:
+ !----#[ original code:
+ ! c3(0) = (f3(0) + f3(1))/two
+ ! c3(1) = -(KK(3)*((one + C0c)*f3(0) + f3(1) - C0c*f3(1) - two*f3(2)))/ &
+ ! (two*(-one + C0c**2)*MP12(3))
+ ! c3(4) = &
+ ! -((KK(3)*c3(0) + C0c*MP12(3)*c3(1) - KK(3)*f3(1))/(KK(3)**2*MP12(3)))
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = f3(0)
+ t2 = f3(1)
+ c3(0) = ((t1+t2)*0.5_ki)
+ t3 = KK(3)
+ t4 = MP12(3)
+ c3(1) = (-1.0_ki)*(t2+((1.0_ki)+C0c)*t1-(t2*C0c+(2.0_ki)*f3(2)))/((C&
+ &0c*C0c-(1.0_ki))*t4)*t3*0.5_ki
+ c3(4) = (-1.0_ki)*(t3*c3(0)+t4*C0c*c3(1)-t2*t3)/(t3*t3*t4)
+ !----#] HAGGIES:
+ !---#] getc3_S1:
+ case(1)
+ ! rank1 c-system: 3 coefficients
+ do m=0,2
+ f3(m)=effe(known,1,3,m)
+ enddo
+
+ do m=3,4
+ mx=m-3
+ f3(m)=effe(known,4,2,mx)
+ enddo
+
+ do m=5,5
+ mx=m-5
+ f3(m)=effe(known,6,1,mx)
+ enddo
+ !---#[ getc3_S2:
+ !----#[ original code:
+ !!$ c3(0) = f3(0)
+ !!$ c3(2) = &
+ !!$ & (KK(3)**2*(f3(0) - f3(3) + &
+ !!$ & C0c**2*(C0c**2*f3(1) + f3(2) - C0c*f3(4))))/&
+ !!$ & ((-one + C0c**6)*MP12(3)**2)
+ !!$ c3(4) = (C0c**2*MP12(3)*c3(2))/KK(3)**3 - f3(1)/(KK(3)*MP12(3))
+ !!$ c3(1) = -((KK(3)*(C0c*KK(3)*MP12(3)*c3(4) + f3(4)))/MP12(3))
+ !!$ c3(5) = (C0c*MP12(3)*c3(1) + KK(3)*f3(2))/(KK(3)**3*MP12(3)**2)
+ !!$ c3(7) = &
+ !!$ & (MP12(3)*c3(1) - MP12(3)**2*c3(2) + C1c*MP12(3)*c3(4)-&
+ !!$ & C1c**2*MP12(3)**2*c3(5) + (-c3(0) + f3(5)))/mu2g(3)
+
+ ! c3(0) = f3(0)
+ ! c3(2) = &
+ ! & (f3(0) - f3(3) + &
+ ! & C0c**2*(C0c**2*f3(1) + f3(2) - C0c*f3(4)))/&
+ ! & ((-one + C0c**6)*MP12(3)**2)
+ ! c3(4) = C0c**2*MP12(3)*c3(2) - f3(1)/MP12(3)
+ ! c3(1) = -(C0c*MP12(3)*c3(4) + f3(4))/MP12(3)
+ ! c3(5) = (C0c*MP12(3)*c3(1) + f3(2))/MP12(3)**2
+ ! c3(7) = &
+ ! & (MP12(3)*c3(1) - MP12(3)**2*c3(2) + C1c*MP12(3)*c3(4)-&
+ ! & C1c**2*MP12(3)**2*c3(5) + (-c3(0) + f3(5)))/mu2g(3)
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = f3(0)
+ c3(0) = t1
+ t2 = C0c*C0c
+ t3 = t2*C0c
+
+ t4 = f3(2)
+ t5 = f3(1)
+ t6 = f3(4)
+ t7 = MP12(3)
+ t8 = t7*t7
+ c3(2) = ((t1+(t4+t2*t5-t6*C0c)*t2-f3(3))/((t3*t3-one)*t8))
+ c3(4) = (t2*t7*c3(2)-t5/t7)
+ t1 = t7*C0c
+ c3(1) = (-1.0_ki)*(t6+t1*c3(4))/t7
+ c3(5) = ((t4+t1*c3(1))/t8)
+ t1 = t7*C1c
+ c3(7) = ((f3(5)+t1*c3(4)+t7*c3(1)-(t8*c3(2)+t1*t1*c3(5)+c3(0)))/(m&
+ &u2g(3)))
+ !----#] HAGGIES:
+ !---#] getc3_S2:
+ case default
+ ! traditional system
+
+ do m=0,3
+ f3(m)=effe(known,1,4,m)
+ enddo
+
+ do m=4,6
+ mx=m-4
+ f3(m)=effe(known,5,3,mx)
+ enddo
+
+ do m=7,9
+ mx=m-7
+ f3(m)=effe(known,8,3,mx)
+ enddo
+
+ !---#[ getc3_S3:
+ !----#[ original code:
+ ! c3(0) = &
+ ! &f3(0)
+ ! c3(1) = &
+ ! & -((KK(3)*(C0c**5*f3(1) + C0c**2*f3(2) + C0c**11*f3(3) + &
+ ! & C0c**8*(f3(0) - f3(4)) - C0c**4*f3(5) - f3(6)))/ &
+ ! & ((-one + C0c**12)*MP12(3)))
+ ! c3(2) = &
+ ! & (KK(3)**2*(C0c*f3(1) + C0c**10*f3(2) + C0c**7*f3(3) + &
+ ! & C0c**4*(f3(0) - f3(4)) - f3(5) - C0c**8*f3(6)))/ &
+ ! & ((-one + C0c**12)*MP12(3)**2)
+ ! c3(3) = &
+ ! & -((KK(3)**3*(f3(0) + C0c**9*f3(1) + C0c**6*f3(2) + &
+ ! & C0c**3*f3(3) - f3(4) - C0c**8*f3(5) - C0c**4*f3(6)))/ &
+ ! & ((-one + C0c**12)*MP12(3)**3))
+ ! c3(4) = &
+ ! & (f3(1) + C0c**9*f3(2) + C0c**6*f3(3) + &
+ ! & C0c**3*(f3(0) - f3(4)) - C0c**11*f3(5) - C0c**7*f3(6))/ &
+ ! & ((-one + C0c**12)*KK(3)*MP12(3))
+ ! c3(5) = &
+ ! & (-(C0c**3*f3(1)) - f3(2) - C0c**9*f3(3) + &
+ ! & C0c**6*(-f3(0) + f3(4)) + C0c**2*f3(5) + C0c**10*f3(6))/ &
+ ! & ((-one + C0c**12)*KK(3)**2*MP12(3)**2)
+ ! c3(6) = &
+ ! & (C0c**6*f3(1) + C0c**3*f3(2) + f3(3) + &
+ ! & C0c**9*(f3(0) - f3(4)) - C0c**5*f3(5) - C0c*f3(6))/ &
+ ! & ((-one + C0c**12)*KK(3)**3*MP12(3)**3)
+ ! c3(7) = &
+ ! & ((C1c**3*KK(3)**3*(C0c**6*f3(1) + C0c**3*f3(2) + f3(3) + &
+ ! & C0c**9*(f3(0) - f3(4)) - C0c**5*f3(5) - C0c*f3(6)))/ &
+ ! & (-one + C0c**12) - &
+ ! & (KK(3)**3*(f3(0) + C0c**9*f3(1) + C0c**6*f3(2) + &
+ ! & C0c**3*f3(3) - f3(4) - C0c**8*f3(5) - C0c**4*f3(6)))/ &
+ ! & (-one + C0c**12) + KK(3)**3*(-f3(0) + f3(7)))/(KK(3)**3*mu2g(3))
+ ! c3(8) = &
+ ! & -((-((KK(3)*(C0c**5*f3(1) + C0c**2*f3(2) + C0c**11*f3(3) + &
+ ! & C0c**8*(f3(0) - f3(4)) - C0c**4*f3(5) - f3(6)))/ &
+ ! & (-one + C0c**12)) - &
+ ! & (C1c**2*KK(3)*(-(C0c**3*f3(1)) - f3(2) - C0c**9*f3(3) + &
+ ! & C0c**6*(-f3(0) + f3(4)) + C0c**2*f3(5) + &
+ ! & C0c**10*f3(6)))/(-one + C0c**12) + KK(3)*f3(9))/ &
+ ! & (MP12(3)*mu2g(3)))
+ ! c3(9) = &
+ ! & (-((C1c*KK(3)**2*(f3(1) + C0c**9*f3(2) + C0c**6*f3(3) + &
+ ! & C0c**3*(f3(0) - f3(4)) - C0c**11*f3(5) - &
+ ! & C0c**7*f3(6)))/(-one + C0c**12)) + &
+ ! & (KK(3)**2*(C0c*f3(1) + C0c**10*f3(2) + C0c**7*f3(3) + &
+ ! & C0c**4*(f3(0) - f3(4)) - f3(5) - C0c**8*f3(6)))/ &
+ ! & (-one + C0c**12) - KK(3)**2*f3(8))/(C1c*KK(3)**3*MP12(3)*mu2g(3))
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = f3(0)
+ c3(0) = t1
+ t2 = C0c*C0c
+ t3 = t2*C0c
+ t4 = t3*t3
+ t5 = f3(6)
+ t6 = f3(4)
+ t7 = t1-t6
+ t8 = t2*t2
+ t9 = t8*t8
+ t10 = f3(1)
+ t11 = t10*C0c
+ t12 = f3(2)
+ t13 = f3(3)
+ t14 = t13*C0c
+ t15 = t8*C0c
+ t15 = t15*t15
+ t16 = f3(5)
+ t17 = KK(3)
+ t18 = MP12(3)
+ t19 = (t11*t8+t12*t2+t14*t15+t7*t9-(t16*t8+t5))*t17
+ t3 = (t3-(1.0_ki))*((1.0_ki)+t3)*((1.0_ki)+t4)
+ t20 = t18*t3
+ c3(1) = (-1.0_ki)*t19/t20
+ t21 = t17*t17
+ t22 = (t11+t12*t15+t14*t4+t7*t8-(t5*t9+t16))*t21
+ t23 = t18*t18
+ c3(2) = (t22/(t23*t3))
+ t24 = (t7+t11*t9+t12*t4+t14*t2-(t5*t8+t16*t9))*t17*t21
+ c3(3) = (-1.0_ki)*t24/(t20*t23)
+ t7 = t7*C0c
+ t20 = t12*C0c
+ t23 = t16*C0c
+ t25 = t5*C0c
+ t26 = t10+t13*t4+t2*t7+t20*t9-(t25*t4+t15*t23)
+ t27 = t17*t18*t3
+ c3(4) = (t26/t27)
+ t5 = (t6-t1)*t4+t15*t5+t16*t2-(t14*t9+t11*t2+t12)
+ t6 = t17*t18
+ t11 = t6*t6
+ c3(5) = (t5/(t11*t3))
+ t2 = t13+t10*t4+t2*t20+t7*t9-(t23*t8+t25)
+ c3(6) = (t2/(t11*t27))
+ t4 = t17*C1c
+ t7 = mu2g(3)
+ c3(7) = (((f3(7)-t1)*t17*t21+t17*t2/t3*t4*t4*C1c-t24/t3)/(t17*t21*t&
+ &7))
+ c3(8) = (-1.0_ki)*(f3(9)*t17-(t17/t3*t5*C1c*C1c+t19/t3))/(t18*t7)
+ c3(9) = ((t22/t3-(t21*t26/t3*C1c+f3(8)*t21))/(t21*t6*t7*C1c))
+ !----#] HAGGIES:
+ !---#] getc3_S3:
+ end select
+ !---#] Old Sampling:
+ endif
+ end if if_diff
+
+ if (diff.ge.1) then
+ c3(3)=czip
+ c3(6)=czip
+ c3(8)=czip
+ c3(9)=czip
+ if (diff.ge.2) then
+ c3(2)=czip
+ c3(5)=czip
+ c3(7)=czip
+ if (diff.ge.3) then
+ c3(1)=czip
+ c3(4)=czip
+ endif
+ endif
+ endif
+ end subroutine getc3_cm
+
+ subroutine getc3_rm(numeval,nleg,rank,c3,cut3,q3,qt,Vi,msq)
+ use mglobal, only: C0,C1,mu2g,MP12,KK,mu2t,resit,denst,mu2test
+ use options, only: C0_thrs
+ implicit none
+ integer, intent(in) :: nleg, rank, cut3
+ complex(ki), dimension(0:9), intent(out) :: c3
+ complex(ki), dimension(10,4), intent(in) :: q3
+ complex(ki), dimension(4), intent(in) :: qt
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(10) :: mu2vec
+
+ integer :: i,m,n,i1,i2,i3,i4,i5,dicut5,dicut4,mx,j1,j2,j3,diff
+ integer :: nsol, acc
+ complex(ki), dimension(10) :: dens3,dens4,dens5,xneval
+ complex(ki), dimension(10) :: resi5,resi4,known
+ complex(ki), dimension(0:9) :: f3
+ complex(ki) :: dens4t,dens5t
+ logical evalres
+
+ !!! TR: I have used haggies to rewrite the systems.
+ !---#[ HAGGIES:
+ complex(ki) :: t1
+ complex(ki) :: t2
+ complex(ki) :: t3
+ complex(ki) :: t4
+ complex(ki) :: t5
+ complex(ki) :: t6
+ complex(ki) :: t7
+ complex(ki) :: t8
+ complex(ki) :: t9
+ complex(ki) :: t10
+ complex(ki) :: t11
+ complex(ki) :: t12
+ complex(ki) :: t13
+ complex(ki) :: t14
+ complex(ki) :: t15
+ complex(ki) :: t16
+ complex(ki) :: t17
+ complex(ki) :: t18
+ complex(ki) :: t19
+ complex(ki) :: t20
+ complex(ki) :: t21
+ complex(ki) :: t22
+ complex(ki) :: t23
+ complex(ki) :: t24
+ complex(ki) :: t25
+ complex(ki) :: t26
+ complex(ki) :: t27
+ !---#] HAGGIES:
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ mu2test(3) = mu2t(3)
+
+ j3=cut3/100
+ acc = j3*100
+ j2=(cut3-acc)/10
+ j1=cut3-acc-j2*10
+
+ resi5(:)=czip
+ resi4(:)=czip
+ known(:)=czip
+ xneval(:)=czip
+ dens3(:)=cone
+
+ !--- for lnntest
+ resit(3)=czip
+ denst(3)=cone
+
+ !--- for simplified sampling
+ diff = nleg-rank
+
+
+ if_diff: if (diff.ge.3) then
+ ! simplified sampling -- only c3(0)
+
+ select case(nleg)
+ case(5)
+ resi5(1)=res5(1,czip)
+ resit(3)=res5(1,mu2t(3))
+ goto 11
+ case(4)
+ resi4(1)=Res4(1,q3(1,:),czip)
+ resit(3) =res4(1,qt,mu2t(3))
+ goto 21
+ case(3)
+ goto 26
+ case default
+ dicut5=1
+ loop_i5: do i5=4,nleg-1
+ loop_i4: do i4=3,i5-1
+ loop_i3: do i3=2,i4-1
+ loop_i2: do i2=1,i3-1
+ loop_i1: do i1=0,i2-1
+
+ dens5(1)=cone
+ dens5t=cone
+
+ evalres=.false.
+
+ loop_10: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3)&
+ & .and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2).or.(i.eq.j3)) then
+ dens5(1)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_10
+ else
+ dens5(1)=dens5(1)&
+ &*denevalmu2(nleg,i,q3(1,:),Vi,msq,czip)
+ dens5t=dens5t&
+ &*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_10
+
+ if (evalres) then
+ resi5(1)=resi5(1)+dens5(1)*res5(dicut5,czip)
+ resit(3)=resit(3)+dens5t*Res5(dicut5,mu2t(3))
+ endif
+
+ dicut5=dicut5+1
+ enddo loop_i1
+ enddo loop_i2
+ enddo loop_i3
+ enddo loop_i4
+ enddo loop_i5
+
+ end select
+
+ 11 continue
+
+ dicut4=1
+ loop_21: do i4=3,nleg-1
+ loop_21_i3: do i3=2,i4-1
+ loop_21_i2: do i2=1,i3-1
+ loop_21_i1: do i1=0,i2-1
+
+ dens4(1)=cone
+ dens4t=cone
+ evalres=.false.
+
+ loop_20: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)) then
+ if ((i.ne.j1).and.(i.ne.j2).and.(i.ne.j3)) then
+ dens4(1)=dens4(1)&
+ &*denevalmu2(nleg,i,q3(1,:),Vi,msq,czip)
+ dens4t=dens4t*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ evalres=.true.
+ else
+ dens4(1)=czip
+ dens4t=czip
+ evalres=.false.
+ exit loop_20
+ endif
+ endif
+ enddo loop_20
+
+ if (evalres) then
+ resi4(1)=resi4(1)+dens4(1)*Res4(dicut4,q3(1,:),czip)
+ resit(3)=resit(3)+dens4t*Res4(dicut4,qt,mu2t(3))
+ endif
+
+ dicut4=dicut4+1
+ enddo loop_21_i1
+ enddo loop_21_i2
+ enddo loop_21_i3
+ enddo loop_21
+
+ 21 continue
+
+ loop_26: do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2).and.(i.ne.j3)) then
+ dens3(1)=dens3(1)*denevalmu2(nleg,i,q3(1,:),Vi,msq,czip)
+ denst(3)=denst(3)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ endif
+ enddo loop_26
+
+ 26 continue
+
+ xneval(1)=numeval(cut3,q3(1,:),czip)
+ if (imeth.eq.'diag') then
+ known(1)=(xneval(1)-resi5(1)-resi4(1))/dens3(1)
+ elseif (imeth.eq.'tree') then
+ known(1)=xneval(1)-(resi5(1)+resi4(1))/dens3(1)
+ endif
+
+ c3(0)=known(1)
+ do m=1,9
+ c3(m)=czip
+ enddo
+
+ else
+ if (abs(C0-1.0_ki) .lt. C0_thrs) then
+ !---#[ New Sampling:
+ ! The new sampling is the one that is safe around C0=1
+ ! but not around C0=0
+
+ ! traditional system
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,mu2g(3),mu2g(3),mu2g(3)/)
+ nsol=10
+ !---#] New Sampling:
+ else
+ !---#[ Old Sampling:
+ ! The old sampling is the one that is safe around C0=0
+ ! but not around C0=1
+ if (diff.eq.2) then
+ ! rank1 c-system: 3 coefficients
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,czip,czip,czip/)
+ nsol=3
+ elseif (diff.eq.1) then
+ ! rank1 c-system: 3 coefficients
+ mu2vec=(/czip,czip,czip,czip,czip,mu2g(3),czip,czip,czip,czip/)
+ nsol=6
+ else
+ ! traditional system
+ mu2vec=(/czip,czip,czip,czip,czip,czip,czip,mu2g(3),mu2g(3),mu2g(3)/)
+ nsol=10
+ endif
+ !---#] Old Sampling:
+ endif
+
+
+ if_nleg: if (nleg.eq.5) then
+ do n=1,nsol
+ resi5(n)=Res5(1,mu2vec(n))
+ enddo
+ resit(3)=Res5(1,mu2t(3))
+ goto 111
+ elseif (nleg.eq.4) then
+ do n=1,nsol
+ resi4(n)=Res4(1,q3(n,:),mu2vec(n))
+ enddo
+ resit(3)=Res4(1,qt,mu2t(3))
+ goto 121
+ elseif (nleg.eq.3) then
+ goto 126
+ else
+ dicut5=1
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5(:)=cone
+ dens5t=cone
+
+ evalres=.false.
+
+ loop_110: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.&
+ &(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2).or.(i.eq.j3)) then
+ dens5(:)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop_110
+ else
+ do n=1,nsol
+ dens5(n)=dens5(n)*denevalmu2(nleg,i,&
+ &q3(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens5t=dens5t&
+ &*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_110
+
+ if (evalres) then
+ do n=1,nsol
+ resi5(n)=resi5(n)&
+ &+dens5(n)*res5(dicut5,mu2vec(n))
+ enddo
+ resit(3)=resit(3)+dens5t*res5(dicut5,mu2t(3))
+ endif
+
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ endif if_nleg
+
+ 111 continue
+
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+
+ dens4(:)=cone
+ dens4t=cone
+
+ evalres=.false.
+
+ loop_120: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)) then
+ if ((i.eq.j1).or.(i.eq.j2).or.(i.eq.j3)) then
+ dens4(:)=czip
+ dens4t=czip
+
+ evalres=.false.
+ exit loop_120
+ else
+ do n=1,nsol
+ dens4(n)=dens4(n)&
+ &*denevalmu2(nleg,i,q3(n,:),Vi,msq,mu2vec(n))
+ enddo
+ dens4t=dens4t&
+ &*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ evalres=.true.
+ endif
+ endif
+ enddo loop_120
+
+ if (evalres) then
+ do n=1,nsol
+ resi4(n)=resi4(n)&
+ & +dens4(n)*Res4(dicut4,q3(n,:),mu2vec(n))
+ enddo
+ resit(3)=resit(3)+dens4t*Res4(dicut4,qt,mu2t(3))
+ endif
+
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+
+ 121 continue
+
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2).and.(i.ne.j3)) then
+ do n=1,nsol
+ dens3(n)=dens3(n)*denevalmu2(nleg,i,q3(n,:),Vi,msq,mu2vec(n))
+ enddo
+ denst(3)=denst(3)*denevalmu2(nleg,i,qt,Vi,msq,mu2t(3))
+ endif
+ enddo
+
+ 126 continue
+
+ do n=1,nsol
+ xneval(n)=numeval(cut3,q3(n,:),mu2vec(n))
+ enddo
+
+ if (imeth.eq.'diag') then
+ known(:)=(xneval(:)-resi5(:)-resi4(:))/dens3(:)
+ elseif (imeth.eq.'tree') then
+ known(:)=xneval(:)-(resi5(:)+resi4(:))/dens3(:)
+ endif
+
+ if (abs(C0-1.0_ki) .lt. C0_thrs) then
+ !---#[ New Sampling:
+ ! The new sampling is the one that is safe around C0=1
+ ! but not around C0=0
+
+ ! traditional system
+
+ do m=0,6
+ f3(m)=effe(known,1,7,m)
+ enddo
+
+ do m=7,9
+ mx=m-7
+ f3(m)=effe(known,8,3,mx)
+ enddo
+
+ !---#[ getc3_S3:
+ c3(0) = f3(0)
+ c3(1) = -(f3(6)/(C0*MP12(3)))
+ c3(2) = f3(5)/(C0**2*MP12(3)**2)
+ c3(3) = -(f3(4)/(C0**3*MP12(3)**3))
+ c3(4) = -(f3(1)/MP12(3))
+ c3(5) = f3(2)/MP12(3)**2
+ c3(6) = -(f3(3)/MP12(3)**3)
+ c3(7) = (-f3(0) + MP12(3)**3*(-((C1**3*f3(3))/MP12(3)**3) -&
+ &f3(4)/(C0**3*MP12(3)**3)) + f3(7))/mu2g(3)
+ c3(8) = (C1**2*f3(2) + f3(6)/C0 - f3(9))/(MP12(3)*mu2g(3))
+ c3(9) = (C1*f3(1) + f3(5)/C0**2 - f3(8))/(C1*MP12(3)*mu2g(3))
+ !---#] getc3_S3:
+
+ !---#] New Sampling:
+ else
+ !---#[ Old Sampling:
+ ! The old sampling is the one that is safe around C0=0
+ ! but not around C0=1
+ select case(diff)
+ case(2)
+ ! rank1 c-system: 3 coefficients
+ f3(0:2)=known(1:3)
+ !---#[ getc3_S1:
+ !----#[ original code:
+ ! c3(0) = (f3(0) + f3(1))/two
+ ! c3(1) = -(KK(3)*((one + C0)*f3(0) + f3(1) - C0*f3(1) - two*f3(2)))/ &
+ ! (two*(-one + C0**2)*MP12(3))
+ ! c3(4) = &
+ ! -((KK(3)*c3(0) + C0*MP12(3)*c3(1) - KK(3)*f3(1))/(KK(3)**2*MP12(3)))
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = f3(0)
+ t2 = f3(1)
+ c3(0) = ((t1+t2)*0.5_ki)
+ t3 = KK(3)
+ t4 = MP12(3)
+ c3(1) = (-1.0_ki)*(t2+((1.0_ki)+C0)*t1-(t2*C0+(2.0_ki)*f3(2)))/((C&
+ &0*C0-(1.0_ki))*t4)*t3*0.5_ki
+ c3(4) = (-1.0_ki)*(t3*c3(0)+t4*C0*c3(1)-t2*t3)/(t3*t3*t4)
+ !----#] HAGGIES:
+ !---#] getc3_S1:
+ case(1)
+ ! rank1 c-system: 3 coefficients
+ do m=0,2
+ f3(m)=effe(known,1,3,m)
+ enddo
+
+ do m=3,4
+ mx=m-3
+ f3(m)=effe(known,4,2,mx)
+ enddo
+
+ do m=5,5
+ mx=m-5
+ f3(m)=effe(known,6,1,mx)
+ enddo
+ !---#[ getc3_S2:
+ !----#[ original code:
+ !!$ c3(0) = f3(0)
+ !!$ c3(2) = &
+ !!$ & (KK(3)**2*(f3(0) - f3(3) + &
+ !!$ & C0**2*(C0**2*f3(1) + f3(2) - C0*f3(4))))/&
+ !!$ & ((-one + C0**6)*MP12(3)**2)
+ !!$ c3(4) = (C0**2*MP12(3)*c3(2))/KK(3)**3 - f3(1)/(KK(3)*MP12(3))
+ !!$ c3(1) = -((KK(3)*(C0*KK(3)*MP12(3)*c3(4) + f3(4)))/MP12(3))
+ !!$ c3(5) = (C0*MP12(3)*c3(1) + KK(3)*f3(2))/(KK(3)**3*MP12(3)**2)
+ !!$ c3(7) = &
+ !!$ & (MP12(3)*c3(1) - MP12(3)**2*c3(2) + C1*MP12(3)*c3(4)-&
+ !!$ & C1**2*MP12(3)**2*c3(5) + (-c3(0) + f3(5)))/mu2g(3)
+
+ ! c3(0) = f3(0)
+ ! c3(2) = &
+ ! & (f3(0) - f3(3) + &
+ ! & C0**2*(C0**2*f3(1) + f3(2) - C0*f3(4)))/&
+ ! & ((-one + C0**6)*MP12(3)**2)
+ ! c3(4) = C0**2*MP12(3)*c3(2) - f3(1)/MP12(3)
+ ! c3(1) = -(C0*MP12(3)*c3(4) + f3(4))/MP12(3)
+ ! c3(5) = (C0*MP12(3)*c3(1) + f3(2))/MP12(3)**2
+ ! c3(7) = &
+ ! & (MP12(3)*c3(1) - MP12(3)**2*c3(2) + C1*MP12(3)*c3(4)-&
+ ! & C1**2*MP12(3)**2*c3(5) + (-c3(0) + f3(5)))/mu2g(3)
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = f3(0)
+ c3(0) = t1
+ t2 = C0*C0
+ t3 = t2*C0
+
+ t4 = f3(2)
+ t5 = f3(1)
+ t6 = f3(4)
+ t7 = MP12(3)
+ t8 = t7*t7
+ c3(2) = ((t1+(t4+t2*t5-t6*C0)*t2-f3(3))/((t3*t3-one)*t8))
+ c3(4) = (t2*t7*c3(2)-t5/t7)
+ t1 = t7*C0
+ c3(1) = (-1.0_ki)*(t6+t1*c3(4))/t7
+ c3(5) = ((t4+t1*c3(1))/t8)
+ t1 = t7*C1
+ c3(7) = ((f3(5)+t1*c3(4)+t7*c3(1)-(t8*c3(2)+t1*t1*c3(5)+c3(0)))/(m&
+ &u2g(3)))
+ !----#] HAGGIES:
+ !---#] getc3_S2:
+ case default
+ ! traditional system
+
+ do m=0,3
+ f3(m)=effe(known,1,4,m)
+ enddo
+
+ do m=4,6
+ mx=m-4
+ f3(m)=effe(known,5,3,mx)
+ enddo
+
+ do m=7,9
+ mx=m-7
+ f3(m)=effe(known,8,3,mx)
+ enddo
+
+ !---#[ getc3_S3:
+ !----#[ original code:
+ ! c3(0) = &
+ ! &f3(0)
+ ! c3(1) = &
+ ! & -((KK(3)*(C0**5*f3(1) + C0**2*f3(2) + C0**11*f3(3) + &
+ ! & C0**8*(f3(0) - f3(4)) - C0**4*f3(5) - f3(6)))/ &
+ ! & ((-one + C0**12)*MP12(3)))
+ ! c3(2) = &
+ ! & (KK(3)**2*(C0*f3(1) + C0**10*f3(2) + C0**7*f3(3) + &
+ ! & C0**4*(f3(0) - f3(4)) - f3(5) - C0**8*f3(6)))/ &
+ ! & ((-one + C0**12)*MP12(3)**2)
+ ! c3(3) = &
+ ! & -((KK(3)**3*(f3(0) + C0**9*f3(1) + C0**6*f3(2) + &
+ ! & C0**3*f3(3) - f3(4) - C0**8*f3(5) - C0**4*f3(6)))/ &
+ ! & ((-one + C0**12)*MP12(3)**3))
+ ! c3(4) = &
+ ! & (f3(1) + C0**9*f3(2) + C0**6*f3(3) + &
+ ! & C0**3*(f3(0) - f3(4)) - C0**11*f3(5) - C0**7*f3(6))/ &
+ ! & ((-one + C0**12)*KK(3)*MP12(3))
+ ! c3(5) = &
+ ! & (-(C0**3*f3(1)) - f3(2) - C0**9*f3(3) + &
+ ! & C0**6*(-f3(0) + f3(4)) + C0**2*f3(5) + C0**10*f3(6))/ &
+ ! & ((-one + C0**12)*KK(3)**2*MP12(3)**2)
+ ! c3(6) = &
+ ! & (C0**6*f3(1) + C0**3*f3(2) + f3(3) + &
+ ! & C0**9*(f3(0) - f3(4)) - C0**5*f3(5) - C0*f3(6))/ &
+ ! & ((-one + C0**12)*KK(3)**3*MP12(3)**3)
+ ! c3(7) = &
+ ! & ((C1**3*KK(3)**3*(C0**6*f3(1) + C0**3*f3(2) + f3(3) + &
+ ! & C0**9*(f3(0) - f3(4)) - C0**5*f3(5) - C0*f3(6)))/ &
+ ! & (-one + C0**12) - &
+ ! & (KK(3)**3*(f3(0) + C0**9*f3(1) + C0**6*f3(2) + &
+ ! & C0**3*f3(3) - f3(4) - C0**8*f3(5) - C0**4*f3(6)))/ &
+ ! & (-one + C0**12) + KK(3)**3*(-f3(0) + f3(7)))/(KK(3)**3*mu2g(3))
+ ! c3(8) = &
+ ! & -((-((KK(3)*(C0**5*f3(1) + C0**2*f3(2) + C0**11*f3(3) + &
+ ! & C0**8*(f3(0) - f3(4)) - C0**4*f3(5) - f3(6)))/ &
+ ! & (-one + C0**12)) - &
+ ! & (C1**2*KK(3)*(-(C0**3*f3(1)) - f3(2) - C0**9*f3(3) + &
+ ! & C0**6*(-f3(0) + f3(4)) + C0**2*f3(5) + &
+ ! & C0**10*f3(6)))/(-one + C0**12) + KK(3)*f3(9))/ &
+ ! & (MP12(3)*mu2g(3)))
+ ! c3(9) = &
+ ! & (-((C1*KK(3)**2*(f3(1) + C0**9*f3(2) + C0**6*f3(3) + &
+ ! & C0**3*(f3(0) - f3(4)) - C0**11*f3(5) - &
+ ! & C0**7*f3(6)))/(-one + C0**12)) + &
+ ! & (KK(3)**2*(C0*f3(1) + C0**10*f3(2) + C0**7*f3(3) + &
+ ! & C0**4*(f3(0) - f3(4)) - f3(5) - C0**8*f3(6)))/ &
+ ! & (-one + C0**12) - KK(3)**2*f3(8))/(C1*KK(3)**3*MP12(3)*mu2g(3))
+ !----#] original code:
+ !----#[ HAGGIES:
+ t1 = f3(0)
+ c3(0) = t1
+ t2 = C0*C0
+ t3 = t2*C0
+ t4 = t3*t3
+ t5 = f3(6)
+ t6 = f3(4)
+ t7 = t1-t6
+ t8 = t2*t2
+ t9 = t8*t8
+ t10 = f3(1)
+ t11 = t10*C0
+ t12 = f3(2)
+ t13 = f3(3)
+ t14 = t13*C0
+ t15 = t8*C0
+ t15 = t15*t15
+ t16 = f3(5)
+ t17 = KK(3)
+ t18 = MP12(3)
+ t19 = (t11*t8+t12*t2+t14*t15+t7*t9-(t16*t8+t5))*t17
+ t3 = (t3-(1.0_ki))*((1.0_ki)+t3)*((1.0_ki)+t4)
+ t20 = t18*t3
+ c3(1) = (-1.0_ki)*t19/t20
+ t21 = t17*t17
+ t22 = (t11+t12*t15+t14*t4+t7*t8-(t5*t9+t16))*t21
+ t23 = t18*t18
+ c3(2) = (t22/(t23*t3))
+ t24 = (t7+t11*t9+t12*t4+t14*t2-(t5*t8+t16*t9))*t17*t21
+ c3(3) = (-1.0_ki)*t24/(t20*t23)
+ t7 = t7*C0
+ t20 = t12*C0
+ t23 = t16*C0
+ t25 = t5*C0
+ t26 = t10+t13*t4+t2*t7+t20*t9-(t25*t4+t15*t23)
+ t27 = t17*t18*t3
+ c3(4) = (t26/t27)
+ t5 = (t6-t1)*t4+t15*t5+t16*t2-(t14*t9+t11*t2+t12)
+ t6 = t17*t18
+ t11 = t6*t6
+ c3(5) = (t5/(t11*t3))
+ t2 = t13+t10*t4+t2*t20+t7*t9-(t23*t8+t25)
+ c3(6) = (t2/(t11*t27))
+ t4 = t17*C1
+ t7 = mu2g(3)
+ c3(7) = (((f3(7)-t1)*t17*t21+t17*t2/t3*t4*t4*C1-t24/t3)/(t17*t21*t&
+ &7))
+ c3(8) = (-1.0_ki)*(f3(9)*t17-(t17/t3*t5*C1*C1+t19/t3))/(t18*t7)
+ c3(9) = ((t22/t3-(t21*t26/t3*C1+f3(8)*t21))/(t21*t6*t7*C1))
+ !----#] HAGGIES:
+ !---#] getc3_S3:
+ end select
+ !---#] Old Sampling:
+ endif
+ end if if_diff
+
+ if (diff.ge.1) then
+ c3(3)=czip
+ c3(6)=czip
+ c3(8)=czip
+ c3(9)=czip
+ if (diff.ge.2) then
+ c3(2)=czip
+ c3(5)=czip
+ c3(7)=czip
+ if (diff.ge.3) then
+ c3(1)=czip
+ c3(4)=czip
+ endif
+ endif
+ endif
+ end subroutine getc3_rm
+
+end module mgetc3
+
diff --git a/samurai-2.1.1/mgetc4.f90 b/samurai-2.1.1/mgetc4.f90
new file mode 100644
index 0000000..8c2216e
--- /dev/null
+++ b/samurai-2.1.1/mgetc4.f90
@@ -0,0 +1,320 @@
+module mgetc4
+ use precision, only: ki
+ use constants
+ use options
+ use mfunctions
+ use mrestore
+ implicit none
+
+ private
+
+ interface getc4
+ module procedure getc4_rm
+ module procedure getc4_cm
+ end interface getc4
+
+ public :: getc4
+
+contains
+
+ subroutine getc4_cm(numeval,nleg,rank,c4,cut4,q4,qt,p0,Vi,msq)
+ use mglobal, only: MP12,mu2g,mu2t,resit,denst,mu2test,dx
+ implicit none
+ integer, intent(in) :: nleg, rank, cut4
+ complex(ki), dimension(0:4), intent(out) :: c4
+ complex(ki), dimension(5,4), intent(in) :: q4
+ complex(ki), dimension(4), intent(in) :: qt
+ real(ki), dimension(4), intent(in) :: p0
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki) :: dens5t
+ integer :: i,m,i1,i2,i3,i4,i5,j1,j2,j3,j4
+ integer :: dicut5,diff, acc
+ complex(ki), dimension(5) :: dens5, dens4, xneval, resi5, f4
+ complex(ki), dimension(5) :: mu2vec
+ logical evalres
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ mu2test(4)=mu2t(4)
+ mu2vec = (/ czip, czip, mu2g(4), mu2g(4),-mu2g(4) /)
+
+ dens4(:)=cone
+ resi5(:)=czip
+ xneval(:)=czip
+
+!--- for lnntest
+ resit(4)=czip
+ denst(4)=cone
+
+!--- for simplified sampling
+ diff = nleg-rank
+
+ j4= cut4/1000
+ acc = j4*1000
+ j3=(cut4-acc)/100
+ acc = acc + j3*100
+ j2=(cut4-acc)/10
+ j1= cut4-acc-j2*10
+
+ nleg_ne_4: if (nleg.ne.4) then
+ nleg_eq_5: if (nleg.eq.5) then
+ do m=1,5
+ resi5(m)=Res5(1,mu2vec(m))
+ enddo
+ resit(4)=Res5(1,mu2t(4))
+ else
+ dicut5=1
+ loop_i5: do i5=4,nleg-1
+ loop_i4: do i4=3,i5-1
+ loop_i3: do i3=2,i4-1
+ loop_i2: do i2=1,i3-1
+ loop_i1: do i1=0,i2-1
+ dens5(:)=cone
+ dens5t=cone
+ evalres=.false.
+
+ loop110: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)&
+ & .and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2)&
+ & .or.(i.eq.j3).or.(i.eq.j4)) then
+ dens5(:)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop110
+ else
+ do m=1,5
+ dens5(m)=dens5(m)*denevalmu2(&
+ &nleg,i,q4(m,:),Vi,msq,mu2vec(m))
+ enddo
+ dens5t=dens5t*denevalmu2(&
+ &nleg,i,qt,Vi,msq,mu2t(4))
+ evalres=.true.
+ endif
+ endif
+ enddo loop110
+
+ if (evalres) then
+ do m=1,5
+ resi5(m)=resi5(m)+dens5(m)*&
+ & Res5(dicut5,mu2vec(m))
+ enddo
+ resit=resit+dens5t*Res5(dicut5,mu2t(4))
+ endif
+
+ dicut5=dicut5+1
+ enddo loop_i1
+ enddo loop_i2
+ enddo loop_i3
+ enddo loop_i4
+ enddo loop_i5
+
+ end if nleg_eq_5
+
+ ! 111 continue
+
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2) &
+ & .and.(i.ne.j3).and.(i.ne.j4)) then
+ do m=1,5
+ dens4(m)=dens4(m)*denevalmu2(nleg,i,q4(m,:),Vi,msq,mu2vec(m))
+ enddo
+ denst=denst*denevalmu2(nleg,i,qt,Vi,msq,mu2t(4))
+ endif
+ enddo
+ end if nleg_ne_4
+
+ ! 116 continue
+
+ do m=1,5
+ xneval(m)=numeval(cut4,q4(m,:),mu2vec(m))
+ enddo
+
+ if (imeth.eq.'diag') then
+ f4(:)=(xneval(:)-resi5(:))/dens4(:)
+ elseif (imeth.eq.'tree') then
+ f4(:)=xneval(:)-resi5(:)/dens4(:)
+ endif
+
+ c4(0)= (f4(1)+f4(2))/two
+ c4(1)= (f4(1)-f4(2))/(two*dx(1)*MP12(4))
+ c4(3)= -(two*dx(3)*MP12(4)*c4(1)-f4(3)+f4(4))/(two*dx(3)*MP12(4)*mu2g(4))
+ c4(2)= ((-dx(3)+dx(5))*MP12(4)*c4(1)-(dx(3)+dx(5))*MP12(4)*mu2g(4)*c4(3) &
+ & +f4(3)-f4(5))/(two*mu2g(4))
+ c4(4)= -((c4(0)+mu2g(4)*c4(2)+dx(3)*MP12(4)*(c4(1)+mu2g(4)*c4(3)) &
+ & -f4(3))/mu2g(4)**2)
+
+ if (diff.ge.1) then
+ c4(4)=czip
+ if (diff.ge.2) then
+ c4(3)=czip
+ if (diff.ge.3) then
+ c4(2)=czip
+ endif
+ endif
+ endif
+ end subroutine getc4_cm
+
+ subroutine getc4_rm(numeval,nleg,rank,c4,cut4,q4,qt,p0,Vi,msq)
+ use mglobal, only: MP12,mu2g,mu2t,resit,denst,mu2test,dx
+ implicit none
+ integer, intent(in) :: nleg, rank, cut4
+ complex(ki), dimension(0:4), intent(out) :: c4
+ complex(ki), dimension(5,4), intent(in) :: q4
+ complex(ki), dimension(4), intent(in) :: qt
+ real(ki), dimension(4), intent(in) :: p0
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki) :: dens5t
+ integer :: i,m,i1,i2,i3,i4,i5,j1,j2,j3,j4
+ integer :: dicut5,diff, acc
+ complex(ki), dimension(5) :: dens5, dens4, xneval, resi5, f4
+ complex(ki), dimension(5) :: mu2vec
+ logical evalres
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ mu2test(4)=mu2t(4)
+ mu2vec = (/ czip, czip, mu2g(4), mu2g(4),-mu2g(4) /)
+
+ dens4(:)=cone
+ resi5(:)=czip
+ xneval(:)=czip
+
+!--- for lnntest
+ resit(4)=czip
+ denst(4)=cone
+
+!--- for simplified sampling
+ diff = nleg-rank
+
+ j4= cut4/1000
+ acc = j4*1000
+ j3=(cut4-acc)/100
+ acc = acc + j3*100
+ j2=(cut4-acc)/10
+ j1= cut4-acc-j2*10
+
+ nleg_ne_4: if (nleg.ne.4) then
+ nleg_eq_5: if (nleg.eq.5) then
+ do m=1,5
+ resi5(m)=Res5(1,mu2vec(m))
+ enddo
+ resit(4)=Res5(1,mu2t(4))
+ else
+ dicut5=1
+ loop_i5: do i5=4,nleg-1
+ loop_i4: do i4=3,i5-1
+ loop_i3: do i3=2,i4-1
+ loop_i2: do i2=1,i3-1
+ loop_i1: do i1=0,i2-1
+ dens5(:)=cone
+ dens5t=cone
+ evalres=.false.
+
+ loop110: do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)&
+ & .and.(i.ne.i4).and.(i.ne.i5)) then
+ if ((i.eq.j1).or.(i.eq.j2)&
+ & .or.(i.eq.j3).or.(i.eq.j4)) then
+ dens5(:)=czip
+ dens5t=czip
+ evalres=.false.
+ exit loop110
+ else
+ do m=1,5
+ dens5(m)=dens5(m)*denevalmu2(&
+ &nleg,i,q4(m,:),Vi,msq,mu2vec(m))
+ enddo
+ dens5t=dens5t*denevalmu2(&
+ &nleg,i,qt,Vi,msq,mu2t(4))
+ evalres=.true.
+ endif
+ endif
+ enddo loop110
+
+ if (evalres) then
+ do m=1,5
+ resi5(m)=resi5(m)+dens5(m)*&
+ & Res5(dicut5,mu2vec(m))
+ enddo
+ resit=resit+dens5t*Res5(dicut5,mu2t(4))
+ endif
+
+ dicut5=dicut5+1
+ enddo loop_i1
+ enddo loop_i2
+ enddo loop_i3
+ enddo loop_i4
+ enddo loop_i5
+
+ end if nleg_eq_5
+
+ ! 111 continue
+
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2) &
+ & .and.(i.ne.j3).and.(i.ne.j4)) then
+ do m=1,5
+ dens4(m)=dens4(m)*denevalmu2(nleg,i,q4(m,:),Vi,msq,mu2vec(m))
+ enddo
+ denst=denst*denevalmu2(nleg,i,qt,Vi,msq,mu2t(4))
+ endif
+ enddo
+ end if nleg_ne_4
+
+ ! 116 continue
+
+ do m=1,5
+ xneval(m)=numeval(cut4,q4(m,:),mu2vec(m))
+ enddo
+
+ if (imeth.eq.'diag') then
+ f4(:)=(xneval(:)-resi5(:))/dens4(:)
+ elseif (imeth.eq.'tree') then
+ f4(:)=xneval(:)-resi5(:)/dens4(:)
+ endif
+
+ c4(0)= (f4(1)+f4(2))/two
+ c4(1)= (f4(1)-f4(2))/(two*dx(1)*MP12(4))
+ c4(3)= -(two*dx(3)*MP12(4)*c4(1)-f4(3)+f4(4))/(two*dx(3)*MP12(4)*mu2g(4))
+ c4(2)= ((-dx(3)+dx(5))*MP12(4)*c4(1)-(dx(3)+dx(5))*MP12(4)*mu2g(4)*c4(3) &
+ & +f4(3)-f4(5))/(two*mu2g(4))
+ c4(4)= -((c4(0)+mu2g(4)*c4(2)+dx(3)*MP12(4)*(c4(1)+mu2g(4)*c4(3)) &
+ & -f4(3))/mu2g(4)**2)
+
+ if (diff.ge.1) then
+ c4(4)=czip
+ if (diff.ge.2) then
+ c4(3)=czip
+ if (diff.ge.3) then
+ c4(2)=czip
+ endif
+ endif
+ endif
+ end subroutine getc4_rm
+
+end module mgetc4
+
+
+
+
diff --git a/samurai-2.1.1/mgetc5.f90 b/samurai-2.1.1/mgetc5.f90
new file mode 100644
index 0000000..f2e9cb1
--- /dev/null
+++ b/samurai-2.1.1/mgetc5.f90
@@ -0,0 +1,130 @@
+module mgetc5
+ use precision, only: ki
+ use constants
+ use options
+ use mfunctions
+ implicit none
+
+ private
+
+ interface getc5
+ module procedure getc5_rm
+ module procedure getc5_cm
+ end interface getc5
+
+ public :: getc5
+
+contains
+ subroutine getc5_cm(numeval,nleg,c5,cut5,Vi,msq,q5,mu2)
+ implicit none
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ integer, intent(in) :: nleg
+ complex(ki), intent(out) :: c5
+ integer, intent(in) :: cut5
+ real(ki), dimension(0:nleg-1, 4), intent(in) :: Vi
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(4) :: q5
+ complex(ki), intent(in) :: mu2
+
+ integer i,j1,j2,j3,j4,j5,acc
+ complex(ki) :: denoms
+
+ if (meth_is_diag) then
+ j5=cut5/10000
+ acc = j5*10000
+ j4=(cut5-acc)/1000
+ acc = acc + j4*1000
+ j3=(cut5-acc)/100
+ acc = acc + j3*100
+ j2=(cut5-acc)/10
+ j1= cut5-acc-j2*10
+
+ denoms=cone
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2).and.(i.ne.j3)&
+ & .and.(i.ne.j4).and.(i.ne.j5)) then
+ denoms=denoms*denevalmu2(nleg,i,q5,Vi,msq,mu2)
+ endif
+ enddo
+
+ c5=numeval(cut5,q5,mu2)/denoms/mu2
+ ! c5=numeval(cut5,q5,mu2)/denoms/mu2**2
+ elseif (meth_is_tree) then
+ c5=numeval(cut5,q5,mu2)/mu2
+ ! c5=numeval(cut5,q5,mu2)/mu2**2
+ else
+ print*, "imeth must be 'tree' or 'diag'"
+ stop
+ endif
+ end subroutine getc5_cm
+
+ subroutine getc5_rm(numeval,nleg,c5,cut5,Vi,msq,q5,mu2)
+ implicit none
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ integer, intent(in) :: nleg
+ complex(ki), intent(out) :: c5
+ integer, intent(in) :: cut5
+ real(ki), dimension(0:nleg-1, 4), intent(in) :: Vi
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(4) :: q5
+ complex(ki), intent(in) :: mu2
+
+ integer i,j1,j2,j3,j4,j5,acc
+ complex(ki) :: denoms
+
+ if (meth_is_diag) then
+ j5=cut5/10000
+ acc = j5*10000
+ j4=(cut5-acc)/1000
+ acc = acc + j4*1000
+ j3=(cut5-acc)/100
+ acc = acc + j3*100
+ j2=(cut5-acc)/10
+ j1= cut5-acc-j2*10
+
+ denoms=cone
+ do i=0,nleg-1
+ if ((i.ne.j1).and.(i.ne.j2).and.(i.ne.j3)&
+ & .and.(i.ne.j4).and.(i.ne.j5)) then
+ denoms=denoms*denevalmu2(nleg,i,q5,Vi,msq,mu2)
+ endif
+ enddo
+
+ c5=numeval(cut5,q5,mu2)/denoms/mu2
+ ! c5=numeval(cut5,q5,mu2)/denoms/mu2**2
+ elseif (meth_is_tree) then
+ c5=numeval(cut5,q5,mu2)/mu2
+ ! c5=numeval(cut5,q5,mu2)/mu2**2
+ else
+ print*, "imeth must be 'tree' or 'diag'"
+ stop
+ endif
+ end subroutine getc5_rm
+
+end module mgetc5
+
+
+
+
diff --git a/samurai-2.1.1/mgetqs.f90 b/samurai-2.1.1/mgetqs.f90
new file mode 100644
index 0000000..c716a60
--- /dev/null
+++ b/samurai-2.1.1/mgetqs.f90
@@ -0,0 +1,1199 @@
+module mgetqs
+ use precision
+ use constants
+ use mfunctions
+ implicit none
+
+ private
+
+ interface getq5
+ module procedure getq5_rm
+ module procedure getq5_cm
+ end interface getq5
+
+ interface getq4
+ module procedure getq4_rm
+ module procedure getq4_cm
+ end interface getq4
+
+ interface getq3
+ module procedure getq3_rm
+ module procedure getq3_cm
+ end interface getq3
+
+ interface getq2
+ module procedure getq2_rm
+ module procedure getq2_cm
+ end interface getq2
+
+ interface getq1
+ module procedure getq1_rm
+ module procedure getq1_cm
+ end interface getq1
+
+ public :: getq1, getq2, getq3, getq4, getq5
+
+contains
+
+ subroutine getq5_cm(nleg,cut5,e1,e2,e3,e4,p0,Vi,msq,r1,r2,q5,mu2)
+ implicit none
+ integer, intent(in) :: nleg, cut5
+ real(ki), dimension(4), intent(in) :: e1, e2, p0
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ real(ki), intent(in) :: r1, r2
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ complex(ki), dimension(4), intent(out) :: q5
+ complex(ki), intent(out) :: mu2
+
+ integer :: j1,j2,j3,j4,j5
+ complex(ki) :: x1, x2,var2, var3
+ real(ki) :: MP12, MP1v2, MP1v3, MP2v2, MP2v3, MPv22, MPv33
+ real(ki), dimension(4) :: v2, v3
+ complex(ki) :: MP3v2, MP3v3, MP4v2, MP4v3, x3, x4, tmu2, den
+
+ j5=cut5/10000
+ j4=(cut5-j5*10000)/1000
+ j3=(cut5-j5*10000-j4*1000)/100
+ j2=(cut5-j5*10000-j4*1000-j3*100)/10
+ j1= cut5-j5*10000-j4*1000-j3*100-j2*10
+
+ v2(:)=Vi(j3,:)-p0(:)
+ v3(:)=Vi(j4,:)-p0(:)
+
+ MP12 =sdot(e1,e2)
+ MP1v2=sdot(v2,e1)
+ MP1v3=sdot(v3,e1)
+ MP2v2=sdot(v2,e2)
+ MP2v3=sdot(v3,e2)
+ MP3v2=sdot(v2,e3)
+ MP3v3=sdot(v3,e3)
+ MP4v2=sdot(v2,e4)
+ MP4v3=sdot(v3,e4)
+ MPv22=sdot(v2,v2)
+ MPv33=sdot(v3,v3)
+
+ den = -(MP3v3*MP4v2*two) + MP3v2*MP4v3*two
+
+ x1 = (0.5_ki*( -(MP12*(1.0_ki+r1)*r2*two)-(1.0_ki+r2)*msq(j1) &
+ & +r2*msq(j2) + msq(j5)))/(MP12*(-1.0_ki + r1*r2))
+
+ x2 = -((0.5_ki*(-(MP12*r1*(1.0_ki+r2)*two)-(1.0_ki+r1)*msq(j1) &
+ & +msq(j2) + r1*msq(j5)))/(MP12*(-1.0_ki + r1*r2)))
+
+ var2 = MPv22 + MP1v2*two*x1 + MP2v2*two*x2+msq(j1)-msq(j3)
+ var3 = MPv33 + MP1v3*two*x1 + MP2v3*two*x2+msq(j1)-msq(j4)
+
+ x3 = (-MP4v3*var2+MP4v2*var3)/den
+
+ x4 = ( MP3v3*var2-MP3v2*var3)/den
+
+ tmu2=two*MP12*(x1*x2-x3*x4)-msq(j1)
+ if (aimag(tmu2)/real(tmu2).lt.1e-10_ki) then
+ mu2=real(tmu2,ki)*cone
+ else
+ mu2=tmu2
+ endif
+ q5(:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3*e3(:)+x4*e4(:)
+ end subroutine getq5_cm
+
+ subroutine getq5_rm(nleg,cut5,e1,e2,e3,e4,p0,Vi,msq,r1,r2,q5,mu2)
+ implicit none
+ integer, intent(in) :: nleg, cut5
+ real(ki), dimension(4), intent(in) :: e1, e2, p0
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ real(ki), intent(in) :: r1, r2
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ complex(ki), dimension(4), intent(out) :: q5
+ complex(ki), intent(out) :: mu2
+
+ integer :: j1,j2,j3,j4,j5
+ real(ki) :: x1, x2,var2, var3
+ real(ki) :: MP12, MP1v2, MP1v3, MP2v2, MP2v3, MPv22, MPv33
+ real(ki), dimension(4) :: v2, v3
+ complex(ki) :: MP3v2, MP3v3, MP4v2, MP4v3, x3, x4, tmu2, den
+
+ j5=cut5/10000
+ j4=(cut5-j5*10000)/1000
+ j3=(cut5-j5*10000-j4*1000)/100
+ j2=(cut5-j5*10000-j4*1000-j3*100)/10
+ j1= cut5-j5*10000-j4*1000-j3*100-j2*10
+
+ v2(:)=Vi(j3,:)-p0(:)
+ v3(:)=Vi(j4,:)-p0(:)
+
+ MP12 =sdot(e1,e2)
+ MP1v2=sdot(v2,e1)
+ MP1v3=sdot(v3,e1)
+ MP2v2=sdot(v2,e2)
+ MP2v3=sdot(v3,e2)
+ MP3v2=sdot(v2,e3)
+ MP3v3=sdot(v3,e3)
+ MP4v2=sdot(v2,e4)
+ MP4v3=sdot(v3,e4)
+ MPv22=sdot(v2,v2)
+ MPv33=sdot(v3,v3)
+
+ den = -(MP3v3*MP4v2*two) + MP3v2*MP4v3*two
+
+ x1 = (0.5_ki*( -(MP12*(1.0_ki+r1)*r2*two)-(1.0_ki+r2)*msq(j1) &
+ & +r2*msq(j2) + msq(j5)))/(MP12*(-1.0_ki + r1*r2))
+
+ x2 = -((0.5_ki*(-(MP12*r1*(1.0_ki+r2)*two)-(1.0_ki+r1)*msq(j1) &
+ & +msq(j2) + r1*msq(j5)))/(MP12*(-1.0_ki + r1*r2)))
+
+ var2 = MPv22 + MP1v2*two*x1 + MP2v2*two*x2+msq(j1)-msq(j3)
+ var3 = MPv33 + MP1v3*two*x1 + MP2v3*two*x2+msq(j1)-msq(j4)
+
+ x3 = (-MP4v3*var2+MP4v2*var3)/den
+
+ x4 = ( MP3v3*var2-MP3v2*var3)/den
+
+ tmu2=two*MP12*(x1*x2-x3*x4)-msq(j1)
+
+ mu2=real(tmu2, ki)
+ q5(:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3*e3(:)+x4*e4(:)
+ end subroutine getq5_rm
+
+ subroutine getq4_cm(nleg,cut4,e1,e2,e3,e4,p0,k1,k2,k3,L3,r1,r2,q4,qt,msq)
+ use mglobal, only: MP12, mu2g, mu2t, dx
+ implicit none
+ integer, intent(in) :: nleg, cut4
+ real(ki), dimension(4) :: k1, k2, k3, L3, e1, e2, p0
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), intent(in) :: r1,r2
+ complex(ki), dimension(5,4), intent(out) :: q4
+ complex(ki), dimension(4), intent(out) :: qt
+
+ real(ki) :: beta,mu2x
+ complex(ki) :: x1,x2,A1,A2
+ real(ki) :: ME31, ME32, MK11, MK22, MK33
+ complex(ki) :: x31,x32,x33,x34,x35,x3t,x41,x42,x43,x44,x45,x4t
+ complex(ki) :: ME33,ME34,ML33,ML34
+ complex(ki) :: B0,B1,B2,rtdel,A3,A4
+ integer :: j1,j2,j3,j4
+
+ j4=cut4/1000
+ j3=(cut4-j4*1000)/100
+ j2=(cut4-j4*1000-j3*100)/10
+ j1= cut4-j4*1000-j3*100-j2*10
+
+ MP12(4)=sdot(e1,e2)
+ ML33=sdot(L3,e3)
+ ML34=sdot(L3,e4)
+ ME31=sdot(k3,e1)
+ ME32=sdot(k3,e2)
+ ME33=sdot(k3,e3)
+ ME34=sdot(k3,e4)
+ MK11=sdot(k1,k1)
+ MK22=sdot(k2,k2)
+ MK33=sdot(k3,k3)
+ beta=one/(one-r1*r2)
+ A1=(msq(j2)-msq(j1)-MK11)/two/MP12(4)
+ A2=(msq(j1)-msq(j4)+MK22)/two/MP12(4)
+ x1=beta*(A2-r2*A1)
+ x2=beta*(A1-r1*A2)
+ A3=(msq(j3)-msq(j1)-MK33-2d0*x1*ME31-2d0*x2*ME32)/2d0/ME33
+ A4=-ME34/ME33
+ B1=-two*MP12(4)*A3
+ B2=-two*MP12(4)*A4
+
+ mu2g(4)=zip
+ B0=(two*x1*x2*MP12(4)-msq(j1)-mu2g(4))*cone
+ rtdel=sqrt(B1**2-four*B0*B2)
+ x41=(-B1+rtdel)/two/B2
+ x42=(-B1-rtdel)/two/B2
+ x31=x41*A4+A3
+ x32=x42*A4+A3
+ q4(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x31*e3(:)+x41*e4(:)
+ q4(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x32*e3(:)+x42*e4(:)
+
+!--- scelta dinamica
+ mu2g(4)=max(abs(msq(j1)),abs(msq(j2)),abs(msq(j3)),abs(msq(j4)),&
+ & abs(MK11),abs(MK22),abs(MK33),&
+ & abs(two*sdot(k1,k2)),abs(two*sdot(k2,k3)),abs(two*sdot(k1,k3)),&
+ & abs(two*MP12(4)))
+
+ if (abs(mu2g(4)).lt.1.0e-10_ki) mu2g(4)=one
+
+!--- scelta statica
+! mu2g(4)=one
+
+ B0=(two*x1*x2*MP12(4)-msq(j1)-mu2g(4))*cone
+ rtdel=sqrt(B1**2-four*B0*B2)
+ x43=(-B1+rtdel)/two/B2
+ x44=(-B1-rtdel)/two/B2
+ x33=x43*A4+A3
+ x34=x44*A4+A3
+ q4(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x33*e3(:)+x43*e4(:)
+ q4(4,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x34*e3(:)+x44*e4(:)
+
+ mu2x=-mu2g(4)
+ B0=(two*x1*x2*MP12(4)-msq(j1)-mu2x)*cone
+ rtdel=sqrt(B1**2-four*B0*B2)
+ x45=(-B1+rtdel)/two/B2
+! x45=(-B1-rtdel)/two/B2
+ x35=x45*A4+A3
+! x35=x4t*A4+A3
+ q4(5,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x35*e3(:)+x45*e4(:)
+
+ mu2t(4)=half
+ B0=(two*x1*x2*MP12(4)-msq(j1)-mu2t(4))*cone
+ rtdel=sqrt(B1**2-four*B0*B2)
+! x4t=(-B1+rtdel)/two/B2
+ x4t=(-B1-rtdel)/two/B2
+! x3t=x45*A4+A3
+ x3t=x4t*A4+A3
+ qt(:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3t*e3(:)+x4t*e4(:)
+
+ dx(1)=ML33*x31-ML34*x41
+ dx(2)=ML33*x32-ML34*x42
+ dx(3)=ML33*x33-ML34*x43
+ dx(4)=ML33*x34-ML34*x44
+ dx(5)=ML33*x35-ML34*x45
+ end subroutine getq4_cm
+
+ subroutine getq4_rm(nleg,cut4,e1,e2,e3,e4,p0,k1,k2,k3,L3,r1,r2,q4,qt,msq)
+ use mglobal, only: MP12, mu2g, mu2t, dx
+ implicit none
+ integer, intent(in) :: nleg, cut4
+ real(ki), dimension(4) :: k1, k2, k3, L3, e1, e2, p0
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), intent(in) :: r1,r2
+ complex(ki), dimension(5,4), intent(out) :: q4
+ complex(ki), dimension(4), intent(out) :: qt
+
+ real(ki) :: beta,mu2x,x1,x2,A1,A2
+ real(ki) :: ME31, ME32, MK11, MK22, MK33
+ complex(ki) :: x31,x32,x33,x34,x35,x3t,x41,x42,x43,x44,x45,x4t
+ complex(ki) :: ME33,ME34,ML33,ML34
+ complex(ki) :: B0,B1,B2,rtdel,A3,A4
+ integer :: j1,j2,j3,j4
+
+ j4=cut4/1000
+ j3=(cut4-j4*1000)/100
+ j2=(cut4-j4*1000-j3*100)/10
+ j1= cut4-j4*1000-j3*100-j2*10
+
+ MP12(4)=sdot(e1,e2)
+ ML33=sdot(L3,e3)
+ ML34=sdot(L3,e4)
+ ME31=sdot(k3,e1)
+ ME32=sdot(k3,e2)
+ ME33=sdot(k3,e3)
+ ME34=sdot(k3,e4)
+ MK11=sdot(k1,k1)
+ MK22=sdot(k2,k2)
+ MK33=sdot(k3,k3)
+ beta=one/(one-r1*r2)
+ A1=(msq(j2)-msq(j1)-MK11)/two/MP12(4)
+ A2=(msq(j1)-msq(j4)+MK22)/two/MP12(4)
+ x1=beta*(A2-r2*A1)
+ x2=beta*(A1-r1*A2)
+ A3=(msq(j3)-msq(j1)-MK33-2d0*x1*ME31-2d0*x2*ME32)/2d0/ME33
+ A4=-ME34/ME33
+ B1=-two*MP12(4)*A3
+ B2=-two*MP12(4)*A4
+
+ mu2g(4)=zip
+ B0=(two*x1*x2*MP12(4)-msq(j1)-mu2g(4))*cone
+ rtdel=sqrt(B1**2-four*B0*B2)
+ x41=(-B1+rtdel)/two/B2
+ x42=(-B1-rtdel)/two/B2
+ x31=x41*A4+A3
+ x32=x42*A4+A3
+ q4(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x31*e3(:)+x41*e4(:)
+ q4(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x32*e3(:)+x42*e4(:)
+
+!--- scelta dinamica
+ mu2g(4)=max(msq(j1),msq(j2),msq(j3),msq(j4),&
+ & abs(MK11),abs(MK22),abs(MK33),&
+ & abs(two*sdot(k1,k2)),abs(two*sdot(k2,k3)),abs(two*sdot(k1,k3)),&
+ & abs(two*MP12(4)))
+
+ if (abs(mu2g(4)).lt.1.0e-10_ki) mu2g(4)=one
+
+!--- scelta statica
+! mu2g(4)=one
+
+ B0=(two*x1*x2*MP12(4)-msq(j1)-mu2g(4))*cone
+ rtdel=sqrt(B1**2-four*B0*B2)
+ x43=(-B1+rtdel)/two/B2
+ x44=(-B1-rtdel)/two/B2
+ x33=x43*A4+A3
+ x34=x44*A4+A3
+ q4(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x33*e3(:)+x43*e4(:)
+ q4(4,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x34*e3(:)+x44*e4(:)
+
+ mu2x=-mu2g(4)
+ B0=(two*x1*x2*MP12(4)-msq(j1)-mu2x)*cone
+ rtdel=sqrt(B1**2-four*B0*B2)
+ x45=(-B1+rtdel)/two/B2
+! x45=(-B1-rtdel)/two/B2
+ x35=x45*A4+A3
+! x35=x4t*A4+A3
+ q4(5,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x35*e3(:)+x45*e4(:)
+
+ mu2t(4)=half
+ B0=(two*x1*x2*MP12(4)-msq(j1)-mu2t(4))*cone
+ rtdel=sqrt(B1**2-four*B0*B2)
+! x4t=(-B1+rtdel)/two/B2
+ x4t=(-B1-rtdel)/two/B2
+! x3t=x45*A4+A3
+ x3t=x4t*A4+A3
+ qt(:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3t*e3(:)+x4t*e4(:)
+
+ dx(1)=ML33*x31-ML34*x41
+ dx(2)=ML33*x32-ML34*x42
+ dx(3)=ML33*x33-ML34*x43
+ dx(4)=ML33*x34-ML34*x44
+ dx(5)=ML33*x35-ML34*x45
+ end subroutine getq4_rm
+
+ subroutine getq3_cm(nleg,irank,cut3,e1,e2,e3,e4,p0,k1,k2,msq,r1,r2,q3,qt)
+ use mglobal, only: C0c,C1c,mu2g,MP12,KK,Kmu,mu2t
+ use options, only: C0_thrs
+ implicit none
+ integer, intent(in) :: nleg, cut3, irank
+ real(ki), dimension(4), intent(in) :: p0, k1, k2, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(10,4), intent(out) :: q3
+ complex(ki), dimension(4), intent(out) :: qt
+
+ integer :: j1,j2,j3,j,ndiff
+ real(ki) :: r1,r2,beta,teta
+ complex(ki) :: x1,x2,A1,A2,C1t
+ real(ki) :: MK11,MK12,MK22
+ complex(ki) :: x3t, x4t
+ complex(ki), dimension(10) :: x3, x4
+
+ ndiff=nleg-irank
+ KK(3)=one
+ Kmu(3)=one
+
+ j3=cut3/100
+ j2=(cut3-j3*100)/10
+ j1=cut3-j3*100-j2*10
+
+ MP12(3)=sdot(e1,e2)
+ MK11=sdot(k1,k1)
+ MK12=sdot(k1,k2)
+ MK22=sdot(k2,k2)
+ beta=1d0/(1d0-r1*r2)
+ A1=(msq(j2)-msq(j1)-MK11)/two/MP12(3)
+ A2=(msq(j1)-msq(j3)+MK22)/two/MP12(3)
+ x1=beta*(A2-r2*A1)
+ x2=beta*(A1-r1*A2)
+
+ C0c=x1*x2-msq(j1)/two/MP12(3)
+
+ !---#[ scelta dinamica:
+ mu2g(3)=max(abs(msq(j1)),abs(msq(j2)),abs(msq(j3)),abs(MK11), &
+ & abs(MK22),abs(two*MK12))
+ if (abs(mu2g(3)).lt.1d-10) mu2g(3)=one
+ !---#] scelta dinamica:
+ !---#[ scelta statica:
+ ! mu2g(3)=one
+ !---#] scelta statica:
+
+ C1c=x1*x2-(msq(j1)+mu2g(3))/two/MP12(3)
+
+ if (abs(C0c-1.0_ki) .lt. C0_thrs) then
+ !---#[ New Sampling:
+ ! The new sampling is the one that is safe around C0=1
+ ! but not around C0=0
+
+ ! complete c-system: 10 coefficients
+
+ teta=twopi/seven
+ do j=1,7
+ x3(j)=cos(teta*real(j-1,ki))-im*sin(teta*real(j-1,ki))
+ x4(j)=C0c/x3(j)
+ enddo
+
+ teta=twopi/three
+ do j=8,10
+ x4(j)=cos(teta*real(j-8,ki))+im*sin(teta*real(j-8,ki))
+ x3(j)=C1c/x4(j)
+ enddo
+
+ mu2t(3)=half
+ C1t=x1*x2-(msq(j1)+mu2t(3))/two/MP12(3)
+ x3t=32.4_ki
+ x4t=C1t*cone/x3t
+
+ q3(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(1)*e3(:)+x4(1)*e4(:)
+ q3(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(2)*e3(:)+x4(2)*e4(:)
+ q3(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(3)*e3(:)+x4(3)*e4(:)
+ q3(4,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(4)*e3(:)+x4(4)*e4(:)
+ q3(5,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(5)*e3(:)+x4(5)*e4(:)
+ q3(6,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(6)*e3(:)+x4(6)*e4(:)
+ q3(7,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(7)*e3(:)+x4(7)*e4(:)
+ q3(8,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(8)*e3(:)+x4(8)*e4(:)
+ q3(9,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(9)*e3(:)+x4(9)*e4(:)
+ q3(10,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(10)*e3(:)+x4(10)*e4(:)
+ !---#] New Sampling:
+ else
+ !---#[ Old Sampling:
+ ! The old sampling is the one that is safe around C0=0
+ ! but not around C0=1
+
+ !!!! HERE WE BRANCH ACCORDING TO THE RANK
+ select case(ndiff)
+ case(1)
+ ! rank2 c-system: 6 coefficients
+ teta=twopi/three
+ do j=1,3
+ x3(j)=cos(teta*real(j-1,ki))-im*sin(teta*real(j-1,ki))
+ x4(j)=C0c/x3(j)
+ enddo
+
+ teta=twopi/two
+ do j=4,5
+ x3(j)=cos(teta*real(j-4,ki))+im*sin(teta*real(j-4,ki))
+ x4(j)=cone/x3(j)
+ enddo
+
+ teta=twopi
+ do j=6,6
+ x3(j)=cos(teta*real(j-6,ki))+im*sin(teta*real(j-6,ki))
+ x4(j)=cone/x3(j)
+ enddo
+
+ x3(7:10)=czip
+ x4(7:10)=czip
+
+ ! those numbers are for the test!!
+ mu2t(3)=half
+ C1t=x1*x2-(msq(j1)+mu2t(3))/two/MP12(3)
+ x3t=32.4_ki
+ x4t=C1t*cone/x3t
+
+ ! here are the qs for system 3.2
+ q3(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(1)*e3(:)+x4(1)*e4(:)
+ q3(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(2)*e3(:)+x4(2)*e4(:)
+ q3(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(3)*e3(:)+x4(3)*e4(:)
+ q3(4,:)=-p0(:)+x1*e1(:)+x2*e2(:)+C0c*x3(4)*e3(:)+x4(4)*e4(:)
+ q3(5,:)=-p0(:)+x1*e1(:)+x2*e2(:)+C0c*x3(5)*e3(:)+x4(5)*e4(:)
+ q3(6,:)=-p0(:)+x1*e1(:)+x2*e2(:)+C1c*x3(6)*e3(:)+x4(6)*e4(:)
+ case(2)
+ ! rank1 c-system: 3 coefficients
+
+ x3(1)=cone
+ x4(1)=C0c
+
+ x3(2)=-cone
+ x4(2)=-C0c
+
+ x3(3)=C0c
+ x4(3)=cone
+
+ x3(4:10)=czip
+ x4(4:10)=czip
+
+ mu2t(3)=half
+ C1t=x1*x2-(msq(j1)+mu2t(3))/two/MP12(3)
+ x3t=32.4_ki
+ x4t=C1t*cone/x3t
+
+ q3(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(1)*e3(:)+x4(1)*e4(:)/KK(3)
+ q3(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(2)*e3(:)+x4(2)*e4(:)/KK(3)
+ q3(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(3)*e3(:)+x4(3)*e4(:)/KK(3)
+ case default
+ ! complete c-system: 10 coefficients
+
+ teta=twopi/four
+ do j=1,4
+ x3(j)=cos(teta*real(j-1,ki))-im*sin(teta*real(j-1,ki))
+ x4(j)=C0c/x3(j)
+ enddo
+
+ teta=twopi/three
+ do j=5,7
+ x4(j)=cos(teta*real(j-5,ki))+im*sin(teta*real(j-5,ki))
+ x3(j)=C0c/x4(j)
+ enddo
+
+ teta=twopi/three
+ do j=8,10
+ x4(j)=cos(teta*real(j-8,ki))+im*sin(teta*real(j-8,ki))
+ x3(j)=C1c/x4(j)
+ enddo
+
+ mu2t(3)=half
+ C1t=x1*x2-(msq(j1)+mu2t(3))/two/MP12(3)
+ x3t=32.4_ki
+ x4t=C1t*cone/x3t
+
+ q3(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(1)*e3(:)+x4(1)*e4(:)/KK(3)
+ q3(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(2)*e3(:)+x4(2)*e4(:)/KK(3)
+ q3(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(3)*e3(:)+x4(3)*e4(:)/KK(3)
+ q3(4,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(4)*e3(:)+x4(4)*e4(:)/KK(3)
+ q3(5,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(5)*e3(:)+x4(5)*e4(:)/KK(3)
+ q3(6,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(6)*e3(:)+x4(6)*e4(:)/KK(3)
+ q3(7,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(7)*e3(:)+x4(7)*e4(:)/KK(3)
+ q3(8,:)=-p0(:)+x1*e1(:)+x2*e2(:)+Kmu(3)*x3(8)*e3(:)+x4(8)*e4(:)/Kmu(3)
+ q3(9,:)=-p0(:)+x1*e1(:)+x2*e2(:)+Kmu(3)*x3(9)*e3(:)+x4(9)*e4(:)/Kmu(3)
+ q3(10,:)=-p0(:)+x1*e1(:)+x2*e2(:)+Kmu(3)*x3(10)*e3(:)+x4(10)*e4(:)/Kmu(3)
+ end select
+ !---#] Old Sampling:
+ end if
+ qt(:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3t*e3(:)+x4t*e4(:)
+ end subroutine getq3_cm
+
+ subroutine getq3_rm(nleg,irank,cut3,e1,e2,e3,e4,p0,k1,k2,msq,r1,r2,q3,qt)
+ use mglobal, only: C0,C1,mu2g,MP12,KK,Kmu,mu2t
+ use options, only: C0_thrs
+ implicit none
+ integer, intent(in) :: nleg, cut3, irank
+ real(ki), dimension(4), intent(in) :: p0, k1, k2, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(10,4), intent(out) :: q3
+ complex(ki), dimension(4), intent(out) :: qt
+
+ integer :: j1,j2,j3,j,ndiff
+ real(ki) :: r1,r2,beta,teta,x1,x2,A1,A2,C1t
+ real(ki) :: MK11,MK12,MK22
+ complex(ki) :: x3t, x4t
+ complex(ki), dimension(10) :: x3, x4
+
+ ndiff=nleg-irank
+ KK(3)=one
+ Kmu(3)=one
+
+ j3=cut3/100
+ j2=(cut3-j3*100)/10
+ j1=cut3-j3*100-j2*10
+
+ MP12(3)=sdot(e1,e2)
+ MK11=sdot(k1,k1)
+ MK12=sdot(k1,k2)
+ MK22=sdot(k2,k2)
+ beta=1d0/(1d0-r1*r2)
+ A1=(msq(j2)-msq(j1)-MK11)/two/MP12(3)
+ A2=(msq(j1)-msq(j3)+MK22)/two/MP12(3)
+ x1=beta*(A2-r2*A1)
+ x2=beta*(A1-r1*A2)
+
+ C0=x1*x2-msq(j1)/two/MP12(3)
+
+ !---#[ scelta dinamica:
+ mu2g(3)=max(msq(j1),msq(j2),msq(j3),abs(MK11),abs(MK22),abs(two*MK12))
+ if (abs(mu2g(3)).lt.1d-10) mu2g(3)=one
+ !---#] scelta dinamica:
+ !---#[ scelta statica:
+ ! mu2g(3)=one
+ !---#] scelta statica:
+
+ C1=x1*x2-(msq(j1)+mu2g(3))/two/MP12(3)
+
+ if (abs(C0-1.0_ki) .lt. C0_thrs) then
+ !---#[ New Sampling:
+ ! The new sampling is the one that is safe around C0=1
+ ! but not around C0=0
+
+ ! complete c-system: 10 coefficients
+
+ teta=twopi/seven
+ do j=1,7
+ x3(j)=cos(teta*real(j-1,ki))-im*sin(teta*real(j-1,ki))
+ x4(j)=C0*cone/x3(j)
+ enddo
+
+ teta=twopi/three
+ do j=8,10
+ x4(j)=cos(teta*real(j-8,ki))+im*sin(teta*real(j-8,ki))
+ x3(j)=C1*cone/x4(j)
+ enddo
+
+ mu2t(3)=half
+ C1t=x1*x2-(msq(j1)+mu2t(3))/two/MP12(3)
+ x3t=32.4_ki
+ x4t=C1t*cone/x3t
+
+ q3(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(1)*e3(:)+x4(1)*e4(:)
+ q3(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(2)*e3(:)+x4(2)*e4(:)
+ q3(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(3)*e3(:)+x4(3)*e4(:)
+ q3(4,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(4)*e3(:)+x4(4)*e4(:)
+ q3(5,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(5)*e3(:)+x4(5)*e4(:)
+ q3(6,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(6)*e3(:)+x4(6)*e4(:)
+ q3(7,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(7)*e3(:)+x4(7)*e4(:)
+ q3(8,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(8)*e3(:)+x4(8)*e4(:)
+ q3(9,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(9)*e3(:)+x4(9)*e4(:)
+ q3(10,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(10)*e3(:)+x4(10)*e4(:)
+ !---#] New Sampling:
+ else
+ !---#[ Old Sampling:
+ ! The old sampling is the one that is safe around C0=0
+ ! but not around C0=1
+
+ !!!! HERE WE BRANCH ACCORDING TO THE RANK
+ select case(ndiff)
+ case(1)
+ ! rank2 c-system: 6 coefficients
+ teta=twopi/three
+ do j=1,3
+ x3(j)=cos(teta*real(j-1,ki))-im*sin(teta*real(j-1,ki))
+ x4(j)=C0*cone/x3(j)
+ enddo
+
+ teta=twopi/two
+ do j=4,5
+ x3(j)=cos(teta*real(j-4,ki))+im*sin(teta*real(j-4,ki))
+ x4(j)=cone/x3(j)
+ enddo
+
+ teta=twopi
+ do j=6,6
+ x3(j)=cos(teta*real(j-6,ki))+im*sin(teta*real(j-6,ki))
+ x4(j)=cone/x3(j)
+ enddo
+
+ x3(7:10)=czip
+ x4(7:10)=czip
+
+ ! those numbers are for the test!!
+ mu2t(3)=half
+ C1t=x1*x2-(msq(j1)+mu2t(3))/two/MP12(3)
+ x3t=32.4_ki
+ x4t=C1t*cone/x3t
+
+ ! here are the qs for system 3.2
+ q3(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(1)*e3(:)+x4(1)*e4(:)
+ q3(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(2)*e3(:)+x4(2)*e4(:)
+ q3(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3(3)*e3(:)+x4(3)*e4(:)
+ q3(4,:)=-p0(:)+x1*e1(:)+x2*e2(:)+C0*x3(4)*e3(:)+x4(4)*e4(:)
+ q3(5,:)=-p0(:)+x1*e1(:)+x2*e2(:)+C0*x3(5)*e3(:)+x4(5)*e4(:)
+ q3(6,:)=-p0(:)+x1*e1(:)+x2*e2(:)+C1*x3(6)*e3(:)+x4(6)*e4(:)
+ case(2)
+ ! rank1 c-system: 3 coefficients
+
+ x3(1)=cone
+ x4(1)=C0*cone
+
+ x3(2)=-cone
+ x4(2)=-C0*cone
+
+ x3(3)=C0*cone
+ x4(3)=cone
+
+ x3(4:10)=czip
+ x4(4:10)=czip
+
+ mu2t(3)=half
+ C1t=x1*x2-(msq(j1)+mu2t(3))/two/MP12(3)
+ x3t=32.4_ki
+ x4t=C1t*cone/x3t
+
+ q3(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(1)*e3(:)+x4(1)*e4(:)/KK(3)
+ q3(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(2)*e3(:)+x4(2)*e4(:)/KK(3)
+ q3(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(3)*e3(:)+x4(3)*e4(:)/KK(3)
+ case default
+ ! complete c-system: 10 coefficients
+
+ teta=twopi/four
+ do j=1,4
+ x3(j)=cos(teta*real(j-1,ki))-im*sin(teta*real(j-1,ki))
+ x4(j)=C0*cone/x3(j)
+ enddo
+
+ teta=twopi/three
+ do j=5,7
+ x4(j)=cos(teta*real(j-5,ki))+im*sin(teta*real(j-5,ki))
+ x3(j)=C0*cone/x4(j)
+ enddo
+
+ teta=twopi/three
+ do j=8,10
+ x4(j)=cos(teta*real(j-8,ki))+im*sin(teta*real(j-8,ki))
+ x3(j)=C1*cone/x4(j)
+ enddo
+
+ mu2t(3)=half
+ C1t=x1*x2-(msq(j1)+mu2t(3))/two/MP12(3)
+ x3t=32.4_ki
+ x4t=C1t*cone/x3t
+
+ q3(1,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(1)*e3(:)+x4(1)*e4(:)/KK(3)
+ q3(2,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(2)*e3(:)+x4(2)*e4(:)/KK(3)
+ q3(3,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(3)*e3(:)+x4(3)*e4(:)/KK(3)
+ q3(4,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(4)*e3(:)+x4(4)*e4(:)/KK(3)
+ q3(5,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(5)*e3(:)+x4(5)*e4(:)/KK(3)
+ q3(6,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(6)*e3(:)+x4(6)*e4(:)/KK(3)
+ q3(7,:)=-p0(:)+x1*e1(:)+x2*e2(:)+KK(3)*x3(7)*e3(:)+x4(7)*e4(:)/KK(3)
+ q3(8,:)=-p0(:)+x1*e1(:)+x2*e2(:)+Kmu(3)*x3(8)*e3(:)+x4(8)*e4(:)/Kmu(3)
+ q3(9,:)=-p0(:)+x1*e1(:)+x2*e2(:)+Kmu(3)*x3(9)*e3(:)+x4(9)*e4(:)/Kmu(3)
+ q3(10,:)=-p0(:)+x1*e1(:)+x2*e2(:)+Kmu(3)*x3(10)*e3(:)+x4(10)*e4(:)/Kmu(3)
+ end select
+ !---#] Old Sampling:
+ end if
+ qt(:)=-p0(:)+x1*e1(:)+x2*e2(:)+x3t*e3(:)+x4t*e4(:)
+ end subroutine getq3_rm
+
+ subroutine getq2_cm(nleg,irank,cut2,e1,e2,e3,e4,p0,k1,msq,q2,qt)
+ use mglobal, only: Fpc,Fzc,Fmc,F1zc,KB,mu2g,KK,Kmu,MP12,mu2t
+ implicit none
+ integer, intent(in) :: nleg, cut2, irank
+ real(ki), dimension(4), intent(in) :: p0, k1, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(10,4), intent(out) :: q2
+ complex(ki), dimension(4), intent(out) :: qt
+
+ complex(ki), dimension(10) :: x1, x2
+ real(ki) :: teta,K1SQ
+ complex(ki) :: A1,x1t,x2t,Ft
+ complex(ki) :: X1p,X2p,X1z,X2z,X1m,X2m
+ complex(ki) :: x3t, x4t
+ complex(ki), dimension(10) :: x3, x4
+ integer :: j1,j2,j,ndiff
+
+ ndiff=nleg-irank
+ KK(2)=one
+ KB=one
+ Kmu(2)=one
+
+ j2=cut2/10
+ j1=cut2-j2*10
+
+ K1SQ=sdot(k1,k1)
+ MP12(2)=sdot(e1,e2)
+ A1=(msq(j2)-msq(j1)-K1SQ)/two/MP12(2)
+
+ X1z=zip
+ X2z=A1
+ Fzc=-msq(j1)/two/MP12(2)
+
+ X1p=KB
+ X2p=A1-KB*K1SQ/two/MP12(2)
+ Fpc=KB*X2p-msq(j1)/two/MP12(2)
+
+ X1m=-KB
+ X2m=A1+KB*K1SQ/two/MP12(2)
+ Fmc=-KB*X2m-msq(j1)/two/MP12(2)
+
+!--- scelta dinamica
+
+ mu2g(2)=max(abs(msq(j1)),abs(msq(j2)),K1SQ)
+ if (abs(mu2g(2)).lt.1.0e-10_ki) mu2g(2)=one
+
+!--- scelta statica
+! mu2g(2)=one
+
+ F1zc=-(msq(j1)+mu2g(2))/two/MP12(2)
+
+!!!! HERE WE BRANCH ACCORDING TO THE RANK
+
+ if (ndiff.eq.1) then
+! rank 1
+
+ teta=twopi/two
+
+ do j=1,2
+ x1(j)=X1z
+ x2(j)=X2z
+ x4(j)=cos(teta*real(j-1,ki))+im*sin(teta*real(j-1,ki))
+ x3(j)=Fzc/x4(j)
+ enddo
+
+ do j=3,4
+ x1(j)=X1p
+ x2(j)=X2p
+ x3(j)=cos(teta*real(j-3,ki))-im*sin(teta*real(j-3,ki))
+ x4(j)=Fpc/x3(j)
+ enddo
+
+
+ mu2t(2)=half
+ x1t=2.3_ki
+ x2t=A1-x1t*K1SQ/two/MP12(2)
+ Ft=x1t*x2t-(msq(j1)+mu2t(2))/two/MP12(2)
+ x3t=(2.5_ki,0.3_ki)
+ x4t=Ft/x3t
+
+ do j=5,10
+ x3(j)=czip
+ x4(j)=czip
+ enddo
+
+ q2(1,:)=-p0(:)+x1(1)*e1(:)+x2(1)*e2(:)+KK(2)*x3(1)*e3(:)+x4(1)*e4(:)/KK(2)
+ q2(2,:)=-p0(:)+x1(2)*e1(:)+x2(2)*e2(:)+KK(2)*x3(2)*e3(:)+x4(2)*e4(:)/KK(2)
+ q2(3,:)=-p0(:)+x1(3)*e1(:)+x2(3)*e2(:)+KK(2)*x3(3)*e3(:)+x4(3)*e4(:)/KK(2)
+ q2(4,:)=-p0(:)+x1(4)*e1(:)+x2(4)*e2(:)+KK(2)*x3(4)*e3(:)+x4(4)*e4(:)/KK(2)
+ ! q2(5,:)=-p0(:)+x1(5)*e1(:)+x2(5)*e2(:)+KK(2)*x3(5)*e3(:)+x4(5)*e4(:)/KK(2)
+ ! q2(6,:)=-p0(:)+x1(6)*e1(:)+x2(6)*e2(:)+KK(2)*x3(6)*e3(:)+x4(6)*e4(:)/KK(2)
+! q2(7,:)=-p0(:)+x1(7)*e1(:)+x2(7)*e2(:)+KK(2)*x3(7)*e3(:)+x4(7)*e4(:)/KK(2)
+! q2(8,:)=-p0(:)+x1(8)*e1(:)+x2(8)*e2(:)+KK(2)*x3(8)*e3(:)+x4(8)*e4(:)/KK(2)
+! q2(9,:)=-p0(:)+x1(9)*e1(:)+x2(9)*e2(:)+KK(2)*x3(9)*e3(:)+x4(9)*e4(:)/KK(2)
+! q2(10,:)=-p0(:)+x1(10)*e1(:)+x2(10)*e2(:)+KK(2)*x3(10)*e3(:) &
+! & +x4(10)*e4(:)/KK(2)
+ qt(:)=-p0(:)+x1t*e1(:)+x2t*e2(:)+x3t*e3(:)+x4t*e4(:)
+
+
+ else
+! standard (rank 2)
+
+ teta=twopi/three
+ do j=1,3
+ x1(j)=X1z
+ x2(j)=X2z
+ x4(j)=cos(teta*real(j-1,ki))+im*sin(teta*real(j-1,ki))
+ x3(j)=Fzc/x4(j)
+ enddo
+ teta=twopi/two
+ do j=4,5
+ x1(j)=X1z
+ x2(j)=X2z
+ x3(j)=cos(teta*real(j-4,ki))-im*sin(teta*real(j-4,ki))
+ x4(j)=Fzc/x3(j)
+ enddo
+
+ teta=twopi/two
+ do j=6,7
+ x1(j)=X1p
+ x2(j)=X2p
+ x4(j)=cos(teta*real(j-6,ki))+im*sin(teta*real(j-6,ki))
+ x3(j)=Fpc/x4(j)
+ enddo
+ x1(8)=X1p
+ x2(8)=X2p
+ x3(8)=cone
+ x4(8)=Fpc
+
+ x1(9)=X1m
+ x2(9)=X2m
+ x3(9)=Fmc
+ x4(9)=cone
+
+ x1(10)=X1z
+ x2(10)=X2z
+ x3(10)=F1zc
+ x4(10)=cone
+
+ mu2t(2)=half
+ x1t=2.3_ki
+ x2t=A1-x1t*K1SQ/two/MP12(2)
+ Ft=x1t*x2t-(msq(j1)+mu2t(2))/two/MP12(2)
+ x3t=(2.5_ki,0.3_ki)
+ x4t=Ft/x3t
+
+ q2(1,:)=-p0(:)+x1(1)*e1(:)+x2(1)*e2(:)+KK(2)*x3(1)*e3(:)+x4(1)*e4(:)/KK(2)
+ q2(2,:)=-p0(:)+x1(2)*e1(:)+x2(2)*e2(:)+KK(2)*x3(2)*e3(:)+x4(2)*e4(:)/KK(2)
+ q2(3,:)=-p0(:)+x1(3)*e1(:)+x2(3)*e2(:)+KK(2)*x3(3)*e3(:)+x4(3)*e4(:)/KK(2)
+ q2(4,:)=-p0(:)+x1(4)*e1(:)+x2(4)*e2(:)+KK(2)*x3(4)*e3(:)+x4(4)*e4(:)/KK(2)
+ q2(5,:)=-p0(:)+x1(5)*e1(:)+x2(5)*e2(:)+KK(2)*x3(5)*e3(:)+x4(5)*e4(:)/KK(2)
+ q2(6,:)=-p0(:)+x1(6)*e1(:)+x2(6)*e2(:)+KK(2)*x3(6)*e3(:)+x4(6)*e4(:)/KK(2)
+ q2(7,:)=-p0(:)+x1(7)*e1(:)+x2(7)*e2(:)+KK(2)*x3(7)*e3(:)+x4(7)*e4(:)/KK(2)
+ q2(8,:)=-p0(:)+x1(8)*e1(:)+x2(8)*e2(:)+KK(2)*x3(8)*e3(:)+x4(8)*e4(:)/KK(2)
+ q2(9,:)=-p0(:)+x1(9)*e1(:)+x2(9)*e2(:)+KK(2)*x3(9)*e3(:)+x4(9)*e4(:)/KK(2)
+ q2(10,:)=-p0(:)+x1(10)*e1(:)+x2(10)*e2(:)+KK(2)*x3(10)*e3(:) &
+ & +x4(10)*e4(:)/KK(2)
+ qt(:)=-p0(:)+x1t*e1(:)+x2t*e2(:)+x3t*e3(:)+x4t*e4(:)
+
+ endif
+
+ end subroutine getq2_cm
+
+ subroutine getq2_rm(nleg,irank,cut2,e1,e2,e3,e4,p0,k1,msq,q2,qt)
+ use mglobal, only: Fp,Fz,Fm,F1z,KB,mu2g,KK,Kmu,MP12,mu2t
+ implicit none
+ integer, intent(in) :: nleg, cut2, irank
+ real(ki), dimension(4), intent(in) :: p0, k1, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ complex(ki), dimension(10,4), intent(out) :: q2
+ complex(ki), dimension(4), intent(out) :: qt
+
+ real(ki), dimension(10) :: x1, x2
+ real(ki) :: teta,A1,K1SQ,x1t,x2t,Ft
+ real(ki) :: X1p,X2p,X1z,X2z,X1m,X2m
+ complex(ki) :: x3t, x4t
+ complex(ki), dimension(10) :: x3, x4
+ integer :: j1,j2,j,ndiff
+
+ ndiff=nleg-irank
+ KK(2)=one
+ KB=one
+ Kmu(2)=one
+
+ j2=cut2/10
+ j1=cut2-j2*10
+
+ K1SQ=sdot(k1,k1)
+ MP12(2)=sdot(e1,e2)
+ A1=(msq(j2)-msq(j1)-K1SQ)/two/MP12(2)
+
+ X1z=zip
+ X2z=A1
+ Fz=-msq(j1)/two/MP12(2)
+
+ X1p=KB
+ X2p=A1-KB*K1SQ/two/MP12(2)
+ Fp=KB*X2p-msq(j1)/two/MP12(2)
+
+ X1m=-KB
+ X2m=A1+KB*K1SQ/two/MP12(2)
+ Fm=-KB*X2m-msq(j1)/two/MP12(2)
+
+!--- scelta dinamica
+ mu2g(2)=max(msq(j1),msq(j2),K1SQ)
+ if (abs(mu2g(2)).lt.1.0e-10_ki) mu2g(2)=one
+
+!--- scelta statica
+! mu2g(2)=one
+
+ F1z=-(msq(j1)+mu2g(2))/two/MP12(2)
+
+!!!! HERE WE BRANCH ACCORDING TO THE RANK
+
+ if (ndiff.eq.1) then
+! rank 1
+
+ teta=twopi/two
+
+ do j=1,2
+ x1(j)=X1z
+ x2(j)=X2z
+ x4(j)=cos(teta*real(j-1,ki))+im*sin(teta*real(j-1,ki))
+ x3(j)=Fz/x4(j)
+ enddo
+
+ do j=3,4
+ x1(j)=X1p
+ x2(j)=X2p
+ x3(j)=cos(teta*real(j-3,ki))-im*sin(teta*real(j-3,ki))
+ x4(j)=Fp/x3(j)
+ enddo
+
+
+ mu2t(2)=half
+ x1t=2.3_ki
+ x2t=A1-x1t*K1SQ/two/MP12(2)
+ Ft=x1t*x2t-(msq(j1)+mu2t(2))/two/MP12(2)
+ x3t=(2.5_ki,0.3_ki)
+ x4t=Ft/x3t
+
+ do j=5,10
+ x3(j)=czip
+ x4(j)=czip
+ enddo
+
+ q2(1,:)=-p0(:)+x1(1)*e1(:)+x2(1)*e2(:)+KK(2)*x3(1)*e3(:)+x4(1)*e4(:)/KK(2)
+ q2(2,:)=-p0(:)+x1(2)*e1(:)+x2(2)*e2(:)+KK(2)*x3(2)*e3(:)+x4(2)*e4(:)/KK(2)
+ q2(3,:)=-p0(:)+x1(3)*e1(:)+x2(3)*e2(:)+KK(2)*x3(3)*e3(:)+x4(3)*e4(:)/KK(2)
+ q2(4,:)=-p0(:)+x1(4)*e1(:)+x2(4)*e2(:)+KK(2)*x3(4)*e3(:)+x4(4)*e4(:)/KK(2)
+ ! q2(5,:)=-p0(:)+x1(5)*e1(:)+x2(5)*e2(:)+KK(2)*x3(5)*e3(:)+x4(5)*e4(:)/KK(2)
+ ! q2(6,:)=-p0(:)+x1(6)*e1(:)+x2(6)*e2(:)+KK(2)*x3(6)*e3(:)+x4(6)*e4(:)/KK(2)
+! q2(7,:)=-p0(:)+x1(7)*e1(:)+x2(7)*e2(:)+KK(2)*x3(7)*e3(:)+x4(7)*e4(:)/KK(2)
+! q2(8,:)=-p0(:)+x1(8)*e1(:)+x2(8)*e2(:)+KK(2)*x3(8)*e3(:)+x4(8)*e4(:)/KK(2)
+! q2(9,:)=-p0(:)+x1(9)*e1(:)+x2(9)*e2(:)+KK(2)*x3(9)*e3(:)+x4(9)*e4(:)/KK(2)
+! q2(10,:)=-p0(:)+x1(10)*e1(:)+x2(10)*e2(:)+KK(2)*x3(10)*e3(:) &
+! & +x4(10)*e4(:)/KK(2)
+ qt(:)=-p0(:)+x1t*e1(:)+x2t*e2(:)+x3t*e3(:)+x4t*e4(:)
+
+
+ else
+! standard (rank 2)
+
+ teta=twopi/three
+ do j=1,3
+ x1(j)=X1z
+ x2(j)=X2z
+ x4(j)=cos(teta*real(j-1,ki))+im*sin(teta*real(j-1,ki))
+ x3(j)=Fz/x4(j)
+ enddo
+ teta=twopi/two
+ do j=4,5
+ x1(j)=X1z
+ x2(j)=X2z
+ x3(j)=cos(teta*real(j-4,ki))-im*sin(teta*real(j-4,ki))
+ x4(j)=Fz/x3(j)
+ enddo
+
+ teta=twopi/two
+ do j=6,7
+ x1(j)=X1p
+ x2(j)=X2p
+ x4(j)=cos(teta*real(j-6,ki))+im*sin(teta*real(j-6,ki))
+ x3(j)=Fp/x4(j)
+ enddo
+ x1(8)=X1p
+ x2(8)=X2p
+ x3(8)=cone
+ x4(8)=Fp*cone
+
+ x1(9)=X1m
+ x2(9)=X2m
+ x3(9)=Fm*cone
+ x4(9)=cone
+
+ x1(10)=X1z
+ x2(10)=X2z
+ x3(10)=F1z*cone
+ x4(10)=cone
+
+ mu2t(2)=half
+ x1t=2.3_ki
+ x2t=A1-x1t*K1SQ/two/MP12(2)
+ Ft=x1t*x2t-(msq(j1)+mu2t(2))/two/MP12(2)
+ x3t=(2.5_ki,0.3_ki)
+ x4t=Ft/x3t
+
+ q2(1,:)=-p0(:)+x1(1)*e1(:)+x2(1)*e2(:)+KK(2)*x3(1)*e3(:)+x4(1)*e4(:)/KK(2)
+ q2(2,:)=-p0(:)+x1(2)*e1(:)+x2(2)*e2(:)+KK(2)*x3(2)*e3(:)+x4(2)*e4(:)/KK(2)
+ q2(3,:)=-p0(:)+x1(3)*e1(:)+x2(3)*e2(:)+KK(2)*x3(3)*e3(:)+x4(3)*e4(:)/KK(2)
+ q2(4,:)=-p0(:)+x1(4)*e1(:)+x2(4)*e2(:)+KK(2)*x3(4)*e3(:)+x4(4)*e4(:)/KK(2)
+ q2(5,:)=-p0(:)+x1(5)*e1(:)+x2(5)*e2(:)+KK(2)*x3(5)*e3(:)+x4(5)*e4(:)/KK(2)
+ q2(6,:)=-p0(:)+x1(6)*e1(:)+x2(6)*e2(:)+KK(2)*x3(6)*e3(:)+x4(6)*e4(:)/KK(2)
+ q2(7,:)=-p0(:)+x1(7)*e1(:)+x2(7)*e2(:)+KK(2)*x3(7)*e3(:)+x4(7)*e4(:)/KK(2)
+ q2(8,:)=-p0(:)+x1(8)*e1(:)+x2(8)*e2(:)+KK(2)*x3(8)*e3(:)+x4(8)*e4(:)/KK(2)
+ q2(9,:)=-p0(:)+x1(9)*e1(:)+x2(9)*e2(:)+KK(2)*x3(9)*e3(:)+x4(9)*e4(:)/KK(2)
+ q2(10,:)=-p0(:)+x1(10)*e1(:)+x2(10)*e2(:)+KK(2)*x3(10)*e3(:) &
+ & +x4(10)*e4(:)/KK(2)
+ qt(:)=-p0(:)+x1t*e1(:)+x2t*e2(:)+x3t*e3(:)+x4t*e4(:)
+
+ endif
+
+ end subroutine getq2_rm
+
+ subroutine getq1_cm(nleg,cut1,e1,e2,e3,e4,p0,msq,q1,qt)
+ use mglobal, only: G0c,KK,mu2g,MP12,mu2t
+ implicit none
+ integer, intent(in) :: nleg, cut1
+ real(ki), dimension(4), intent(in) :: p0, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ complex(ki), dimension(5,4), intent(out) :: q1
+ complex(ki), dimension(4), intent(out) :: qt
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+
+ complex(ki), dimension(5) :: x1, x2
+ complex(ki), dimension(5) :: x3, x4
+ complex(ki) :: varx,x1t,x2t,x3t,x4t
+ integer :: j1
+
+ KK(1)=one
+ j1=cut1
+
+ mu2g(1)=zip
+ if (abs(msq(j1)).eq.zip) then
+ mu2g(1)=one
+ endif
+
+ MP12(1)=sdot(e1,e2)
+ G0c=(msq(j1)+mu2g(1))/two/MP12(1)
+
+ x1(1)=G0c
+ x2(1)=cone
+ x3(1)=czip
+ x4(1)=czip
+
+ x1(2)=-G0c
+ x2(2)=-cone
+ x3(2)=czip
+ x4(2)=czip
+
+ x1(3)=G0c
+ x2(3)=cone
+ x3(3)=cone
+ x4(3)=czip
+
+ x1(4)=czip
+ x2(4)=cone
+ x3(4)=-cone
+ x4(4)=G0c
+
+ x1(5)=czip
+ x2(5)=cone
+ x3(5)=cone
+ x4(5)=-G0c
+
+
+ mu2t(1)=half
+ varx=-(msq(j1)+mu2t(1))/two/MP12(1)
+ x1t=3.2_ki
+ x2t=1.2_ki
+ x3t=4.2_ki
+ x4t=(varx+x1t*x2t)/x3t
+
+ q1(1,:)=-p0(:)+x1(1)*e1(:)+x2(1)*e2(:)+x3(1)*e3(:)+x4(1)*e4(:)
+ q1(2,:)=-p0(:)+x1(2)*e1(:)+x2(2)*e2(:)+x3(2)*e3(:)+x4(2)*e4(:)
+ q1(3,:)=-p0(:)+x1(3)*e1(:)+x2(3)*e2(:)+x3(3)*e3(:)+x4(3)*e4(:)
+ q1(4,:)=-p0(:)+x1(4)*e1(:)+x2(4)*e2(:)+x3(4)*e3(:)+x4(4)*e4(:)
+ q1(5,:)=-p0(:)+x1(5)*e1(:)+x2(5)*e2(:)+x3(5)*e3(:)+x4(5)*e4(:)
+ qt(:)=-p0(:)+x1t *e1(:)+x2t *e2(:)+x3t *e3(:)+x4t *e4(:)
+ end subroutine getq1_cm
+
+ subroutine getq1_rm(nleg,cut1,e1,e2,e3,e4,p0,msq,q1,qt)
+ use mglobal, only: G0,KK,mu2g,MP12,mu2t
+ implicit none
+ integer, intent(in) :: nleg, cut1
+ real(ki), dimension(4), intent(in) :: p0, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ complex(ki), dimension(5,4), intent(out) :: q1
+ complex(ki), dimension(4), intent(out) :: qt
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+
+ real(ki), dimension(5) :: x1, x2
+ complex(ki), dimension(5) :: x3, x4
+ real(ki) :: varx,x1t,x2t,x3t,x4t
+ integer :: j1
+
+ KK(1)=one
+ j1=cut1
+
+ mu2g(1)=zip
+ if (msq(j1).eq.zip) then
+ mu2g(1)=one
+ endif
+
+ MP12(1)=sdot(e1,e2)
+ G0=(msq(j1)+mu2g(1))/two/MP12(1)
+
+ x1(1)=G0
+ x2(1)=one
+ x3(1)=zip
+ x4(1)=zip
+
+ x1(2)=-G0
+ x2(2)=-one
+ x3(2)=zip
+ x4(2)=zip
+
+ x1(3)=G0
+ x2(3)=one
+ x3(3)=one
+ x4(3)=zip
+
+ x1(4)=zip
+ x2(4)=one
+ x3(4)=-one
+ x4(4)=G0
+
+ x1(5)=zip
+ x2(5)=one
+ x3(5)=one
+ x4(5)=-G0
+
+
+ mu2t(1)=half
+ varx=-(msq(j1)+mu2t(1))/two/MP12(1)
+ x1t=3.2_ki
+ x2t=1.2_ki
+ x3t=4.2_ki
+ x4t=(varx+x1t*x2t)/x3t
+
+ q1(1,:)=-p0(:)+x1(1)*e1(:)+x2(1)*e2(:)+x3(1)*e3(:)+x4(1)*e4(:)
+ q1(2,:)=-p0(:)+x1(2)*e1(:)+x2(2)*e2(:)+x3(2)*e3(:)+x4(2)*e4(:)
+ q1(3,:)=-p0(:)+x1(3)*e1(:)+x2(3)*e2(:)+x3(3)*e3(:)+x4(3)*e4(:)
+ q1(4,:)=-p0(:)+x1(4)*e1(:)+x2(4)*e2(:)+x3(4)*e3(:)+x4(4)*e4(:)
+ q1(5,:)=-p0(:)+x1(5)*e1(:)+x2(5)*e2(:)+x3(5)*e3(:)+x4(5)*e4(:)
+ qt(:)=-p0(:)+x1t *e1(:)+x2t *e2(:)+x3t *e3(:)+x4t *e4(:)
+ end subroutine getq1_rm
+
+end module mgetqs
+
diff --git a/samurai-2.1.1/mglobal.f90 b/samurai-2.1.1/mglobal.f90
new file mode 100644
index 0000000..0477fe5
--- /dev/null
+++ b/samurai-2.1.1/mglobal.f90
@@ -0,0 +1,93 @@
+module mglobal
+ use precision, only: ki
+ implicit none
+
+ private :: ki
+
+
+ !mgetc1.f90: common/FGzip/G0,KK,mu2,MP12,mu2t
+ ! G0 ---> G0
+ ! KK KK(1)
+ ! mu2 mu2g(1)
+ ! MP12 MP12(1)
+ ! mu2t mu2t(1)
+ !mgetc1.f90: common/t1/resit,dens1t,mu2test
+ ! resit ----> resit(1)
+ ! dens1t ---> denst(1)
+ ! mu2test --> mu2test(1)
+
+ !mgetc2.f90: common/Fzip/Fp,Fz,Fm,F1z,mu2,KK,Kmu,KB,MP12,mu2t
+ ! Fp,Fz,Fm,F1z --> Fp,Fz,Fm,F1z
+ ! KB ---> KB
+ ! mu2 ---> mu2g(2)
+ ! KK ---> KK(2)
+ ! Kmu --> Kmu(2)
+ ! MP12 ---> MP12(2)
+ ! mu2t ---> mu2t(2)
+ !mgetc2.f90: common/t2/resit,dens2t,mu2test
+ ! resit --> resit(2)
+ ! dens2t --> denst(2)
+ ! mu2test --> mu2test(2)
+
+
+ !mgetc3.f90: common/C0C1/C0,C1,mu2,MP12,KK,Kmu,mu2t
+ ! C0,C1 ---> C0,C1
+ ! mu2 ----> mu2g(3)
+ ! MP12 ---> MP12(3)
+ ! KK ----> KK(3)
+ ! Kmu ---> Kmu(3)
+ ! mu2t ---> mu2t(3)
+ !mgetc3.f90: common/t3/resit,dens3t,mu2test
+ ! resit ---> resit(3)
+ ! dens3t --> denst(3)
+ ! mu2test -> mu2test(3)
+
+ !mgetqs.f90: common/FGzip/G0,KK,mu2,MP12,mu2t
+ ! G0 ---> G0
+ ! KK KK(1)
+ ! mu2 mu2g(1)
+ ! MP12 MP12(1)
+ ! mu2t mu2t(1)
+ !mgetqs.f90: common/Fzip/Fp,Fz,Fm,F1z,mu2,KK,Kmu,KB,MP12,mu2t
+ ! Fp,Fz,Fm,F1z --> Fp,Fz,Fm,F1z
+ ! KB ---> KB
+ ! mu2 ---> mu2g(2)
+ ! KK ---> KK(2)
+ ! Kmu --> Kmu(2)
+ ! MP12 ---> MP12(2)
+ ! mu2t ---> mu2t(2)
+ !mgetqs.f90: common/ds/dx1,dx2,dx3,dx4,dx5
+ ! dxi --> dx(i)
+ !mgetqs.f90: common/C0C1/C0,C1,mu2,MP12,KK,Kmu,mu2t
+ ! C0,C1 ---> C0,C1
+ ! mu2 ----> mu2g(3)
+ ! MP12 ---> MP12(3)
+ ! KK ----> KK(3)
+ ! Kmu ---> Kmu(3)
+ ! mu2t ---> mu2t(3)
+ !mgetqs.f90: common/mp12mu2/MP12,mu2,mu2t
+ ! mp12 ---> MP12(4)
+ ! mu2 ---> mu2g(4)
+ ! mu2t ---> mu2t(4)
+
+ !mgetc4.f90: common/ds/dx1,dx2,dx3,dx4,dx5
+ ! dxi --> dx(i)
+ !mgetc4.f90: common/mp12mu2/mp12,mu2,mu2t
+ ! mp12 ---> MP12(4)
+ ! mu2 ---> mu2g(4)
+ ! mu2t ---> mu2t(4)
+ !mgetc4.f90: common/t4/resi5t,dens4t,mu2test
+ ! resi5t ---> resit(4)
+ ! dens4t ---> denst(4)
+ ! mu2test --> mu2test(4)
+
+ real(ki), dimension(1:4) :: MP12
+ real(ki), dimension(1:3) :: KK
+ complex(ki), dimension(1:4) :: mu2g, mu2t, mu2test
+ complex(ki), dimension(1:4) :: resit, denst
+ real(ki), dimension(2:3) :: Kmu
+ complex(ki), dimension(1:5) :: dx
+ real(ki) :: Fp,Fz,Fm,F1z,KB,C0,C1,G0
+ complex(ki) :: Fpc,Fzc,Fmc,F1zc,C0c,C1c,G0c
+
+end module mglobal
diff --git a/samurai-2.1.1/mrestore.f90 b/samurai-2.1.1/mrestore.f90
new file mode 100644
index 0000000..08a8f98
--- /dev/null
+++ b/samurai-2.1.1/mrestore.f90
@@ -0,0 +1,178 @@
+module mrestore
+ use precision
+ use constants
+ use save
+ use mfunctions
+ implicit none
+
+ private
+
+ public :: store1, store2, store3, store4, store5
+ public :: res1, res2, res3, res4, res5
+
+contains
+ subroutine store5(icut5,cut5,p0,e1,e2,e3,e4,c5)
+ implicit none
+ integer, intent(in) :: icut5,cut5
+ real(ki), dimension(4), intent(in) :: p0, e1, e2
+ complex(ki), intent(in) :: c5
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ sav5p0(icut5,:)=p0(:)
+ sav5e1(icut5,:)=e1(:)
+ sav5e2(icut5,:)=e2(:)
+ sav5e3(icut5,:)=e3(:)
+ sav5e4(icut5,:)=e4(:)
+ savc5(icut5)=c5
+ savcut5(icut5)=cut5
+ end subroutine store5
+
+ subroutine store4(icut4,cut4,L3,p0,e1,e2,e3,e4,c4)
+ implicit none
+ real(ki), dimension(4), intent(in) :: L3, p0, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ complex(ki), dimension(0:4), intent(in) :: c4
+ integer, intent(in) :: icut4,cut4
+ savL3(icut4,:)=L3(:)
+ sav4p0(icut4,:)=p0(:)
+ sav4e1(icut4,:)=e1(:)
+ sav4e2(icut4,:)=e2(:)
+ sav4e3(icut4,:)=e3(:)
+ sav4e4(icut4,:)=e4(:)
+ savc4(icut4,:)=c4(:)
+ savcut4(icut4)=cut4
+ end subroutine store4
+
+ subroutine store3(icut3,cut3,p0,e1,e2,e3,e4,c3)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p0, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ complex(ki), dimension(0:9), intent(in) :: c3
+ integer, intent(in) :: icut3,cut3
+ sav3p0(icut3,:)=p0(:)
+ sav3e1(icut3,:)=e1(:)
+ sav3e2(icut3,:)=e2(:)
+ sav3e3(icut3,:)=e3(:)
+ sav3e4(icut3,:)=e4(:)
+ savc3(icut3,:)=c3(:)
+ savcut3(icut3)=cut3
+ end subroutine store3
+
+ subroutine store2(icut2,cut2,p0,e1,e2,e3,e4,c2)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p0, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ complex(ki), dimension(0:9), intent(in) :: c2
+ integer, intent(in) :: icut2,cut2
+ sav2p0(icut2,:)=p0(:)
+ sav2e1(icut2,:)=e1(:)
+ sav2e2(icut2,:)=e2(:)
+ sav2e3(icut2,:)=e3(:)
+ sav2e4(icut2,:)=e4(:)
+ savc2(icut2,:)=c2(:)
+ savcut2(icut2)=cut2
+ end subroutine store2
+
+ subroutine store1(icut1,cut1,p0,e1,e2,e3,e4,c1)
+ implicit none
+ real(ki), dimension(4), intent(in) :: p0, e1, e2
+ complex(ki), dimension(4), intent(in) :: e3, e4
+ complex(ki), dimension(0:4), intent(in) :: c1
+ integer, intent(in) :: icut1,cut1
+
+ sav1p0(icut1,:)=p0(:)
+ sav1e1(icut1,:)=e1(:)
+ sav1e2(icut1,:)=e2(:)
+ sav1e3(icut1,:)=e3(:)
+ sav1e4(icut1,:)=e4(:)
+ savc1(icut1,:)=c1(:)
+ savcut1(icut1)=cut1
+ end subroutine store1
+
+ pure function res5(icut5,mu2)
+ implicit none
+ integer, intent(in) :: icut5
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: res5
+
+ res5=savc5(icut5)*mu2
+ ! res5=savc5(icut5)*mu2**2
+ end function res5
+
+ pure function res4(icut4,q,mu2)
+ implicit none
+ integer, intent(in) :: icut4
+ complex(ki), intent(in) :: mu2
+ complex(ki), dimension(4), intent(in) :: q
+ complex(ki) :: res4
+
+ real(ki), dimension(4) :: L3
+ complex(ki), dimension(4) :: e3, e4, pm
+ complex(ki), dimension(0:4) :: c4
+
+ L3(:)=savL3(icut4,:)
+ pm(:)=sav4p0(icut4,:)+q(:)
+ e3(:)=sav4e3(icut4,:)
+ e4(:)=sav4e4(icut4,:)
+ c4(:)=savc4(icut4,:)
+
+ res4=poly4(c4,pm,mu2,L3,e3,e4)
+ end function res4
+
+ pure function res3(icut3,q,mu2)
+ implicit none
+ integer, intent(in) :: icut3
+ complex(ki), intent(in) :: mu2
+ complex(ki), dimension(4), intent(in) :: q
+ complex(ki) :: res3
+
+ complex(ki), dimension(4) :: e3, e4, pm
+ complex(ki) :: c3(0:9)
+
+ pm(:)=sav3p0(icut3,:)+q(:)
+ e3(:)=sav3e3(icut3,:)
+ e4(:)=sav3e4(icut3,:)
+ c3(:)=savc3(icut3,:)
+
+ res3=poly3(c3,pm,mu2,e3,e4)
+ end function res3
+
+ pure function res2(icut2,q,mu2)
+ implicit none
+ integer, intent(in) :: icut2
+ complex(ki), dimension(4), intent(in) :: q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: res2
+
+ real(ki), dimension(4) :: e2
+ complex(ki), dimension(4) :: e3,e4,pm
+ complex(ki), dimension(0:9) :: c2
+
+ pm(:)=sav2p0(icut2,:)+q(:)
+ e2(:)=sav2e2(icut2,:)
+ e3(:)=sav2e3(icut2,:)
+ e4(:)=sav2e4(icut2,:)
+ c2(:)=savc2(icut2,:)
+ res2=poly2(c2,pm,mu2,e2,e3,e4)
+ end function res2
+
+ pure function res1(icut1,q)
+ implicit none
+ integer, intent(in) :: icut1
+ complex(ki), dimension(4), intent(in) :: q
+ complex(ki) :: res1
+
+ real(ki), dimension(4) :: e1, e2
+ complex(ki), dimension(4) :: e3, e4, pm
+ complex(ki), dimension(0:4) :: c1
+
+ pm(:)=sav1p0(icut1,:)+q(:)
+ e1(:)=sav1e1(icut1,:)
+ e2(:)=sav1e2(icut1,:)
+ e3(:)=sav1e3(icut1,:)
+ e4(:)=sav1e4(icut1,:)
+ c1(:)=savc1(icut1,:)
+
+ res1=poly1(c1,pm,e1,e2,e3,e4)
+ end function res1
+
+end module mrestore
diff --git a/samurai-2.1.1/msamurai.f90.in b/samurai-2.1.1/msamurai.f90.in
new file mode 100644
index 0000000..6fe5acf
--- /dev/null
+++ b/samurai-2.1.1/msamurai.f90.in
@@ -0,0 +1,1547 @@
+module msamurai
+ use precision
+ use constants
+ use options
+ use ncuts
+ use notfirst
+ use ltest
+ use madds
+ use mgetqs
+ use mgetbase
+ use mrestore
+ use mgetc5
+ use mgetc4
+ use mgetc3
+ use mgetc2
+ use mgetc1
+ use mtests
+ use mtens, only: tensor_reconstruction, numetens
+ implicit none
+
+ private
+
+ interface samurai
+ module procedure samurai_rm
+ module procedure samurai_cm
+ end interface samurai
+
+ interface InitDenominators
+ module procedure InitDenominators_rm
+ module procedure InitDenominators_cm
+ end interface InitDenominators
+
+ public :: initsamurai, exitsamurai, InitDenominators, samurai
+ public :: samurai_cm, samurai_rm
+
+contains
+
+ !---#[ subroutine initsamurai:
+ subroutine initsamurai(ameth, asca, averb, atest, aresc)
+@case_with_avh@ use avh_olo, only: olo_onshell
+ implicit none
+ integer, intent(in) :: asca, averb, atest
+ character(len=4), intent(in) :: ameth
+ integer, intent(in), optional :: aresc
+
+ call banner
+
+
+ if (ameth.eq.'diag') then
+ imeth = ameth
+ meth_is_tree = .false.
+ meth_is_diag = .true.
+ elseif (ameth.eq.'tree') then
+ imeth = ameth
+ meth_is_tree = .true.
+ meth_is_diag = .false.
+ else
+ write(6,*) 'incompatible value for imeth'
+ write(6,*) 'imeth =','ameth'
+ stop
+ endif
+
+ if ((asca.ge.1).and.(asca.le.4)) then
+ isca = asca
+ else
+ write(6,*) 'incompatible value for isca'
+ write(6,*) 'isca =',asca
+ stop
+ endif
+
+ if ((averb.ge.0).or.(averb.le.3)) then
+ verbosity = averb
+ else
+ write(6,*) 'incompatible value for verbosity'
+ write(6,*) 'verbosity =',averb
+ stop
+ endif
+
+ if ((atest.ge.0).or.(atest.le.3)) then
+ itest = atest
+ else
+ write(6,*) 'incompatible value for itest'
+ write(6,*) 'itest =',atest
+ stop
+ endif
+
+ if (present(aresc)) then
+ if ((0.le.aresc).and.(aresc.le.3)) then
+ iresc = aresc
+ else
+ write(6,*) 'incompatible value for iresc'
+ write(6,*) 'iresc =',aresc
+ stop
+ endif
+ else
+ iresc=0
+ endif
+
+ if (imeth.eq.'tree') itest=2
+
+ if (isca .eq. 1) then
+@case_with_ql@ call qlinit
+ elseif (isca .eq. 2) then
+@case_with_avh@ call olo_onshell(1.d-8)
+ elseif (isca .eq. 4) then
+@case_with_lt@ call ltini
+ end if
+
+ 901 format(a40,a4,a10,I1,a15,I1,a11,I1)
+
+ if (verbosity.gt.0) then
+ if (notfirstp.eqv.(.false.)) then
+ open(unit=iout,file='output.dat',status='unknown')
+ write(iout,*) '-------------------------------------------&
+ &----------------------- ---------------'
+ write(iout,901) ' SAMURAI called with arguments: imeth = ',imeth,&
+ & ' ; isca = ',isca,' ; verbosity = ',verbosity,' ; itest = ',itest
+ write(iout,*) '-------------------------------------------------&
+ &----------------- ---------------'
+ notfirstp = .TRUE.
+ endif
+ endif
+ if (itest.gt.0 .and. verbosity.gt.0) then
+ if (notfirstd.eqv.(.false.)) then
+ if (ibad.gt.0) then
+ open(unit=ibad,file='bad.points',status='unknown')
+ write(ibad,*) '-------------------------------------------------&
+ &-------------------'
+ write(ibad,904) ' Points that have been discarded by &
+ &SAMURAI because failing itest = ',itest
+ write(ibad,*) '-------------------------------------------------&
+ &-------------------'
+ endif
+ notfirstd = .true.
+ endif
+ endif
+
+ 904 format(a68,I1)
+
+ call rtlimit
+
+ end subroutine initsamurai
+ !---#] subroutine initsamurai:
+ !---#[ subroutine rtlimit:
+ subroutine rtlimit
+ implicit none
+ real :: tpwlimit,tnnlimit,tnnlimit4,tnnlimit3,tnnlimit2,tnnlimit1
+ integer :: ierr
+ open(unit=10,file='ltest.dat',status='old',iostat=ierr)
+
+ if (ierr.eq.0) then
+ read(10,*)
+ read(10,*)
+ read(10,*) tpwlimit
+ pwlimit = real(tpwlimit, ki)
+ read(10,*) tnnlimit
+ nnlimit = real(tnnlimit, ki)
+ read(10,*) tnnlimit4
+ lnnlimit4 = real(tnnlimit4, ki)
+ read(10,*) tnnlimit3
+ lnnlimit3 = real(tnnlimit3, ki)
+ read(10,*) tnnlimit2
+ lnnlimit2 = real(tnnlimit2, ki)
+ read(10,*) tnnlimit1
+ lnnlimit1 = real(tnnlimit1, ki)
+
+ close(10)
+ else
+ pwlimit = 1.0E-03_ki
+ nnlimit = 1.0E-03_ki
+ lnnlimit4 = 1.0E-02_ki
+ lnnlimit3 = 1.0E-02_ki
+ lnnlimit2 = 1.0E-02_ki
+ lnnlimit1 = 1.0E+01_ki
+ end if
+ end subroutine rtlimit
+ !---#] subroutine rtlimit:
+ !---#[ subroutine exitsamurai:
+ subroutine exitsamurai()
+ implicit none
+
+ if (verbosity.gt.0) then
+ close(iout)
+ endif
+
+ if (itest.gt.0) then
+ if (ibad.gt.0) then
+ close(ibad)
+ endif
+ endif
+
+ if (isca.eq.4) then
+@case_with_lt@ call ltexi
+ endif
+ end subroutine exitsamurai
+ !---#] subroutine exitsamurai:
+ !---#[ subroutine banner:
+ subroutine banner
+ implicit none
+
+ print*
+ print*, ' *******************************************************&
+ &*************'
+ print*, ' ********************** SAMURAI - version @VERSION@'
+ print*, ' *******************************************************&
+ &*************'
+ print*, ' * &
+ & *'
+ print*, ' * &
+ & *'
+ print*, ' * Authors: P. Mastrolia, G. Ossola, T. Reiter and F. Tr&
+ &amontano *'
+ print*, ' * &
+ & *'
+ print*, ' * pierpaolo.mastrolia@cern.ch &
+ & *'
+ print*, ' * gossola@citytech.cuny.edu &
+ & *'
+ print*, ' * reiterth@mpp.mpg.de &
+ & *'
+ print*, ' * francesco.tramontano@cern.ch &
+ & *'
+ print*, ' * &
+ & *'
+ print*, ' * For details please see: arXiv:1006.0710 &
+ & *'
+ print*, ' * &
+ & *'
+ print*, ' * On the web: http://cern.ch/samurai &
+ & *'
+ print*, ' * &
+ & *'
+ print*, ' *******************************************************&
+ &*************'
+ print*, ' * &
+ & *'
+ print*, ' * output files: <output.log> [ for verbosity.gt.0 ] &
+ & *'
+ print*, ' * &
+ & *'
+ print*, ' * <bad.points> [ for itest.gt.0 ] &
+ & *'
+ print*, ' * &
+ & *'
+ print*, ' *******************************************************&
+ &*************'
+ end subroutine banner
+ !---#] subroutine banner:
+ !---#[ subroutine InitDenominators_cm:
+ pure subroutine InitDenominators_cm(nleg,Vi,msq,&
+ &Q0,m0,Q1,m1,Q2,m2,Q3,m3,Q4,m4,Q5,m5,Q6,m6,Q7,m7)
+ implicit none
+ integer, intent(in) :: nleg
+ real(ki), dimension(0:nleg-1,4), intent(out) :: Vi
+ complex(ki), dimension(0:nleg-1), intent(out) :: msq
+
+ real(ki), dimension(4), intent(in), optional :: Q0
+ complex(ki), intent(in), optional :: m0
+ real(ki), dimension(4), intent(in), optional :: Q1
+ complex(ki), intent(in), optional :: m1
+ real(ki), dimension(4), intent(in), optional :: Q2
+ complex(ki), intent(in), optional :: m2
+ real(ki), dimension(4), intent(in), optional :: Q3
+ complex(ki), intent(in), optional :: m3
+ real(ki), dimension(4), intent(in), optional :: Q4
+ complex(ki), intent(in), optional :: m4
+ real(ki), dimension(4), intent(in), optional :: Q5
+ complex(ki), intent(in), optional :: m5
+ real(ki), dimension(4), intent(in), optional :: Q6
+ complex(ki), intent(in), optional :: m6
+ real(ki), dimension(4), intent(in), optional :: Q7
+ complex(ki), intent(in), optional :: m7
+
+ if(present(Q0) .and. present(m0)) then
+ Vi(0,:) = Q0
+ msq(0) = m0*m0
+ end if
+ if(present(Q1) .and. present(m1)) then
+ Vi(1,:) = Q1
+ msq(1) = m1*m1
+ end if
+ if(present(Q2) .and. present(m2)) then
+ Vi(2,:) = Q2
+ msq(2) = m2*m2
+ end if
+ if(present(Q3) .and. present(m3)) then
+ Vi(3,:) = Q3
+ msq(3) = m3*m3
+ end if
+ if(present(Q4) .and. present(m4)) then
+ Vi(4,:) = Q4
+ msq(4) = m4*m4
+ end if
+ if(present(Q5) .and. present(m5)) then
+ Vi(5,:) = Q5
+ msq(5) = m5*m5
+ end if
+ if(present(Q6) .and. present(m6)) then
+ Vi(6,:) = Q6
+ msq(6) = m6*m6
+ end if
+ if(present(Q7) .and. present(m7)) then
+ Vi(7,:) = Q7
+ msq(7) = m7*m7
+ end if
+
+ end subroutine InitDenominators_cm
+ !---#] subroutine InitDenominators_cm:
+ !---#[ subroutine InitDenominators_rm:
+ pure subroutine InitDenominators_rm(nleg,Vi,msq,&
+ &Q0,m0,Q1,m1,Q2,m2,Q3,m3,Q4,m4,Q5,m5,Q6,m6,Q7,m7)
+ implicit none
+ integer, intent(in) :: nleg
+ real(ki), dimension(0:nleg-1,4), intent(out) :: Vi
+ real(ki), dimension(0:nleg-1), intent(out) :: msq
+
+ real(ki), dimension(4), intent(in), optional :: Q0
+ real(ki), intent(in), optional :: m0
+ real(ki), dimension(4), intent(in), optional :: Q1
+ real(ki), intent(in), optional :: m1
+ real(ki), dimension(4), intent(in), optional :: Q2
+ real(ki), intent(in), optional :: m2
+ real(ki), dimension(4), intent(in), optional :: Q3
+ real(ki), intent(in), optional :: m3
+ real(ki), dimension(4), intent(in), optional :: Q4
+ real(ki), intent(in), optional :: m4
+ real(ki), dimension(4), intent(in), optional :: Q5
+ real(ki), intent(in), optional :: m5
+ real(ki), dimension(4), intent(in), optional :: Q6
+ real(ki), intent(in), optional :: m6
+ real(ki), dimension(4), intent(in), optional :: Q7
+ real(ki), intent(in), optional :: m7
+
+ if(present(Q0) .and. present(m0)) then
+ Vi(0,:) = Q0
+ msq(0) = m0*m0
+ end if
+ if(present(Q1) .and. present(m1)) then
+ Vi(1,:) = Q1
+ msq(1) = m1*m1
+ end if
+ if(present(Q2) .and. present(m2)) then
+ Vi(2,:) = Q2
+ msq(2) = m2*m2
+ end if
+ if(present(Q3) .and. present(m3)) then
+ Vi(3,:) = Q3
+ msq(3) = m3*m3
+ end if
+ if(present(Q4) .and. present(m4)) then
+ Vi(4,:) = Q4
+ msq(4) = m4*m4
+ end if
+ if(present(Q5) .and. present(m5)) then
+ Vi(5,:) = Q5
+ msq(5) = m5*m5
+ end if
+ if(present(Q6) .and. present(m6)) then
+ Vi(6,:) = Q6
+ msq(6) = m6*m6
+ end if
+ if(present(Q7) .and. present(m7)) then
+ Vi(7,:) = Q7
+ msq(7) = m7*m7
+ end if
+
+ end subroutine InitDenominators_rm
+ !---#] subroutine InitDenominators_rm:
+ !---#[ subroutine samurai_cm:
+ subroutine samurai_cm(numeval,tot,totr,Vi,msq,nleg,rank,istop,scale2,ok,&
+ cache_flag, scalar_cache)
+ use options, only: use_maccu
+ use maccu
+ implicit none
+
+ integer, intent(in) :: nleg, rank, istop
+ real(ki), intent(in) :: scale2
+ complex(ki), intent(out) :: totr
+ complex(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ complex(ki), dimension(-2:0), intent(out) :: tot
+ logical, intent(out) :: ok
+ logical, intent(inout), optional :: cache_flag
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+ type(accumulator_type), dimension(-2:0) :: acc_re, acc_im
+ type(accumulator_type) :: accr_re, accr_im
+
+ integer :: i,j,k,j1,j2,j3,j4,j5,icut5,icut4,icut3,icut2,icut1
+ integer :: cut5,cut4,cut3,cut2,cut1,n1,ep
+ integer :: diff
+ integer :: cache_offset
+
+ complex(ki) :: mu2, mu2test
+ real(ki) :: r1, r2, factor
+ real(ki), dimension(4):: k1, k2, k3, e1, e2, p0, L3
+
+ complex(ki) :: c5,tot2r,tot3r,tot4r
+ complex(ki), dimension(5,4) :: q4, q1
+ complex(ki), dimension(10,4) :: q3, q2
+ complex(ki), dimension(4):: q5, e3, e4, qt, qtest
+ complex(ki), dimension(0:4) :: c4, c1
+ complex(ki), dimension(0:9) :: c3, c2
+ complex(ki), dimension(-2:0) :: tot4, tot3, tot2, tot1
+
+ logical :: rescue
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ if (nleg.gt.maxleg) then
+ write(6,*) 'reduction called for nleg.gt.maxleg'
+ write(6,*) 'maxleg, nleg ',maxleg,nleg
+ write(6,*) 'please change the values max1,..,max5,maxleg &
+ &in constants.f90'
+ write(6,*) 'and compile again the library'
+ stop
+ endif
+
+ cache_offset = 0
+ diff = nleg-rank
+
+ if(verbosity.gt.0)then
+ write(iout,*)
+ write(iout,*)
+ write(iout,*) 'Denominators: '
+ do k=0,nleg-1
+ write(iout,902) ' Pi(',k,') = ', Vi(k,:)
+ write(iout,903) 'msq(',k,') = ', msq(k)
+ write(iout,*)
+ enddo
+ write(iout,*)' '
+ endif
+
+ totr=czip
+ tot4r=czip
+ tot3r=czip
+ tot2r=czip
+
+ tot(:)=czip
+ tot4(:)=czip
+ tot3(:)=czip
+ tot2(:)=czip
+ tot1(:)=czip
+
+ rescue = .false.
+
+ if (use_maccu) then
+ do ep=-2,0
+ acc_re(ep)%a(:) = 0.0_ki
+ acc_im(ep)%a(:) = 0.0_ki
+ end do
+ accr_re%a(:) = 0.0_ki
+ accr_im%a(:) = 0.0_ki
+ end if
+
+! 5 continue
+
+!!$ if ( (iresc.eq.1).or.(iresc.eq.2).or.&
+!!$ ((iresc.eq.3).and.(rescue))) then
+!!$ call tensor_reconstruction(numeval,nleg,rank)
+!!$ if (iresc.eq.1) goto 6
+!!$ if ( (iresc.eq.2).or.&
+!!$ ((iresc.eq.3).and.(rescue)) ) then
+!!$
+!!$ ! Last parameter sets tot_or_rat in golem95
+!!$ ! false -- full reconstruction
+!!$ ! true -- rational part only
+!!$ tot = addtens(rank,nleg,Vi,msq,scale2,.false.)
+!!$ ok = .true.
+!!$ goto 100
+!!$ endif
+
+ notfirsti = .false.
+
+ if (iresc.eq.1) then
+ call tensor_reconstruction(numeval,nleg,rank)
+ endif
+
+! 6 continue
+
+ if (nleg.ge.5) then
+ goto 10
+ elseif (nleg.eq.4) then
+ goto 20
+ elseif (nleg.eq.3) then
+ goto 30
+ elseif (nleg.eq.2) then
+ goto 40
+ elseif ((nleg.eq.1).or.(nleg.le.0)) then
+ goto 50
+ endif
+
+ 10 continue
+
+ if(verbosity.gt.0)then
+ write(iout,*) 'Pentagon coefficients: '
+ endif
+
+!--- Quintuple cuts
+ icut5=1
+ do j5=4,nleg-1
+ do j4=3,j5-1
+ do j3=2,j4-1
+ do j2=1,j3-1
+ do j1=0,j2-1
+
+ cut5=j5*10000+j4*1000+j3*100+j2*10+j1
+
+ do n1=1,4
+ k1(n1)=Vi(j2,n1)-Vi(j1,n1)
+ k2(n1)=Vi(j1,n1)-Vi(j5,n1)
+ p0(n1)=Vi(j1,n1)
+ enddo
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+ call getq5(nleg,cut5,e1,e2,e3,e4,p0,Vi,msq,r1,r2,q5,mu2)
+
+ if (iresc.eq.1) then
+ call getc5(numetens,nleg,c5,cut5,Vi,msq,q5,mu2)
+ else
+ call getc5(numeval,nleg,c5,cut5,Vi,msq,q5,mu2)
+ endif
+
+ call store5(icut5,cut5,p0,e1,e2,e3,e4,c5)
+
+ if(verbosity.gt.0)then
+ write(iout,9005) 'c5(', cut5,') = (',real(c5),',',aimag(c5),' )'
+ write(iout,*)
+ endif
+
+!--- nullify all
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ k1(:)=0.0_ki
+ k2(:)=0.0_ki
+ p0(:)=0.0_ki
+
+ icut5=icut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ nc5=icut5-1
+
+ if (istop.eq.5) goto 99
+
+ 20 continue
+
+ if(verbosity.gt.0)then
+ write(iout,*) 'Box coefficients: '
+ endif
+
+
+!--- Quadruple cuts
+ icut4=1
+ do j4=3,nleg-1
+ do j3=2,j4-1
+ do j2=1,j3-1
+ do j1=0,j2-1
+
+ cut4=j4*1000+j3*100+j2*10+j1
+
+ do n1=1,4
+ k1(n1)=Vi(j2,n1)-Vi(j1,n1)
+ k2(n1)=Vi(j1,n1)-Vi(j4,n1)
+ k3(n1)=Vi(j3,n1)-Vi(j1,n1)
+ p0(n1)=Vi(j1,n1)
+ L3(n1)=Vi(j4,n1)-Vi(j3,n1)
+ enddo
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+ call getq4(nleg,cut4,e1,e2,e3,e4,p0,k1,k2,k3,L3,r1,r2,q4,qt,msq)
+
+ if (iresc.eq.1) then
+ call getc4(numetens,nleg,rank,c4,cut4,q4,qt,p0,Vi,msq)
+ else
+ call getc4(numeval,nleg,rank,c4,cut4,q4,qt,p0,Vi,msq)
+ endif
+
+ if (itest.eq.2) call lnntest4(numeval,cut4,c4,qt,p0,L3,e3,e4,ok)
+ call store4(icut4,cut4,L3,p0,e1,e2,e3,e4,c4)
+ if (present(cache_flag)) then
+ call add4_cm(nleg,c4,cut4,Vi,msq,tot4,tot4r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+ else
+ call add4_cm(nleg,c4,cut4,Vi,msq,tot4,tot4r,scale2)
+ end if
+
+ if(verbosity.gt.0)then
+ do i=0,4
+ write(iout,9004) 'c4(', cut4,',',i,') = (',real(c4(i)),',',aimag(c4(i)),' )'
+ enddo
+ write(iout,*)
+ endif
+
+ if (use_maccu) then
+ call add_accu(accr_re, accr_im, tot4r)
+ call add_accu(acc_re(:), acc_im(:), tot4(:))
+ else
+ tot(:)=tot(:)+tot4(:)
+ totr=totr+tot4r
+ end if
+
+!--- nullify all
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ k1(:)=0.0_ki
+ k2(:)=0.0_ki
+ k3(:)=0.0_ki
+ p0(:)=0.0_ki
+ L3(:)=0.0_ki
+
+ icut4=icut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ nc4=icut4-1
+
+
+ if (istop.eq.4) goto 99
+
+ 30 continue
+
+ if (diff.ge.4.and.itest.ne.1) goto 93
+
+ if(verbosity.gt.0.and.diff.le.3)then
+ write(iout,*) 'Triangle coefficients: '
+ endif
+
+!--- Triple cuts
+ icut3=1
+ do j3=2,nleg-1
+ do j2=1,j3-1
+ do j1=0,j2-1
+
+ cut3=j3*100+j2*10+j1
+
+ k1(:)=Vi(j2,:)-Vi(j1,:)
+ k2(:)=Vi(j1,:)-Vi(j3,:)
+ p0(:)=Vi(j1,:)
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+
+ call getq3(nleg,rank,cut3,e1,e2,e3,e4,p0,k1,k2,msq,r1,r2,q3,qt)
+
+ if (iresc.eq.1) then
+ call getc3(numetens,nleg,rank,c3,cut3,q3,qt,Vi,msq)
+ else
+ call getc3(numeval,nleg,rank,c3,cut3,q3,qt,Vi,msq)
+ endif
+
+ if (itest.eq.2) call lnntest3(numeval,cut3,c3,qt,p0,e3,e4,ok)
+ call store3(icut3,cut3,p0,e1,e2,e3,e4,c3)
+ if (present(cache_flag)) then
+ call add3_cm(nleg,c3,cut3,Vi,msq,tot3,tot3r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+ else
+ call add3_cm(nleg,c3,cut3,Vi,msq,tot3,tot3r,scale2)
+ end if
+
+ if(verbosity.gt.0.and.diff.le.3)then
+ do i=0,9
+ write(iout,9003) 'c3(',cut3,',',i,') = (',real(c3(i)),',',aimag(c3(i)),' )'
+ enddo
+ write(iout,*)
+ endif
+
+ if (use_maccu) then
+ call add_accu(accr_re, accr_im, tot3r)
+ call add_accu(acc_re(:), acc_im(:), tot3(:))
+ else
+ tot(:)=tot(:)+tot3(:)
+ totr=totr+tot3r
+ end if
+
+!--- nullify all
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ k1(:)=0.0_ki
+ k2(:)=0.0_ki
+ p0(:)=0.0_ki
+
+ icut3=icut3+1
+ enddo
+ enddo
+ enddo
+ nc3=icut3-1
+
+ if (istop.eq.3) goto 99
+
+ 40 continue
+
+ if (diff.ge.3) goto 95
+
+ if(verbosity.gt.0)then
+ write(iout,*) 'Bubble coefficients: '
+ endif
+
+!--- Double cuts
+ icut2=1
+ do j2=1,nleg-1
+ do j1=0,j2-1
+
+ cut2=j2*10+j1
+
+ k1(:)=Vi(j2,:)-Vi(j1,:)
+ p0(:)=Vi(j1,:)
+
+
+ if (abs(abs(k1(4))-1.0_ki) .lt. 0.1_ki) then
+ factor = 0.345_ki
+ else
+ factor = one
+ end if
+ k2(1)=-sign(factor/rt3,k1(1))
+ k2(2)=-sign(factor/rt3,k1(2))
+ k2(3)=-sign(factor/rt3,k1(3))
+ k2(4)= sign(factor,k1(4))
+
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+
+ call getq2(nleg,rank,cut2,e1,e2,e3,e4,p0,k1,msq,q2,qt)
+
+ if (iresc.eq.1) then
+ call getc2(numetens,nleg,rank,c2,cut2,q2,qt,Vi,msq)
+ else
+ call getc2(numeval,nleg,rank,c2,cut2,q2,qt,Vi,msq)
+ endif
+
+ if (itest.eq.2) call lnntest2(numeval,cut2,c2,qt,p0,e2,e3,e4,ok)
+ call store2(icut2,cut2,p0,e1,e2,e3,e4,c2)
+ if (present(cache_flag)) then
+ call add2_cm(nleg,c2,cut2,k1,k2,msq,tot2,tot2r,scale2, &
+ & cache_flag, cache_offset, scalar_cache)
+ else
+ call add2_cm(nleg,c2,cut2,k1,k2,msq,tot2,tot2r,scale2)
+ end if
+
+ if(verbosity.gt.0)then
+ do i=0,9
+ write(iout,9002) 'c2(',cut2,',',i,') = (', &
+ & real(c2(i)),',',aimag(c2(i)),' )'
+ enddo
+ write(iout,*)
+ endif
+
+ if (use_maccu) then
+ call add_accu(accr_re, accr_im, tot2r)
+ call add_accu(acc_re(:), acc_im(:), tot2(:))
+ else
+ tot(:)=tot(:)+tot2(:)
+ totr=totr+tot2r
+ end if
+
+!--- nullify k1,k2,p0
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ k1(:)=0.0_ki
+ p0(:)=0.0_ki
+
+ icut2=icut2+1
+ enddo
+ enddo
+ nc2=icut2-1
+
+ if (istop.eq.2) goto 99
+
+ 50 continue
+
+ if (diff.ge.2) goto 97
+
+ if(verbosity.gt.0)then
+ write(iout,*) 'Tadpole coefficients: '
+ endif
+
+
+!--- Single cut
+ icut1=1
+ do j1=0,nleg-1
+
+ cut1=j1
+
+ k1(1)=+one/rt3
+ k1(2)=-one/rt3
+ k1(3)=+one/rt3
+ k1(4)=+two
+ k2(1)=+one/rt2
+ k2(2)=-one/rt2
+ k2(3)=+one/rt2
+ k2(4)=+rt3
+
+ p0(:)=Vi(j1,:)
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+ call getq1(nleg,cut1,e1,e2,e3,e4,p0,msq,q1,qt)
+
+ if (iresc.eq.1) then
+ call getc1(numetens,nleg,rank,c1,cut1,q1,qt,Vi,msq)
+ else
+ call getc1(numeval,nleg,rank,c1,cut1,q1,qt,Vi,msq)
+ endif
+
+ if (itest.eq.2) call lnntest1(numeval,cut1,c1,qt,p0,e1,e2,e3,e4,ok)
+ call store1(icut1,cut1,p0,e1,e2,e3,e4,c1)
+
+ if (present(cache_flag)) then
+ call add1_cm(nleg,c1,cut1,msq,tot1,scale2,&
+ & cache_flag, cache_offset, scalar_cache)
+ else
+ call add1_cm(nleg,c1,cut1,msq,tot1,scale2)
+ end if
+
+ if(verbosity.gt.0)then
+ do i=0,4
+ write(iout,9002) 'c1(',cut1,',',i,') = (',real(c1(i)),',',aimag(c1(i)),' )'
+ enddo
+ write(iout,*)
+ endif
+
+ if (use_maccu) then
+ call add_accu(acc_re, acc_im, tot1)
+ else
+ tot(:)=tot(:)+tot1(:)
+ end if
+
+!--- nullify k1,k2,p0
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ p0(:)=0.0_ki
+
+ icut1=icut1+1
+ enddo
+ nc1=icut1-1
+
+ 93 continue
+
+ do j=0,9
+ c3(j)=czip
+ enddo
+
+ 95 continue
+
+ do j=0,9
+ c2(j)=czip
+ enddo
+
+ 97 continue
+
+ do j=0,4
+ c1(j)=czip
+ enddo
+
+ 99 continue
+
+ if (use_maccu) then
+ tot = reduce_accu(acc_re, acc_im)
+ totr = reduce_accu(accr_re, accr_im)
+ end if
+
+
+! TEST N=N -------------------------------------------
+ if (itest.eq.1) then
+ qtest=10.3_ki*cone
+ mu2test=13.0_ki
+ call nntest(numeval,qtest,mu2test,nleg,Vi,msq,ok)
+ endif
+!-----------------------------------------------------
+
+! POWER test ----------------------------------
+ if (itest.eq.3) call pwtest(nleg,rank,ok)
+! ---------------------------------------------
+
+!!$ if ((itest.eq.3).and.(iresc.eq.3).and.(ok.eqv.(.false.))) then
+!!$ rescue = .true.
+!!$ print*, 'eccolo'
+!!$ goto 5
+!!$ endif
+
+ ! 100 continue
+
+ if (ok) then
+
+ if(verbosity.gt.0)then
+ write(iout,*)
+ write(iout,*)' Result: '
+ write(iout,*)' Double Pole = ', tot(-2)
+ write(iout,*)' Single Pole = ', tot(-1)
+ write(iout,*)' Finite Part = ', tot(0)
+ write(iout,*)
+ write(iout,*)'[Rational Part = ', totr,']'
+ write(iout,*)
+ write(iout,*)
+ endif
+
+ else
+
+ if(ibad.gt.0.and.verbosity.gt.0)then
+ write(ibad,*) 'Denominators: '
+ do k=0,nleg-1
+ write(ibad,902) ' Pi(',k,') = ', Vi(k,:)
+ write(ibad,903) 'msq(',k,') = ', msq(k)
+ write(ibad,*)
+ enddo
+ write(ibad,*)'---------------------------------------- '
+ write(ibad,*)' '
+ endif
+ endif
+
+ if(present(cache_flag)) cache_flag = .true.
+
+ 902 format(a4,I1,a4,4(D24.15))
+ 903 format(a4,I1,a4,2(D24.15))
+
+ 9005 format(A3,I5,A6,D24.15,A1,D24.15,A3)
+ 9004 format(A3,I4,A1,I1,A5,D24.15,A1,D24.15,A3)
+ 9003 format(A3,I3,A1,I1,A6,D24.15,A1,D24.15,A3)
+ 9002 format(A3,I2,A1,I1,A7,D24.15,A1,D24.15,A3)
+
+ end subroutine samurai_cm
+ !---#] subroutine samurai_cm:
+ !---#[ subroutine samurai_rm:
+ subroutine samurai_rm(numeval,tot,totr,Vi,msq,nleg,rank,istop,scale2,ok,&
+ cache_flag, scalar_cache)
+ use options, only: use_maccu
+ use maccu
+ implicit none
+
+ integer, intent(in) :: nleg, rank, istop
+ real(ki), intent(in) :: scale2
+ complex(ki), intent(out) :: totr
+ real(ki), dimension(0:nleg-1), intent(in) :: msq
+ real(ki), dimension(0:nleg-1,4), intent(in) :: Vi
+ complex(ki), dimension(-2:0), intent(out) :: tot
+ logical, intent(out) :: ok
+ logical, intent(inout), optional :: cache_flag
+ complex(ki), intent(inout), optional, dimension(-2:0,*) :: scalar_cache
+
+ type(accumulator_type), dimension(-2:0) :: acc_re, acc_im
+ type(accumulator_type) :: accr_re, accr_im
+
+ integer :: i,j,k,j1,j2,j3,j4,j5,icut5,icut4,icut3,icut2,icut1
+ integer :: cut5,cut4,cut3,cut2,cut1,n1,ep
+ integer :: diff
+ integer :: cache_offset
+
+ complex(ki) :: mu2, mu2test
+ real(ki) :: r1, r2, factor
+ real(ki), dimension(4):: k1, k2, k3, e1, e2, p0, L3
+
+ complex(ki) :: c5,tot2r,tot3r,tot4r
+ complex(ki), dimension(5,4) :: q4, q1
+ complex(ki), dimension(10,4) :: q3, q2
+ complex(ki), dimension(4):: q5, e3, e4, qt, qtest
+ complex(ki), dimension(0:4) :: c4, c1
+ complex(ki), dimension(0:9) :: c3, c2
+ complex(ki), dimension(-2:0) :: tot4, tot3, tot2, tot1
+
+ logical :: rescue
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ if (nleg.gt.maxleg) then
+ write(6,*) 'reduction called for nleg.gt.maxleg'
+ write(6,*) 'maxleg, nleg ',maxleg,nleg
+ write(6,*) 'please change the values max1,..,max5,maxleg &
+ &in constants.f90'
+ write(6,*) 'and compile again the library'
+ stop
+ endif
+
+ cache_offset = 0
+ diff = nleg-rank
+
+ if(verbosity.gt.0)then
+ write(iout,*)
+ write(iout,*)
+ write(iout,*) 'Denominators: '
+ do k=0,nleg-1
+ write(iout,902) ' Pi(',k,') = ', Vi(k,:)
+ write(iout,903) 'msq(',k,') = ', msq(k)
+ write(iout,*)
+ enddo
+ write(iout,*)' '
+ endif
+
+ totr=czip
+ tot4r=czip
+ tot3r=czip
+ tot2r=czip
+
+ tot(:)=czip
+ tot4(:)=czip
+ tot3(:)=czip
+ tot2(:)=czip
+ tot1(:)=czip
+
+ rescue = .false.
+
+ if (use_maccu) then
+ do ep=-2,0
+ acc_re(ep)%a(:) = 0.0_ki
+ acc_im(ep)%a(:) = 0.0_ki
+ end do
+ accr_re%a(:) = 0.0_ki
+ accr_im%a(:) = 0.0_ki
+ end if
+
+! 5 continue
+
+!!$ if ( (iresc.eq.1).or.(iresc.eq.2).or.&
+!!$ ((iresc.eq.3).and.(rescue))) then
+!!$ call tensor_reconstruction(numeval,nleg,rank)
+!!$ if (iresc.eq.1) goto 6
+!!$ if ( (iresc.eq.2).or.&
+!!$ ((iresc.eq.3).and.(rescue)) ) then
+!!$
+!!$ ! Last parameter sets tot_or_rat in golem95
+!!$ ! false -- full reconstruction
+!!$ ! true -- rational part only
+!!$ tot = addtens(rank,nleg,Vi,msq,scale2,.false.)
+!!$ ok = .true.
+!!$ goto 100
+!!$ endif
+
+ notfirsti = .false.
+
+ if (iresc.eq.1) then
+ call tensor_reconstruction(numeval,nleg,rank)
+ endif
+
+! 6 continue
+
+ if (nleg.ge.5) then
+ goto 10
+ elseif (nleg.eq.4) then
+ goto 20
+ elseif (nleg.eq.3) then
+ goto 30
+ elseif (nleg.eq.2) then
+ goto 40
+ elseif ((nleg.eq.1).or.(nleg.le.0)) then
+ goto 50
+ endif
+
+ 10 continue
+
+ if(verbosity.gt.0)then
+ write(iout,*) 'Pentagon coefficients: '
+ endif
+
+!--- Quintuple cuts
+ icut5=1
+ do j5=4,nleg-1
+ do j4=3,j5-1
+ do j3=2,j4-1
+ do j2=1,j3-1
+ do j1=0,j2-1
+
+ cut5=j5*10000+j4*1000+j3*100+j2*10+j1
+
+ do n1=1,4
+ k1(n1)=Vi(j2,n1)-Vi(j1,n1)
+ k2(n1)=Vi(j1,n1)-Vi(j5,n1)
+ p0(n1)=Vi(j1,n1)
+ enddo
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+ call getq5(nleg,cut5,e1,e2,e3,e4,p0,Vi,msq,r1,r2,q5,mu2)
+
+ if (iresc.eq.1) then
+ call getc5(numetens,nleg,c5,cut5,Vi,msq,q5,mu2)
+ else
+ call getc5(numeval,nleg,c5,cut5,Vi,msq,q5,mu2)
+ endif
+
+ call store5(icut5,cut5,p0,e1,e2,e3,e4,c5)
+
+ if(verbosity.gt.0)then
+ write(iout,9005) 'c5(', cut5,') = (',real(c5),',',aimag(c5),' )'
+ write(iout,*)
+ endif
+
+!--- nullify all
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ k1(:)=0.0_ki
+ k2(:)=0.0_ki
+ p0(:)=0.0_ki
+
+ icut5=icut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ nc5=icut5-1
+
+ if (istop.eq.5) goto 99
+
+ 20 continue
+
+ if(verbosity.gt.0)then
+ write(iout,*) 'Box coefficients: '
+ endif
+
+
+!--- Quadruple cuts
+ icut4=1
+ do j4=3,nleg-1
+ do j3=2,j4-1
+ do j2=1,j3-1
+ do j1=0,j2-1
+
+ cut4=j4*1000+j3*100+j2*10+j1
+
+ do n1=1,4
+ k1(n1)=Vi(j2,n1)-Vi(j1,n1)
+ k2(n1)=Vi(j1,n1)-Vi(j4,n1)
+ k3(n1)=Vi(j3,n1)-Vi(j1,n1)
+ p0(n1)=Vi(j1,n1)
+ L3(n1)=Vi(j4,n1)-Vi(j3,n1)
+ enddo
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+ call getq4(nleg,cut4,e1,e2,e3,e4,p0,k1,k2,k3,L3,r1,r2,q4,qt,msq)
+
+ if (iresc.eq.1) then
+ call getc4(numetens,nleg,rank,c4,cut4,q4,qt,p0,Vi,msq)
+ else
+ call getc4(numeval,nleg,rank,c4,cut4,q4,qt,p0,Vi,msq)
+ endif
+
+ if (itest.eq.2) call lnntest4(numeval,cut4,c4,qt,p0,L3,e3,e4,ok)
+ call store4(icut4,cut4,L3,p0,e1,e2,e3,e4,c4)
+
+ if (present(cache_flag)) then
+ call add4_rm(nleg,c4,cut4,Vi,msq,tot4,tot4r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+ else
+ call add4_rm(nleg,c4,cut4,Vi,msq,tot4,tot4r,scale2)
+ end if
+
+ if(verbosity.gt.0)then
+ do i=0,4
+ write(iout,9004) 'c4(', cut4,',',i,') = (',real(c4(i)),',',aimag(c4(i)),' )'
+ enddo
+ write(iout,*)
+ endif
+
+ if (use_maccu) then
+ call add_accu(accr_re, accr_im, tot4r)
+ call add_accu(acc_re(:), acc_im(:), tot4(:))
+ else
+ tot(:)=tot(:)+tot4(:)
+ totr=totr+tot4r
+ end if
+
+!--- nullify all
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ k1(:)=0.0_ki
+ k2(:)=0.0_ki
+ k3(:)=0.0_ki
+ p0(:)=0.0_ki
+ L3(:)=0.0_ki
+
+ icut4=icut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ nc4=icut4-1
+
+
+ if (istop.eq.4) goto 99
+
+ 30 continue
+
+ if (diff.ge.4.and.itest.ne.1) goto 93
+
+ if(verbosity.gt.0.and.diff.le.3)then
+ write(iout,*) 'Triangle coefficients: '
+ endif
+
+!--- Triple cuts
+ icut3=1
+ do j3=2,nleg-1
+ do j2=1,j3-1
+ do j1=0,j2-1
+
+ cut3=j3*100+j2*10+j1
+
+ do n1=1,4
+ k1(n1)=Vi(j2,n1)-Vi(j1,n1)
+ k2(n1)=Vi(j1,n1)-Vi(j3,n1)
+ p0(n1)=Vi(j1,n1)
+ enddo
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+ call getq3(nleg,rank,cut3,e1,e2,e3,e4,p0,k1,k2,msq,r1,r2,q3,qt)
+
+ if (iresc.eq.1) then
+ call getc3(numetens,nleg,rank,c3,cut3,q3,qt,Vi,msq)
+ else
+ call getc3(numeval,nleg,rank,c3,cut3,q3,qt,Vi,msq)
+ endif
+
+ if (itest.eq.2) call lnntest3(numeval,cut3,c3,qt,p0,e3,e4,ok)
+ call store3(icut3,cut3,p0,e1,e2,e3,e4,c3)
+ if (present(cache_flag)) then
+ call add3_rm(nleg,c3,cut3,Vi,msq,tot3,tot3r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+ else
+ call add3_rm(nleg,c3,cut3,Vi,msq,tot3,tot3r,scale2)
+ end if
+
+ if(verbosity.gt.0.and.diff.le.3)then
+ do i=0,9
+ write(iout,9003) 'c3(',cut3,',',i,') = (',real(c3(i)),',',aimag(c3(i)),' )'
+ enddo
+ write(iout,*)
+ endif
+
+ if (use_maccu) then
+ call add_accu(accr_re, accr_im, tot3r)
+ call add_accu(acc_re(:), acc_im(:), tot3(:))
+ else
+ tot(:)=tot(:)+tot3(:)
+ totr=totr+tot3r
+ end if
+
+!--- nullify all
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ k1(:)=0.0_ki
+ k2(:)=0.0_ki
+ p0(:)=0.0_ki
+
+ icut3=icut3+1
+ enddo
+ enddo
+ enddo
+ nc3=icut3-1
+
+ if (istop.eq.3) goto 99
+
+ 40 continue
+
+ if (diff.ge.3) goto 95
+
+ if(verbosity.gt.0)then
+ write(iout,*) 'Bubble coefficients: '
+ endif
+
+!--- Double cuts
+ icut2=1
+ do j2=1,nleg-1
+ do j1=0,j2-1
+
+ cut2=j2*10+j1
+
+ do n1=1,4
+ k1(n1)=Vi(j2,n1)-Vi(j1,n1)
+ p0(n1)=Vi(j1,n1)
+ enddo
+
+
+ if (abs(abs(k1(4))-1.0_ki) .lt. 0.1_ki) then
+ factor = 0.345_ki
+ else
+ factor = one
+ end if
+
+ k2(1)=-sign(factor/rt3,k1(1))
+ k2(2)=-sign(factor/rt3,k1(2))
+ k2(3)=-sign(factor/rt3,k1(3))
+ k2(4)= sign(factor,k1(4))
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+
+ call getq2(nleg,rank,cut2,e1,e2,e3,e4,p0,k1,msq,q2,qt)
+
+ if (iresc.eq.1) then
+ call getc2(numetens,nleg,rank,c2,cut2,q2,qt,Vi,msq)
+ else
+ call getc2(numeval,nleg,rank,c2,cut2,q2,qt,Vi,msq)
+ endif
+
+ if (itest.eq.2) call lnntest2(numeval,cut2,c2,qt,p0,e2,e3,e4,ok)
+ call store2(icut2,cut2,p0,e1,e2,e3,e4,c2)
+
+ if (present(cache_flag)) then
+ call add2_rm(nleg,c2,cut2,k1,k2,msq,tot2,tot2r,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+ else
+ call add2_rm(nleg,c2,cut2,k1,k2,msq,tot2,tot2r,scale2)
+ end if
+
+ if(verbosity.gt.0)then
+ do i=0,9
+ write(iout,9002) 'c2(',cut2,',',i,') = (',real(c2(i)),',',aimag(c2(i)),' )'
+ enddo
+ write(iout,*)
+ endif
+
+ if (use_maccu) then
+ call add_accu(accr_re, accr_im, tot2r)
+ call add_accu(acc_re(:), acc_im(:), tot2(:))
+ else
+ tot(:)=tot(:)+tot2(:)
+ totr=totr+tot2r
+ end if
+
+!--- nullify k1,k2,p0
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ k1(:)=0.0_ki
+ p0(:)=0.0_ki
+
+ icut2=icut2+1
+ enddo
+ enddo
+ nc2=icut2-1
+
+ if (istop.eq.2) goto 99
+
+ 50 continue
+
+ if (diff.ge.2) goto 97
+
+ if(verbosity.gt.0)then
+ write(iout,*) 'Tadpole coefficients: '
+ endif
+
+
+!--- Single cut
+ icut1=1
+ do j1=0,nleg-1
+
+ cut1=j1
+
+ k1(1)=+one/rt3
+ k1(2)=-one/rt3
+ k1(3)=+one/rt3
+ k1(4)=+two
+
+ k2(1)=+one/rt2
+ k2(2)=-one/rt2
+ k2(3)=+one/rt2
+ k2(4)=+rt3
+
+ do n1=1,4
+ p0(n1)=Vi(j1,n1)
+ enddo
+
+ call getbase(k1,k2,r1,r2,e1,e2,e3,e4)
+ call getq1(nleg,cut1,e1,e2,e3,e4,p0,msq,q1,qt)
+
+ if (iresc.eq.1) then
+ call getc1(numetens,nleg,rank,c1,cut1,q1,qt,Vi,msq)
+ else
+ call getc1(numeval,nleg,rank,c1,cut1,q1,qt,Vi,msq)
+ endif
+
+ if (itest.eq.2) call lnntest1(numeval,cut1,c1,qt,p0,e1,e2,e3,e4,ok)
+ call store1(icut1,cut1,p0,e1,e2,e3,e4,c1)
+
+ if (present(cache_flag)) then
+ call add1_rm(nleg,c1,cut1,msq,tot1,scale2,&
+ cache_flag, cache_offset, scalar_cache)
+ else
+ call add1_rm(nleg,c1,cut1,msq,tot1,scale2)
+ end if
+
+ if(verbosity.gt.0)then
+ do i=0,4
+ write(iout,9002) 'c1(',cut1,',',i,') = (',real(c1(i)),',',&
+ & aimag(c1(i)),' )'
+ enddo
+ write(iout,*)
+ endif
+
+ if (use_maccu) then
+ call add_accu(acc_re, acc_im, tot1)
+ else
+ tot(:)=tot(:)+tot1(:)
+ end if
+
+
+!--- nullify k1,k2,p0
+ r1=zip
+ r2=zip
+ e1(:)=0.0_ki
+ e2(:)=0.0_ki
+ e3(:)=czip
+ e4(:)=czip
+ p0(:)=0.0_ki
+
+ icut1=icut1+1
+ enddo
+ nc1=icut1-1
+
+ 93 continue
+
+ do j=0,9
+ c3(j)=czip
+ enddo
+
+ 95 continue
+
+ do j=0,9
+ c2(j)=czip
+ enddo
+
+ 97 continue
+
+ do j=0,4
+ c1(j)=czip
+ enddo
+
+ 99 continue
+
+ if (use_maccu) then
+ tot = reduce_accu(acc_re, acc_im)
+ totr = reduce_accu(accr_re, accr_im)
+ end if
+
+
+! TEST N=N -------------------------------------------
+ if (itest.eq.1) then
+ qtest=10.3_ki*cone
+ mu2test=13.0_ki
+ call nntest(numeval,qtest,mu2test,nleg,Vi,msq,ok)
+ endif
+!-----------------------------------------------------
+
+! POWER test ----------------------------------
+ if (itest.eq.3) call pwtest(nleg,rank,ok)
+! ---------------------------------------------
+
+!!$ if ((itest.eq.3).and.(iresc.eq.3).and.(ok.eqv.(.false.))) then
+!!$ rescue = .true.
+!!$ print*, 'eccolo'
+!!$ goto 5
+!!$ endif
+
+ ! 100 continue
+
+ if (ok) then
+
+ if(verbosity.gt.0)then
+ write(iout,*)
+ write(iout,*)' Result: '
+ write(iout,*)' Double Pole = ', tot(-2)
+ write(iout,*)' Single Pole = ', tot(-1)
+ write(iout,*)' Finite Part = ', tot(0)
+ write(iout,*)
+ write(iout,*)'[Rational Part = ', totr,']'
+ write(iout,*)
+ write(iout,*)
+ endif
+
+ else
+
+ if(ibad.gt.0.and.verbosity.gt.0)then
+ write(ibad,*) 'Denominators: '
+ do k=0,nleg-1
+ write(ibad,902) ' Pi(',k,') = ', Vi(k,:)
+ write(ibad,903) 'msq(',k,') = ', msq(k)
+ write(ibad,*)
+ enddo
+ write(ibad,*)'---------------------------------------- '
+ write(ibad,*)' '
+ endif
+ endif
+
+ if (present(cache_flag)) cache_flag = .true.
+
+ 902 format(a4,I1,a4,4(D24.15))
+ 903 format(a4,I1,a4,1(D24.15))
+
+ 9005 format(A3,I5,A6,D24.15,A1,D24.15,A3)
+ 9004 format(A3,I4,A1,I1,A5,D24.15,A1,D24.15,A3)
+ 9003 format(A3,I3,A1,I1,A6,D24.15,A1,D24.15,A3)
+ 9002 format(A3,I2,A1,I1,A7,D24.15,A1,D24.15,A3)
+
+ end subroutine samurai_rm
+ !---#] subroutine samurai_rm:
+end module msamurai
+
diff --git a/samurai-2.1.1/mtens.f90 b/samurai-2.1.1/mtens.f90
new file mode 100644
index 0000000..a034082
--- /dev/null
+++ b/samurai-2.1.1/mtens.f90
@@ -0,0 +1,1609 @@
+module mtens
+ use precision, only: ki
+ use constants, only: czip, cone, im, two, half, zip,ctwo,one,six,three, &
+ chaf
+ use options, only: verbosity
+ use mfunctions
+ use mcgs
+ implicit none
+ private
+ save
+
+ complex(ki), dimension(0:209,4) :: qg
+
+ logical :: qg_list_is_initialized = .false.
+
+ integer :: myrank, mynleg
+
+ public :: tensor_reconstruction
+ public :: numetens
+
+ private :: ki, czip, cone, im, two, half, zip, verbosity
+
+contains
+
+ subroutine tensor_reconstruction(numeval,nleg,rank)
+
+ integer, intent(in) :: nleg, rank
+ complex(ki), dimension(0:209) :: xneval,known
+ complex(ki), dimension(0:9) :: dxneval,dknown
+ integer :: ig
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ mynleg=nleg
+ myrank=rank
+
+ if (.not. qg_list_is_initialized) call init_qg_list
+
+ call init_cg(numeval,rank,xneval,dxneval)
+
+ if (rank.eq.1) then
+ do ig=1,4
+ cg(ig) = xneval(ig)
+ enddo
+ if (verbosity .ge. 3) then
+ do ig=0,4
+ print*, ig, cg(ig)
+ enddo
+ end if
+
+ elseif (rank.eq.2) then
+ call solve_system_rk2(xneval,known)
+ if (nleg.le.3) call solve_system_extra(dxneval,dknown,nleg,rank)
+ elseif (rank.eq.3) then
+ call solve_system_rk3(xneval,known)
+ if (nleg.le.3) call solve_system_extra(dxneval,dknown,nleg,rank)
+ elseif (rank.eq.4) then
+ call solve_system_rk4(xneval,known)
+ if (nleg.le.4) call solve_system_extra(dxneval,dknown,nleg,rank)
+ elseif (rank.eq.5) then
+ call solve_system_rk5(xneval,known)
+ elseif (rank.ge.6) then
+ call solve_system_rk6(xneval,known)
+ elseif (rank.ge.7) then
+ print*, 'rank',rank,' not implemented'
+ stop
+ endif
+
+! print*, 'allora=',- (&
+! & + cg(35) + cg(36) + cg(37) + cg(38)&
+! & + (cg(51) - cg(56) + cg(52) - cg(53)&
+! & + +cg(54) - cg(55))/3.0_ki ) *3.0_ki/8.0_ki&
+!
+! & + ((cg(35) + cg(36) + cg(37) + cg(38))&
+! & + (cg(51) + cg(56) + cg(52) + cg(53)&
+! & + +cg(54) + cg(55))/3.0_ki ) *3.0_ki/4.0_ki
+
+
+
+! print*, 'allora=', (&
+! & + cg(35) + cg(36) + cg(37) + cg(38)&
+! & + (cg(51) - cg(56) + cg(52) - cg(53)&
+! & + +cg(54) - cg(55))/3.0_ki ) *1.0_ki/8.0_ki,&
+! abs((&
+! & + cg(35) + cg(36) + cg(37) + cg(38)&
+! & + (cg(51) - cg(56) + cg(52) - cg(53)&
+! & + +cg(54) - cg(55))/3.0_ki ) *1.0_ki/8.0_ki)
+
+! print*, 'allora=',+ (&
+! & + cg(35) + cg(36) + cg(37) + cg(38)&
+! & + (cg(51) + cg(56) + cg(52) + cg(53)&
+! & + +cg(54) + cg(55)) ) /four!&
+! & - (&
+! & + cg(35) + cg(36) + cg(37) + cg(38)&
+! & + (cg(51) + cg(56) + cg(52) + cg(53)&
+! & + +cg(54) + cg(55))) /eight
+
+!,&
+! abs((&
+! & + cg(35) + cg(36) + cg(37) + cg(38)&
+! & + (cg(51) + cg(56) + cg(52) + cg(53)&
+! & + +cg(54) + cg(55)) ) /four)
+
+
+
+ end subroutine tensor_reconstruction
+
+
+ subroutine solve_system_extra(dxneval,dknown,nleg, rank)
+ implicit none
+ complex(ki), dimension(0:9) :: dxneval,dknown
+ integer :: ig
+ !complex(ki) :: mu2
+ integer :: nleg, rank, diff
+
+ diff = nleg-rank
+
+ if ((nleg.eq.2).and.(rank.eq.2)) then
+ cgx(1) = dxneval(0) ! termine mu2
+ endif
+
+ if ((nleg.eq.3).and.(rank.ge.2)) then
+ cgx(1) = dxneval(0)! termine mu2
+ if (rank.eq.3) then
+ cgx(3)=dxneval(1)-cgx(1)-sub1(1)-sub2(1)-sub3(1) ! termini mu2*q1
+ cgx(4)=dxneval(2)-cgx(1)-sub1(2)-sub2(2)-sub3(2) ! termini mu2*q2
+ cgx(5)=dxneval(3)-cgx(1)-sub1(3)-sub2(3)-sub3(3) ! termini mu2*q3
+ cgx(6)=dxneval(4)-cgx(1)-sub1(4)-sub2(4)-sub3(4) ! termini mu2*q4
+ endif
+ endif
+
+ if ((nleg.eq.4).and.(rank.eq.4)) then
+! mu2 and mu4
+ cgx(2)= (dxneval(0)+ dxneval(5))/two ! termine mu2**2
+ cgx(1)= (dxneval(0)- dxneval(5))/two ! termine mu2
+ do ig =1,4
+ !MU2=1
+ dknown(ig)=dxneval(ig)-cgx(2)-cgx(1)-sub1(ig)-sub2(ig)-sub3(ig)-sub4(ig)
+ dknown(ig+5)=dxneval(ig+5)-cgx(2)-cgx(1)-sub1(ig+4)-sub2(ig+4)-sub3(ig+4)-sub4(ig+4)
+ enddo
+! mu2*q
+ cgx(3) = (dknown(1) - dknown(6))/two
+ cgx(4) = (dknown(2) - dknown(7))/two
+ cgx(5) = (dknown(3) - dknown(8))/two
+ cgx(6) = (dknown(4) - dknown(9))/two
+! mu2*q*q
+ cgx(7) = (dknown(1) + dknown(6))/two
+ cgx(8) = (dknown(2) + dknown(7))/two
+ cgx(9) = (dknown(3) + dknown(8))/two
+ cgx(10)= (dknown(4) + dknown(9))/two
+ endif
+
+! do ig =1,10
+! print*, 'cgx',ig,'=',cgx(ig)
+! enddo
+! stop
+ end subroutine solve_system_extra
+
+subroutine solve_system_rk2(xneval,known)
+ implicit none
+ complex(ki), dimension(0:209),intent(inout) :: xneval,known
+ integer :: ig
+
+ do ig=0,3
+ cg(1+ig) = (xneval(1+ig)-xneval(5+ig))/two
+ cg(5+ig) = (xneval(1+ig)+xneval(5+ig))/two
+ enddo
+ cg(9) = xneval(9) - sub1(9)- sub2(9)
+ cg(10) = xneval(10) - sub1(10)- sub2(10)
+ cg(11) = xneval(11) - sub1(11)- sub2(11)
+ cg(12) = xneval(12) - sub1(12)- sub2(12)
+ cg(13) = xneval(13) - sub1(13)- sub2(13)
+ cg(14) = xneval(14) - sub1(14)- sub2(14)
+
+ if (verbosity .ge. 1) then
+ do ig=0,14
+ print*, ig, cg(ig)
+ enddo
+ end if
+end subroutine solve_system_rk2
+
+subroutine solve_system_rk3(xneval,known)
+ implicit none
+ complex(ki), dimension(0:209),intent(inout) :: xneval,known
+ integer :: ig, igs
+ integer, dimension(0:5,3) :: is2
+
+ do ig=0,3
+ cg(1+ig) = ( - 1.0_ki/2.0_ki*xneval(ig+1) - 1.0_ki/6.0_ki*xneval(ig+5) &
+ + 8.0_ki/3.0_ki*xneval(ig+15))
+ cg(5+ig) = (1.0_ki/2.0_ki*xneval(ig+1) + 1.0_ki/2.0_ki*xneval(ig+5))
+ cg(15+ig) = (xneval(ig+1) - 1.0_ki/3.0_ki*xneval(ig+5) - &
+ 8.0_ki/3.0_ki*xneval(ig+15))
+ enddo
+
+ !1-2: 9,19,22
+ !1-3: 10,20,23
+ !1-4: 11,21,24
+ !2-3: 12,25,27
+ !2-4: 13,26,28
+ !3-4: 14,29,30
+
+ is2(0,:) = (/ 9 ,19,22 /)
+ is2(1,:) = (/ 10,20,23 /)
+ is2(2,:) = (/ 11,21,24 /)
+ is2(3,:) = (/ 12,25,27 /)
+ is2(4,:) = (/ 13,26,28 /)
+ is2(5,:) = (/ 14,29,30 /)
+
+ do igs=9,30
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)
+ enddo
+
+ do ig=0,5
+ cg(is2(ig,1))= - 3.0_ki/2.0_ki*known(9+ig) - 1.0_ki/2.0_ki*known(19+ig) +&
+ 4.0_ki*known(25+ig)
+ cg(is2(ig,2)) = 2.0_ki*known(9+ig) - 4.0_ki*known(25+ig)
+ cg(is2(ig,3)) = 1.0_ki/2.0_ki*known(9+ig) + 1.0_ki/2.0_ki*known(19+ig)
+ enddo
+! finally k=3
+ do igs=31,34
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)
+ cg(igs) = known(igs)
+ enddo
+
+ if (verbosity .ge. 1) then
+ do ig=0,34
+ print*, ig, cg(ig)
+ enddo
+ end if
+
+end subroutine solve_system_rk3
+
+subroutine solve_system_rk4(xneval,known)
+ implicit none
+ complex(ki), dimension(0:209),intent(inout) :: xneval,known
+ integer :: ig, igs
+ integer, dimension(0:5,6) :: is2
+ integer, dimension(0:3,4) :: is3
+
+
+! one q
+ do ig=0,3
+ cg(1+ig) = ( - 1.0_ki/6.0_ki*xneval(ig+1) + 1.0_ki/6.0_ki*xneval(ig+5) + 4.0_ki/&
+ & 3.0_ki*xneval(ig+15) - 4.0_ki/3.0_ki*xneval(ig+35))
+
+ cg(5+ig) = ( - 1.0_ki/6.0_ki*xneval(ig+1) - 1.0_ki/6.0_ki*xneval(ig+5) + 8.0_ki/&
+ & 3.0_ki*xneval(ig+15) + 8.0_ki/3.0_ki*xneval(ig+35))
+
+ cg(15+ig) = (2.0_ki/3.0_ki*xneval(ig+1) - 2.0_ki/3.0_ki*xneval(ig+5) - 4.0_ki/3.0_&
+ &ki*xneval(ig+15) + 4.0_ki/3.0_ki*xneval(ig+35))
+
+ cg(35+ig) = (2.0_ki/3.0_ki*xneval(ig+1) + 2.0_ki/3.0_ki*xneval(ig+5) - 8.0_ki/3.0_&
+ &ki*xneval(ig+15) - 8.0_ki/3.0_ki*xneval(ig+35))
+ enddo
+
+ ! two q
+ do igs=1,56
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-sub4(igs)
+ enddo
+
+ !1-2: 9,19,22,39,42,51
+ !1-3: 10,20,23,40,43,52
+ !1-4: 11,21,24,41,44,53
+ !2-3: 12,25,27,45,47,54
+ !2-4: 13,26,28,46,48,55
+ !3-4: 14,29,30,49,50,56
+
+ is2(0,:) = (/ 9 ,19,22,39,42,51 /)
+ is2(1,:) = (/ 10,20,23,40,43,52 /)
+ is2(2,:) = (/ 11,21,24,41,44,53 /)
+ is2(3,:) = (/ 12,25,27,45,47,54 /)
+ is2(4,:) = (/ 13,26,28,46,48,55 /)
+ is2(5,:) = (/ 14,29,30,49,50,56 /)
+
+
+ do ig=0,5
+ cg(is2(ig,1)) = 1.0_ki/6.0_ki*known(ig+9) + 1.0_ki/2.0_ki*known(ig+19) - 2.0_ki/3.0&
+ &_ki*known(ig+25) - 2.0_ki/3.0_ki*known(ig+39) - 16.0_ki/3.0_ki*known(ig+&
+ & 45)
+
+ cg(is2(ig,2)) = - 1.0_ki/4.0_ki*known(ig+19) + known(ig+25) + known(ig+39) - 1.0_ki/&
+ & 4.0_ki*known(ig+51)
+
+ cg(is2(ig,3)) = 1.0_ki/2.0_ki*known(ig+9) + 1.0_ki/4.0_ki*known(ig+19) - known(ig+25)&
+ & - known(ig+39) - 1.0_ki/4.0_ki*known(ig+51)
+
+ cg(is2(ig,4)) = 4.0_ki/3.0_ki*known(ig+9) - 4.0_ki*known(ig+25) - 4.0_ki/3.0_ki*&
+ & known(ig+39)
+
+ cg(is2(ig,5)) = - known(ig+9) - 3.0_ki/4.0_ki*known(ig+19) + 11.0_ki/3.0_ki*&
+ & known(ig+25) + known(ig+39) + 16.0_ki/3.0_ki*known(ig+45) + 1.0_ki/4.0_ki&
+ & *known(ig+51)
+
+ cg(is2(ig,6)) = 1.0_ki/4.0_ki*known(ig+19) + known(ig+25) + known(ig+39) + 1.0_ki/4.0_&
+ &ki*known(ig+51)
+ enddo
+
+ ! three q
+ do igs = 57,68
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-sub4(igs)
+ enddo
+ do igs = 31,34
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-sub4(igs)
+ enddo
+
+ !1-2-3: 31,57,60,62
+ !1-2-4: 32,58,61,63
+ !1-3-4: 33,59,64,65
+ !2-3-4: 34,66,67,68
+ is3(0,:) = (/ 31,57,60,62 /)
+ is3(1,:) = (/ 32,58,61,63 /)
+ is3(2,:) = (/ 33,59,64,65 /)
+ is3(3,:) = (/ 34,66,67,68 /)
+
+
+ do ig=0,3
+ cg(is3(ig,1)) = - 1.0_ki/2.0_ki*known(ig+31) - 1.0_ki/2.0_ki*known(ig+57) - 1.0_&
+ &ki/2.0_ki*known(ig+61) - 1.0_ki/2.0_ki*known(ig+65)
+
+ cg(is3(ig,2)) = 1.0_ki/2.0_ki*known(ig+31) + 1.0_ki/2.0_ki*known(ig+57)
+
+ cg(is3(ig,3)) = 1.0_ki/2.0_ki*known(ig+31) + 1.0_ki/2.0_ki*known(ig+61)
+
+ cg(is3(ig,4)) = 1.0_ki/2.0_ki*known(ig+31) + 1.0_ki/2.0_ki*known(ig+65)
+ enddo
+
+ ! four q
+ cg(69) = xneval(69)-sub1(69)-sub2(69)-sub3(69)-sub4(69)
+
+ if (verbosity .ge. 1) then
+ do ig=0,69
+ print*, ig, cg(ig)
+ enddo
+ end if
+ end subroutine solve_system_rk4
+
+
+subroutine solve_system_rk5(xneval,known)
+ implicit none
+ complex(ki), dimension(0:209),intent(inout) :: xneval,known
+ integer :: ig, igs
+ integer, dimension(0:5,10) :: is2
+ integer, dimension(0:3,10) :: is3
+
+ ! one q
+ do ig=0,3
+ cg(1+ig) = - 1.0_ki/3.0_ki*xneval(ig+1) + 1.0_ki/9.0_ki*xneval(ig+5) + 16.0_ki/&
+ & 9.0_ki*xneval(ig+15) - 16.0_ki/15.0_ki*xneval(ig+35) + 1.0_ki/90.0_ki*&
+ & xneval(ig+70)
+
+ cg(5+ig) = - 1.0_ki/6.0_ki*xneval(ig+1) - 1.0_ki/6.0_ki*xneval(ig+5) + 8.0_ki/&
+ & 3.0_ki*xneval(ig+15) + 8.0_ki/3.0_ki*xneval(ig+35)
+
+ cg(15+ig) = 3.0_ki/2.0_ki*xneval(ig+1) - 7.0_ki/18.0_ki*xneval(ig+5) - 32.0_ki/9.&
+ &0_ki*xneval(ig+15) - 1.0_ki/18.0_ki*xneval(ig+70)
+
+ cg(35+ig) = 2.0_ki/3.0_ki*xneval(ig+1) + 2.0_ki/3.0_ki*xneval(ig+5) - 8.0_ki/3.0_&
+ &ki*xneval(ig+15) - 8.0_ki/3.0_ki*xneval(ig+35)
+
+ cg(70+ig) = - 2.0_ki/3.0_ki*xneval(ig+1) - 2.0_ki/9.0_ki*xneval(ig+5) + 16.0_ki/&
+ & 9.0_ki*xneval(ig+15) + 16.0_ki/15.0_ki*xneval(ig+35) + 2.0_ki/45.0_ki*&
+ & xneval(ig+70)
+ enddo
+
+ ! two q
+ do igs=9,97
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-sub4(igs)-sub5(igs)
+ enddo
+
+ !1-2: 9,19,51,22,39,42,74,77,86,89
+ !1-3: 10,20,52,23,40,43,75,78,87,90
+ !1-4: 11,21,53,24,41,44,76,79,88,91
+ !2-3: 12,25,54,27,45,47,80,82,92,94
+ !2-4: 13,26,55,28,46,48,81,83,93,95
+ !3-4: 14,29,56,30,49,50,84,85,96,97
+
+ is2(0,:) = (/ 9 ,19,22,39,42,51,74,77,86,89 /)
+ is2(1,:) = (/ 10,20,23,40,43,52,75,78,87,90 /)
+ is2(2,:) = (/ 11,21,24,41,44,53,76,79,88,91 /)
+ is2(3,:) = (/ 12,25,27,45,47,54,80,82,92,94 /)
+ is2(4,:) = (/ 13,26,28,46,48,55,81,83,93,95 /)
+ is2(5,:) = (/ 14,29,30,49,50,56,84,85,96,97 /)
+
+ do ig=0,5
+ cg(is2(ig,1)) = - 1.0_ki/36.0_ki*known(ig+9) + 5.0_ki/36.0_ki*known(ig+19) - 4.0_k&
+ &i/9.0_ki*known(ig+25) - 4.0_ki/3.0_ki*known(ig+39) - 32.0_ki/9.0_ki*&
+ & known(ig+45) - 1.0_ki/36.0_ki*known(ig+51) + 7.0_ki/12.0_ki*known(ig+74)&
+ & + 4.0_ki/9.0_ki*known(ig+80) + 4.0_ki/9.0_ki*known(ig+86) - 8.0_ki/9.0&
+ &_ki*known(ig+92)
+
+ cg(is2(ig,2)) = - 11.0_ki/12.0_ki*known(ig+9) - 1.0_ki/12.0_ki*known(ig+19) + 8.0_&
+ &ki/3.0_ki*known(ig+25) + 8.0_ki/3.0_ki*known(ig+39) - 1.0_ki/12.0_ki*&
+ & known(ig+51) - 11.0_ki/12.0_ki*known(ig+74) + 4.0_ki/3.0_ki*known(ig+80)&
+ & + 4.0_ki/3.0_ki*known(ig+92)
+
+ cg(is2(ig,3)) = - 35.0_ki/36.0_ki*known(ig+9) - 11.0_ki/36.0_ki*known(ig+19) + 16.&
+ &0_ki/9.0_ki*known(ig+25) + 32.0_ki/9.0_ki*known(ig+45) - 5.0_ki/36.0_ki&
+ & *known(ig+51) + 1.0_ki/12.0_ki*known(ig+74) + 20.0_ki/9.0_ki*known(ig+80)&
+ & + 8.0_ki/9.0_ki*known(ig+86) - 4.0_ki/9.0_ki*known(ig+92)
+
+ cg(is2(ig,4)) = 1.0_ki/9.0_ki*known(ig+9) + 1.0_ki/9.0_ki*known(ig+19) + 4.0_ki/9.0&
+ &_ki*known(ig+25) + 4.0_ki/3.0_ki*known(ig+39) + 32.0_ki/9.0_ki*known(ig+&
+ & 45) + 1.0_ki/9.0_ki*known(ig+51) - 1.0_ki/3.0_ki*known(ig+74) - 4.0_ki/&
+ & 9.0_ki*known(ig+80) - 16.0_ki/9.0_ki*known(ig+86) - 4.0_ki/9.0_ki*&
+ & known(ig+92)
+
+ cg(is2(ig,5)) = 1.0_ki/6.0_ki*known(ig+9) - 1.0_ki/2.0_ki*known(ig+19) + 1.0_ki/6.0&
+ &_ki*known(ig+51) - 1.0_ki/2.0_ki*known(ig+74) + 4.0_ki/3.0_ki*known(ig+86&
+ & ) + 4.0_ki/3.0_ki*known(ig+92)
+
+ cg(is2(ig,6)) = 1.0_ki/4.0_ki*known(ig+9) + 1.0_ki/4.0_ki*known(ig+19) + 1.0_ki/4.0&
+ &_ki*known(ig+51) + 1.0_ki/4.0_ki*known(ig+74)
+
+ cg(is2(ig,7)) = 2.0_ki/3.0_ki*known(ig+9) - 8.0_ki/3.0_ki*known(ig+25) - 8.0_ki/3.0&
+ &_ki*known(ig+39) + 2.0_ki/3.0_ki*known(ig+74)
+
+ cg(is2(ig,8)) = 2.0_ki/3.0_ki*known(ig+9) + 2.0_ki/3.0_ki*known(ig+19) - 8.0_ki/3.0&
+ &_ki*known(ig+80) - 8.0_ki/3.0_ki*known(ig+86)
+
+ cg(is2(ig,9)) = 5.0_ki/9.0_ki*known(ig+9) - 1.0_ki/9.0_ki*known(ig+19) - 16.0_ki/9.&
+ &0_ki*known(ig+25) - 32.0_ki/9.0_ki*known(ig+45) - 1.0_ki/9.0_ki*known(ig+&
+ & 51) - 1.0_ki/3.0_ki*known(ig+74) + 4.0_ki/9.0_ki*known(ig+80) + 16.0_ki&
+ &/9.0_ki*known(ig+86) + 4.0_ki/9.0_ki*known(ig+92)
+
+ cg(is2(ig,10)) = 1.0_ki/2.0_ki*known(ig+9) - 1.0_ki/6.0_ki*known(ig+19) - 1.0_ki/6.0&
+ &_ki*known(ig+51) + 1.0_ki/2.0_ki*known(ig+74) - 4.0_ki/3.0_ki*known(ig+80&
+ & ) - 4.0_ki/3.0_ki*known(ig+92)
+ enddo
+
+! three q ------------------------------------------------------------
+
+ !1-2-3: 31,57,60,62, 98,101,103,110,112,116
+ !1-2-4: 32,58,61,63, 99,102,104,111,113,117
+ !1-3-4: 33,59,64,65,100,105,106,114,115,118
+ !2-3-4: 34,66,67,68,107,108,109,119,120,121
+
+ is3(0,:) = (/ 31,57,60,62, 98,101,103,110,112,116 /)
+ is3(1,:) = (/ 32,58,61,63, 99,102,104,111,113,117 /)
+ is3(2,:) = (/ 33,59,64,65,100,105,106,114,115,118 /)
+ is3(3,:) = (/ 34,66,67,68,107,108,109,119,120,121 /)
+
+ do igs = 31,34
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-sub4(igs)-sub5(igs)
+ enddo
+ do igs = 57,121
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-sub4(igs)-sub5(igs)
+ enddo
+
+ do ig=0,3
+ cg(is3(ig,1)) = - 11.0_ki/4.0_ki*known(ig+31) + 1.0_ki/3.0_ki*known(ig+57) + 1.0&
+ &_ki/3.0_ki*known(ig+61) + 1.0_ki/3.0_ki*known(ig+65) + 1.0_ki/4.0_ki*&
+ & known(ig+98) + 1.0_ki/4.0_ki*known(ig+102) + 1.0_ki/4.0_ki*known(ig+106)&
+ & + 8.0_ki/3.0_ki*known(ig+110) + 8.0_ki/3.0_ki*known(ig+114) + 8.0_ki/&
+ & 3.0_ki*known(ig+118)
+
+ cg(is3(ig,2)) = - 1.0_ki/4.0_ki*known(ig+61) - 1.0_ki/4.0_ki*known(ig+65) - 1.0_&
+ &ki/4.0_ki*known(ig+98) - 1.0_ki/4.0_ki*known(ig+102)
+
+ cg(is3(ig,3)) = - 1.0_ki/4.0_ki*known(ig+57) - 1.0_ki/4.0_ki*known(ig+65) - 1.0_&
+ &ki/4.0_ki*known(ig+98) - 1.0_ki/4.0_ki*known(ig+106)
+
+ cg(is3(ig,4)) = - 1.0_ki/4.0_ki*known(ig+57) - 1.0_ki/4.0_ki*known(ig+61) - 1.0_&
+ &ki/4.0_ki*known(ig+102) - 1.0_ki/4.0_ki*known(ig+106)
+
+ cg(is3(ig,5)) = known(ig+31) - 1.0_ki/3.0_ki*known(ig+57) - 8.0_ki/3.0_ki*known(ig+110)
+
+ cg(is3(ig,6)) = known(ig+31) - 1.0_ki/3.0_ki*known(ig+61) - 8.0_ki/3.0_ki*known(ig+114)
+
+ cg(is3(ig,7)) = known(ig+31) - 1.0_ki/3.0_ki*known(ig+65) - 8.0_ki/3.0_ki*known(ig+118)
+
+ cg(is3(ig,8)) = 1.0_ki/4.0_ki*known(ig+31) + 1.0_ki/4.0_ki*known(ig+57) + 1.0_ki/&
+ & 4.0_ki*known(ig+61) + 1.0_ki/4.0_ki*known(ig+98)
+
+ cg(is3(ig,9)) = 1.0_ki/4.0_ki*known(ig+31) + 1.0_ki/4.0_ki*known(ig+57) + 1.0_ki/&
+ & 4.0_ki*known(ig+65) + 1.0_ki/4.0_ki*known(ig+102)
+
+ cg(is3(ig,10)) = 1.0_ki/4.0_ki*known(ig+31) + 1.0_ki/4.0_ki*known(ig+61) + 1.0_ki/&
+ & 4.0_ki*known(ig+65) + 1.0_ki/4.0_ki*known(ig+106)
+ enddo
+
+! four q ------------------------------------------------------------- !
+ do igs = 122,125
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-sub4(igs)-sub5(igs)
+ enddo
+ known(69) = xneval(69)-sub1(69)-sub2(69)-sub3(69)-sub4(69)-sub5(69)
+
+!!$ cg(69) = - known(69) - 1.0_ki/2.0_ki*known(122) - 1.0_ki/2.0_ki*&
+!!$ & known(123) - 1.0_ki/2.0_ki*known(124) - 1.0_ki/2.0_ki*known(125)
+!!$ cg(122) = 1.0_ki/2.0_ki*known(69) + 1.0_ki/2.0_ki*known(122)
+!!$ cg(123) = 1.0_ki/2.0_ki*known(69) + 1.0_ki/2.0_ki*known(123)
+!!$ cg(124) = 1.0_ki/2.0_ki*known(69) + 1.0_ki/2.0_ki*known(124)
+!!$ cg(125) = 1.0_ki/2.0_ki*known(69) + 1.0_ki/2.0_ki*known(125)
+
+ cg(69) = (-two*known(69) - known(122) - known (123) - known (124) - known (125))/two
+ cg(122) = (known(69) + known(122))/two
+ cg(123) = (known(69) + known(123))/two
+ cg(124) = (known(69) + known(124))/two
+ cg(125) = (known(69) + known(125))/two
+
+ if (verbosity .ge. 1) then
+ do ig=0,125
+ print*, ig, cg(ig)
+ enddo
+ end if
+! stop
+ end subroutine solve_system_rk5
+
+subroutine solve_system_rk6(xneval,known)
+ implicit none
+ complex(ki), dimension(0:209),intent(inout) :: xneval,known
+ integer :: ig, igs
+ integer, dimension(0:5,15) :: is2
+ integer, dimension(0:3,20) :: is3
+ ! one q
+ do ig=0,3
+ cg(1+ig) = - 2.0_ki/9.0_ki*xneval(ig+1) + 2.0_ki/9.0_ki*xneval(ig+5) + 64.0_ki/&
+ & 45.0_ki*xneval(ig+15) - 64.0_ki/45.0_ki*xneval(ig+35) + 1.0_ki/180.0_ki*&
+ & xneval(ig+70) - 1.0_ki/180.0_ki*xneval(ig+126)
+
+ cg(5+ig) = - 2.0_ki/9.0_ki*xneval(ig+1) - 2.0_ki/9.0_ki*xneval(ig+5) + 128.0_ki&
+ &/45.0_ki*xneval(ig+15) + 128.0_ki/45.0_ki*xneval(ig+35) + 1.0_ki/360.0_ki&
+ & *xneval(ig+70) + 1.0_ki/360.0_ki*xneval(ig+126)
+
+ cg(15+ig) = 17.0_ki/18.0_ki*xneval(ig+1) - 17.0_ki/18.0_ki*xneval(ig+5) - 16.0_ki&
+ &/9.0_ki*xneval(ig+15) + 16.0_ki/9.0_ki*xneval(ig+35) - 1.0_ki/36.0_ki*&
+ & xneval(ig+70) + 1.0_ki/36.0_ki*xneval(ig+126)
+
+ cg(35+ig) = 17.0_ki/18.0_ki*xneval(ig+1) + 17.0_ki/18.0_ki*xneval(ig+5) - 32.0_ki&
+ &/9.0_ki*xneval(ig+15) - 32.0_ki/9.0_ki*xneval(ig+35) - 1.0_ki/72.0_ki*&
+ & xneval(ig+70) - 1.0_ki/72.0_ki*xneval(ig+126)
+
+ cg(70+ig) = - 2.0_ki/9.0_ki*xneval(ig+1) + 2.0_ki/9.0_ki*xneval(ig+5) + 16.0_ki/&
+ & 45.0_ki*xneval(ig+15) - 16.0_ki/45.0_ki*xneval(ig+35) + 1.0_ki/45.0_ki*&
+ & xneval(ig+70) - 1.0_ki/45.0_ki*xneval(ig+126)
+
+ cg(126+ig)= - 2.0_ki/9.0_ki*xneval(ig+1) - 2.0_ki/9.0_ki*xneval(ig+5) + 32.0_ki/&
+ & 45.0_ki*xneval(ig+15) + 32.0_ki/45.0_ki*xneval(ig+35) + 1.0_ki/90.0_ki*&
+ & xneval(ig+70) + 1.0_ki/90.0_ki*xneval(ig+126)
+ enddo
+
+ ! two q
+ do igs=9,159
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-&
+ sub4(igs)-sub5(igs)-sub6(igs)
+ enddo
+ !1-2: 9,19,51,22,39,42,74,77,86,89,130,133,142,145,166
+ !1-3: 10,20,52,23,40,43,75,78,87,90,131,134,143,146,167
+ !1-4: 11,21,53,24,41,44,76,79,88,91,132,135,144,147,168
+ !2-3: 12,25,54,27,45,47,80,82,92,94,136,138,148,150,169
+ !2-4: 13,26,55,28,46,48,81,83,93,95,137,139,149,151,170
+ !3-4: 14,29,56,30,49,50,84,85,96,97,140,141,152,153,171
+
+ is2(0,:) = (/ 9 ,19,22,39,42,51,74,77,86,89,130,133,142,145,166 /)
+ is2(1,:) = (/ 10,20,23,40,43,52,75,78,87,90,131,134,143,146,167 /)
+ is2(2,:) = (/ 11,21,24,41,44,53,76,79,88,91,132,135,144,147,168 /)
+ is2(3,:) = (/ 12,25,27,45,47,54,80,82,92,94,136,138,148,150,169 /)
+ is2(4,:) = (/ 13,26,28,46,48,55,81,83,93,95,137,139,149,151,170 /)
+ is2(5,:) = (/ 14,29,30,49,50,56,84,85,96,97,140,141,152,153,171 /)
+
+ do ig=0,5
+ cg(is2(ig,11)) = - 1.0_ki/4.0_ki*known(ig+9) - 11.0_ki/36.0_ki*known(ig+19) + 1.0_k&
+ &i/3.0_ki*known(ig+25) + 2.0_ki/3.0_ki*known(ig+39) - 24.0_ki/5.0_ki*&
+ & known(ig+45) - 1.0_ki/36.0_ki*known(ig+51) - 1.0_ki/12.0_ki*known(ig+74)&
+ & + 5.0_ki/9.0_ki*known(ig+80) + 4.0_ki/3.0_ki*known(ig+86) + 1.0_ki/3.0&
+ &_ki*known(ig+92) + known(ig+130) + 2.0_ki/9.0_ki*known(ig+136) - 136.0_ki/&
+ & 45.0_ki*known(ig+142) + 1.0_ki/45.0_ki*known(ig+148) + 1.0_ki/45.0_ki*&
+ & known(ig+154)
+
+ cg(is2(ig,2)) = - 5.0_ki/12.0_ki*known(ig+9) + 13.0_ki/12.0_ki*known(ig+19) + 2.0_&
+ &ki*known(ig+25) + 10.0_ki/3.0_ki*known(ig+39) + 16.0_ki/3.0_ki*known(ig+&
+ & 45) + 5.0_ki/12.0_ki*known(ig+51) - 13.0_ki/12.0_ki*known(ig+74) - 8.0_&
+ &ki/3.0_ki*known(ig+86) + 8.0_ki/3.0_ki*known(ig+92) - 10.0_ki/3.0_ki*&
+ & known(ig+130) - 2.0_ki*known(ig+136) - 16.0_ki/3.0_ki*known(ig+142)
+
+ cg(is2(ig,3)) = - 5.0_ki/12.0_ki*known(ig+9) + 11.0_ki/12.0_ki*known(ig+19) + 2.0_&
+ &ki*known(ig+25) + 10.0_ki/3.0_ki*known(ig+39) + 32.0_ki/3.0_ki*known(ig+&
+ & 45) + 5.0_ki/12.0_ki*known(ig+51) - 11.0_ki/12.0_ki*known(ig+74) - 8.0_&
+ &ki/3.0_ki*known(ig+86) + 8.0_ki/3.0_ki*known(ig+92) - 10.0_ki/3.0_ki*&
+ & known(ig+130) - 2.0_ki*known(ig+136) - 32.0_ki/3.0_ki*known(ig+142)
+
+ cg(is2(ig,4)) = 5.0_ki/12.0_ki*known(ig+9) - 13.0_ki/36.0_ki*known(ig+19) - 7.0_ki/&
+ & 3.0_ki*known(ig+25) - 11.0_ki/3.0_ki*known(ig+39) - 5.0_ki/36.0_ki*&
+ & known(ig+51) + 13.0_ki/12.0_ki*known(ig+74) + 13.0_ki/9.0_ki*known(ig+80)&
+ & - 29.0_ki/9.0_ki*known(ig+92) + 11.0_ki/9.0_ki*known(ig+130) + 7.0_ki/&
+ & 9.0_ki*known(ig+136) + 80.0_ki/9.0_ki*known(ig+142) - 1.0_ki/9.0_ki*&
+ & known(ig+154)
+
+ cg(is2(ig,5)) = 5.0_ki/12.0_ki*known(ig+9) + 11.0_ki/36.0_ki*known(ig+19) + 2.0_ki/&
+ & 3.0_ki*known(ig+25) - 7.0_ki/3.0_ki*known(ig+39) + 8.0_ki/3.0_ki*&
+ & known(ig+45) - 5.0_ki/36.0_ki*known(ig+51) + 5.0_ki/12.0_ki*known(ig+74)&
+ & - 14.0_ki/9.0_ki*known(ig+80) - 4.0_ki/3.0_ki*known(ig+86) - 10.0_ki/&
+ & 9.0_ki*known(ig+92) - 8.0_ki/9.0_ki*known(ig+130) + 7.0_ki/9.0_ki*&
+ & known(ig+136) + 56.0_ki/9.0_ki*known(ig+142) - 1.0_ki/9.0_ki*known(ig+148)
+
+ cg(is2(ig,6)) = - 5.0_ki/12.0_ki*known(ig+9) - 7.0_ki/4.0_ki*known(ig+19) - 8.0_ki&
+ &/3.0_ki*known(ig+39) - 32.0_ki/3.0_ki*known(ig+45) - 5.0_ki/12.0_ki*&
+ & known(ig+51) + 11.0_ki/12.0_ki*known(ig+74) + 8.0_ki/3.0_ki*known(ig+80)&
+ & + 16.0_ki/3.0_ki*known(ig+86) - 8.0_ki/3.0_ki*known(ig+92) + 16.0_ki/&
+ & 3.0_ki*known(ig+130) + 8.0_ki/3.0_ki*known(ig+136) + 32.0_ki/3.0_ki*&
+ & known(ig+142)
+
+ cg(is2(ig,7)) = 1.0_ki/3.0_ki*known(ig+9) - 1.0_ki/3.0_ki*known(ig+19) - 4.0_ki/3.0&
+ &_ki*known(ig+25) - 4.0_ki/3.0_ki*known(ig+39) - 1.0_ki/3.0_ki*known(ig+51&
+ & ) + 1.0_ki/3.0_ki*known(ig+74) + 4.0_ki/3.0_ki*known(ig+130) + 4.0_ki/&
+ & 3.0_ki*known(ig+136)
+
+ cg(is2(ig,8)) = 1.0_ki/3.0_ki*known(ig+9) - known(ig+19) - 4.0_ki/3.0_ki*known(ig+25)&
+ & - 4.0_ki*known(ig+39) - 32.0_ki/3.0_ki*known(ig+45) - 1.0_ki/3.0_ki*&
+ & known(ig+51) + known(ig+74) + 8.0_ki/3.0_ki*known(ig+86) - 8.0_ki/3.0_ki*&
+ & known(ig+92) + 4.0_ki*known(ig+130) + 4.0_ki/3.0_ki*known(ig+136) + 32.0_k&
+ &i/3.0_ki*known(ig+142)
+
+ cg(is2(ig,9)) = 1.0_ki/3.0_ki*known(ig+9) + 1.0_ki/3.0_ki*known(ig+19) - 2.0_ki/3.0&
+ &_ki*known(ig+25) + 2.0_ki/3.0_ki*known(ig+39) - 1.0_ki/3.0_ki*known(ig+51&
+ & ) - 1.0_ki/3.0_ki*known(ig+74) - 2.0_ki/3.0_ki*known(ig+130) + 2.0_ki/&
+ & 3.0_ki*known(ig+136)
+
+ cg(is2(ig,10)) = 1.0_ki/3.0_ki*known(ig+9) - known(ig+19) - 2.0_ki/3.0_ki*known(ig+25)&
+ & - 2.0_ki*known(ig+39) - 16.0_ki/3.0_ki*known(ig+45) - 1.0_ki/3.0_ki*&
+ & known(ig+51) + known(ig+74) + 8.0_ki/3.0_ki*known(ig+86) - 8.0_ki/3.0_ki*&
+ & known(ig+92) + 2.0_ki*known(ig+130) + 2.0_ki/3.0_ki*known(ig+136) + 16.0_k&
+ &i/3.0_ki*known(ig+142)
+
+ cg(is2(ig,11))= - 1.0_ki/3.0_ki*known(ig+9) + 1.0_ki/9.0_ki*known(ig+19) + 4.0_ki/&
+ & 3.0_ki*known(ig+25) + 4.0_ki/3.0_ki*known(ig+39) + 1.0_ki/9.0_ki*&
+ & known(ig+51) - 1.0_ki/3.0_ki*known(ig+74) - 4.0_ki/9.0_ki*known(ig+80) + &
+ & 4.0_ki/9.0_ki*known(ig+92) - 4.0_ki/9.0_ki*known(ig+130) - 4.0_ki/9.0_k&
+ &i*known(ig+136) - 64.0_ki/45.0_ki*known(ig+142) + 4.0_ki/45.0_ki*&
+ & known(ig+154)
+
+ cg(is2(ig,12))= - 1.0_ki/3.0_ki*known(ig+9) + 1.0_ki/9.0_ki*known(ig+19) + 4.0_ki/&
+ & 3.0_ki*known(ig+39) + 32.0_ki/15.0_ki*known(ig+45) + 1.0_ki/9.0_ki*&
+ & known(ig+51) - 1.0_ki/3.0_ki*known(ig+74) + 8.0_ki/9.0_ki*known(ig+80) + &
+ & 8.0_ki/9.0_ki*known(ig+92) - 8.0_ki/9.0_ki*known(ig+130) - 4.0_ki/9.0_k&
+ &i*known(ig+136) - 32.0_ki/9.0_ki*known(ig+142) + 4.0_ki/45.0_ki*known(ig+148)
+
+ cg(is2(ig,13))= 1.0_ki/3.0_ki*known(ig+9) + 1.0_ki/3.0_ki*known(ig+19) - 4.0_ki/3.0&
+ &_ki*known(ig+25) - 4.0_ki/3.0_ki*known(ig+39) + 1.0_ki/3.0_ki*known(ig+51&
+ & ) + 1.0_ki/3.0_ki*known(ig+74) - 4.0_ki/3.0_ki*known(ig+130) - 4.0_ki/&
+ & 3.0_ki*known(ig+136)
+
+ cg(is2(ig,14))= 1.0_ki/3.0_ki*known(ig+9) + 5.0_ki/3.0_ki*known(ig+19) + 4.0_ki/3.0&
+ &_ki*known(ig+25) + 4.0_ki*known(ig+39) + 32.0_ki/3.0_ki*known(ig+45) + 1.0&
+ &_ki/3.0_ki*known(ig+51) - known(ig+74) - 8.0_ki/3.0_ki*known(ig+80) - 16.0&
+ &_ki/3.0_ki*known(ig+86) + 8.0_ki/3.0_ki*known(ig+92) - 4.0_ki*known(ig+&
+ & 130) - 4.0_ki/3.0_ki*known(ig+136) - 32.0_ki/3.0_ki*known(ig+142)
+
+ cg(is2(ig,15))= 1.0_ki/3.0_ki*known(ig+9) - 1.0_ki/9.0_ki*known(ig+19) + 8.0_ki/3.0&
+ &_ki*known(ig+39) + 1.0_ki/3.0_ki*known(ig+51) - known(ig+74) - 8.0_ki/9.0_&
+ &ki*known(ig+80) + 8.0_ki/3.0_ki*known(ig+92) - 8.0_ki/9.0_ki*known(ig+136&
+ & ) - 64.0_ki/9.0_ki*known(ig+142)
+ enddo
+
+!--------------------------------------------------------------------
+ do igs=31,199
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-&
+ sub4(igs)-sub5(igs)-sub6(igs)
+ enddo
+! three q
+!1-2-3: 31,57,60,62, 98,101,103,110,112,116,154,157,159,172,174,178,180,184,186,200
+!1-2-4: 32,58,61,63, 99,102,104,111,113,117,155,158,160,173,175,179,181,185,187,201
+!1-3-4: 33,59,64,65,100,105,106,114,115,118,156,161,162,176,177,182,183,188,189,202
+!2-3-4: 34,66,67,68,107,108,109,119,120,121,163,164,165,190,191,192,193,194,195,203
+ is3(0,:) = (/ 31,57,60,62, 98,101,103,110,112,116,154,157,159,172,174,178,180,184,186,200 /)
+ is3(1,:) = (/ 32,58,61,63, 99,102,104,111,113,117,155,158,160,173,175,179,181,185,187,201 /)
+ is3(2,:) = (/ 33,59,64,65,100,105,106,114,115,118,156,161,162,176,177,182,183,188,189,202 /)
+ is3(3,:) = (/ 34,66,67,68,107,108,109,119,120,121,163,164,165,190,191,192,193,194,195,203 /)
+
+ do ig=0,3
+ cg(is3(ig,1)) = - 2687.0_ki/4680.0_ki*known(ig+31) - 293.0_ki/4680.0_ki*&
+ & known(ig+57) + 37.0_ki/180.0_ki*known(ig+61) + 2269.0_ki/4680.0_ki*&
+ & known(ig+65) + 23.0_ki/234.0_ki*known(ig+98) - 337.0_ki/936.0_ki*&
+ & known(ig+102) - 547.0_ki/2340.0_ki*known(ig+106) - 121.0_ki/195.0_ki*&
+ & known(ig+110) + 892.0_ki/585.0_ki*known(ig+114) + 4.0_ki/3.0_ki*known(ig+&
+ & 118) - 1711.0_ki/1755.0_ki*known(ig+160) - 734.0_ki/1755.0_ki*&
+ & known(ig+164) + 17824.0_ki/8775.0_ki*known(ig+168) - 83.0_ki/1755.0_ki&
+ & *known(ig+172) - 1858.0_ki/2925.0_ki*known(ig+176) + 8588.0_ki/1755.0_k&
+ &i*known(ig+180) + 692.0_ki/351.0_ki*known(ig+184) + 36544.0_ki/8775.0_k&
+ &i*known(ig+188) - 224.0_ki/1755.0_ki*known(ig+192) + 1264.0_ki/975.0_ki&
+ & *known(ig+196)
+
+ cg(is3(ig,2)) = - 47.0_ki/39.0_ki*known(ig+31) + 1.0_ki/39.0_ki*known(ig+57) + &
+ & 1.0_ki/12.0_ki*known(ig+61) - 95.0_ki/156.0_ki*known(ig+65) - 9.0_ki/&
+ & 52.0_ki*known(ig+98) + 25.0_ki/156.0_ki*known(ig+102) + 4.0_ki/39.0_ki&
+ & *known(ig+106) + 12.0_ki/13.0_ki*known(ig+110) + 80.0_ki/39.0_ki*&
+ & known(ig+114) + 76.0_ki/117.0_ki*known(ig+160) + 200.0_ki/117.0_ki*&
+ & known(ig+164) + 1856.0_ki/585.0_ki*known(ig+168) + 80.0_ki/117.0_ki*&
+ & known(ig+172) + 88.0_ki/195.0_ki*known(ig+176) - 128.0_ki/117.0_ki*&
+ & known(ig+180) - 448.0_ki/117.0_ki*known(ig+184) - 8128.0_ki/585.0_ki*&
+ & known(ig+188) - 160.0_ki/117.0_ki*known(ig+192) - 48.0_ki/65.0_ki*&
+ & known(ig+196)
+
+ cg(is3(ig,3)) = - 269.0_ki/468.0_ki*known(ig+31) + 29.0_ki/234.0_ki*known(ig+57&
+ & ) - 1.0_ki/4.0_ki*known(ig+61) - 305.0_ki/468.0_ki*known(ig+65) - 43.0_&
+ &ki/234.0_ki*known(ig+98) + 37.0_ki/117.0_ki*known(ig+102) + 115.0_ki/&
+ & 468.0_ki*known(ig+106) + 32.0_ki/13.0_ki*known(ig+110) - 140.0_ki/117.0&
+ &_ki*known(ig+114) + 868.0_ki/351.0_ki*known(ig+160) + 560.0_ki/351.0_ki&
+ & *known(ig+164) - 4912.0_ki/1755.0_ki*known(ig+168) - 10.0_ki/351.0_ki*&
+ & known(ig+172) + 574.0_ki/585.0_ki*known(ig+176) - 3104.0_ki/351.0_ki*&
+ & known(ig+180) - 1504.0_ki/351.0_ki*known(ig+184) + 5696.0_ki/1755.0_ki&
+ & *known(ig+188) + 176.0_ki/351.0_ki*known(ig+192) - 128.0_ki/65.0_ki*&
+ & known(ig+196)
+
+ cg(is3(ig,4)) = - 101.0_ki/195.0_ki*known(ig+31) - 7.0_ki/260.0_ki*known(ig+57)&
+ & - 4.0_ki/45.0_ki*known(ig+61) + 241.0_ki/260.0_ki*known(ig+65) + 29.0_&
+ &ki/156.0_ki*known(ig+98) - 5.0_ki/78.0_ki*known(ig+102) - 253.0_ki/780.&
+ &0_ki*known(ig+106) + 58.0_ki/195.0_ki*known(ig+110) - 116.0_ki/585.0_ki&
+ & *known(ig+114) + 8.0_ki/3.0_ki*known(ig+118) - 74.0_ki/585.0_ki*known(ig+&
+ & 160) - 556.0_ki/585.0_ki*known(ig+164) - 5584.0_ki/2925.0_ki*known(ig+&
+ & 168) - 472.0_ki/585.0_ki*known(ig+172) - 722.0_ki/975.0_ki*known(ig+&
+ & 176) + 1192.0_ki/585.0_ki*known(ig+180) + 136.0_ki/39.0_ki*known(ig+&
+ & 184) + 1344.0_ki/325.0_ki*known(ig+188) + 944.0_ki/585.0_ki*known(ig+&
+ & 192) + 1328.0_ki/975.0_ki*known(ig+196)
+
+ cg(is3(ig,5)) = 41.0_ki/65.0_ki*known(ig+31) - 43.0_ki/195.0_ki*known(ig+57) + 1.&
+ &0_ki/10.0_ki*known(ig+61) - 19.0_ki/130.0_ki*known(ig+65) + 1.0_ki/26.0&
+ &_ki*known(ig+98) + 1.0_ki/26.0_ki*known(ig+102) + 166.0_ki/195.0_ki*&
+ & known(ig+106) - 404.0_ki/195.0_ki*known(ig+110) + 32.0_ki/65.0_ki*&
+ & known(ig+114) - 656.0_ki/195.0_ki*known(ig+160) - 284.0_ki/195.0_ki*&
+ & known(ig+164) - 256.0_ki/975.0_ki*known(ig+168) + 32.0_ki/195.0_ki*&
+ & known(ig+172) - 48.0_ki/325.0_ki*known(ig+176) + 448.0_ki/195.0_ki*&
+ & known(ig+180) + 64.0_ki/39.0_ki*known(ig+184) - 256.0_ki/975.0_ki*&
+ & known(ig+188) - 64.0_ki/195.0_ki*known(ig+192) + 192.0_ki/325.0_ki*&
+ & known(ig+196)
+
+ cg(is3(ig,6)) = - 1771.0_ki/4680.0_ki*known(ig+31) + 431.0_ki/4680.0_ki*&
+ & known(ig+57) - 143.0_ki/360.0_ki*known(ig+61) - 989.0_ki/2340.0_ki*&
+ & known(ig+65) - 173.0_ki/936.0_ki*known(ig+98) + 103.0_ki/234.0_ki*&
+ & known(ig+102) - 191.0_ki/2340.0_ki*known(ig+106) + 144.0_ki/65.0_ki*&
+ & known(ig+110) - 994.0_ki/585.0_ki*known(ig+114) + 6142.0_ki/1755.0_ki*&
+ & known(ig+160) + 4808.0_ki/1755.0_ki*known(ig+164) - 12328.0_ki/8775.0_k&
+ &i*known(ig+168) - 19.0_ki/1755.0_ki*known(ig+172) + 2401.0_ki/2925.0_ki&
+ & *known(ig+176) - 14696.0_ki/1755.0_ki*known(ig+180) - 2768.0_ki/351.0_k&
+ &i*known(ig+184) - 45088.0_ki/8775.0_ki*known(ig+188) + 428.0_ki/1755.0_&
+ &ki*known(ig+192) - 576.0_ki/325.0_ki*known(ig+196)
+
+ cg(is3(ig,7)) = 187.0_ki/390.0_ki*known(ig+31) + 41.0_ki/780.0_ki*known(ig+57)&
+ & - 1.0_ki/120.0_ki*known(ig+61) - 121.0_ki/1560.0_ki*known(ig+65) + 19.&
+ &0_ki/104.0_ki*known(ig+98) + 5.0_ki/312.0_ki*known(ig+102) - 187.0_ki/&
+ & 780.0_ki*known(ig+106) + 19.0_ki/65.0_ki*known(ig+110) - 38.0_ki/195.0_&
+ &ki*known(ig+114) - 4.0_ki/3.0_ki*known(ig+118) - 1.0_ki/585.0_ki*&
+ & known(ig+160) - 914.0_ki/585.0_ki*known(ig+164) - 1256.0_ki/2925.0_ki*&
+ & known(ig+168) - 38.0_ki/585.0_ki*known(ig+172) - 73.0_ki/975.0_ki*&
+ & known(ig+176) + 1028.0_ki/585.0_ki*known(ig+180) + 548.0_ki/117.0_ki*&
+ & known(ig+184) + 3424.0_ki/2925.0_ki*known(ig+188) + 76.0_ki/585.0_ki*&
+ & known(ig+192) + 32.0_ki/975.0_ki*known(ig+196)
+
+ cg(is3(ig,8)) = 41.0_ki/260.0_ki*known(ig+31) + 29.0_ki/260.0_ki*known(ig+57) + &
+ & 3.0_ki/20.0_ki*known(ig+61) - 21.0_ki/130.0_ki*known(ig+65) + 7.0_ki/&
+ & 52.0_ki*known(ig+98) - 3.0_ki/26.0_ki*known(ig+102) + 3.0_ki/65.0_ki*&
+ & known(ig+106) - 12.0_ki/65.0_ki*known(ig+110) + 8.0_ki/65.0_ki*known(ig+&
+ & 114) - 164.0_ki/195.0_ki*known(ig+160) - 136.0_ki/195.0_ki*known(ig+&
+ & 164) - 64.0_ki/975.0_ki*known(ig+168) + 8.0_ki/195.0_ki*known(ig+172)&
+ & - 12.0_ki/325.0_ki*known(ig+176) + 112.0_ki/195.0_ki*known(ig+180) + &
+ & 16.0_ki/39.0_ki*known(ig+184) - 64.0_ki/975.0_ki*known(ig+188) - 16.0_k&
+ &i/195.0_ki*known(ig+192) + 48.0_ki/325.0_ki*known(ig+196)
+
+ cg(is3(ig,9)) = 41.0_ki/260.0_ki*known(ig+31) + 29.0_ki/260.0_ki*known(ig+57) - &
+ & 1.0_ki/10.0_ki*known(ig+61) + 23.0_ki/260.0_ki*known(ig+65) - 3.0_ki/&
+ & 26.0_ki*known(ig+98) + 7.0_ki/52.0_ki*known(ig+102) + 3.0_ki/65.0_ki*&
+ & known(ig+106) - 12.0_ki/65.0_ki*known(ig+110) + 8.0_ki/65.0_ki*known(ig+&
+ & 114) - 164.0_ki/195.0_ki*known(ig+160) - 136.0_ki/195.0_ki*known(ig+&
+ & 164) - 64.0_ki/975.0_ki*known(ig+168) + 8.0_ki/195.0_ki*known(ig+172)&
+ & - 12.0_ki/325.0_ki*known(ig+176) + 112.0_ki/195.0_ki*known(ig+180) + &
+ & 16.0_ki/39.0_ki*known(ig+184) - 64.0_ki/975.0_ki*known(ig+188) - 16.0_k&
+ &i/195.0_ki*known(ig+192) + 48.0_ki/325.0_ki*known(ig+196)
+
+ cg(is3(ig,10)) = 41.0_ki/260.0_ki*known(ig+31) - 9.0_ki/65.0_ki*known(ig+57) + 3.0&
+ &_ki/20.0_ki*known(ig+61) + 23.0_ki/260.0_ki*known(ig+65) - 3.0_ki/26.0_&
+ &ki*known(ig+98) - 3.0_ki/26.0_ki*known(ig+102) + 77.0_ki/260.0_ki*&
+ & known(ig+106) - 12.0_ki/65.0_ki*known(ig+110) + 8.0_ki/65.0_ki*known(ig+&
+ & 114) - 164.0_ki/195.0_ki*known(ig+160) - 136.0_ki/195.0_ki*known(ig+&
+ & 164) - 64.0_ki/975.0_ki*known(ig+168) + 8.0_ki/195.0_ki*known(ig+172)&
+ & - 12.0_ki/325.0_ki*known(ig+176) + 112.0_ki/195.0_ki*known(ig+180) + &
+ & 16.0_ki/39.0_ki*known(ig+184) - 64.0_ki/975.0_ki*known(ig+188) - 16.0_k&
+ &i/195.0_ki*known(ig+192) + 48.0_ki/325.0_ki*known(ig+196)
+
+ cg(is3(ig,11)) = - 34.0_ki/195.0_ki*known(ig+31) + 14.0_ki/195.0_ki*known(ig+57)&
+ & - 2.0_ki/15.0_ki*known(ig+61) + 38.0_ki/195.0_ki*known(ig+65) - 2.0_ki&
+ &/39.0_ki*known(ig+98) - 2.0_ki/39.0_ki*known(ig+102) - 16.0_ki/65.0_ki&
+ & *known(ig+106) + 64.0_ki/65.0_ki*known(ig+110) - 128.0_ki/195.0_ki*&
+ & known(ig+114) + 1064.0_ki/585.0_ki*known(ig+160) + 616.0_ki/585.0_ki*&
+ & known(ig+164) + 1024.0_ki/2925.0_ki*known(ig+168) - 128.0_ki/585.0_ki*&
+ & known(ig+172) + 64.0_ki/325.0_ki*known(ig+176) - 1792.0_ki/585.0_ki*&
+ & known(ig+180) - 256.0_ki/117.0_ki*known(ig+184) + 1024.0_ki/2925.0_ki*&
+ & known(ig+188) + 256.0_ki/585.0_ki*known(ig+192) - 256.0_ki/325.0_ki*&
+ & known(ig+196)
+
+ cg(is3(ig,12)) = 11.0_ki/468.0_ki*known(ig+31) - 55.0_ki/468.0_ki*known(ig+57) + &
+ & 7.0_ki/36.0_ki*known(ig+61) + 73.0_ki/234.0_ki*known(ig+65) + 17.0_ki/&
+ & 468.0_ki*known(ig+98) - 25.0_ki/117.0_ki*known(ig+102) + 7.0_ki/234.0_k&
+ &i*known(ig+106) - 16.0_ki/13.0_ki*known(ig+110) + 148.0_ki/117.0_ki*&
+ & known(ig+114) - 460.0_ki/351.0_ki*known(ig+160) - 176.0_ki/351.0_ki*&
+ & known(ig+164) + 4432.0_ki/1755.0_ki*known(ig+168) + 70.0_ki/351.0_ki*&
+ & known(ig+172) - 274.0_ki/585.0_ki*known(ig+176) + 1136.0_ki/351.0_ki*&
+ & known(ig+180) + 544.0_ki/351.0_ki*known(ig+184) - 4928.0_ki/1755.0_ki*&
+ & known(ig+188) - 296.0_ki/351.0_ki*known(ig+192) + 64.0_ki/65.0_ki*&
+ & known(ig+196)
+
+ cg(is3(ig,13)) = 149.0_ki/195.0_ki*known(ig+31) + 19.0_ki/130.0_ki*known(ig+57)&
+ & + 19.0_ki/180.0_ki*known(ig+61) - 129.0_ki/260.0_ki*known(ig+65) + 19.&
+ &0_ki/156.0_ki*known(ig+98) + 19.0_ki/156.0_ki*known(ig+102) - 19.0_ki/&
+ & 390.0_ki*known(ig+106) + 38.0_ki/195.0_ki*known(ig+110) - 76.0_ki/585.0&
+ &_ki*known(ig+114) - 8.0_ki/3.0_ki*known(ig+118) - 694.0_ki/585.0_ki*&
+ & known(ig+160) - 956.0_ki/585.0_ki*known(ig+164) - 10544.0_ki/2925.0_ki&
+ & *known(ig+168) + 148.0_ki/585.0_ki*known(ig+172) + 298.0_ki/975.0_ki*&
+ & known(ig+176) + 2072.0_ki/585.0_ki*known(ig+180) + 56.0_ki/13.0_ki*&
+ & known(ig+184) + 7232.0_ki/975.0_ki*known(ig+188) - 296.0_ki/585.0_ki*&
+ & known(ig+192) - 224.0_ki/325.0_ki*known(ig+196)
+
+ cg(is3(ig,14)) = 107.0_ki/195.0_ki*known(ig+31) - 2.0_ki/195.0_ki*known(ig+57) + &
+ & 1.0_ki/15.0_ki*known(ig+61) + 41.0_ki/195.0_ki*known(ig+65) + 4.0_ki/&
+ & 39.0_ki*known(ig+98) + 4.0_ki/39.0_ki*known(ig+102) - 151.0_ki/195.0_ki&
+ & *known(ig+106) - 176.0_ki/195.0_ki*known(ig+110) - 56.0_ki/195.0_ki*&
+ & known(ig+114) + 368.0_ki/585.0_ki*known(ig+160) - 608.0_ki/585.0_ki*&
+ & known(ig+164) - 5792.0_ki/2925.0_ki*known(ig+168) - 56.0_ki/585.0_ki*&
+ & known(ig+172) - 436.0_ki/975.0_ki*known(ig+176) + 2336.0_ki/585.0_ki*&
+ & known(ig+180) + 512.0_ki/117.0_ki*known(ig+184) + 12928.0_ki/2925.0_ki&
+ & *known(ig+188) + 112.0_ki/585.0_ki*known(ig+192) + 704.0_ki/975.0_ki*&
+ & known(ig+196)
+
+ cg(is3(ig,15)) = - 6.0_ki/65.0_ki*known(ig+31) - 9.0_ki/65.0_ki*known(ig+57) - 1.&
+ &0_ki/10.0_ki*known(ig+61) - 21.0_ki/130.0_ki*known(ig+65) - 3.0_ki/26.0&
+ &_ki*known(ig+98) - 3.0_ki/26.0_ki*known(ig+102) + 3.0_ki/65.0_ki*&
+ & known(ig+106) - 12.0_ki/65.0_ki*known(ig+110) + 8.0_ki/65.0_ki*known(ig+&
+ & 114) + 356.0_ki/195.0_ki*known(ig+160) + 128.0_ki/65.0_ki*known(ig+164&
+ & ) + 672.0_ki/325.0_ki*known(ig+168) + 8.0_ki/195.0_ki*known(ig+172) + &
+ & 484.0_ki/975.0_ki*known(ig+176) - 928.0_ki/195.0_ki*known(ig+180) - 64.&
+ &0_ki/13.0_ki*known(ig+184) - 1408.0_ki/325.0_ki*known(ig+188) - 16.0_ki&
+ &/195.0_ki*known(ig+192) - 896.0_ki/975.0_ki*known(ig+196)
+
+ cg(is3(ig,16)) = 557.0_ki/390.0_ki*known(ig+31) + 23.0_ki/390.0_ki*known(ig+57)&
+ & + 1.0_ki/30.0_ki*known(ig+61) + 73.0_ki/195.0_ki*known(ig+65) + 19.0_k&
+ &i/78.0_ki*known(ig+98) - 10.0_ki/39.0_ki*known(ig+102) + 7.0_ki/195.0_k&
+ &i*known(ig+106) - 96.0_ki/65.0_ki*known(ig+110) - 328.0_ki/195.0_ki*&
+ & known(ig+114) - 1856.0_ki/585.0_ki*known(ig+160) - 2224.0_ki/585.0_ki*&
+ & known(ig+164) - 9856.0_ki/2925.0_ki*known(ig+168) - 328.0_ki/585.0_ki*&
+ & known(ig+172) - 548.0_ki/975.0_ki*known(ig+176) + 4768.0_ki/585.0_ki*&
+ & known(ig+180) + 1216.0_ki/117.0_ki*known(ig+184) + 40064.0_ki/2925.0_ki&
+ & *known(ig+188) + 656.0_ki/585.0_ki*known(ig+192) + 384.0_ki/325.0_ki*&
+ & known(ig+196)
+
+ cg(is3(ig,17)) = 17.0_ki/390.0_ki*known(ig+31) - 7.0_ki/390.0_ki*known(ig+57) - 2.&
+ &0_ki/15.0_ki*known(ig+61) - 19.0_ki/390.0_ki*known(ig+65) - 2.0_ki/13.0&
+ &_ki*known(ig+98) + 1.0_ki/78.0_ki*known(ig+102) + 4.0_ki/65.0_ki*&
+ & known(ig+106) - 16.0_ki/65.0_ki*known(ig+110) + 32.0_ki/195.0_ki*&
+ & known(ig+114) + 904.0_ki/585.0_ki*known(ig+160) + 1016.0_ki/585.0_ki*&
+ & known(ig+164) - 256.0_ki/2925.0_ki*known(ig+168) + 32.0_ki/585.0_ki*&
+ & known(ig+172) - 16.0_ki/325.0_ki*known(ig+176) - 2672.0_ki/585.0_ki*&
+ & known(ig+180) - 560.0_ki/117.0_ki*known(ig+184) - 256.0_ki/2925.0_ki*&
+ & known(ig+188) - 64.0_ki/585.0_ki*known(ig+192) + 64.0_ki/325.0_ki*&
+ & known(ig+196)
+
+ cg(is3(ig,18)) = - 4.0_ki/65.0_ki*known(ig+31) - 6.0_ki/65.0_ki*known(ig+57) - 1.&
+ &0_ki/15.0_ki*known(ig+61) - 7.0_ki/65.0_ki*known(ig+65) - 1.0_ki/13.0_k&
+ &i*known(ig+98) - 1.0_ki/13.0_ki*known(ig+102) + 2.0_ki/65.0_ki*known(ig+&
+ & 106) - 8.0_ki/65.0_ki*known(ig+110) + 16.0_ki/195.0_ki*known(ig+114)&
+ & + 64.0_ki/195.0_ki*known(ig+160) + 256.0_ki/195.0_ki*known(ig+164) + &
+ & 3424.0_ki/975.0_ki*known(ig+168) + 92.0_ki/195.0_ki*known(ig+172) - 8.0&
+ &_ki/325.0_ki*known(ig+176) - 272.0_ki/195.0_ki*known(ig+180) - 128.0_ki&
+ &/39.0_ki*known(ig+184) - 6976.0_ki/975.0_ki*known(ig+188) - 184.0_ki/&
+ & 195.0_ki*known(ig+192) + 32.0_ki/325.0_ki*known(ig+196)
+
+ cg(is3(ig,19)) = 37.0_ki/390.0_ki*known(ig+31) - 7.0_ki/65.0_ki*known(ig+57) + 4.0&
+ &_ki/45.0_ki*known(ig+61) + 8.0_ki/195.0_ki*known(ig+65) - 7.0_ki/78.0_k&
+ &i*known(ig+98) - 7.0_ki/78.0_ki*known(ig+102) + 79.0_ki/390.0_ki*&
+ & known(ig+106) - 28.0_ki/195.0_ki*known(ig+110) + 56.0_ki/585.0_ki*&
+ & known(ig+114) - 556.0_ki/585.0_ki*known(ig+160) + 376.0_ki/585.0_ki*&
+ & known(ig+164) + 6784.0_ki/2925.0_ki*known(ig+168) - 68.0_ki/585.0_ki*&
+ & known(ig+172) - 28.0_ki/975.0_ki*known(ig+176) + 608.0_ki/585.0_ki*&
+ & known(ig+180) - 80.0_ki/39.0_ki*known(ig+184) - 4672.0_ki/975.0_ki*&
+ & known(ig+188) + 136.0_ki/585.0_ki*known(ig+192) + 112.0_ki/975.0_ki*&
+ & known(ig+196)
+
+ cg(is3(ig,20)) = 6.0_ki/65.0_ki*known(ig+31) + 9.0_ki/65.0_ki*known(ig+57) + 1.0_k&
+ &i/10.0_ki*known(ig+61) + 21.0_ki/130.0_ki*known(ig+65) + 3.0_ki/26.0_ki&
+ & *known(ig+98) + 3.0_ki/26.0_ki*known(ig+102) - 3.0_ki/65.0_ki*known(ig+&
+ & 106) + 12.0_ki/65.0_ki*known(ig+110) - 8.0_ki/65.0_ki*known(ig+114) + &
+ & 164.0_ki/195.0_ki*known(ig+160) + 136.0_ki/195.0_ki*known(ig+164) + 64.&
+ &0_ki/975.0_ki*known(ig+168) - 8.0_ki/195.0_ki*known(ig+172) + 12.0_ki/&
+ & 325.0_ki*known(ig+176) - 112.0_ki/195.0_ki*known(ig+180) - 16.0_ki/39.0&
+ &_ki*known(ig+184) + 64.0_ki/975.0_ki*known(ig+188) + 16.0_ki/195.0_ki*&
+ & known(ig+192) - 48.0_ki/325.0_ki*known(ig+196)
+
+ enddo
+
+
+!---------------------------------------------------------------------------
+ do igs=69,209
+ known(igs) = xneval(igs)-sub1(igs)-sub2(igs)-sub3(igs)-&
+ sub4(igs)-sub5(igs)-sub6(igs)
+ enddo
+! four q
+ cg(69) = (1082.0_ki/369.0_ki*known(69) + 215.0_ki/246.0_ki*known(122)&
+ & + 2617.0_ki/246.0_ki*known(123) - 1751.0_ki/246.0_ki*known(124)&
+ & - 73.0_ki/82.0_ki*known(125) - 472.0_ki/41.0_ki*known(200) - &
+ & 616.0_ki/123.0_ki*known(201) - 9352.0_ki/369.0_ki*known(202) + &
+ & 7184.0_ki/369.0_ki*known(203) + 48.0_ki/41.0_ki*known(204) - 728.&
+ &0_ki/369.0_ki*known(205) + 48.0_ki/41.0_ki*known(206) - 1360.0_ki&
+ &/369.0_ki*known(207) - 18.0_ki/41.0_ki*known(208) + 52.0_ki/123.0&
+ &_ki*known(209))
+
+ cg(122) = ( - 505.0_ki/246.0_ki*known(69) + 429.0_ki/82.0_ki*known(&
+ & 122) + 20.0_ki/41.0_ki*known(123) + 200.0_ki/41.0_ki*known(124)&
+ & + 40.0_ki/41.0_ki*known(125) - 1280.0_ki/41.0_ki*known(200) - &
+ & 744.0_ki/41.0_ki*known(201) - 680.0_ki/123.0_ki*known(202) - &
+ & 1832.0_ki/123.0_ki*known(203) - 120.0_ki/41.0_ki*known(204) + &
+ & 224.0_ki/123.0_ki*known(205) - 120.0_ki/41.0_ki*known(206) + 40.0&
+ &_ki/123.0_ki*known(207) + 4.0_ki/41.0_ki*known(208) - 16.0_ki/41.&
+ &0_ki*known(209))
+
+ cg(123) = ( - 355.0_ki/246.0_ki*known(69) - 26.0_ki/41.0_ki*known(122&
+ & ) - 21.0_ki/82.0_ki*known(123) - 23.0_ki/41.0_ki*known(124) - 21.&
+ &0_ki/41.0_ki*known(125) + 344.0_ki/41.0_ki*known(200) + 120.0_ki/&
+ & 41.0_ki*known(201) - 176.0_ki/123.0_ki*known(202) + 232.0_ki/123.&
+ &0_ki*known(203) + 104.0_ki/41.0_ki*known(204) - 52.0_ki/123.0_ki&
+ & *known(205) + 104.0_ki/41.0_ki*known(206) + 184.0_ki/123.0_ki*&
+ & known(207) + 2.0_ki/41.0_ki*known(208) - 8.0_ki/41.0_ki*known(&
+ & 209))
+
+ cg(124) = ( - 2905.0_ki/738.0_ki*known(69) - 1223.0_ki/246.0_ki*&
+ & known(122) - 1583.0_ki/123.0_ki*known(123) + 1021.0_ki/123.0_ki*&
+ & known(124) + 38.0_ki/41.0_ki*known(125) + 1408.0_ki/41.0_ki*&
+ & known(200) + 802.0_ki/41.0_ki*known(201) + 12904.0_ki/369.0_ki*&
+ & known(202) - 8780.0_ki/369.0_ki*known(203) - 424.0_ki/123.0_ki*&
+ & known(204) + 827.0_ki/369.0_ki*known(205) - 32.0_ki/41.0_ki*&
+ & known(206) + 1180.0_ki/369.0_ki*known(207) + 12.0_ki/41.0_ki*&
+ & known(208) + 20.0_ki/123.0_ki*known(209))
+
+ cg(125) = ( - 811.0_ki/738.0_ki*known(69) + 31.0_ki/246.0_ki*known(&
+ & 122) - 878.0_ki/123.0_ki*known(123) + 767.0_ki/246.0_ki*known(&
+ & 124) + 155.0_ki/82.0_ki*known(125) + 472.0_ki/41.0_ki*known(200)&
+ & + 14.0_ki/41.0_ki*known(201) + 6400.0_ki/369.0_ki*known(202) - &
+ & 2756.0_ki/369.0_ki*known(203) - 472.0_ki/123.0_ki*known(204) + &
+ & 113.0_ki/369.0_ki*known(205) - 48.0_ki/41.0_ki*known(206) + 868.0&
+ &_ki/369.0_ki*known(207) + 18.0_ki/41.0_ki*known(208) - 52.0_ki/&
+ & 123.0_ki*known(209))
+
+ cg(196) = (1.0_ki/3.0_ki*known(69) - known(122) + 8.0_ki/3.0_ki*&
+ & known(201))
+
+ cg(197) = (1.0_ki/3.0_ki*known(69) - known(123) + 8.0_ki/3.0_ki*&
+ & known(202))
+
+ cg(198) = (1.0_ki/3.0_ki*known(69) - known(124) + 8.0_ki/3.0_ki*&
+ & known(203))
+
+ cg(199) = (1.0_ki/3.0_ki*known(69) - known(125) + 8.0_ki/3.0_ki*&
+ & known(204))
+
+ cg(204) = ( - 2.0_ki*known(122) - 2.0_ki*known(123) + 16.0_ki*known(&
+ & 200) + 8.0_ki*known(201) + 8.0_ki*known(202))
+
+ cg(205) = (4.0_ki*known(69) + known(122) - 5.0_ki*known(124) - 4.0_ki&
+ & *known(201) + 16.0_ki*known(203) - 2.0_ki*known(205))
+
+ cg(206) = ( - 178.0_ki/123.0_ki*known(69) - 153.0_ki/41.0_ki*known(&
+ & 122) + 62.0_ki/41.0_ki*known(123) + 5.0_ki/41.0_ki*known(124) - &
+ & 40.0_ki/41.0_ki*known(125) + 624.0_ki/41.0_ki*known(200) + 580.0_&
+ &ki/41.0_ki*known(201) - 304.0_ki/123.0_ki*known(202) - 136.0_ki/&
+ & 123.0_ki*known(203) + 120.0_ki/41.0_ki*known(204) + 22.0_ki/123.0&
+ &_ki*known(205) + 120.0_ki/41.0_ki*known(206) - 40.0_ki/123.0_ki*&
+ & known(207) - 4.0_ki/41.0_ki*known(208) + 16.0_ki/41.0_ki*known(&
+ & 209))
+
+ cg(207) = ( - 1.0_ki/3.0_ki*known(69) + 3.0_ki/2.0_ki*known(122) + 5.0&
+ &_ki*known(123) + 1.0_ki/2.0_ki*known(124) - 16.0_ki*known(200)&
+ & - 6.0_ki*known(201) - 40.0_ki/3.0_ki*known(202) - 4.0_ki/3.0_ki&
+ & *known(203) + 1.0_ki/3.0_ki*known(205) - 4.0_ki/3.0_ki*known(207&
+ & ))
+
+ cg(208) = (280.0_ki/123.0_ki*known(69) + 93.0_ki/82.0_ki*known(122)&
+ & - 92.0_ki/41.0_ki*known(123) + 5.0_ki/82.0_ki*known(124) + 21.0_&
+ &ki/41.0_ki*known(125) - 344.0_ki/41.0_ki*known(200) - 202.0_ki/&
+ & 41.0_ki*known(201) + 832.0_ki/123.0_ki*known(202) - 68.0_ki/123.0&
+ &_ki*known(203) - 104.0_ki/41.0_ki*known(204) + 11.0_ki/123.0_ki*&
+ & known(205) - 104.0_ki/41.0_ki*known(206) - 20.0_ki/123.0_ki*&
+ & known(207) - 2.0_ki/41.0_ki*known(208) + 8.0_ki/41.0_ki*known(&
+ & 209))
+
+ cg(209) = (284.0_ki/369.0_ki*known(69) + 304.0_ki/123.0_ki*known(122)&
+ & + 968.0_ki/123.0_ki*known(123) - 406.0_ki/123.0_ki*known(124)&
+ & - 38.0_ki/41.0_ki*known(125) - 752.0_ki/41.0_ki*known(200) - &
+ & 392.0_ki/41.0_ki*known(201) - 7984.0_ki/369.0_ki*known(202) + &
+ & 3368.0_ki/369.0_ki*known(203) + 424.0_ki/123.0_ki*known(204) - &
+ & 212.0_ki/369.0_ki*known(205) + 32.0_ki/41.0_ki*known(206) - 688.0&
+ &_ki/369.0_ki*known(207) - 12.0_ki/41.0_ki*known(208) - 20.0_ki/&
+ & 123.0_ki*known(209))
+
+
+ if (verbosity .ge. 1) then
+ do ig=0,209
+ print*, ig, cg(ig)
+ enddo
+ end if
+ end subroutine solve_system_rk6
+
+
+subroutine init_qg_list
+ implicit none
+
+
+
+ qg(0,:) = (/ czip, czip, czip, czip /)
+
+ qg(1,:) = (/ cone, czip, czip, czip /)
+ qg(2,:) = (/ czip, cone, czip, czip /)
+ qg(3,:) = (/ czip, czip, cone, czip /)
+ qg(4,:) = (/ czip, czip, czip, cone /)
+
+ qg(5,:) = (/ -cone, czip, czip, czip /)
+ qg(6,:) = (/ czip,-cone, czip, czip /)
+ qg(7,:) = (/ czip, czip,-cone, czip /)
+ qg(8,:) = (/ czip, czip, czip,-cone /)
+
+ qg(9,:) = (/ cone, cone, czip, czip /)
+ qg(10,:) =(/ cone, czip, cone, czip /)
+ qg(11,:) =(/ cone, czip, czip, cone /)
+ qg(12,:) =(/ czip, cone, cone, czip /)
+ qg(13,:) =(/ czip, cone, czip, cone /)
+ qg(14,:) =(/ czip, czip, cone, cone /)
+
+ qg(15,:) = (/ chaf, czip, czip, czip /)
+ qg(16,:) = (/ czip, chaf, czip, czip /)
+ qg(17,:) = (/ czip, czip, chaf, czip /)
+ qg(18,:) = (/ czip, czip, czip, chaf /)
+
+ qg(19,:) = (/ cone, -cone, czip, czip /)
+ qg(20,:) = (/ cone, czip,-cone, czip /)
+ qg(21,:) = (/ cone, czip, czip,-cone /)
+ qg(22,:) = (/ czip, cone,-cone, czip /)
+ qg(23,:) = (/ czip, cone, czip,-cone /)
+ qg(24,:) = (/ czip, czip, cone,-cone /)
+
+ qg(25,:) = (/ chaf, cone, czip, czip /)
+ qg(26,:) = (/ chaf, czip, cone, czip /)
+ qg(27,:) = (/ chaf, czip, czip, cone /)
+ qg(28,:) = (/ czip, chaf, cone, czip /)
+ qg(29,:) = (/ czip, chaf, czip, cone /)
+ qg(30,:) = (/ czip, czip, chaf, cone /)
+
+ qg(31,:) = (/ cone, cone, cone, czip /)
+ qg(32,:) = (/ cone, cone, czip, cone /)
+ qg(33,:) = (/ cone, czip, cone, cone /)
+ qg(34,:) = (/ czip, cone, cone, cone /)
+
+ qg(35,:) = (/ -chaf, czip, czip, czip /)
+ qg(36,:) = (/ czip,-chaf, czip, czip /)
+ qg(37,:) = (/ czip, czip,-chaf, czip /)
+ qg(38,:) = (/ czip, czip, czip,-chaf /)
+
+ qg(39,:) = (/ -chaf, cone, czip, czip /)
+ qg(40,:) = (/ -chaf, czip, cone, czip /)
+ qg(41,:) = (/ -chaf, czip, czip, cone /)
+ qg(42,:) = (/ czip,-chaf, cone, czip /)
+ qg(43,:) = (/ czip,-chaf, czip, cone /)
+ qg(44,:) = (/ czip, czip,-chaf, cone /)
+
+ qg(45,:) = (/ chaf, -chaf, czip, czip /)
+ qg(46,:) = (/ chaf, czip, -chaf, czip /)
+ qg(47,:) = (/ chaf, czip, czip, -chaf /)
+ qg(48,:) = (/ czip, chaf, -chaf, czip /)
+ qg(49,:) = (/ czip, chaf, czip, -chaf /)
+ qg(50,:) = (/ czip, czip, chaf, -chaf /)
+
+ qg(51,:) = (/ -cone, -cone, czip, czip /)
+ qg(52,:) = (/ -cone, czip,-cone, czip /)
+ qg(53,:) = (/ -cone, czip, czip,-cone /)
+ qg(54,:) = (/ czip, -cone,-cone, czip /)
+ qg(55,:) = (/ czip, -cone, czip,-cone /)
+ qg(56,:) = (/ czip, czip,-cone,-cone /)
+
+ qg(57,:) = (/ -cone, cone, cone, czip /)
+ qg(58,:) = (/ -cone, cone, czip, cone /)
+ qg(59,:) = (/ -cone, czip, cone, cone /)
+ qg(60,:) = (/ czip,-cone, cone, cone /)
+
+ qg(61,:) = (/ cone, -cone, cone, czip /)
+ qg(62,:) = (/ cone, -cone, czip, cone /)
+ qg(63,:) = (/ cone, czip,-cone, cone /)
+ qg(64,:) = (/ czip, cone,-cone, cone /)
+
+ qg(65,:) = (/ cone, cone, -cone, czip /)
+ qg(66,:) = (/ cone, cone, czip, -cone /)
+ qg(67,:) = (/ cone, czip, cone, -cone /)
+ qg(68,:) = (/ czip, cone, cone, -cone /)
+
+ qg(69,:) = (/ cone, cone, cone, cone /)
+
+ qg(70,:) = (/ ctwo, czip, czip, czip /)
+ qg(71,:) = (/ czip, ctwo, czip, czip /)
+ qg(72,:) = (/ czip, czip, ctwo, czip /)
+ qg(73,:) = (/ czip, czip, czip, ctwo /)
+
+ qg(74,:) = (/ -cone, cone, czip, czip /)
+ qg(75,:) = (/ -cone, czip, cone, czip /)
+ qg(76,:) = (/ -cone, czip, czip, cone /)
+ qg(77,:) = (/ czip, -cone, cone, czip /)
+ qg(78,:) = (/ czip, -cone, czip, cone /)
+ qg(79,:) = (/ czip, czip, -cone, cone /)
+
+ qg(80,:) = (/ cone, chaf, czip, czip /)
+ qg(81,:) = (/ cone, czip, chaf, czip /)
+ qg(82,:) = (/ cone, czip, czip, chaf /)
+ qg(83,:) = (/ czip, cone, chaf, czip /)
+ qg(84,:) = (/ czip, cone, czip, chaf /)
+ qg(85,:) = (/ czip, czip, cone, chaf /)
+
+ qg(86,:) = (/ cone, -chaf, czip, czip /)
+ qg(87,:) = (/ cone, czip,-chaf, czip /)
+ qg(88,:) = (/ cone, czip, czip,-chaf /)
+ qg(89,:) = (/ czip, cone,-chaf, czip /)
+ qg(90,:) = (/ czip, cone, czip,-chaf /)
+ qg(91,:) = (/ czip, czip, cone,-chaf /)
+
+ qg(92,:) = (/ -cone, chaf, czip, czip /)
+ qg(93,:) = (/ -cone, czip, chaf, czip /)
+ qg(94,:) = (/ -cone, czip, czip, chaf /)
+ qg(95,:) = (/ czip,-cone, chaf, czip /)
+ qg(96,:) = (/ czip,-cone, czip, chaf /)
+ qg(97,:) = (/ czip, czip,-cone, chaf /)
+
+ qg(98,:) = (/ -cone, -cone, cone, czip /)
+ qg(99,:) = (/ -cone, -cone, czip, cone /)
+ qg(100,:) =(/ -cone, czip, -cone, cone /)
+ qg(101,:) =(/ czip, -cone, -cone, cone /)
+
+ qg(102,:) = (/ -cone, cone,-cone, czip /)
+ qg(103,:) = (/ -cone, cone, czip, -cone /)
+ qg(104,:) = (/ -cone, czip, cone, -cone /)
+ qg(105,:) = (/ czip,-cone, cone, -cone /)
+
+ qg(106,:) = (/ cone, -cone, -cone, czip /)
+ qg(107,:) = (/ cone, -cone, czip, -cone /)
+ qg(108,:) = (/ cone, czip, -cone, -cone /)
+ qg(109,:) = (/ czip, cone, -cone, -cone /)
+
+ qg(110,:) = (/ chaf, cone, cone, czip /)
+ qg(111,:) = (/ chaf, cone, czip, cone /)
+ qg(112,:) = (/ chaf, czip, cone, cone /)
+ qg(113,:) = (/ czip, chaf, cone, cone /)
+
+ qg(114,:) = (/ cone, chaf, cone, czip /)
+ qg(115,:) = (/ cone, chaf, czip, cone /)
+ qg(116,:) = (/ cone, czip, chaf, cone /)
+ qg(117,:) = (/ czip, cone, chaf, cone /)
+
+ qg(118,:) = (/ cone, cone, chaf, czip /)
+ qg(119,:) = (/ cone, cone, czip, chaf /)
+ qg(120,:) = (/ cone, czip, cone, chaf /)
+ qg(121,:) = (/ czip, cone, cone, chaf /)
+
+ qg(122,:) = (/ -cone, cone, cone, cone /)
+ qg(123,:) = (/ cone,-cone, cone, cone /)
+ qg(124,:) = (/ cone, cone,-cone, cone /)
+ qg(125,:) = (/ cone, cone, cone,-cone /)
+
+ qg(126,:) = (/ -ctwo, czip, czip, czip /)
+ qg(127,:) = (/ czip,-ctwo, czip, czip /)
+ qg(128,:) = (/ czip, czip,-ctwo, czip /)
+ qg(129,:) = (/ czip, czip, czip,-ctwo /)
+
+ qg(130,:) = (/ chaf,-cone, czip, czip /)
+ qg(131,:) = (/ chaf, czip,-cone, czip /)
+ qg(132,:) = (/ chaf, czip, czip, -cone /)
+ qg(133,:) = (/ czip, chaf,-cone, czip /)
+ qg(134,:) = (/ czip, chaf, czip, -cone /)
+ qg(135,:) = (/ czip, czip, chaf, -cone /)
+
+ qg(136,:) = (/ -chaf,-cone, czip, czip /)
+ qg(137,:) = (/ -chaf, czip,-cone, czip /)
+ qg(138,:) = (/ -chaf, czip, czip, -cone /)
+ qg(139,:) = (/ czip,-chaf,-cone, czip /)
+ qg(140,:) = (/ czip,-chaf, czip, -cone /)
+ qg(141,:) = (/ czip, czip,-chaf, -cone /)
+
+ qg(142,:) = (/ -chaf, chaf, czip, czip /)
+ qg(143,:) = (/ -chaf, czip, chaf, czip /)
+ qg(144,:) = (/ -chaf, czip, czip, chaf /)
+ qg(145,:) = (/ czip,-chaf, chaf, czip /)
+ qg(146,:) = (/ czip,-chaf, czip, chaf /)
+ qg(147,:) = (/ czip, czip,-chaf, chaf /)
+
+ qg(148,:) = (/ chaf, ctwo, czip, czip /)
+ qg(149,:) = (/ chaf, czip, ctwo, czip /)
+ qg(150,:) = (/ chaf, czip, czip, ctwo /)
+ qg(151,:) = (/ czip, chaf, ctwo, czip /)
+ qg(152,:) = (/ czip, chaf, czip, ctwo /)
+ qg(153,:) = (/ czip, czip, chaf, ctwo /)
+
+ qg(154,:) = (/ ctwo, chaf, czip, czip /)
+ qg(155,:) = (/ ctwo, czip, chaf, czip /)
+ qg(156,:) = (/ ctwo, czip, czip, chaf /)
+ qg(157,:) = (/ czip, ctwo, chaf, czip /)
+ qg(158,:) = (/ czip, ctwo, czip, chaf /)
+ qg(159,:) = (/ czip, czip, ctwo, chaf /)
+
+ qg(160,:) = (/ chaf, -cone, -cone, czip /)
+ qg(161,:) = (/ chaf, -cone, czip, -cone /)
+ qg(162,:) = (/ chaf, czip, -cone, -cone /)
+ qg(163,:) = (/ czip, chaf, -cone, -cone /)
+
+ qg(164,:) = (/ -chaf, -cone, -cone, czip /)
+ qg(165,:) = (/ -chaf, -cone, czip, -cone /)
+ qg(166,:) = (/ -chaf, czip, -cone, -cone /)
+ qg(167,:) = (/ czip, -chaf, -cone, -cone /)
+
+ qg(168,:) = (/ -chaf, chaf,-cone, czip /)
+ qg(169,:) = (/ -chaf, chaf, czip, -cone /)
+ qg(170,:) = (/ -chaf, czip, chaf, -cone /)
+ qg(171,:) = (/ czip,-chaf, chaf, -cone /)
+
+ qg(172,:) = (/ chaf, ctwo,-cone, czip /)
+ qg(173,:) = (/ chaf, ctwo, czip, -cone /)
+ qg(174,:) = (/ chaf, czip, ctwo, -cone /)
+ qg(175,:) = (/ czip, chaf, ctwo, -cone /)
+
+ qg(176,:) = (/ ctwo, chaf,-cone, czip /)
+ qg(177,:) = (/ ctwo, chaf, czip, -cone /)
+ qg(178,:) = (/ ctwo, czip, chaf, -cone /)
+ qg(179,:) = (/ czip, ctwo, chaf, -cone /)
+
+ qg(180,:) = (/ chaf, -cone, -chaf, czip /)
+ qg(181,:) = (/ chaf, -cone, czip, -chaf /)
+ qg(182,:) = (/ chaf, czip, -cone, -chaf /)
+ qg(183,:) = (/ czip, chaf, -cone, -chaf /)
+
+ qg(184,:) = (/ -chaf,-cone, -chaf, czip /)
+ qg(185,:) = (/ -chaf,-cone, czip, -chaf /)
+ qg(186,:) = (/ -chaf, czip, -cone, -chaf /)
+ qg(187,:) = (/ czip,-chaf, -cone, -chaf /)
+
+ qg(188,:) = (/ -chaf, chaf,-chaf, czip /)
+ qg(189,:) = (/ -chaf, chaf, czip, -chaf /)
+ qg(190,:) = (/ -chaf, czip, chaf, -chaf /)
+ qg(191,:) = (/ czip,-chaf, chaf, -chaf /)
+
+ qg(192,:) = (/ chaf, ctwo,-chaf, czip /)
+ qg(193,:) = (/ chaf, ctwo, czip, -chaf /)
+ qg(194,:) = (/ chaf, czip, ctwo, -chaf /)
+ qg(195,:) = (/ czip, chaf, ctwo, -chaf /)
+
+ qg(196,:) = (/ ctwo, chaf,-chaf, czip /)
+ qg(197,:) = (/ ctwo, chaf, czip, -chaf /)
+ qg(198,:) = (/ ctwo, czip, chaf, -chaf /)
+ qg(199,:) = (/ czip, ctwo, chaf, -chaf /)
+
+ qg(200,:) = (/ chaf, chaf, cone, cone /)
+ qg(201,:) = (/ -chaf, cone, cone, cone /)
+ qg(202,:) = (/ cone,-chaf, cone, cone /)
+ qg(203,:) = (/ cone, cone,-chaf, cone /)
+ qg(204,:) = (/ cone, cone, cone,-chaf /)
+ qg(205,:) = (/ chaf, cone, ctwo, cone /)
+ qg(206,:) = (/ chaf, ctwo, cone, chaf /)
+ qg(207,:) = (/ chaf,-ctwo, chaf, cone /)
+ qg(208,:) = (/ chaf,-chaf,-ctwo, ctwo /)
+ qg(209,:) = (/ ctwo, ctwo, chaf,-chaf /)
+
+ qg_list_is_initialized = .true.
+end subroutine init_qg_list
+
+subroutine init_cg(numeval,rank,xneval,dxneval)
+ implicit none
+
+ integer, intent(in) :: rank
+ complex(ki), dimension(0:209), intent(out) :: xneval
+ complex(ki), dimension(0:9), intent(out) :: dxneval
+
+ integer :: ig, igm
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ select case(rank)
+ case(0:1)
+ igm = 4
+ case(2)
+ igm = 14
+ case(3)
+ igm = 34
+ case(4)
+ igm = 69
+ case(5)
+ igm = 125
+ case(6)
+ igm = 209
+ case default
+ print*, "In init_qg: rank not yet implemented: rank =", rank
+ stop
+ end select
+
+ ! Use icut = 9 to avoid confusing numerators which make use of
+ ! the icut parameter (like golem-2.0). [TR]
+ cg(:)=czip
+ cgx(:)=czip
+ cg(0) = numeval(9, qg(0,:),czip)
+ do ig = 1, igm
+ xneval(ig) = numeval(9, qg(ig,:),czip) - cg(0)
+! cg(ig) = czip
+ enddo
+! initialization of d-xneval
+ dxneval(0)=numeval(9,qg(0,:),cone)- cg(0)
+ dxneval(5)=numeval(9,qg(0,:),-cone)- cg(0)
+ do ig = 1, 4
+ dxneval(ig)=numeval(9,qg(ig,:),cone)- cg(0)
+ dxneval(5+ig)=numeval(9,qg(4+ig,:),cone)- cg(0)
+ enddo
+
+end subroutine init_cg
+
+function numetens(ncut,Q,mu2)
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numetens
+ complex(ki) :: sub1, sub2, sub3, sub4, sub5, sub6, subx
+ complex(ki) :: q1,q2,q3,q4,a1,a2,a3
+ !integer :: i
+
+ q1 = Q(1)
+ q2 = Q(2)
+ q3 = Q(3)
+ q4 = Q(4)
+
+ a1 = q4*q4
+ a2 = a1*a1
+ a3 = a1*q4
+
+ sub1=czip
+ sub2=czip
+ sub3=czip
+ sub4=czip
+ sub5=czip
+ sub6=czip
+ subx=czip
+
+ if (myrank.eq.6) goto 1
+ if (myrank.eq.5) goto 2
+ if (myrank.eq.4) goto 3
+ if (myrank.eq.3) goto 4
+ if (myrank.eq.2) goto 5
+ if (myrank.eq.1) goto 6
+ if (myrank.eq.0) then
+ numetens=cg(0)
+ goto 7
+ endif
+
+ 1 continue
+
+ !rank6
+ sub6 = ((((((cg(128)*q3+cg(140)*q4)*q3+cg(152)*a1)*q3+cg(171)*a1*q4)*q3+cg(15&
+ &3)*a2)*q3+cg(141)*a2*q4)*q3+(((((cg(138)*q3+cg(164)*q4)*q3+cg(194)*a1)*q3+cg&
+ &(195)*a1*q4)*q3+cg(165)*a2)*q3+((((cg(150)*q3+cg(192)*q4)*q3+cg(203)*a1)*q3+&
+ &cg(193)*a1*q4)*q3+(((cg(169)*q3+cg(190)*q4)*q3+cg(191)*a1)*q3+((cg(148)*q3+c&
+ &g(163)*q4)*q3+(cg(127)*q2+cg(136)*q3+cg(137)*q4)*q2+cg(149)*a1)*q2+cg(170)*a&
+ &1*q4)*q2+cg(151)*a2)*q2+cg(139)*a2*q4)*q2+(((((cg(134)*q3+cg(161)*q4)*q3+cg(&
+ &188)*a1)*q3+cg(189)*a1*q4)*q3+cg(162)*a2)*q3+((((cg(159)*q3+cg(198)*q4)*q3+c&
+ &g(209)*a1)*q3+cg(199)*a1*q4)*q3+(((cg(186)*q3+cg(207)*q4)*q3+cg(208)*a1)*q3+&
+ &((cg(184)*q3+cg(197)*q4)*q3+(cg(133)*q2+cg(157)*q3+cg(158)*q4)*q2+cg(185)*a1&
+ &)*q2+cg(187)*a1*q4)*q2+cg(160)*a2)*q2+((((cg(146)*q3+cg(182)*q4)*q3+cg(202)*&
+ &a1)*q3+cg(183)*a1*q4)*q3+(((cg(180)*q3+cg(205)*q4)*q3+cg(206)*a1)*q3+((cg(20&
+ &0)*q3+cg(204)*q4)*q3+(cg(145)*q2+cg(178)*q3+cg(179)*q4)*q2+cg(201)*a1)*q2+cg&
+ &(181)*a1*q4)*q2+(((cg(167)*q3+cg(176)*q4)*q3+cg(177)*a1)*q3+((cg(174)*q3+cg(&
+ &196)*q4)*q3+(cg(166)*q2+cg(172)*q3+cg(173)*q4)*q2+cg(175)*a1)*q2+((cg(143)*q&
+ &3+cg(156)*q4)*q3+(cg(142)*q2+cg(154)*q3+cg(155)*q4)*q2+(cg(126)*q1+cg(130)*q&
+ &2+cg(131)*q3+cg(132)*q4)*q1+cg(144)*a1)*q1+cg(168)*a1*q4)*q1+cg(147)*a2)*q1+&
+ &cg(135)*a2*q4)*q1+cg(129)*a3*a3)
+
+ 2 continue
+
+!rank5
+ sub5 = (((((cg(72)*q3+cg(84)*q4)*q3+cg(96)*a1)*q3+cg(97)*a1*q4)*q3+cg(85)*a2)&
+ &*q3+((((cg(82)*q3+cg(108)*q4)*q3+cg(121)*a1)*q3+cg(109)*a1*q4)*q3+(((cg(94)*&
+ &q3+cg(119)*q4)*q3+cg(120)*a1)*q3+((cg(92)*q3+cg(107)*q4)*q3+(cg(71)*q2+cg(80&
+ &)*q3+cg(81)*q4)*q2+cg(93)*a1)*q2+cg(95)*a1*q4)*q2+cg(83)*a2)*q2+((((cg(78)*q&
+ &3+cg(105)*q4)*q3+cg(118)*a1)*q3+cg(106)*a1*q4)*q3+(((cg(103)*q3+cg(124)*q4)*&
+ &q3+cg(125)*a1)*q3+((cg(116)*q3+cg(123)*q4)*q3+(cg(77)*q2+cg(101)*q3+cg(102)*&
+ &q4)*q2+cg(117)*a1)*q2+cg(104)*a1*q4)*q2+(((cg(90)*q3+cg(114)*q4)*q3+cg(115)*&
+ &a1)*q3+((cg(112)*q3+cg(122)*q4)*q3+(cg(89)*q2+cg(110)*q3+cg(111)*q4)*q2+cg(1&
+ &13)*a1)*q2+((cg(87)*q3+cg(100)*q4)*q3+(cg(86)*q2+cg(98)*q3+cg(99)*q4)*q2+(cg&
+ &(70)*q1+cg(74)*q2+cg(75)*q3+cg(76)*q4)*q1+cg(88)*a1)*q1+cg(91)*a1*q4)*q1+cg(&
+ &79)*a2)*q1+cg(73)*a2*q4)
+
+ 3 continue
+
+!rank4
+ sub4 = ((((cg(37)*q3+cg(49)*q4)*q3+cg(56)*a1)*q3+cg(50)*a1*q4)*q3+(((cg(47)*q&
+ &3+cg(67)*q4)*q3+cg(68)*a1)*q3+((cg(54)*q3+cg(66)*q4)*q3+(cg(36)*q2+cg(45)*q3&
+ &+cg(46)*q4)*q2+cg(55)*a1)*q2+cg(48)*a1*q4)*q2+(((cg(43)*q3+cg(64)*q4)*q3+cg(&
+ &65)*a1)*q3+((cg(62)*q3+cg(69)*q4)*q3+(cg(42)*q2+cg(60)*q3+cg(61)*q4)*q2+cg(6&
+ &3)*a1)*q2+((cg(52)*q3+cg(59)*q4)*q3+(cg(51)*q2+cg(57)*q3+cg(58)*q4)*q2+(cg(3&
+ &5)*q1+cg(39)*q2+cg(40)*q3+cg(41)*q4)*q1+cg(53)*a1)*q1+cg(44)*a1*q4)*q1+cg(38&
+ &)*a1*a1)
+
+ 4 continue
+
+!rank3
+ sub3 = (((cg(17)*q3+cg(29)*q4)*q3+cg(30)*a1)*q3+((cg(27)*q3+cg(34)*q4)*q3+(cg&
+ &(16)*q2+cg(25)*q3+cg(26)*q4)*q2+cg(28)*a1)*q2+((cg(23)*q3+cg(33)*q4)*q3+(cg(&
+ &22)*q2+cg(31)*q3+cg(32)*q4)*q2+(cg(15)*q1+cg(19)*q2+cg(20)*q3+cg(21)*q4)*q1+&
+ &cg(24)*a1)*q1+cg(18)*a1*q4)
+
+ 5 continue
+
+!rank2
+ sub2 = ((cg(7)*q3+cg(14)*q4)*q3+(cg(6)*q2+cg(12)*q3+cg(13)*q4)*q2+(cg(5)*q1&
+ & +cg(9)*q2+cg(10)*q3+cg(11)*q4)*q1+cg(8)*q4*q4)
+
+ 6 continue
+
+!rank1
+ sub1 = cg(1)*q1+cg(2)*q2+cg(3)*q3+cg(4)*q4
+
+! extra
+ subx = cgx(1)*mu2+cgx(2)*mu2*mu2+(cgx(3)*q1+cgx(4)*q2+cgx(5)*q3+cgx(6)*q4)*&
+ mu2+(cgx(7)*q1*q1+cgx(8)*q2*q2+cgx(9)*q3*q3+cgx(10)*q4*q4)*mu2
+! sum
+ numetens=cg(0)+subx+sub1+sub2+sub3+sub4+sub5+sub6
+
+ 7 continue
+
+ end function numetens
+
+pure function sub1(is)
+ implicit none
+ complex(ki) :: sub1
+ complex(ki) :: q1,q2,q3,q4
+ integer, intent(in):: is
+
+ q1 = qg(is,1)
+ q2 = qg(is,2)
+ q3 = qg(is,3)
+ q4 = qg(is,4)
+
+ sub1 = cg(1)*q1+cg(2)*q2+cg(3)*q3+cg(4)*q4
+
+end function sub1
+
+pure function subx(is,mu2)
+ implicit none
+ complex(ki) :: subx
+ complex(ki) :: q1,q2,q3,q4
+ complex(ki), intent(in) :: mu2
+ integer, intent(in):: is
+
+ q1 = qg(is,1)
+ q2 = qg(is,2)
+ q3 = qg(is,3)
+ q4 = qg(is,4)
+
+ subx = cgx(1)*mu2+cgx(2)*mu2*mu2+(cgx(3)*q1+cgx(4)*q2+cgx(5)*q3+cgx(6)*q4)*mu2+&
+ (cgx(7)*q1*q1+cgx(8)*q2*q2+cgx(9)*q3*q3+cgx(10)*q4*q4)*mu2
+
+end function subx
+
+
+
+pure function sub2(is)
+ ! generated: Do, 1 Jul 2010 16:15:15 +0200
+ implicit none
+ integer, intent(in) :: is
+ complex(ki) :: sub2
+ complex(ki) :: q1, q2, q3, q4
+
+ q1 = qg(is,1)
+ q2 = qg(is,2)
+ q3 = qg(is,3)
+ q4 = qg(is,4)
+
+ sub2 = ((cg(7)*q3+cg(14)*q4)*q3+(cg(6)*q2+cg(12)*q3+cg(13)*q4)*q2+(cg(5)*q1&
+ & +cg(9)*q2+cg(10)*q3+cg(11)*q4)*q1+cg(8)*q4*q4)
+end function sub2
+
+pure function sub3(is)
+ ! generated: Do, 1 Jul 2010 16:15:16 +0200
+ implicit none
+ integer, intent(in) :: is
+ complex(ki) :: sub3
+ complex(ki) :: q1, q2, q3, q4
+ complex(ki) :: a1
+
+ q1 = qg(is,1)
+ q2 = qg(is,2)
+ q3 = qg(is,3)
+ q4 = qg(is,4)
+
+ a1 = q4*q4
+ sub3 = (((cg(17)*q3+cg(29)*q4)*q3+cg(30)*a1)*q3+((cg(27)*q3+cg(34)*q4)*q3+(cg&
+ &(16)*q2+cg(25)*q3+cg(26)*q4)*q2+cg(28)*a1)*q2+((cg(23)*q3+cg(33)*q4)*q3+(cg(&
+ &22)*q2+cg(31)*q3+cg(32)*q4)*q2+(cg(15)*q1+cg(19)*q2+cg(20)*q3+cg(21)*q4)*q1+&
+ &cg(24)*a1)*q1+cg(18)*a1*q4)
+end function sub3
+
+pure function sub4(is)
+ ! generated: Do, 1 Jul 2010 16:15:17 +0200
+ implicit none
+ integer, intent(in) :: is
+ complex(ki) :: sub4
+ complex(ki) :: q1, q2, q3, q4
+ complex(ki) :: a1
+
+ q1 = qg(is,1)
+ q2 = qg(is,2)
+ q3 = qg(is,3)
+ q4 = qg(is,4)
+
+ a1 = q4*q4
+ sub4 = ((((cg(37)*q3+cg(49)*q4)*q3+cg(56)*a1)*q3+cg(50)*a1*q4)*q3+(((cg(47)*q&
+ &3+cg(67)*q4)*q3+cg(68)*a1)*q3+((cg(54)*q3+cg(66)*q4)*q3+(cg(36)*q2+cg(45)*q3&
+ &+cg(46)*q4)*q2+cg(55)*a1)*q2+cg(48)*a1*q4)*q2+(((cg(43)*q3+cg(64)*q4)*q3+cg(&
+ &65)*a1)*q3+((cg(62)*q3+cg(69)*q4)*q3+(cg(42)*q2+cg(60)*q3+cg(61)*q4)*q2+cg(6&
+ &3)*a1)*q2+((cg(52)*q3+cg(59)*q4)*q3+(cg(51)*q2+cg(57)*q3+cg(58)*q4)*q2+(cg(3&
+ &5)*q1+cg(39)*q2+cg(40)*q3+cg(41)*q4)*q1+cg(53)*a1)*q1+cg(44)*a1*q4)*q1+cg(38&
+ &)*a1*a1)
+end function sub4
+
+pure function sub5(is)
+ ! generated: Do, 1 Jul 2010 16:15:18 +0200
+ implicit none
+ integer, intent(in) :: is
+
+ complex(ki) :: sub5
+ complex(ki) :: q1, q2, q3, q4
+
+
+ complex(ki) :: a1
+ complex(ki) :: a2
+
+ q1 = qg(is,1)
+ q2 = qg(is,2)
+ q3 = qg(is,3)
+ q4 = qg(is,4)
+
+
+ a1 = q4*q4
+ a2 = a1*a1
+ sub5 = (((((cg(72)*q3+cg(84)*q4)*q3+cg(96)*a1)*q3+cg(97)*a1*q4)*q3+cg(85)*a2)&
+ &*q3+((((cg(82)*q3+cg(108)*q4)*q3+cg(121)*a1)*q3+cg(109)*a1*q4)*q3+(((cg(94)*&
+ &q3+cg(119)*q4)*q3+cg(120)*a1)*q3+((cg(92)*q3+cg(107)*q4)*q3+(cg(71)*q2+cg(80&
+ &)*q3+cg(81)*q4)*q2+cg(93)*a1)*q2+cg(95)*a1*q4)*q2+cg(83)*a2)*q2+((((cg(78)*q&
+ &3+cg(105)*q4)*q3+cg(118)*a1)*q3+cg(106)*a1*q4)*q3+(((cg(103)*q3+cg(124)*q4)*&
+ &q3+cg(125)*a1)*q3+((cg(116)*q3+cg(123)*q4)*q3+(cg(77)*q2+cg(101)*q3+cg(102)*&
+ &q4)*q2+cg(117)*a1)*q2+cg(104)*a1*q4)*q2+(((cg(90)*q3+cg(114)*q4)*q3+cg(115)*&
+ &a1)*q3+((cg(112)*q3+cg(122)*q4)*q3+(cg(89)*q2+cg(110)*q3+cg(111)*q4)*q2+cg(1&
+ &13)*a1)*q2+((cg(87)*q3+cg(100)*q4)*q3+(cg(86)*q2+cg(98)*q3+cg(99)*q4)*q2+(cg&
+ &(70)*q1+cg(74)*q2+cg(75)*q3+cg(76)*q4)*q1+cg(88)*a1)*q1+cg(91)*a1*q4)*q1+cg(&
+ &79)*a2)*q1+cg(73)*a2*q4)
+end function sub5
+
+pure function sub6(is)
+ implicit none
+ integer, intent(in) :: is
+
+ complex(ki) :: sub6
+ complex(ki) :: q1, q2, q3, q4
+
+
+ complex(ki) :: a1
+ complex(ki) :: a2
+ complex(ki) :: a3
+
+ q1 = qg(is,1)
+ q2 = qg(is,2)
+ q3 = qg(is,3)
+ q4 = qg(is,4)
+
+
+ a1 = q4*q4
+ a2 = a1*a1
+ a3 = a1*q4
+ sub6 = ((((((cg(128)*q3+cg(140)*q4)*q3+cg(152)*a1)*q3+cg(171)*a1*q4)*q3+cg(15&
+ &3)*a2)*q3+cg(141)*a2*q4)*q3+(((((cg(138)*q3+cg(164)*q4)*q3+cg(194)*a1)*q3+cg&
+ &(195)*a1*q4)*q3+cg(165)*a2)*q3+((((cg(150)*q3+cg(192)*q4)*q3+cg(203)*a1)*q3+&
+ &cg(193)*a1*q4)*q3+(((cg(169)*q3+cg(190)*q4)*q3+cg(191)*a1)*q3+((cg(148)*q3+c&
+ &g(163)*q4)*q3+(cg(127)*q2+cg(136)*q3+cg(137)*q4)*q2+cg(149)*a1)*q2+cg(170)*a&
+ &1*q4)*q2+cg(151)*a2)*q2+cg(139)*a2*q4)*q2+(((((cg(134)*q3+cg(161)*q4)*q3+cg(&
+ &188)*a1)*q3+cg(189)*a1*q4)*q3+cg(162)*a2)*q3+((((cg(159)*q3+cg(198)*q4)*q3+c&
+ &g(209)*a1)*q3+cg(199)*a1*q4)*q3+(((cg(186)*q3+cg(207)*q4)*q3+cg(208)*a1)*q3+&
+ &((cg(184)*q3+cg(197)*q4)*q3+(cg(133)*q2+cg(157)*q3+cg(158)*q4)*q2+cg(185)*a1&
+ &)*q2+cg(187)*a1*q4)*q2+cg(160)*a2)*q2+((((cg(146)*q3+cg(182)*q4)*q3+cg(202)*&
+ &a1)*q3+cg(183)*a1*q4)*q3+(((cg(180)*q3+cg(205)*q4)*q3+cg(206)*a1)*q3+((cg(20&
+ &0)*q3+cg(204)*q4)*q3+(cg(145)*q2+cg(178)*q3+cg(179)*q4)*q2+cg(201)*a1)*q2+cg&
+ &(181)*a1*q4)*q2+(((cg(167)*q3+cg(176)*q4)*q3+cg(177)*a1)*q3+((cg(174)*q3+cg(&
+ &196)*q4)*q3+(cg(166)*q2+cg(172)*q3+cg(173)*q4)*q2+cg(175)*a1)*q2+((cg(143)*q&
+ &3+cg(156)*q4)*q3+(cg(142)*q2+cg(154)*q3+cg(155)*q4)*q2+(cg(126)*q1+cg(130)*q&
+ &2+cg(131)*q3+cg(132)*q4)*q1+cg(144)*a1)*q1+cg(168)*a1*q4)*q1+cg(147)*a2)*q1+&
+ &cg(135)*a2*q4)*q1+cg(129)*a3*a3)
+end function sub6
+
+end module mtens
diff --git a/samurai-2.1.1/mtests.f90 b/samurai-2.1.1/mtests.f90
new file mode 100644
index 0000000..e50a337
--- /dev/null
+++ b/samurai-2.1.1/mtests.f90
@@ -0,0 +1,693 @@
+module mtests
+ use precision, only: ki
+ use constants
+ use options
+ use mfunctions
+ use mrestore
+ use save
+ use ltest
+ use mglobal, only: resit, denst
+ implicit none
+
+ private
+ public :: pwtest, nntest, lnntest1, lnntest2, lnntest3, lnntest4
+
+ real(ki), parameter :: nprec = epsilon(1.0_ki) * 1.0E+03_ki
+
+ interface nntest
+ module procedure nntest_rm
+ module procedure nntest_cm
+ end interface nntest
+
+contains
+
+ subroutine pwtest(nleg,rank,ok)
+ implicit none
+ integer, intent(in) :: nleg, rank
+ logical, intent(out) :: ok
+
+ integer :: i,j
+ integer :: diff
+ real(ki), dimension(4) :: e1, e2
+ real(ki) :: pwval
+ complex(ki), dimension(4) :: e3, e4
+ complex(ki) :: pwt
+ complex(ki), dimension(4) :: pwtv
+
+ diff = nleg-rank
+ pwt=czip
+
+ if(verbosity.ge.3)then
+ write(iout,*) '------------------------------------'
+ write(iout,*) 'PoWer test'
+ endif
+
+ if (diff.eq.0) then
+ !---#[ maximum rank :
+ pwtv=(/ czip, czip, czip, czip /)
+
+ do j =1,max1
+ do i=1,4
+ e1(i)=sav1e1(j,i)
+ e2(i)=sav1e2(j,i)
+ e3(i)=sav1e3(j,i)
+ e4(i)=sav1e4(j,i)
+ enddo
+ do i=1,4
+ pwtv(i)=pwtv(i)+savc1(j,1)*e1(i)+savc1(j,2)*e2(i) &
+ & +savc1(j,3)*e3(i)+savc1(j,4)*e4(i)
+ enddo
+ enddo
+
+ pwval = maxval(abs(pwtv))
+ !---#] maximum rank :
+ elseif (diff.eq.1) then
+ !---#[ nleg-rank = 1:
+ pwt=czip
+ do i =1,6
+ pwt=pwt+savc1(i,0)
+ enddo
+
+ pwval = abs(pwt)
+ !---#] nleg-rank = 1:
+ elseif (diff.eq.2) then
+ !---#[ nleg-rank = 2:
+ pwt=czip
+ do i =1,max2
+ pwt=pwt+savc2(i,0)
+ enddo
+ pwval = abs(pwt)
+ !---#] nleg-rank = 2:
+ else
+ !---#[ nleg-rank > 2:
+ pwt=czip
+ do i =1,max3
+ pwt=pwt+savc3(i,0)
+ enddo
+ pwval = abs(pwt)
+ !---#] nleg-rank > 2:
+ endif
+
+ if(verbosity.ge.3) write(iout,*) 'pwtest = ', pwval
+ if (pwval.ge.pwlimit) then
+ ok=.false.
+ if(verbosity.gt.0) then
+ write(iout,*) ' POWERTEST FAILED! '
+ write(iout,*) 'point above discarded'
+ endif
+ else
+ ok=.true.
+ if(verbosity.ge.3) write(iout,*) ' PowerTest passed! '
+ endif
+ if(verbosity.ge.3) write(iout,*) '------------------------------------'
+ end subroutine
+
+ subroutine nntest_rm(numeval,q1,mu2,nleg,Vi,msq,ok)
+ implicit none
+
+ complex(ki), dimension(4), intent(in) :: q1
+ complex(ki), intent(in) :: mu2
+ integer, intent(in) :: nleg
+ real(ki), dimension(0:nleg-1) :: msq
+ real(ki), dimension(0:nleg-1,4) :: Vi
+ logical, intent(out) :: ok
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ integer :: i, i1, i2, i3, i4, i5, ncut
+ integer :: dicut5, dicut4, dicut3, dicut2, dicut1
+ complex(ki) :: dens1,dens2,dens3,dens4,dens5,xneval
+ complex(ki) :: resi5, resi4, resi3, resi2 ,resi1, resitot, ztest
+
+ resi1=czip
+ resi2=czip
+ resi3=czip
+ resi4=czip
+ resi5=czip
+
+ ztest=czip
+ xneval=czip
+
+ if (nleg.gt.5) then
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5=cone
+ do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)&
+ & .and.(i.ne.i5)) then
+ dens5=dens5*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ endif
+ enddo
+ resi5=resi5+dens5*res5(dicut5,mu2)
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ elseif (nleg.eq.5) then
+ resi5=res5(1,mu2)
+ end if
+
+ if (nleg.ge.5) then
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4=cone
+ do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ &.and.(i.ne.i3).and.(i.ne.i4)) then
+ dens4=dens4*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ endif
+ enddo
+
+ resi4=resi4+dens4*Res4(dicut4,q1,mu2)
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+ elseif (nleg.eq.4) then
+ resi4=Res4(1,q1,mu2)
+ end if
+
+ if (nleg.ge.4) then
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens3=cone
+ do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ dens3=dens3*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ endif
+ enddo
+
+ resi3=resi3+dens3*Res3(dicut3,q1,mu2)
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei Triple cuts:
+ elseif (nleg.eq.3) then
+ resi3=Res3(1,q1,mu2)
+ end if
+
+ if (nleg.ge.3) then
+ !---#[ Contributo dei Double cuts:
+ dicut2=1
+ do i2=1,nleg-1
+ do i1=0,i2-1
+ dens2=cone
+ do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2)) then
+ dens2=dens2*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ endif
+ enddo
+
+ resi2=resi2+dens2*Res2(dicut2,q1,mu2)
+ dicut2=dicut2+1
+ enddo
+ enddo
+ !---#] Contributo dei Double cuts:
+ elseif (nleg.eq.2) then
+ resi2=Res2(1,q1,mu2)
+ endif
+
+ !---#[ Contribution of the single cut:
+ dicut1=1
+ do i1=0,nleg-1
+ dens1=cone
+ ! ---> I replaced this loop
+ !do i=0,nleg-1
+ ! if (i.ne.i1) then
+ ! dens1=dens1*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ ! endif
+ !enddo
+ ! ---> because we can do this without an if statement inside:
+ do i=0,i1-1
+ dens1=dens1*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ enddo
+ do i=i1+1,nleg-1
+ dens1=dens1*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ enddo
+
+ resi1=resi1+dens1*Res1(dicut1,q1)
+ dicut1=dicut1+1
+ enddo
+ !---#] Contribution of the single cut:
+
+ xneval=numeval(ncut,q1,mu2)
+ resitot=resi5+resi4+resi3+resi2+resi1
+ ztest=xneval-resitot
+
+ if(verbosity.ge.3)then
+ write(iout,*) '--------------------------------------------'
+ write(iout,*) 'N=N test for'
+ write(iout,*) 'q(0) = ', q1(4)
+ write(iout,*) 'q(1) = ', q1(1)
+ write(iout,*) 'q(2) = ', q1(2)
+ write(iout,*) 'q(3) = ', q1(3)
+ write(iout,*) 'and mu2 = ', mu2
+ write(iout,*) 'N calculated', xneval
+ write(iout,*) 'N reconstructed', resitot
+ write(iout,*) ' '
+ write(iout,*) 'difference = ', ztest
+ write(iout,*) 'rel.diff. = ', ztest/xneval
+ write(iout,*) '--------------------------------------------'
+ endif
+
+ if (abs(ztest/xneval).gt.nnlimit) then
+ ok=.false.
+ if (verbosity.gt.0) write(iout,*) 'N=N test FAILED'
+ else
+ ok=.true.
+ endif
+ end subroutine nntest_rm
+
+ subroutine nntest_cm(numeval,q1,mu2,nleg,Vi,msq,ok)
+ implicit none
+
+ complex(ki), dimension(4), intent(in) :: q1
+ complex(ki), intent(in) :: mu2
+ integer, intent(in) :: nleg
+ complex(ki), dimension(0:nleg-1) :: msq
+ real(ki), dimension(0:nleg-1,4) :: Vi
+ logical, intent(out) :: ok
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ integer :: i, i1, i2, i3, i4, i5, ncut
+ integer :: dicut5, dicut4, dicut3, dicut2, dicut1
+ complex(ki) :: dens1,dens2,dens3,dens4,dens5,xneval
+ complex(ki) :: resi5, resi4, resi3, resi2 ,resi1, resitot, ztest
+
+ resi1=czip
+ resi2=czip
+ resi3=czip
+ resi4=czip
+ resi5=czip
+
+ ztest=czip
+ xneval=czip
+
+ if (nleg.gt.5) then
+ !---#[ Contributo dei pentuple cuts:
+ dicut5=1
+
+ do i5=4,nleg-1
+ do i4=3,i5-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens5=cone
+ do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ & .and.(i.ne.i3).and.(i.ne.i4)&
+ & .and.(i.ne.i5)) then
+ dens5=dens5*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ endif
+ enddo
+ resi5=resi5+dens5*res5(dicut5,mu2)
+ dicut5=dicut5+1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei pentuple cuts:
+ elseif (nleg.eq.5) then
+ resi5=res5(1,mu2)
+ end if
+
+ if (nleg.ge.5) then
+ !---#[ Contributo dei quadruple cuts:
+ dicut4=1
+ do i4=3,nleg-1
+ do i3=2,i4-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens4=cone
+ do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2) &
+ &.and.(i.ne.i3).and.(i.ne.i4)) then
+ dens4=dens4*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ endif
+ enddo
+
+ resi4=resi4+dens4*Res4(dicut4,q1,mu2)
+ dicut4=dicut4+1
+ enddo
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei quadruple cuts:
+ elseif (nleg.eq.4) then
+ resi4=Res4(1,q1,mu2)
+ end if
+
+ if (nleg.ge.4) then
+ !---#[ Contributo dei Triple cuts:
+ dicut3=1
+ do i3=2,nleg-1
+ do i2=1,i3-1
+ do i1=0,i2-1
+ dens3=cone
+ do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2).and.(i.ne.i3)) then
+ dens3=dens3*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ endif
+ enddo
+
+ resi3=resi3+dens3*Res3(dicut3,q1,mu2)
+ dicut3=dicut3+1
+ enddo
+ enddo
+ enddo
+ !---#] Contributo dei Triple cuts:
+ elseif (nleg.eq.3) then
+ resi3=Res3(1,q1,mu2)
+ end if
+
+ if (nleg.ge.3) then
+ !---#[ Contributo dei Double cuts:
+ dicut2=1
+ do i2=1,nleg-1
+ do i1=0,i2-1
+ dens2=cone
+ do i=0,nleg-1
+ if ((i.ne.i1).and.(i.ne.i2)) then
+ dens2=dens2*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ endif
+ enddo
+
+ resi2=resi2+dens2*Res2(dicut2,q1,mu2)
+ dicut2=dicut2+1
+ enddo
+ enddo
+ !---#] Contributo dei Double cuts:
+ elseif (nleg.eq.2) then
+ resi2=Res2(1,q1,mu2)
+ endif
+
+ !---#[ Contribution of the single cut:
+ dicut1=1
+ do i1=0,nleg-1
+ dens1=cone
+ ! ---> I replaced this loop
+ !do i=0,nleg-1
+ ! if (i.ne.i1) then
+ ! dens1=dens1*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ ! endif
+ !enddo
+ ! ---> because we can do this without an if statement inside:
+ do i=0,i1-1
+ dens1=dens1*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ enddo
+ do i=i1+1,nleg-1
+ dens1=dens1*denevalmu2(nleg,i,q1,Vi,msq,mu2)
+ enddo
+
+ resi1=resi1+dens1*Res1(dicut1,q1)
+ dicut1=dicut1+1
+ enddo
+ !---#] Contribution of the single cut:
+
+ xneval=numeval(ncut,q1,mu2)
+ resitot=resi5+resi4+resi3+resi2+resi1
+ ztest=xneval-resitot
+
+ if(verbosity.ge.3)then
+ write(iout,*) '--------------------------------------------'
+ write(iout,*) 'N=N test for'
+ write(iout,*) 'q(0) = ', q1(4)
+ write(iout,*) 'q(1) = ', q1(1)
+ write(iout,*) 'q(2) = ', q1(2)
+ write(iout,*) 'q(3) = ', q1(3)
+ write(iout,*) 'and mu2 = ', mu2
+ write(iout,*) 'N calculated', xneval
+ write(iout,*) 'N reconstructed', resitot
+ write(iout,*) ' '
+ write(iout,*) 'difference = ', ztest
+ write(iout,*) 'rel.diff. = ', ztest/xneval
+ write(iout,*) '--------------------------------------------'
+ endif
+
+ if (abs(ztest/xneval).gt.nnlimit) then
+ ok=.false.
+ if (verbosity.gt.0) write(iout,*) 'N=N test FAILED'
+ else
+ ok=.true.
+ endif
+ end subroutine nntest_cm
+
+ subroutine lnntest4(numeval,cut4,c4,qt,p0,k3,e3,e4,ok)
+ implicit none
+ integer, intent(in) :: cut4
+ complex(ki), dimension(0:4), intent(in) :: c4
+ complex(ki), dimension(4), intent(in) :: qt, e3, e4
+ real(ki), dimension(4), intent(in) :: p0, k3
+ logical, intent(out) :: ok
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ complex(ki), dimension(4) :: pm
+ complex(ki) :: test4, poli4, reldif
+
+ pm(:)=qt(:)+p0(:)
+ if (imeth.eq.'diag') then
+ test4=(numeval(cut4,qt,chaf)-resit(4))/denst(4)
+ elseif (imeth.eq.'tree') then
+ test4= numeval(cut4,qt,chaf)-resit(4) /denst(4)
+ endif
+ poli4=poly4(c4,pm,chaf,k3,e3,e4)
+
+ if (abs(poli4).lt.nprec .and. abs(test4).lt.nprec) then
+ reldif = nprec
+ else
+ reldif=(test4-poli4)/poli4
+ endif
+
+ if(verbosity.ge.3)then
+ write(iout,*) ' LOCAL N=N TEST - BOX'
+ write(iout,*) 'cut4 =',cut4
+ write(iout,*) 'test4 =',test4
+ write(iout,*) 'poli4 =',poli4
+ write(iout,*) 'diff4 =',test4-poli4
+ write(iout,*) 'rel.dif4=',abs(reldif)
+ endif
+
+ if (abs(reldif).gt.lnnlimit4) then
+ ok = .false.
+ if (verbosity.gt.0) &
+ & write(iout,*) 'LOCAL N=N test FAILED for the BOX',cut4
+ else
+ ok = .true.
+ endif
+ end subroutine lnntest4
+
+ subroutine lnntest3(numeval,cut3,c3,qt,p0,e3,e4,ok)
+ implicit none
+ integer, intent(in) :: cut3
+ complex(ki), dimension(0:9), intent(in) :: c3
+ complex(ki), dimension(4), intent(in) :: qt, e3, e4
+ real(ki), dimension(4), intent(in) :: p0
+ logical, intent(out) :: ok
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ complex(ki), dimension(4) :: pm
+ complex(ki) :: test3, poli3, reldif
+
+ pm(:)=qt(:)+p0(:)
+
+ if (imeth.eq.'diag') then
+ test3=(numeval(cut3,qt,chaf)-resit(3)) / denst(3)
+ elseif (imeth.eq.'tree') then
+ test3= numeval(cut3,qt,chaf)-resit(3) / denst(3)
+ endif
+ poli3=poly3(c3,pm,chaf,e3,e4)
+
+ if (abs(poli3).lt.nprec .and. abs(test3).lt.nprec) then
+ reldif = nprec
+ else
+ reldif=(test3-poli3)/poli3
+ endif
+
+ if(verbosity.ge.3)then
+ write(iout,*) ' LOCAL N=N TEST - triangle'
+ write(iout,*) " cut3 =",cut3
+ write(iout,*) "test3 =",test3
+ write(iout,*) "poli3 =",poli3
+ write(iout,*) "diff3 =",test3-poli3
+ write(iout,*) "rel.dif3=",abs(reldif)
+ endif
+
+ if (abs(reldif).gt.lnnlimit3) then
+ ok = .false.
+ if (verbosity.gt.0) write(iout,*) &
+ & 'LOCAL N=N test FAILED for the 3-cut',cut3
+ else
+ ok = .true.
+ endif
+ end subroutine lnntest3
+
+ subroutine lnntest2(numeval,cut2,c2,qt,p0,e2,e3,e4,ok)
+ implicit none
+ integer, intent(in) :: cut2
+ complex(ki), dimension(0:9), intent(in) :: c2
+ complex(ki), dimension(4), intent(in) :: qt, e3, e4
+ real(ki), dimension(4), intent(in) :: p0, e2
+ logical, intent(out) :: ok
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ complex(ki), dimension(4) :: pm
+ complex(ki) :: test2, poli2, reldif
+
+ pm(:)=qt(:)+p0(:)
+ if (imeth.eq.'diag') then
+ test2=(numeval(cut2,qt,chaf)-resit(2))/denst(2)
+ elseif (imeth.eq.'tree') then
+ test2= numeval(cut2,qt,chaf)-resit(2) /denst(2)
+ endif
+ poli2=poly2(c2,pm,chaf,e2,e3,e4)
+
+ if (abs(poli2).lt.nprec .and. abs(test2).lt.nprec) then
+ reldif = nprec
+ else
+ reldif=(test2-poli2)/poli2
+ endif
+
+ if(verbosity.ge.3)then
+ write(iout,*) ' LOCAL N=N TEST - Bubble'
+ write(iout,*) " cut2 =",cut2
+ write(iout,*) "test2 =",test2
+ write(iout,*) "poli2 =",poli2
+ write(iout,*) "diff2 =",test2-poli2
+ write(iout,*) "rel.dif2=",abs(reldif)
+ endif
+
+ if (abs(reldif).gt.lnnlimit2) then
+ ok = .false.
+ if (verbosity.gt.0) write(iout,*) &
+ &'LOCAL N=N test FAILED for the 2-cut',cut2
+ else
+ ok = .true.
+ endif
+ end subroutine lnntest2
+
+
+ subroutine lnntest1(numeval,cut1,c1,qt,p0,e1,e2,e3,e4,ok)
+ implicit none
+ integer, intent(in) :: cut1
+ complex(ki), dimension(0:4), intent(in) :: c1
+ complex(ki), dimension(4), intent(in) :: qt, e3, e4
+ real(ki), dimension(4), intent(in) :: p0, e1, e2
+ logical, intent(out) :: ok
+
+ interface
+ function numeval(ncut, Q, mu2)
+ use precision
+ implicit none
+ integer, intent(in) :: ncut
+ complex(ki), dimension(4), intent(in) :: Q
+ complex(ki), intent(in) :: mu2
+ complex(ki) :: numeval
+ end function numeval
+ end interface
+
+ complex(ki), dimension(4) :: pm
+ complex(ki) :: test1, poli1, reldif
+
+ pm(:)=qt(:)+p0(:)
+ if (imeth.eq.'diag') then
+ test1=(numeval(cut1,qt,chaf)-resit(1)) / denst(1)
+ elseif (imeth.eq.'tree') then
+ test1= numeval(cut1,qt,chaf)-resit(1) /denst(1)
+ endif
+ poli1=poly1(c1,pm,e1,e2,e3,e4)
+
+ if (abs(poli1).lt.nprec .and. abs(test1).lt.nprec) then
+ reldif = nprec
+ else
+ reldif=(test1-poli1)/poli1
+ endif
+
+ if (verbosity.ge.3) then
+ write(iout,*) ' LOCAL N=N TEST - Tadpole'
+ write(iout,*) " cut1 =",cut1
+ write(iout,*) "test1 =",test1
+ write(iout,*) "poli1 =",poli1
+ write(iout,*) "diff1 =",test1-poli1
+ write(iout,*) "rel.dif1=",abs(reldif)
+ endif
+
+ if (abs(reldif).gt.lnnlimit1) then
+ ok = .false.
+ if (verbosity.gt.0) write(iout,*) &
+ &'LOCAL N=N test FAILED for the 1-cut',cut1
+ else
+ ok = .true.
+ endif
+ end subroutine lnntest1
+
+end module mtests
diff --git a/samurai-2.1.1/ncuts.f90 b/samurai-2.1.1/ncuts.f90
new file mode 100644
index 0000000..c5cd6fe
--- /dev/null
+++ b/samurai-2.1.1/ncuts.f90
@@ -0,0 +1,7 @@
+module ncuts
+ implicit none
+
+ integer nc5,nc4,nc3,nc2,nc1
+
+end module ncuts
+
diff --git a/samurai-2.1.1/notfirst.f90 b/samurai-2.1.1/notfirst.f90
new file mode 100644
index 0000000..d4d23e0
--- /dev/null
+++ b/samurai-2.1.1/notfirst.f90
@@ -0,0 +1,6 @@
+module notfirst
+implicit none
+
+ logical :: notfirstp, notfirstd, notfirsti
+
+end module notfirst
diff --git a/samurai-2.1.1/options.f90 b/samurai-2.1.1/options.f90
new file mode 100644
index 0000000..e634291
--- /dev/null
+++ b/samurai-2.1.1/options.f90
@@ -0,0 +1,21 @@
+module options
+ use precision, only: ki
+ implicit none
+
+ private :: ki
+
+ integer :: isca, verbosity, itest, iresc
+ character(len=4) :: imeth
+ logical :: meth_is_tree
+ logical :: meth_is_diag
+
+ integer :: iout = 20
+ integer :: ibad = 30
+
+ logical :: use_maccu = .false.
+
+ ! value of C0 at which we switch between the two different samplings
+ real(ki), parameter :: C0_thrs = 1.0E-10_ki
+
+end module options
+
diff --git a/samurai-2.1.1/precision.f90.in b/samurai-2.1.1/precision.f90.in
new file mode 100644
index 0000000..457196b
--- /dev/null
+++ b/samurai-2.1.1/precision.f90.in
@@ -0,0 +1,9 @@
+module precision
+ implicit none
+
+ integer, parameter :: ki=@fortran_real_kind@
+ integer, parameter :: ki_ql=kind(1.d0)
+ integer, parameter :: ki_lt=kind(1.d0)
+
+end module precision
+
diff --git a/samurai-2.1.1/save.f90 b/samurai-2.1.1/save.f90
new file mode 100644
index 0000000..2153205
--- /dev/null
+++ b/samurai-2.1.1/save.f90
@@ -0,0 +1,52 @@
+module save
+ use precision, only: ki
+ use constants, only: max1, max2, max3, max4, max5
+ implicit none
+ save
+
+ private :: max1, max2, max3, max4, max5, ki
+
+
+ real(ki) :: sav5p0(max5,4)
+ real(ki) :: sav5e1(max5,4)
+ real(ki) :: sav5e2(max5,4)
+ complex(ki) :: sav5e3(max5,4)
+ complex(ki) :: sav5e4(max5,4)
+ complex(ki) :: savc5(max5)
+ integer :: savcut5(max5)
+
+ real(ki) :: savL3(max4,4)
+ real(ki) :: sav4p0(max4,4)
+ real(ki) :: sav4e1(max4,4)
+ real(ki) :: sav4e2(max4,4)
+ complex(ki) :: sav4e3(max4,4)
+ complex(ki) :: sav4e4(max4,4)
+ complex(ki) :: savc4(max4,0:4)
+ integer :: savcut4(max4)
+
+ real(ki) :: sav3p0(max3,4)
+ real(ki) :: sav3e1(max3,4)
+ real(ki) :: sav3e2(max3,4)
+ complex(ki) :: sav3e3(max3,4)
+ complex(ki) :: sav3e4(max3,4)
+ complex(ki) :: savc3(max3,0:9)
+ integer :: savcut3(max3)
+
+ real(ki) :: sav2p0(max2,4)
+ real(ki) :: sav2e1(max2,4)
+ real(ki) :: sav2e2(max2,4)
+ complex(ki) :: sav2e3(max2,4)
+ complex(ki) :: sav2e4(max2,4)
+ complex(ki) :: savc2(max2,0:9)
+ integer :: savcut2(max2)
+
+ real(ki) :: sav1p0(max1,4)
+ real(ki) :: sav1e1(max1,4)
+ real(ki) :: sav1e2(max1,4)
+ complex(ki) :: sav1e3(max1,4)
+ complex(ki) :: sav1e4(max1,4)
+ complex(ki) :: savc1(max1,0:4)
+ integer :: savcut1(max1)
+
+end module save
+
diff --git a/samurai.pc.in b/samurai.pc.in
new file mode 100644
index 0000000..d087496
--- /dev/null
+++ b/samurai.pc.in
@@ -0,0 +1,15 @@
+prefix=@prefix@
+exec_prefix=@exec_prefix@
+libdir=@libdir@
+includedir=@includedir@/@PACKAGE@
+version=@SAMURAIVERSION@
+
+Cflags: -I${includedir}
+
+Name: samurai
+Version: @SAMURAIVERSION@
+Description: Samurai: Scattering Amplitudes from Unitarity-based
+ Reduction Algorithms at the Integrand level
+URL: https://samurai.web.cern.ch/samurai/
+
+Libs: -L${libdir} -lsamurai

File Metadata

Mime Type
application/octet-stream
Expires
Sun, Oct 13, 9:33 PM (2 d)
Storage Engine
chunks
Storage Format
Chunks
Storage Handle
d7VOBO7ceaGl
Default Alt Text
(6 MB)

Event Timeline