Page MenuHomeHEPForge
Files F10880973

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
diff --git a/ff/Makefile.am b/ff/Makefile.am
new file mode 100644
index 0000000..8dc6699
--- /dev/null
+++ b/ff/Makefile.am
@@ -0,0 +1,79 @@
+AUTOMAKE_OPTIONS = foreign
+AM_FFLAGS = -std=legacy
+
+noinst_LTLIBRARIES = libff.la
+#libff_la_SOURCES = aacbc.f aaxcx.f ff2dl2.f ffcb1.f ffcc0p.f ffcel5.f ffcxr.f ffdcc0.f ffdel4.f ffdl5p.f ffrcvr.f ffxb1.f ffxc0p.f ffxd0i.f ffxdbd.f ffxe1.f ffxxyz.f aaccc.f aaxdx.f ffabcd.f ffcb2.f ffcc1.f ffcel2.f ffceta.f ffcxs3.f ffdcxs.f ffdel5.f ffdxc0.f ffxb2p.f ffxc1.f ffxd0p.f ffxdi.f ffxf0.f npoin.f aacinv.f aaxex.f ffca0.f ffcb2p.f ffcel3.f ffcli2.f ffcxs4.f ffdel2.f ffdel6.f ffini.f fftran.f ffxc0.f ffxd0.f ffxd1.f ffxdpv.f ffxf0h.f aaxbx.f aaxinv.f ffcb0.f ffcc0.f ffcdb0.f ffcel4.f ffcrr.f ffcxyz.f ffdel3.f ffdl2i.f ffinit.f ffxb0.f ffxc0i.f ffxd0h.f ffxdb0.f ffxe0.f ffxli2.f spence.f ff_interface.C # npointes.f fftest.f ffcdbd.f ffcd0.f
+
+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 \
+ ffcc0.f \
+ ffcc0p.f \
+ ffcc1.f \
+ ffcdb0.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 \
+ ff_interface.C
+
+
+#aaxex.f ffcb2.f
+
+
+
+pkginclude_HEADERS = aa.h ff.h ffs.h ff_interface.h
diff --git a/ff/README b/ff/README
new file mode 100644
index 0000000..40dac08
--- /dev/null
+++ b/ff/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/aa.h b/ff/aa.h
new file mode 100644
index 0000000..5ff7c82
--- /dev/null
+++ b/ff/aa.h
@@ -0,0 +1,2 @@
+ logical awrite,atest,aderiv
+ common /aaflag/ awrite,atest,aderiv
diff --git a/ff/aacbc.f b/ff/aacbc.f
new file mode 100644
index 0000000..1c97f7b
--- /dev/null
+++ b/ff/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/aaccc.f b/ff/aaccc.f
new file mode 100644
index 0000000..098aa47
--- /dev/null
+++ b/ff/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/aacinv.f b/ff/aacinv.f
new file mode 100644
index 0000000..1b39cb0
--- /dev/null
+++ b/ff/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/aaxbx.f b/ff/aaxbx.f
new file mode 100644
index 0000000..ccb9cab
--- /dev/null
+++ b/ff/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/aaxcx.f b/ff/aaxcx.f
new file mode 100644
index 0000000..116977b
--- /dev/null
+++ b/ff/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/aaxdx.f b/ff/aaxdx.f
new file mode 100644
index 0000000..e7907d4
--- /dev/null
+++ b/ff/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/aaxex.f b/ff/aaxex.f
new file mode 100644
index 0000000..72370a9
--- /dev/null
+++ b/ff/aaxex.f
@@ -0,0 +1,710 @@
+
+* file aaxex 23-sep-1990
+
+*###[ aaxex:
+ subroutine aaxex(ccxi,cdxi,cexi,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(20) real the same as in FF *
+* level integer rank of tensor integral *
+* Output: ccxi(30) complex cc0(1),cc1( ),[cc2( ),cc3( ) ] i,j *
+* cdxi(55) complex cd0(1),cd1(3),cd2(7),[cd3(13)] *
+* i=1,2,3,4,5 *
+* cexi(35) complex ce0(1),ce1(4),ce2(10),ce3(20) *
+* ier integer FF error flag *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION xpi(20),d0,xmm
+ DOUBLE COMPLEX ccxi(30),cdxi(55),cexi(35)
+*
+* local variables
+*
+ DOUBLE COMPLEX caxi(5),cbxi(30)
+ DOUBLE PRECISION maxi(5),mbxi(30),mcxi(30),mdxi(55),mexi(35)
+*
+* #] declarations:
+* #[ call ffxex:
+*
+ call ffxex(caxi,maxi,cbxi,mbxi,ccxi,mcxi,cdxi,mdxi,cexi,mexi,
+ + d0,xmm,xpi,level,ier)
+*
+* #] call ffxex:
+*###] aaxex:
+ end
+*###[ ffxex:
+ subroutine ffxex(caxi,maxi,cbxi,mbxi,ccxi,mcxi,cdxi,mdxi,cexi,
+ + mexi,d0,xmm,xpi,level,ier)
+***#[*comment:***********************************************************
+* *
+* Calculation of five-point formfactors, notation is defined in *
+* adapt.prc and covdec5.prc (WW), leaving out the d_ terms *
+* adapted by GJvO 4-apr-1995 *
+* *
+* cexi(1) E0 *
+* cexi(2-5) E1i, coeff of pi *
+* cexi(6-15) E2i, coeff of p1p1,p2p2,p3p3,p4p4,(p1p2), *
+* (p1p3),(p1p4),(p2p3),(p2p4),(p3p4) *
+* cexi(16-35) E2i, coeff of p1p1p1,p2p2p2,p3p3p3,p4p4p4, *
+* (p1p1p2),(p1p1p3),(p1p1p4),(p2p2p1),(p2p2p3), *
+* (p2p2p4),(p3p3p1),(p3p3p2),(p3p3p4),(p4p4p1), *
+* (p4p4p2),(p4p4p3),(p1p2p3),(p1p2p4),(p1p3p4), *
+* (p2p3p4) *
+* cdxi(55) 5*(D0(1),D1i(3),D2i(7)), s_i missing *
+* ccxi(30) 15*(C0(1),C1i(2)) ?????? *
+* cbxi(30) not used yet *
+* caxi(5) not used yet *
+* m[abcde]xi() if c[abcde]xi() were written as a sum of stable *
+* terms, the largest term in that sum, i.e., the *
+* accuracy of c[abcde]xi() is precc*m[abcde]xi *
+* *
+* Input: xpi(20) real the same as in FF *
+* level integer rank of tensor integral *
+* Output: ccxi(30) complex cc0(1),cc1( ),[cc2( ),cc3( ) ] i,j *
+* cdxi(55) complex cd0(1),cd1(3),cd2(7),[cd3(13)] *
+* i=1,2,3,4,5 *
+* cexi(35) complex ce0(1),ce1(5),ce2(10),ce3(20) *
+* ier integer FF error flag *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION xpi(20),d0,xmm
+ DOUBLE COMPLEX caxi(5),cbxi(30),ccxi(30),cdxi(55),cexi(35)
+ DOUBLE PRECISION maxi(5),mbxi(30),mcxi(30),mdxi(55),mexi(35)
+*
+* local variables
+*
+ integer i,j,dl,iplace(11,5),ier0,ier1
+ DOUBLE PRECISION xpj(13),absc,big
+ DOUBLE COMPLEX cd0i(5),cdxj(120),ccxj(140),cbxj(60),caxj(20),cc
+ DOUBLE PRECISION mdxj(120),mcxj(140),mbxj(60),maxj(20)
+ save iplace
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement functions
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* 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/
+*
+* #] declarations:
+* #[ init:
+*
+* initialize to something ridiculous so that one immediately
+* notices when it is accidentally used...
+*
+ big = 1/(1d20*xclogm)
+ do i=1,5
+ caxi(i) = big
+ enddo
+ do i=1,30
+ cbxi(i) = big
+ enddo
+ do i=1,30
+ ccxi(i) = big
+ enddo
+ do i=1,55
+ cdxi(i) = big
+ enddo
+ do i=1,35
+ cexi(i) = big
+ enddo
+*
+* #] init:
+* #[ level 0: E0, and kinematical quantities for 5 point PV-red
+* E0-function (ff)
+*
+ ldot = .TRUE.
+ ier1 = ier
+ call ffxe0(cexi(1),cd0i,xpi,ier1)
+ mexi(1) = absc(cexi(1))*DBLE(10)**mod(ier1,50)
+ do i=1,5
+ cdxi(1+11*(i-1)) = cd0i(i)
+ enddo
+*
+ if ( awrite ) then
+ print *,' '
+ print *,'aaxex : level 0, imported from ff '
+ print *,'E0 = ',cexi(1),mexi(1)
+ print *,'D0(1) = ',cd0i(1)
+ print *,'D0(2) = ',cd0i(2)
+ print *,'D0(3) = ',cd0i(3)
+ print *,'D0(4) = ',cd0i(4)
+ print *,'D0(5) = ',cd0i(5)
+ print *,'xpi used:'
+ do i =1,15
+ print *,i,xpi(i)
+ enddo
+ print *,'imported stuff via ff.h:'
+ print *,' kin determinat = ',fdel4
+ print *,'dotpr(1,1)= ',fpij5(6,6)
+ print *,'dotpr(2,2)= ',fpij5(7,7)
+ print *,'dotpr(1,2)= ',fpij5(6,7)
+ endif
+*
+ if (level .eq. 0) return
+*
+* #] level 0: E0, and kinematical quantities for 5 point PV-red
+* #[ need D-functions till d-level=(level-1):
+ dl=level-1
+*
+* go trough the 5 different cancellation patterns
+*
+ if ( awrite ) then
+ print *,' '
+ print *,'------>underlying D-functions up to level:',dl
+ endif
+ xpj(12) = 0
+ xpj(13) = 0
+ do j=1,5
+* D(j) is the D0 with leg j missing.
+ do i=1,11
+ xpj(i) = xpi(iplace(i,j))
+ enddo
+* note that we recompute the D0 (or get it from cache)
+ ier0 = ier
+ call ffxdx(caxj(1+4*(j-1)),maxj(1+4*(j-1)),cbxj(1+12*(j-1))
+ + ,mbxj(1+12*(j-1)),ccxj(1+28*(j-1)),mcxj(1+28*(j-1)),
+ + cdxj(1+24*(j-1)),mdxj(1+24*(j-1)),d0,xmm,xpj,dl,ier0)
+ ier1 = max(ier1,ier0)
+ enddo
+ ier = ier1
+ if ( awrite ) then
+ print *,' '
+ print *,'ier = ',ier
+ print *,'---->end of D-function output--------------------'
+ endif
+ if ( atest ) then
+* (although these should come from cache) (but don't yet!)
+ do i=1,5
+ if ( xloss*10d0**(-mod(ier,50))*absc(cd0i(i)-
+ + cdxj(1+24*(i-1))) .gt. precx*absc(cd0i(i)) )
+ + then
+ print *,'aaxex: error: D0 does not agree with ',
+ + 'recomputed: ',cd0i(i),cdxj(1+24*(i-1)),ier
+ endif
+ enddo
+ endif
+*
+* #] need D-functions till d-level=(level-1):
+* #[ break to let ffzez tie in:
+*
+* convert ??xj to ??xi
+*
+ call ffeji(cdxi,mcxi,ccxi,mcxi,cbxi,mbxi,caxi,maxi,
+ + cdxj,mdxj,ccxj,mcxj,cbxj,mbxj,caxj,maxj,level)
+*
+* and call the real routine for the rest
+*
+ call ffxexp(caxi,maxi,cbxi,mbxi,ccxi,mcxi,cdxi,mdxi,cexi,mexi,
+ + xpi,level,ier)
+*
+* #] break to let ffzez tie in:
+ end
+ subroutine ffxexp(caxi,maxi,cbxi,mbxi,ccxi,mcxi,cdxi,mdxi,cexi,
+ + mexi,xpi,level,ier)
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier,level
+ DOUBLE PRECISION xpi(20),d0,xmm
+ DOUBLE COMPLEX caxi(5),cbxi(30),ccxi(30),cdxi(55),cexi(35)
+ DOUBLE PRECISION maxi(5),mbxi(30),mcxi(30),mdxi(55),mexi(35)
+*
+* local variables
+*
+ integer i,j,ier0,ier1,ij2k(4,4),m2ijk(3,20)
+ DOUBLE PRECISION xi5(10),f1,f2,f3,f4,absc
+ DOUBLE COMPLEX R(70),cd0i(5),cd1ij(3,5),ce2ij(4,4),ce3ijk(4,4,4)
+ + ,cd2ijk(3,3,5),cd2i(5),cxy(70),cc,rg(4),cexj(39)
+ DOUBLE PRECISION mdxj(120),mcxj(140),mbxj(60),maxj(20),
+ + del3ij(5,5),del4i(4)
+ save ij2k,m2ijk
+*
+* common blocks
+*
+ include 'ff.h'
+ include 'aa.h'
+*
+* statement functions
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* data
+*
+ data ij2k / 6,10,11,12,
+ + 10, 7,13,14,
+ + 11,13, 8,15,
+ + 12,14,15, 9/
+ data m2ijk /1,1,1, 2,2,2,
+ + 3,3,3, 4,4,4,
+ + 1,1,2, 1,1,3,
+ + 1,1,4, 2,2,1,
+ + 2,2,3, 2,2,4,
+ + 3,3,1, 3,3,2,
+ + 3,3,4, 4,4,1,
+ + 4,4,2, 4,4,3,
+ + 1,2,3, 1,2,4,
+ + 1,3,4, 2,3,4/
+*
+* #] declarations:
+* #[ kinematical quatities for 5pv-red:
+*
+* inverse kinematical matrix xi5 (4X4)
+*
+ call aaxi5(xi5,ier)
+*
+* AAs f-functions:
+*
+ f1 = 2*fpij5(1,6)
+ f2 = 2*fpij5(1,7)
+ f3 = 2*fpij5(1,8)
+ f4 = 2*fpij5(1,9)
+*
+* #] kinematical quatities for 5pv-red:
+* #[ level 1: E11,E12,E13,E14,D0(I)
+ do i=1,5
+ cd0i(i) = cdxi(1+11*(i-1))
+ enddo
+ call ffxe1(cexi(2),cexi(1),del3ij,del4i,cd0i,xpi,fpij5,fdel4,
+ + ier)
+ if ( atest ) then
+*
+* PV-reduction
+*
+ R(1) = (f1*cexi(1) + cd0i(2) - cd0i(1))/2
+ R(2) = (f2*cexi(1) + cd0i(3) - cd0i(2))/2
+ R(3) = (f3*cexi(1) + cd0i(4) - cd0i(3))/2
+ R(4) = (f4*cexi(1) + cd0i(5) - cd0i(4))/2
+ cxy(2)=xi5(1)*R(1)+xi5(5)*R(2)+xi5(6) *R(3)+xi5(7) *R(4)
+ cxy(3)=xi5(5)*R(1)+xi5(2)*R(2)+xi5(8) *R(3)+xi5(9) *R(4)
+ cxy(4)=xi5(6)*R(1)+xi5(8)*R(2)+xi5(3) *R(3)+xi5(10)*R(4)
+ cxy(5)=xi5(7)*R(1)+xi5(9)*R(2)+xi5(10)*R(3)+xi5(4) *R(4)
+ do i=2,5
+ if ( xloss*10d0**(-mod(ier,50))*absc(cexi(i)-cxy(i))
+ + .gt. precc*absc(cxy(i)) ) then
+ print *,'aaxex: error: E1 from ffxe1 is not correct'
+ + ,i,cexi(i),cxy(i),ier
+ endif
+ enddo
+ endif
+ if ( awrite ) then
+ print *,' '
+ print *,'aaxex: level 1: id,nevent ',id,nevent
+ print *,'E11=',cexi(2),ier
+ print *,'E12=',cexi(3),ier
+ print *,'E13=',cexi(4),ier
+ print *,'E14=',cexi(5),ier
+ endif
+
+ if ( level.le.1 ) return
+*
+* #] level 1:
+* #[ level 2: E21,E22,E23,E24,E25,E26,E27,E28,E29,E210
+*
+* D11(I),D12(I),D13(I) need 5 diff D1-functions
+*
+ do i=1,5
+ j = 2 + (i-1)*11
+ cd1ij(1,i)=cdxi(j)
+ cd1ij(2,i)=cdxi(j+1)
+ cd1ij(3,i)=cdxi(j+2)
+ enddo
+*
+* GJ reduction:
+*
+ call ffxe2(ce2ij,cexi(2),cexi(1),cd1ij,cd0i,xpi,fpij5,
+ + del3ij,del4i,fdel4,ier)
+ if ( atest ) then
+*
+* PV-reduction
+*
+ R(11) = (f1*cexi(2) + cd1ij(1,2) + cd0i(1) )/2
+ R(12) = (f2*cexi(2) + cd1ij(1,3) - cd1ij(1,2))/2
+ R(13) = (f3*cexi(2) + cd1ij(1,4) - cd1ij(1,3))/2
+ R(14) = (f4*cexi(2) + cd1ij(1,5) - cd1ij(1,4))/2
+*
+ R(15) = (f1*cexi(3) + cd1ij(1,2) - cd1ij(1,1))/2
+ R(16) = (f2*cexi(3) + cd1ij(2,3) - cd1ij(1,2))/2
+ R(17) = (f3*cexi(3) + cd1ij(2,4) - cd1ij(2,3))/2
+ R(18) = (f4*cexi(3) + cd1ij(2,5) - cd1ij(2,4))/2
+*
+ R(19) = (f1*cexi(4) + cd1ij(2,2) - cd1ij(2,1))/2
+ R(20) = (f2*cexi(4) + cd1ij(2,3) - cd1ij(2,2))/2
+ R(21) = (f3*cexi(4) + cd1ij(3,4) - cd1ij(2,3))/2
+ R(22) = (f4*cexi(4) + cd1ij(3,5) - cd1ij(3,4))/2
+*
+ R(23) = (f1*cexi(5) + cd1ij(3,2) - cd1ij(3,1))/2
+ R(24) = (f2*cexi(5) + cd1ij(3,3) - cd1ij(3,2))/2
+ R(25) = (f3*cexi(5) + cd1ij(3,4) - cd1ij(3,3))/2
+ R(26) = (f4*cexi(5) - cd1ij(3,4))/2
+*
+ cexi(6) = xi5(1)*R(11)+xi5(5)*R(12)+xi5(6) *R(13)+xi5(7) *R(14)
+ cexi(7) = xi5(5)*R(15)+xi5(2)*R(16)+xi5(8) *R(17)+xi5(9) *R(18)
+ cexi(8) = xi5(6)*R(19)+xi5(8)*R(20)+xi5(3) *R(21)+xi5(10)*R(22)
+ cexi(9) = xi5(7)*R(23)+xi5(9)*R(24)+xi5(10)*R(25)+xi5(4) *R(26)
+ cexi(10)= xi5(5)*R(11)+xi5(2)*R(12)+xi5(8) *R(13)+xi5(9) *R(14)
+ cexi(11)= xi5(6)*R(11)+xi5(8)*R(12)+xi5(3) *R(13)+xi5(10)*R(14)
+ cexi(12)= xi5(7)*R(11)+xi5(9)*R(12)+xi5(10)*R(13)+xi5(4) *R(14)
+ cexi(13)= xi5(6)*R(15)+xi5(8)*R(16)+xi5(3) *R(17)+xi5(10)*R(18)
+ cexi(14)= xi5(7)*R(15)+xi5(9)*R(16)+xi5(10)*R(17)+xi5(4) *R(18)
+ cexi(15)= xi5(7)*R(19)+xi5(9)*R(20)+xi5(10)*R(21)+xi5(4) *R(22)
+*
+ if ( atest ) then
+*
+* redundancy check
+*
+ cxy(10) = xi5(1)*R(15)+xi5(5)*R(16)+xi5(6)*R(17)+xi5(7) *R(18)
+ cxy(11) = xi5(1)*R(19)+xi5(5)*R(20)+xi5(6)*R(21)+xi5(7) *R(22)
+ cxy(12) = xi5(1)*R(23)+xi5(5)*R(24)+xi5(6)*R(25)+xi5(7) *R(26)
+ cxy(13) = xi5(5)*R(19)+xi5(2)*R(20)+xi5(8)*R(21)+xi5(9) *R(22)
+ cxy(14) = xi5(5)*R(23)+xi5(2)*R(24)+xi5(8)*R(25)+xi5(9) *R(26)
+ cxy(15) = xi5(6)*R(23)+xi5(8)*R(24)+xi5(3)*R(25)+xi5(10)*R(26)
+ do i=10,15
+ if ( absc(cxy(i)-cexi(i)) .gt. .1d-3 ) then
+ print *,'redundancy check at level 2 failed'
+ endif
+ enddo
+*###] :
+ endif
+*
+* check against GJ
+*
+ do i=1,4
+ do j=1,4
+ if ( xloss*10d0**(-mod(ier,50))*absc(ce2ij(i,j) -
+ + cexi(ij2k(i,j))) .gt. precc*absc(ce2ij(i,j)) )
+ + then
+ print *,'ffxdxp: error: GJ does not agree with PV:',
+ + i,j,ce2ij(i,j),cexi(ij2k(i,j)),ce2ij(i,j) -
+ + cexi(ij2k(i,j)),ier
+ endif
+ enddo
+ enddo
+ endif
+*
+* copy to AAs arrays
+*
+ do i=1,4
+ do j=1,4
+ cexi(ij2k(j,i)) = ce2ij(j,i)
+ enddo
+ enddo
+*
+ if ( awrite ) then
+ print *,' '
+ print *,'aaxex: level 2: id,nevent ',id,nevent
+ print *,'E21 =',cexi(6),ier
+ print *,'E22 =',cexi(7),ier
+ print *,'E23 =',cexi(8),ier
+ print *,'E24 =',cexi(9),ier
+ print *,'E25 =',cexi(10),ier
+ print *,'E26 =',cexi(11),ier
+ print *,'E27 =',cexi(12),ier
+ print *,'E28 =',cexi(13),ier
+ print *,'E28 =',cexi(14),ier
+ print *,'E210=',cexi(15),ier
+ endif
+*
+ if (level .le. 2) return
+*
+* #] level 2:
+*###[ : level 3 :
+*
+* first recast the D2's to a more useful form
+*
+ do 15 i=1,5
+ j = 5 +(i-1)*11
+ cd2ijk(1,1,i) = cdxi(j)
+ cd2ijk(2,2,i) = cdxi(j+1)
+ cd2ijk(3,3,i) = cdxi(j+2)
+ cd2ijk(1,2,i) = cdxi(j+3)
+ cd2ijk(2,1,i) = cdxi(j+3)
+ cd2ijk(1,3,i) = cdxi(j+4)
+ cd2ijk(3,1,i) = cdxi(j+4)
+ cd2ijk(2,3,i) = cdxi(j+5)
+ cd2ijk(3,2,i) = cdxi(j+5)
+ cd2i(i) = cdxi(j+6)
+ 15 continue
+*
+* FF function
+*
+ call ffxe3(ce3ijk,ce2ij,cexi(2),cexi(1), cd2ijk,cd2i,cd1ij,cd0i,
+ + xpi,fpij5, del3ij,del4i,fdel4, ier)
+*
+* copy FF structs to AA
+*
+ do i=16,35
+ cexi(i) = ce3ijk(m2ijk(1,i),m2ijk(2,i),m2ijk(3,i))
+ enddo
+ if ( atest ) then
+*
+*
+* PV-reduction
+* g-terms
+ rg(1)=1/2d0*( f1*cexi(6)+f2*cexi(10)+f3*cexi(11)+f4*cexi(12) )
+ rg(2)=1/2d0*( f1*cexi(10)+f2*cexi(7)+f3*cexi(13)+f4*cexi(14) )
+ rg(3)=1/2d0*( f1*cexi(11)+f2*cexi(13)+f3*cexi(8)+f4*cexi(15) )
+ rg(4)=1/2d0*( f1*cexi(12)+f2*cexi(14)+f3*cexi(15)+f4*cexi(9) )
+*
+ cexj(36)=xpi(1)*cexj(2)-1/2d0*cd0i(1) -rg(1)
+ cexj(37)=xpi(1)*cexj(3)+1/2d0*cd1ij(1,1)-rg(2)
+ cexj(38)=xpi(1)*cexj(4)+1/2d0*cd1ij(2,1)-rg(3)
+ cexj(39)=xpi(1)*cexj(5)+1/2d0*cd1ij(3,1)-rg(4)
+*
+* terms ~pipi
+* 1)
+ R(31)=1/2d0*(f1*cexj(6)+cd2ijk(1,1,2)-cd0i(1)) -2*cexj(36)
+ R(32)=1/2d0*(f2*cexj(6)+cd2ijk(1,1,3)-cd2ijk(1,1,2))
+ R(33)=1/2d0*(f3*cexj(6)+cd2ijk(1,1,4)-cd2ijk(1,1,3))
+ R(34)=1/2d0*(f4*cexj(6)+cd2ijk(1,1,5)-cd2ijk(1,1,4))
+* 2)
+ R(35)=1/2d0*(f1*cexj(7)+cd2ijk(1,1,2)-cd2ijk(1,1,1))
+ R(36)=1/2d0*(f2*cexj(7)+cd2ijk(2,2,3)-cd2ijk(1,1,2)) -2*cexj(37)
+ R(37)=1/2d0*(f3*cexj(7)+cd2ijk(2,2,4)-cd2ijk(2,2,3))
+ R(38)=1/2d0*(f4*cexj(7)+cd2ijk(2,2,5)-cd2ijk(2,2,4))
+* 3)
+ R(39)=1/2d0*(f1*cexj(8)+cd2ijk(2,2,2)-cd2ijk(2,2,1))
+ R(40)=1/2d0*(f2*cexj(8)+cd2ijk(2,2,3)-cd2ijk(2,2,2))
+ R(41)=1/2d0*(f3*cexj(8)+cd2ijk(3,3,4)-cd2ijk(2,2,3)) -2*cexj(38)
+ R(42)=1/2d0*(f4*cexj(8)+cd2ijk(3,3,5)-cd2ijk(3,3,4))
+* 4)
+ R(43)=1/2d0*(f1*cexj(9)+cd2ijk(3,3,2)-cd2ijk(3,3,1))
+ R(44)=1/2d0*(f2*cexj(9)+cd2ijk(3,3,3)-cd2ijk(3,3,2))
+ R(45)=1/2d0*(f3*cexj(9)+cd2ijk(3,3,4)-cd2ijk(3,3,3))
+ R(46)=1/2d0*(f4*cexj(9) -cd2ijk(3,3,4) ) -2*cexj(39)
+*
+* terms ~p1pi
+* 1)
+ R(47)=1/2d0*(f1*cexj(10)+cd2ijk(1,1,2)+cd1ij(1,1)) -cexj(37)
+ R(48)=1/2d0*(f2*cexj(10)+cd2ijk(1,2,3)-cd2ijk(1,1,2)) -cexj(36)
+ R(49)=1/2d0*(f3*cexj(10)+cd2ijk(1,2,4)-cd2ijk(1,2,3))
+ R(50)=1/2d0*(f4*cexj(10)+cd2ijk(1,2,5)-cd2ijk(1,2,4))
+* 2)
+ R(51)=1/2d0*(f1*cexj(11)+cd2ijk(1,2,2)+cd1ij(2,1) ) -cexj(38)
+ R(52)=1/2d0*(f2*cexj(11)+cd2ijk(1,2,3)-cd2ijk(1,2,2))
+ R(53)=1/2d0*(f3*cexj(11)+cd2ijk(1,3,4)-cd2ijk(1,2,3)) -cexj(36)
+ R(54)=1/2d0*(f4*cexj(11)+cd2ijk(1,3,5)-cd2ijk(1,3,4))
+* 3)
+ R(55)=1/2d0*(f1*cexj(12)+cd2ijk(1,3,2)+cd1ij(3,1) ) -cexj(39)
+ R(56)=1/2d0*(f2*cexj(12)+cd2ijk(1,3,3)-cd2ijk(1,3,2))
+ R(57)=1/2d0*(f3*cexj(12)+cd2ijk(1,3,4)-cd2ijk(1,3,3))
+ R(58)=1/2d0*(f4*cexj(12) -cd2ijk(1,3,4) ) -cexj(36)
+*
+* terms ~p2pi
+* 1)
+ R(59)=1/2d0*(f1*cexj(13)+cd2ijk(1,2,2)-cd2ijk(1,2,1))
+ R(60)=1/2d0*(f2*cexj(13)+cd2ijk(2,2,3)-cd2ijk(1,2,2)) -cexj(38)
+ R(61)=1/2d0*(f3*cexj(13)+cd2ijk(2,3,4)-cd2ijk(2,2,3)) -cexj(37)
+ R(62)=1/2d0*(f4*cexj(13)+cd2ijk(2,3,5)-cd2ijk(2,3,4))
+* 2)
+ R(63)=1/2d0*(f1*cexj(14)+cd2ijk(1,3,2)-cd2ijk(1,3,1))
+ R(64)=1/2d0*(f2*cexj(14)+cd2ijk(2,3,3)-cd2ijk(1,3,2)) -cexj(39)
+ R(65)=1/2d0*(f3*cexj(14)+cd2ijk(2,3,4)-cd2ijk(2,3,3))
+ R(66)=1/2d0*(f4*cexj(14) -cd2ijk(2,3,4) ) -cexj(37)
+*
+* terms ~p3pi
+* 1)
+ R(67)=1/2d0*(f1*cexj(15)+cd2ijk(2,3,2)-cd2ijk(2,3,1))
+ R(68)=1/2d0*(f2*cexj(15)+cd2ijk(2,3,3)-cd2ijk(2,3,2))
+ R(69)=1/2d0*(f3*cexj(15)+cd2ijk(3,3,4)-cd2ijk(2,3,3)) -cexj(39)
+ R(70)=1/2d0*(f4*cexj(15) -cd2ijk(3,3,4) ) -cexj(38)
+
+ cexj(16)=xi5(1)*R(31)+xi5(5)*R(32)+xi5(6)*R(33)+xi5(7) *R(34)
+ cexj(17)=xi5(5)*R(35)+xi5(2)*R(36)+xi5(8)*R(37)+xi5(9) *R(38)
+ cexj(18)=xi5(6)*R(39)+xi5(8)*R(40)+xi5(3)*R(41)+xi5(10)*R(42)
+ cexj(19)=xi5(7)*R(43)+xi5(9)*R(44)+xi5(10)*R(45)+xi5(4)*R(46)
+ cexj(20)=xi5(5)*R(31)+xi5(2)*R(32)+xi5(8)*R(33)+xi5(9) *R(34)
+ cexj(21)=xi5(6)*R(31)+xi5(8)*R(32)+xi5(3)*R(33)+xi5(10)*R(34)
+ cexj(22)=xi5(7)*R(31)+xi5(9)*R(32)+xi5(10)*R(33)+xi5(4)*R(34)
+ cexj(23)=xi5(1)*R(35)+xi5(5)*R(36)+xi5(6)*R(37)+xi5(7) *R(38)
+ cexj(24)=xi5(6)*R(35)+xi5(8)*R(36)+xi5(3)*R(37)+xi5(10)*R(38)
+ cexj(25)=xi5(7)*R(35)+xi5(9)*R(36)+xi5(10)*R(37)+xi5(4)*R(38)
+ cexj(26)=xi5(1)*R(39)+xi5(5)*R(40)+xi5(6)*R(41)+xi5(7) *R(42)
+ cexj(27)=xi5(5)*R(39)+xi5(2)*R(40)+xi5(8)*R(41)+xi5(9) *R(42)
+ cexj(28)=xi5(7)*R(39)+xi5(9)*R(40)+xi5(10)*R(41)+xi5(4)*R(42)
+ cexj(29)=xi5(1)*R(43)+xi5(5)*R(44)+xi5(6)*R(45)+xi5(7) *R(46)
+ cexj(30)=xi5(5)*R(43)+xi5(2)*R(44)+xi5(8)*R(45)+xi5(9) *R(46)
+ cexj(31)=xi5(6)*R(43)+xi5(8)*R(44)+xi5(3)*R(45)+xi5(10)*R(46)
+ cexj(32)=xi5(6)*R(47)+xi5(8)*R(48)+xi5(3)*R(49)+xi5(10)*R(50)
+ cexj(33)=xi5(7)*R(47)+xi5(9)*R(48)+xi5(10)*R(49)+xi5(4)*R(50)
+ cexj(34)=xi5(7)*R(51)+xi5(9)*R(52)+xi5(10)*R(53)+xi5(4)*R(54)
+ cexj(35)=xi5(7)*R(59)+xi5(9)*R(60)+xi5(10)*R(61)+xi5(4)*R(62)
+*
+
+*###[ : redundancy check
+ cxy(20)=xi5(1)*R(47)+xi5(5)*R(48)+xi5(6)*R(49)+xi5(7) *R(50)
+ cxy(21)=xi5(1)*R(51)+xi5(5)*R(52)+xi5(6)*R(53)+xi5(7) *R(54)
+ cxy(22)=xi5(1)*R(55)+xi5(5)*R(56)+xi5(6)*R(57)+xi5(7) *R(58)
+ cxy(23)=xi5(5)*R(47)+xi5(2)*R(48)+xi5(8)*R(49)+xi5(9) *R(50)
+ cxy(24)=xi5(5)*R(59)+xi5(2)*R(60)+xi5(8)*R(61)+xi5(9) *R(62)
+ cxy(25)=xi5(5)*R(63)+xi5(2)*R(64)+xi5(8)*R(65)+xi5(9) *R(66)
+ cxy(26)=xi5(6)*R(51)+xi5(8)*R(52)+xi5(3)*R(53)+xi5(10)*R(54)
+ cxy(27)=xi5(6)*R(59)+xi5(8)*R(60)+xi5(3)*R(61)+xi5(10)*R(62)
+ cxy(28)=xi5(6)*R(67)+xi5(8)*R(68)+xi5(3)*R(69)+xi5(10)*R(70)
+ cxy(29)=xi5(7)*R(55)+xi5(9)*R(56)+xi5(10)*R(57)+xi5(4)*R(58)
+ cxy(30)=xi5(7)*R(63)+xi5(9)*R(64)+xi5(10)*R(65)+xi5(4)*R(66)
+ cxy(31)=xi5(7)*R(67)+xi5(9)*R(68)+xi5(10)*R(69)+xi5(4)*R(70)
+ cxy(32)=xi5(5)*R(51)+xi5(2)*R(52)+xi5(8)*R(53)+xi5(9) *R(54)
+ cxy(32)=xi5(1)*R(59)+xi5(5)*R(60)+xi5(6)*R(61)+xi5(7) *R(62)
+ cxy(33)=xi5(5)*R(55)+xi5(2)*R(56)+xi5(8)*R(57)+xi5(9) *R(58)
+ cxy(33)=xi5(1)*R(63)+xi5(5)*R(64)+xi5(6)*R(65)+xi5(7) *R(66)
+ cxy(34)=xi5(6)*R(55)+xi5(8)*R(56)+xi5(3)*R(57)+xi5(10)*R(58)
+ cxy(34)=xi5(1)*R(67)+xi5(5)*R(68)+xi5(6)*R(69)+xi5(7) *R(70)
+ cxy(35)=xi5(6)*R(63)+xi5(8)*R(64)+xi5(3)*R(65)+xi5(10)*R(66)
+ cxy(35)=xi5(5)*R(67)+xi5(2)*R(68)+xi5(8)*R(69)+xi5(9) *R(70)
+ do 16 i=20,35
+ if ( absc(cxy(i)-cexj(i)) .gt. .1d-3 ) then
+ print *,'ffxdxp: redundancy check at level 3 failed ',
+ + i,cxy(i),cexj(i),cxy(i)-cexj(i),ier
+ return
+ endif
+ 16 continue
+*
+* check against FF
+*
+ do 17 i=16,35
+ if ( xloss*10d0**(-mod(ier,50))*absc(cexi(i)-cexj(i)) .gt.
+ + precc*absc(cexi(i)) ) then
+ print *,'ffxexp: error: FF disagrees with PV: ',i,
+ + cexi(i),cexj(i),cexi(i)-cexj(i),ier
+ endif
+ 17 continue
+*###] :
+ endif
+ if ( awrite ) then
+*###[ : print level 3
+ print *,' '
+ print *,'aaxex : level 3 '
+ print *,'E31 =',cexi(16)
+ print *,'E32 =',cexi(17)
+ print *,'E33 =',cexi(18)
+ print *,'E34 =',cexi(19)
+ print *,'E35 =',cexi(20)
+ print *,'E36 =',cexi(21)
+ print *,'E37 =',cexi(22)
+ print *,'E38 =',cexi(23)
+ print *,'E39 =',cexi(24)
+ print *,'E310=',cexi(25)
+ print *,'E311=',cexi(26)
+ print *,'E312=',cexi(27)
+ print *,'E313=',cexi(28)
+ print *,'E314=',cexi(29)
+ print *,'E315=',cexi(30)
+ print *,'E316=',cexi(31)
+ print *,'E317=',cexi(32)
+ print *,'E318=',cexi(33)
+ print *,'E319=',cexi(34)
+ print *,'E320=',cexi(35)
+*###] :
+ endif
+*
+ if (level .eq. 3) return
+*
+*###] : level 3 :
+ if (level .gt. 3) then
+ print *,'higher than third rank not yet implemented'
+ stop
+ endif
+
+*###] ffxex:
+ end
+*###[ ffeji:
+ subroutine ffeji(cdxi,mdxi,ccxi,mcxi,cbxi,mbxi,caxi,maxi,
+ + cdxj,mdxj,ccxj,mcxj,cbxj,mbxj,caxj,maxj,level)
+***#[*comment:***********************************************************
+* *
+* Copy the fourpoint arrays [cm][dcba]xj to the five point arrays *
+* [cm][dcba]xi. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+*
+ integer level
+ DOUBLE PRECISION mdxi(55),mcxi(30),mbxi(30),maxi(5),
+ + mdxj(120),mcxj(140),mbxj(60),maxj(20)
+ DOUBLE COMPLEX cdxi(55),ccxi(30),cbxi(30),caxi(5),
+ + cdxj(120),ccxj(140),cbxj(60),caxj(20)
+*
+ integer i,j,k
+*
+ include 'aa.h'
+*
+* #] declarations:
+* #[ copy necessary parts to E0 arrays:
+*
+* 1)D-output: reduce the array cdxj(5*24) to cdxi(5*11)
+* d's are calculated only to (level-1)
+ do j=1,5
+ do i=1,11
+ cdxi(i+(j-1)*11) = cdxj(i+(j-1)*24)
+ enddo
+ enddo
+*
+* 2)C-output: reduce the array ccxj(20*7) to ccxi(10*3)
+* c's are calculated only to (level-2)
+*
+ do j=1,4
+ do i=1,3
+ ccxi(0+i+(j-1)*3) = ccxj(0+i+(j-1)*7)
+ enddo
+ enddo
+ do j=1,3
+ do i=1,3
+ ccxi(12+i+(j-1)*3) = ccxj(35+i+(j-1)*7)
+ enddo
+ enddo
+ do j=1,2
+ do i=1,3
+ ccxi(21+i+(j-1)*3) = ccxj(70+i+(j-1)*7)
+ enddo
+ enddo
+ ccxi(28) = ccxj(106)
+ ccxi(29) = ccxj(107)
+ ccxi(30) = ccxj(108)
+*
+* check the symmetry in B0(i,j)
+* if ( atest ) then
+* do 13 i=1,4
+* j=4+i
+* k=8+i
+* if ( ( cbxj(i) - cbxj(i+1*12) ) .ne. 0. .or.
+* + ( cbxj(j) - cbxj(i+2*12) ) .ne. 0. .or.
+* + ( cbxj(k) - cbxj(i+3*12) ) .ne. 0. .or.
+* + ( cbxj(j+1*12)- cbxj(j+2*12) ) .ne. 0. .or.
+* + ( cbxj(k+1*12)- cbxj(j+3*12) ) .ne. 0. .or.
+* + ( cbxj(k+2*12)- cbxj(k+3*12) ) .ne. 0. ) then
+* print *,'error in B0-calculations in aaxcx.for'
+* endif
+* 13 continue
+* endif
+*
+* #] copy necessary parts to E0 arrays:
+*###] ffeji:
+ end
diff --git a/ff/aaxinv.f b/ff/aaxinv.f
new file mode 100644
index 0000000..f9462b7
--- /dev/null
+++ b/ff/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/ff.h b/ff/ff.h
new file mode 100644
index 0000000..828e89f
--- /dev/null
+++ b/ff/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/ff2dl2.f b/ff/ff2dl2.f
new file mode 100644
index 0000000..1998d72
--- /dev/null
+++ b/ff/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/ff_interface.C b/ff/ff_interface.C
new file mode 100644
index 0000000..279f900
--- /dev/null
+++ b/ff/ff_interface.C
@@ -0,0 +1,36 @@
+#include "ff_interface.h"
+double ffli2(double x){
+ /*
+ * Calculate Li2 using the ff library. Note that only the real part
+ * is calculated.
+ */
+ int ierr = 0;
+ double xxli2,xxli1;
+ if ( x >= 2 ){
+ double res = M_PI*M_PI/3 - 0.5 * log(x)*log(x);
+ x=1/x;
+ ffxli2_(xxli2,xxli1,x,ierr);
+ return(res-xxli2);
+ }
+ if ( x > 1. ){
+ double res = M_PI*M_PI/6 - 0.5*log(x)*log(x) + log(1/x)*log(1.-1./x);
+ x=1.-1./x;
+ ffxli2_(xxli2,xxli1,x,ierr);
+ return(res+xxli2);
+ }
+ if ( x > 0.5 ){
+ double res = M_PI*M_PI/6 - log(x)*log(1.-x);
+ x=1.-x;
+ ffxli2_(xxli2,xxli1,x,ierr);
+ return(res-xxli2);
+ }
+ if ( x < -1. ){
+ double res = -M_PI*M_PI/6 - 0.5 * log(-x)*log(-x);
+ x=1./x;
+ ffxli2_(xxli2,xxli1,x,ierr);
+ return(res-xxli2);
+ }
+ ffxli2_(xxli2,xxli1,x,ierr);
+ return(xxli2);
+
+}
diff --git a/ff/ff_interface.h b/ff/ff_interface.h
new file mode 100644
index 0000000..e973531
--- /dev/null
+++ b/ff/ff_interface.h
@@ -0,0 +1,36 @@
+/* $Modified: Sat Oct 21 13:52:39 2006 by puwer $ */
+#ifndef _FF_H_
+#define _FF_H_
+#include <cmath>
+#include <complex>
+
+extern "C" {
+ extern struct {
+ double delta;
+ } ffcut_;
+
+ void ffini_();
+ void ffexi_();
+
+ void ffxa0_(std::complex<double> & cint, const double & xd0,
+ const double & xxmuq, const double & mtq, int & ierr);
+
+ void ffxb0_(std::complex<double> & cint,const double & xd0,
+ const double & xxmuq, const double & xxk,
+ const double & xxma, const double & xxmb, int & ierr);
+
+ void ffxc0_(std::complex<double> & cint, double xxpi[6], int & ierr);
+
+ void ffxd0_(std::complex<double> & cint, double xxpi[13], int & ierr);
+
+ void ffxli2_(double & li2, double & li1, const double & x, int & ierr);
+ /*
+ * d/dp^2 B_0(p^2,maq,mbq);
+ */
+ void ffxdb0_(std::complex<double> & cdb0,std::complex<double> & cdb0p,
+ const double & xp,const double & xma,const double & xmb,
+ int & ier);
+}
+extern double ffli2(double x);
+
+#endif // _FF_H_
diff --git a/ff/ffabcd.f b/ff/ffabcd.f
new file mode 100644
index 0000000..a8e74ea
--- /dev/null
+++ b/ff/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/ffca0.f b/ff/ffca0.f
new file mode 100644
index 0000000..20c1da0
--- /dev/null
+++ b/ff/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/ffcb0.f b/ff/ffcb0.f
new file mode 100644
index 0000000..094f35b
--- /dev/null
+++ b/ff/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/ffcb1.f b/ff/ffcb1.f
new file mode 100644
index 0000000..2366d8c
--- /dev/null
+++ b/ff/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/ffcb2.f b/ff/ffcb2.f
new file mode 100644
index 0000000..e261f5c
--- /dev/null
+++ b/ff/ffcb2.f
@@ -0,0 +1,400 @@
+*###[ ffcb2:
+ subroutine ffcb2(cb2p,cb2d,cb1,cb0,ca0i,xp,xma,xmb,piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* Calculate 1 / d^n Q Q(mu) Q(nu) *
+* ------ | ------------------------ *
+* i pi^2 / (Q^2-ma^2)((Q+p)^2-mb^2) *
+* p mu *
+* = B2p*p(mu)*p(nu) + B2d*delta /p^2 *
+* p nu *
+* *
+* Input: cb1 complex vector twopoint function *
+* cb0 complex scalar twopoint function *
+* ca0i(2) complex scalar onepoint function with *
+* m1,m2 *
+* xp complex p.p in B&D metric *
+* xma,2 complex m_1^2,m_2^2 *
+* piDpj(3,3) complex dotproducts between s1,s2,p *
+* ier integer digits lost so far *
+* Output: cb2p complex coefficient of p(mu)*p(nu) *
+* cb2d complex coefficient of delta()/p^2 *
+* ier integer digits lost *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX xp,xma,xmb,piDpj(3,3)
+ DOUBLE COMPLEX cb2p,cb2d,cb1,cb0,ca0i(2)
+*
+* local variables
+*
+ integer ier0,i,j
+ DOUBLE COMPLEX dmap,dmbp,dmamb,cc
+ DOUBLE PRECISION absc
+ DOUBLE PRECISION rm1,rm2,rp,rpiDpj(3,3),sprec
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ real case:
+ if ( DIMAG(xma).eq.0 .and. DIMAG(xmb).eq.0 ) then
+ rm1 = DBLE(xma)
+ rm2 = DBLE(xmb)
+ 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 ffxb2(cb2p,cb2d,cb1,cb0,ca0i,rp,rm1,rm2,rpiDpj,
+ + ier)
+ precx = sprec
+ return
+ endif
+* #] real case:
+* #[ get differences:
+ ier0 = 0
+ dmamb = xma - xmb
+ dmap = xma - xp
+ dmbp = xmb - xp
+ if ( lwarn ) then
+ if ( absc(dmamb) .lt. xloss*absc(xma) .and. xma .ne. xmb )
+ + call ffwarn(97,ier0,absc(dmamb),absc(xma))
+ if ( absc(dmap) .lt. xloss*absc(xp) .and. xp .ne. xma )
+ + call ffwarn(98,ier0,absc(dmap),absc(xp))
+ if ( absc(dmbp) .lt. xloss*absc(xp) .and. xp .ne. xmb )
+ + call ffwarn(99,ier0,absc(dmbp),absc(xp))
+ endif
+* #] get differences:
+* #[ call ffcb2a:
+ call ffcb2a(cb2p,cb2d,cb1,cb0,ca0i,xp,xma,xmb,dmap,dmbp,dmamb,
+ + piDpj,ier)
+* #] call ffcb2a:
+*###] ffcb2:
+ end
+*###[ ffcb2a:
+ subroutine ffcb2a(cb2p,cb2d,cb1,cb0,ca0i,xp,xma,xmb,
+ + dmap,dmbp,dmamb,piDpj,ier)
+***#[*comment:***********************************************************
+* *
+* see ffcb2, plus differences. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX xp,xma,xmb,dmap,dmbp,dmamb,piDpj(3,3)
+ DOUBLE COMPLEX cb2p,cb2d,cb1,cb0,ca0i(2)
+*
+* local variables
+*
+ integer i,j,ier0,init,ithres
+ logical llogmm,lreal
+ DOUBLE PRECISION absc,xmax,xmxp,rloss
+ DOUBLE PRECISION rm1,rm2,rp,rm1p,rm2p,rm1m2,rpiDpj(3,3),sprec
+ DOUBLE COMPLEX delsp,xlam,xlo3,xlogmm,zfflo1,zfflo3
+ DOUBLE COMPLEX cc,cs(6),cb21,cb22,csom
+ DOUBLE COMPLEX cqi(3),cqiqj(3,3),qiDqj(3,3)
+ save init
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ real case:
+ if ( DIMAG(xma).eq.0 .and. DIMAG(xmb).eq.0 ) then
+ lreal = .TRUE.
+ if ( lwrite ) print *,'ffcb2a: real masses'
+ elseif ( nschem.le.4 ) then
+ lreal = .TRUE.
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb2a: nschem <= 4, ignoring complex masses:',
+ + nschem
+ endif
+ elseif ( nschem.le.6 ) then
+ if ( lwrite .or. init.eq.0 ) then
+ init = 1
+ print *,'ffcb2a: nschem = 5,6 complex masses near ',
+ + 'threshold: ',nschem
+ endif
+ cqi(1) = xma
+ cqi(2) = xmb
+ cqi(3) = xp
+ cqiqj(1,2) = dmamb
+ cqiqj(2,1) = -cqiqj(1,2)
+ cqiqj(1,3) = dmap
+ cqiqj(3,1) = -cqiqj(1,3)
+ cqiqj(2,3) = dmbp
+ 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 *,'ffcb2a: no threshold'
+ else
+ if ( lwrite ) print *,'ffcb2a: found threshold'
+ lreal = .FALSE.
+ endif
+ else
+ lreal = .FALSE.
+ endif
+ if ( lreal ) then
+ rm1 = DBLE(xma)
+ rm2 = DBLE(xmb)
+ rp = DBLE(xp)
+ rm1p = DBLE(dmap)
+ rm2p = DBLE(dmbp)
+ rm1m2 = DBLE(dmamb)
+ 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 ffxb2a(cb2p,cb2d,cb1,cb0,ca0i,rp,rm1,rm2,rm1p,rm2p,
+ + rm1m2,rpiDpj,ier)
+ precx = sprec
+ return
+ endif
+* #] real case:
+* #[ test input:
+ if ( ltest ) then
+ ier0 = ier
+ call ffcot2(qiDqj,xp,xma,xmb,dmap,dmbp,dmamb,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 *,'ffcb2a: ',
+ + '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:
+* #[ p^2 != 0:
+ if ( xp .ne. 0 ) then
+* #[ normal case:
+ call ffclmb(xlam,-xp,-xmb,-xma,dmbp,dmap,dmamb,ier)
+ delsp = -xlam/4
+*
+* the first one is simple...
+*
+ cs(1) = 2*cb1*piDpj(1,3)
+ cs(2) = ca0i(2)
+ cb2p = cs(1) + cs(2)
+ if ( absc(cb2p) .lt. xloss*absc(cs(2)) ) then
+ if ( lwarn ) call ffwarn(214,ier,absc(cb2p),absc(cs(2)))
+ endif
+*
+* the next one ain't.
+*
+ cs(1) = ca0i(2)
+ cs(2) = 2*xma*cb0
+ cs(3) = -2*piDpj(1,3)*cb1
+ cs(4) = xma+xmb
+ cs(5) = -xp/3
+ cb2d = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
+ xmax = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
+ if ( absc(cb2d) .ge. xloss*xmax ) goto 110
+ if ( lwrite ) then
+ print '(a,2e30.16,e12.4)','cb2d = ',cb2d,xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,5)
+ endif
+ if ( lwarn ) then
+ call ffwarn(214,ier,absc(cb2d),xmax)
+ if ( lwrite ) then
+ print *,'xp,xma,xmb = ',xp,xma,xmb
+ endif
+ endif
+ 110 continue
+* #] give up:
+ cb2p = cb2p*DBLE(1/(2*xp))
+ cb2d = cb2d*(1/DBLE(6))
+* #] p^2 != 0:
+* #[ p^2=0:
+ elseif ( dmamb .ne. 0 ) then
+ if ( init.eq.0 ) then
+ init = 1
+ print *,' '
+ print *,'ffcb2a: note: in this case p^2=0 B21 is ',
+ + 'returned rather than B2p which is undefined'
+ print *,' '
+ endif
+ if ( dmamb .ne. 0 ) then
+* #[ B21:
+ llogmm = .FALSE.
+*
+* B21 (see thesis, b21.frm)
+*
+ cs(1) = xma**2/3/dmamb**3*ca0i(1)
+ cs(2) = (-xma**2 + xma*xmb - xmb**2/3)/dmamb**3*ca0i(2)
+ cs(3) = (5*xma**3/18 - xma*xmb**2/2 + 2*xmb**3/9)
+ + /dmamb**3
+ cb21 = cs(1)+cs(2)+cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( absc(cb21).gt.xloss**2*xmax ) goto 160
+ if ( lwrite ) then
+ print *,'cb21 = ',cb21,xmax
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,3)
+ endif
+*
+* ma ~ mb
+*
+ if ( absc(dmamb).lt.xloss*absc(xma) ) then
+ xlogmm = zfflo1(dmamb/xma,ier)
+ else
+ xlogmm = log(xmb/xma)
+ endif
+ llogmm = .TRUE.
+ cs(1) = (xma/dmamb)/6
+ cs(2) = (xma/dmamb)**2/3
+ cs(3) = (xma/dmamb)**3*xlogmm/3
+ cs(4) = -2/DBLE(9) + ca0i(1)/(3*xma)
+ 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 *,'cb21+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,5)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb21 = csom
+ if ( absc(cb21).gt.xloss**2*xmax ) goto 160
+ endif
+*
+* and last try
+*
+ xlo3 = zfflo3(dmamb/xma,ier)
+ cs(1) = (dmamb/xma)**2/6
+ cs(2) = (dmamb/xma)/3
+ cs(3) = xlo3/(3*(dmamb/xma)**3)
+*same cs(4) = -2/DBLE(9) + ca0i(1)/(3*xma)
+ 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 *,'cb21+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,5)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb21 = csom
+ if ( absc(cb21).gt.xloss**2*xmax ) goto 160
+ endif
+*
+* give up
+*
+ if ( lwarn ) then
+ call ffwarn(227,ier,absc(cb21),xmax)
+ if ( lwrite ) then
+ print *,'xp,xma,xmb = ',xp,xma,xmb
+ endif
+ endif
+ 160 continue
+* #] B21:
+* #[ B22:
+*
+* B22
+*
+ cs(1) = +xma/(4*dmamb)*ca0i(1)
+ cs(2) = -xmb/(4*dmamb)*ca0i(2)
+ cs(3) = (xma+xmb)/8
+ cb22 = cs(1) + cs(2) + cs(3)
+ xmax = max(absc(cs(2)),absc(cs(3)))
+ if ( absc(cb22).gt.xloss*xmax ) goto 210
+ if ( lwrite ) then
+ print *,'cb22 = ',cb22,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(dmamb).lt.xloss*absc(xma) ) then
+ xlogmm = zfflo1(dmamb/xma,ier)
+ else
+ xlogmm = log(xmb/xma)
+ endif
+ endif
+ cs(1) = dmamb*( -1/DBLE(8) - ca0i(1)/(4*xma) )
+ cs(2) = dmamb*xlogmm/4
+ cs(3) = xma*(xma/dmamb)/4*xlogmm
+ cs(4) = xma*( 1/DBLE(4) + ca0i(1)/(2*xma) )
+ cs(5) = -xma*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 *,'cb22+= ',csom,xmxp
+ print *,'with cs '
+ print '(i3,2e30.16)',(i,cs(i),i=1,2)
+ endif
+ if ( xmxp.lt.xmax ) then
+ xmax = xmxp
+ cb22 = csom
+ endif
+ if ( absc(cb22).gt.xloss*xmax ) goto 210
+*
+* give up
+*
+ if ( lwarn ) then
+ call ffwarn(214,ier,absc(cb22),xmax)
+ if ( lwrite ) then
+ print *,'xp,xma,xmb = ',xp,xma,xmb
+ endif
+ endif
+ 210 continue
+* #] B22:
+ else
+*
+* ma=mb: simple
+*
+ cb21 = cb0/3
+ cb22 = xma/2*(cb0 + 1)
+ endif
+ cb2d = cb22
+ cb2p = cb21
+ endif
+* #] p^2=0:
+* #[ debug output:
+ if ( lwrite ) then
+ print *,'ffcb2: cb2p = ',cb2p,ier
+ print *,' cb2d = ',cb2d,ier
+ endif
+* #] debug output:
+*###] ffcb2a:
+ end
diff --git a/ff/ffcb2p.f b/ff/ffcb2p.f
new file mode 100644
index 0000000..0e5431b
--- /dev/null
+++ b/ff/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/ffcc0.f b/ff/ffcc0.f
new file mode 100644
index 0000000..17bdae7
--- /dev/null
+++ b/ff/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/ffcc0p.f b/ff/ffcc0p.f
new file mode 100644
index 0000000..e29205b
--- /dev/null
+++ b/ff/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/ffcc1.f b/ff/ffcc1.f
new file mode 100644
index 0000000..09d5bdf
--- /dev/null
+++ b/ff/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/ffcd0.f b/ff/ffcd0.f
new file mode 100644
index 0000000..1d4acad
--- /dev/null
+++ b/ff/ffcd0.f
@@ -0,0 +1,796 @@
+* $Id: ffcd0.f,v 1.3 1995/12/08 10:50:35 gj Exp $
+*###[ ffcd0:
+ subroutine ffcd0(cd0,cpi,ier)
+***#[*comment:***********************************************************
+* *
+* 1 / *
+* calculate d0 = ----- \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\ *
+* *
+* *
+* input: cpi(1-10) (complex) 1-4: m_i^2, 5-10 p_i^2 (B&D metric)
+* cpi(11)=u (complex) u=p5.p5+..-p9.p9-p10.10 or 0 *
+* cpi(12)=v (complex) v=-p5.p5+p6.p6-p7.p7+.. or 0 *
+* cpi(13)=w (complex) w=p5.p5-p6.p6+p7.p7-p8.p8+.. *
+* output: cd0 (complex) D0 *
+* ier (integer) <50: #digits lost, >100: error *
+* calls: ffcd0a,ffxd0 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ DOUBLE COMPLEX cd0,cpi(13)
+ integer ier
+*
+* local variables
+*
+ DOUBLE COMPLEX c,cs,cfac
+ integer i,j,ier0,init
+ logical luvw(3)
+ DOUBLE PRECISION absc,absr,xpi(13),xmax,sprec
+ DOUBLE COMPLEX cpipj(10,13)
+ save init
+*
+* common blocks:
+*
+ include 'ff.h'
+*
+* statement functions:
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+ absr(c) = abs(DBLE(c))
+*
+* data
+*
+ data init /0/
+* #] declarations:
+* #[ the real case:
+*
+ if ( nschem.ge.2 ) then
+ if ( DIMAG(cpi(1)).ne.0 .or. DIMAG(cpi(2)).ne.0 .or.
+ + DIMAG(cpi(3)).ne.0 .or. DIMAG(cpi(4)).ne.0 ) goto 40
+ elseif ( init .eq. 0 ) then
+ init = 1
+ print *,'ffcd0: disregarding complex masses, nschem= ',
+ + nschem
+ endif
+ do 10 i=1,13
+ xpi(i) = DBLE(cpi(i))
+ 10 continue
+ sprec = precx
+ precx = precc
+ call ffxd0(cd0,xpi,ier)
+ if ( ldot ) then
+ ier0 = 0
+ call ffcif4(cpi,luvw,cpipj,ier0)
+ call ffcod4(cpi,cpipj)
+ if ( luvw(1) ) cpi(11) = 0
+ if ( luvw(2) ) cpi(12) = 0
+ if ( luvw(3) ) cpi(13) = 0
+ endif
+ precx = sprec
+ return
+ 40 continue
+*
+* #] the real case:
+* #[ check input:
+*
+ idsub = 0
+ if ( ltest ) then
+ do 50 i=1,4
+ if ( DIMAG(cpi(i)) .gt. 0 ) call fferr(50,ier)
+ 50 continue
+ do 60 i=5,13
+ if ( DIMAG(cpi(i)) .ne. 0 ) call fferr(50,ier)
+ 60 continue
+ endif
+ if ( lwrite ) then
+ print *,'ffcd0: input = ',cpi
+ endif
+*
+* #] check input:
+* #[ call ffcif4,ffcd0a:
+*
+ call ffcif4(cpipj,luvw,cpi,ier)
+ call ffcd0b(cs,cfac,cpi,cpipj,0,ier)
+ cd0 = cs*cfac
+*
+* restore the zeros for u,v,w as we have calculated them
+* ourselves and the user is unlikely to do this...
+*
+ if ( luvw(1) ) cpi(11) = 0
+ if ( luvw(2) ) cpi(12) = 0
+ if ( luvw(3) ) cpi(13) = 0
+*
+* #] call ffcif4,ffcd0a:
+*###] ffcd0:
+ end
+*###[ ffcd0a:
+ subroutine ffcd0a(cd0,cpi,cpipj,ier)
+***#[*comment:***********************************************************
+* *
+* Dummy routine. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX cd0,cpi(13),cpipj(10,13)
+*
+* local variables
+*
+ DOUBLE COMPLEX cs,cfac
+*
+* #] declarations:
+* #[ call ffcd0b:
+*
+ call ffcd0b(cs,cfac,cpi,cpipj,0,ier)
+ cd0 = cs*cfac
+*
+* #] call ffcd0b:
+*###] ffcd0a:
+ end
+*###[ ffcd0b:
+ subroutine ffcd0b(cs,cfac,cpi,cpipj,ndiv,ier)
+***#[*comment:***********************************************************
+* *
+* See ffcd0, the differences between the input parameters are *
+* also input. This routines has the big nschem switchyard. *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier,ndiv
+ DOUBLE COMPLEX cs,cfac,cpi(13),cpipj(10,13)
+*
+* local variables
+*
+ integer ier0,i,j,initlo,iir(2,4),ithres(4,4)
+ logical ldone
+ DOUBLE PRECISION xpi(13),dpipj(10,13),sprec,absc
+ DOUBLE COMPLEX cc
+ save initlo
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+* absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* data
+*
+ data initlo /0/
+* #] declarations:
+* #[ check input:
+ if ( ltest ) then
+ ier0 = 0
+ call ffchck(cpi,cpipj,10,ier0)
+ if ( ier0 .ne. 0 ) print *,'called from ffcd0b'
+ endif
+* #] check input:
+* #[ the real case:
+*
+ if ( DIMAG(cpi(1)).eq.0 .and. DIMAG(cpi(2)).eq.0 .and.
+ + DIMAG(cpi(3)).eq.0 .and. DIMAG(cpi(4)).eq.0 .or.
+ + nschem.le.1 ) then
+ if ( initlo.eq.0 .and. nschem.le.1 ) then
+ initlo = 1
+ print *,'ffcd0b: disregarding all complex masses'
+ endif
+ if ( onshel .and. ndiv.gt.0 ) then
+ cs = 0
+ cfac = 1
+ return
+ endif
+ do 5 i=1,13
+ xpi(i) = DBLE(cpi(i))
+ do 4 j=1,10
+ dpipj(j,i) = DBLE(cpipj(j,i))
+ 4 continue
+ 5 continue
+ sprec = precx
+ precx = precc
+ call ffxd0b(cs,cfac,xpi,dpipj,ndiv,ier)
+ if ( ldot ) call ffcod4(cpi,cpipj)
+ precx = sprec
+ return
+ endif
+*
+* #] the real case:
+* #[ handle poles-only approach:
+ if ( nschem.le.6 ) then
+ if ( initlo .eq. 0 ) then
+ initlo = 1
+ if ( nschem.eq.2 ) then
+ print *,'ffcd0b: disregarding complex masses ',
+ + 'except in linearly divergent terms'
+ elseif ( nschem.eq.3 ) then
+ print *,'ffcd0b: undefined nschem=3'
+ elseif ( nschem.eq.4 ) then
+ print *,'ffcd0b: using the scheme in which ',
+ + 'complex masses are used everywhere when ',
+ + 'there is a divergent log'
+ elseif ( nschem.eq.5 ) then
+ print *,'ffcd0b: 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 *,'ffcd0b: using the scheme in which ',
+ + 'complex masses are used everywhere when ',
+ + 'there is a singular log'
+ elseif ( nschem.eq.7 ) then
+ print *,'ffcd0b: using complex masses'
+ endif
+ if ( nschem.ge.3 ) then
+ print *,'ffcd0b: switching to complex when on',
+ + 'shell or |p^2-Re(m^2)| < ',nwidth,'*|Im(m^2)|'
+ endif
+ endif
+*
+* ffcdir computes all linearly onshell singular cases,
+* returns 0 if ndiv too large
+* and returns the other IR divergences in iir as a bonus
+*
+ call ffcdir(cs,cfac,ldone,iir,cpi,cpipj,4,ndiv,ier)
+ if ( ldone ) return
+*
+* use a subtraction method, or just the real case.
+* for both we need the real vars.
+*
+ sprec = precx
+ precx = precc
+ do 16 i=1,13
+ xpi(i) = DBLE(cpi(i))
+ do 15 j=1,10
+ dpipj(j,i) = DBLE(cpipj(j,i))
+ 15 continue
+ 16 continue
+ if ( nschem.le.3 .or. iir(1,1).eq.0 .and. nschem.eq.4 ) then
+ else
+*
+* finally, search for threshold terms
+*
+ do 20 i=1,3
+ do 19 j=i+1,4
+ call ffthre(ithres(j,i),cpi,cpipj,10,i,j,
+ + inx(i,j))
+ ithres(i,j) = ithres(j,i)
+ 19 continue
+ 20 continue
+ endif
+ call ffcd0c(cs,cfac,cpi,cpipj,xpi,dpipj,iir,ithres,ier)
+ precx = sprec
+*
+* #] handle poles-only approach:
+* #[ complex case:
+ else
+ print *,'ffcd0b: complex D0 not implemented'
+ stop
+ endif
+* #] complex case:
+*###] ffcd0b:
+ end
+*###[ ffcd0c:
+ subroutine ffcd0c(cs,cfac,cpi,cpipj,xpi,dpipj,iir,ithres,ier)
+***#[*comment:***********************************************************
+* *
+* computes the complex D0 by adding and subtracting the complex *
+* C0 (for ir divergences in iir) and B0 (for threshold effects in *
+* ithres). *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer iir(2,4),ithres(4,4),ier
+ DOUBLE PRECISION xpi(13),dpipj(10,13)
+ DOUBLE COMPLEX cs,cfac,cpi(13),cpipj(10,13)
+*
+* local variables
+*
+ integer ir,i,i1,j,j1,ier1,ier0,nscsav,ij,notij(4,4),
+ + notijk(4,4,4),k,l
+ logical ldotsa,lwrisa
+ DOUBLE PRECISION xpi3(6),dpipj3(6,6),absc,a(2),p1,p2,xmax,del2
+ DOUBLE COMPLEX csr,cc0r,cc0c,cb0r,cb0c,cpi3(6),cpipj3(6,6),cc
+ save notij,notijk
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* data
+*
+ data notij/0,3,2,2, 3,0,1,1, 2,1,0,1, 2,1,1,0/
+ 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:
+* #[ D0:
+*
+ if ( lwrite ) print *,'ffcd0c: calling ffxd0b'
+ ier1 = ier
+ ldotsa = ldot
+ ldot = .TRUE.
+ lwrisa = lwrite
+* lwrite = .FALSE.
+ call ffxd0b(csr,cfac,xpi,dpipj,0,ier1)
+ lwrite = lwrisa
+ cs = csr
+*
+* #] D0:
+* #[ bookkeeping:
+ if ( nschem.eq.5 .or. nschem.eq.6 ) then
+*
+* first weed out the thresholds already included in the IR terms
+*
+ if ( lwrite ) then
+ print '(a)','ffcd0c: before comp iir ithres was '
+ print '(4i3)',ithres
+ endif
+ do 15 i=1,2
+ if ( iir(i,1).eq.0 ) goto 16
+ ithres(iir(i,1),iir(i,2)) = 0
+ ithres(iir(i,2),iir(i,1)) = 0
+ ithres(iir(i,1),iir(i,3)) = 0
+ ithres(iir(i,3),iir(i,1)) = 0
+ 15 continue
+ 16 continue
+ if ( lwrite ) then
+ print '(a)','ffcd0c: after comp iir ithres is '
+ print '(4i3)',ithres
+ endif
+*
+* next - we need a complete complex C0 for a (m,m,0) type
+* vertex; the B0 does not contain the 2i\pi^2 jump
+*
+ ir = 1
+ if ( iir(1,1) .ne. 0 ) ir = 2
+ if ( iir(2,1) .ne. 0 ) goto 19
+ do 18 i=1,3
+ do 17 j=i+1,4
+ if ( ithres(i,j).eq.2 ) then
+ if ( xpi(i).lt.xpi(j) ) then
+ iir(ir,1) = i
+ iir(ir,2) = j
+ else
+ iir(ir,1) = j
+ iir(ir,2) = i
+ endif
+ k = notij(i,j)
+ l = notijk(i,j,k)
+ if ( abs(fpij4(iir(ir,1),k)) .lt.
+ + abs(fpij4(iir(ir,1),l)) ) then
+ iir(ir,3) = k
+ iir(ir,4) = l
+ else
+ iir(ir,3) = l
+ iir(ir,4) = k
+ endif
+* throw out the vertices connected with this C0
+ ithres(i,j) = 0
+ ithres(j,i) = 0
+ ithres(iir(ir,1),iir(ir,3)) = 0
+ ithres(iir(ir,3),iir(ir,1)) = 0
+ if ( lwrite ) then
+ print *,'ffcd0c: thresold of (m,m,0) type'
+ print *,xpi(i),xpi(j),xpi(inx(i,j))
+ print *,'made into C0 ',iir(ir,1),iir(ir,2),
+ + iir(ir,3),iir(ir,4)
+ endif
+ ir = ir + 1
+ endif
+ 17 continue
+ 18 continue
+ 19 continue
+ endif
+*
+* #] bookkeeping:
+* #[ IR:
+*
+* get the IR parts correct
+*
+ if ( nschem.le.3 ) goto 31
+ do 30 ir=1,2
+ if ( iir(ir,1).eq.0 ) goto 31
+ do 25 i=1,3
+ i1 = mod(i,3) + 1
+ xpi3(i) = xpi(iir(ir,i))
+ cpi3(i) = cpi(iir(ir,i))
+ xpi3(i+3) = xpi(inx(iir(ir,i),iir(ir,i1)))
+ cpi3(i+3) = cpi(inx(iir(ir,i),iir(ir,i1)))
+ do 24 j=1,3
+ j1 = mod(j,3) + 1
+ dpipj3(j,i) = dpipj(iir(ir,j),iir(ir,i))
+ cpipj3(j,i) = cpipj(iir(ir,j),iir(ir,i))
+ dpipj3(j,i+3) = dpipj(iir(ir,j),
+ + inx(iir(ir,i),iir(ir,i1)))
+ dpipj3(i+3,j) = -dpipj3(j,i+3)
+ cpipj3(j,i+3) = cpipj(iir(ir,j),
+ + inx(iir(ir,i),iir(ir,i1)))
+ cpipj3(i+3,j) = -cpipj3(j,i+3)
+ dpipj3(j+3,i+3) = dpipj(
+ + inx(iir(ir,j),iir(ir,j1)),
+ + inx(iir(ir,i),iir(ir,i1)))
+ cpipj3(j+3,i+3) = cpipj(
+ + inx(iir(ir,j),iir(ir,j1)),
+ + inx(iir(ir,i),iir(ir,i1)))
+ 24 continue
+ 25 continue
+ ier0 = ier
+ if ( lwrite ) then
+ print *,'ffcd0c: calling ffxc0a'
+ print *,'xpi3 = ',xpi3
+ endif
+ ldot = .TRUE.
+ call ffxc0a(cc0r,xpi3,dpipj3,ier0)
+ ier1 = max(ier1,ier0)
+ del2 = fdel2
+ if ( lwrite ) then
+ print *,'ffcd0c: calling ffcc0a'
+ print *,'cpi3 = ',cpi3
+ endif
+ nscsav = nschem
+ nschem = 7
+ ldot = .FALSE.
+ call ffcc0a(cc0c,cpi3,cpipj3,ier0)
+ nschem = nscsav
+ ier1 = max(ier1,ier0)
+ if ( ltest .and. xloss*absc(cc0r-cc0c) .lt.
+ + precc*absc(cc0r) ) print *,'ffcd0c: ',
+ + 'unnecessary subtraction!!',iir
+ p1 = 1/dpipj(inx(iir(ir,4),iir(ir,1)),iir(ir,4))
+ if ( lwrite ) then
+ print *,'Compare propagator and improved factor'
+ print *,'p1 = ',p1
+ print *,'sqrt(-del2/fdel4s)/2 = ',sqrt(-del2/fdel4s)
+ + /2
+ print *,'sqrt(-del2)*DBLE(cfac)/2 = ',sqrt(-del2)*
+ + DBLE(cfac)*2
+ endif
+* this can not cause problems because p1 flips sign when the
+* function is linearly divergent, and that region should
+* never come here
+ p1 = sign(sqrt(-del2/fdel4s)/2,p1)
+ cc0r=cc0r/cfac*DBLE(p1)
+ cc0c=cc0c/cfac*DBLE(p1)
+ cs = cs - cc0r + cc0c
+ if ( lwarn .and. absc(cs) .lt. xloss*max(absc(cc0r),
+ + absc(cc0c)) ) then
+ call ffwarn(211,ier1,absc(cs),max(absc(cc0r),absc(cc0c)))
+ endif
+ if ( lwrite ) then
+ print *
+ if ( ir.eq.1 ) print *,'csr = ',csr
+ print *,'subtracted IR divergence ',iir(ir,1),iir(ir,2),
+ + iir(ir,3)
+ print *,'cc0r = ',cc0r
+ print *,'cc0c = ',cc0c
+ if ( ir.eq.2 .or. iir(2,1).eq.0 ) then
+ print *,'-------------'
+ print *,'cs = ',cs
+ endif
+ endif
+ 30 continue
+ 31 continue
+*
+* #] IR:
+* #[ threshold:
+*
+* and the threshold terms
+*
+ if ( nschem.le.4 ) goto 41
+*
+* next add and subtract the complex/real B0
+*
+ do 40 i=1,3
+ do 39 j=i+1,4
+ if ( ithres(j,i).eq.0 ) goto 39
+ ij = inx(i,j)
+ if ( xpi(ij) .lt. 0 ) then
+ if ( lwrite ) print *,'ffcd0c: error: ',
+ + 'cannot handle pseudothresholds yet: ',xpi(i),
+ + xpi(j),xpi(ij)
+ goto 39
+ endif
+ if ( ltest .and. DIMAG(cpi(i)).eq.0 .and.
+ + DIMAG(cpi(j)).eq.0 ) then
+ print *,'ffcd0c: error: threshold without complex '
+ + //'masses: ',i,cpi(i),j,cpi(j)
+ goto 39
+ endif
+*
+* else just add and subtract the B0
+*
+ if ( lwrite ) print *,'ffcd0c: calling ffxb0p ',i,j,ij
+ ier0 = ier
+ call ffxb0p(cb0r,xpi(ij),xpi(i),xpi(j),dpipj(i,ij),
+ + dpipj(j,ij),dpipj(i,j),ier0)
+ ier1 = max(ier1,ier0)
+*
+ if ( lwrite ) print *,'ffcd0c: calling ffcb0p ',i,j,ij
+ ier0 = ier
+ call ffcb0p(cb0c,cpi(ij),cpi(i),cpi(j),cpipj(i,ij),
+ + cpipj(j,ij),cpipj(i,j),ier0)
+ ier1 = max(ier1,ier0)
+*
+* get the coefficients which are given by Q=a*p(1)
+*
+ a(1) = xpi(i)*(xpi(j)*dpipj(j,i) - xpi(ij)*(xpi(i)+
+ + xpi(j)))/(xpi(ij)*(xpi(i)+xpi(j))**2)
+* a(2) = 1+a(1):
+ a(2) = xpi(j)*(xpi(i)*dpipj(j,i) + xpi(ij)*(xpi(i)+
+ + xpi(j)))/(xpi(ij)*(xpi(i)+xpi(j))**2)
+ if ( lwrite ) print *,'a,1+a,1 = ',a(1),a(2),a(2)-a(1)
+*
+ k = notij(i,j)
+ if ( abs(a(1)) .lt. abs(a(2)) ) then
+ p1 = dpipj(inx(i,k),k) + a(1)**2*xpi(ij) +
+ + 2*a(1)*fpij4(ij,inx(i,k)) *
+ + isgn(i,j)*isgn(i,k)
+ xmax = max(abs(dpipj(inx(i,k),k)),a(1)**2*xpi(ij))
+ if ( lwrite ) print *,'p1 = ',p1,xmax
+ else
+ p1 = dpipj(inx(j,k),k) + a(2)**2*xpi(ij) +
+ + 2*a(2)*fpij4(ij,inx(j,k)) *
+ + isgn(i,j)*isgn(j,k)
+ xmax = max(abs(dpipj(inx(j,k),k)),a(2)**2*xpi(ij))
+ if ( lwrite ) print *,'p1 = ',p1,xmax
+ endif
+ if ( abs(p1) .lt. xloss*xmax )
+ + call ffwarn(212,ier1,p1,xmax)
+*
+ l = notijk(i,j,k)
+ if ( abs(a(1)) .lt. abs(a(2)) ) then
+ p2 = dpipj(inx(i,l),l) + a(1)**2*xpi(ij) +
+ + 2*a(1)*fpij4(ij,inx(i,l)) *
+ + isgn(i,j)*isgn(i,l)
+ xmax = max(abs(dpipj(inx(i,l),l)),a(1)**2*xpi(ij))
+ if ( lwrite ) print *,'p2 = ',p2,xmax
+ else
+ p2 = dpipj(inx(j,l),l) + a(2)**2*xpi(ij) +
+ + 2*a(2)*fpij4(ij,inx(j,l)) *
+ + isgn(i,j)*isgn(j,l)
+ xmax = max(abs(dpipj(inx(j,l),l)),a(2)**2*xpi(ij))
+ if ( lwrite ) print *,'p2 = ',p2,xmax
+ endif
+ if ( abs(p2) .lt. xloss*xmax )
+ + call ffwarn(213,ier1,p2,xmax)
+*
+ cb0r = cb0r/cfac/(p1*p2)
+ cb0c = cb0c/cfac/(p1*p2)
+* minus because we computed B', not B
+ cs = cs + cb0r - cb0c
+ if ( lwrite ) then
+ print *,'subtracted threshold ',i,j
+ print *,'csr = ',csr
+ print *,'cb0r = ',-cb0r
+ print *,'diff ',csr+cb0r
+ print *,'cb0c = ',-cb0c
+ endif
+ 39 continue
+ 40 continue
+ 41 continue
+* #] threshold:
+* #[ dotproducts:
+*
+* and the dot products if requested
+*
+ ldot = ldotsa
+ if ( ldot ) then
+ call ffcod4(cpi,cpipj)
+ endif
+* #] dotproducts:
+* #[ finito:
+*
+* clean up
+*
+ ier = ier1
+ if ( lwrite ) then
+ print *,'cs,cfac :',cs,cfac,ier
+ print *,'cd0 :',cs*cfac,ier
+ endif
+* #] finito:
+*###] ffcd0c:
+ end
+*###[ ffcod4:
+ subroutine ffcod4(cpi,cpipj)
+***#[*comment:***********************************************************
+* *
+* Convert real dorproducts into complex ones, adding the *
+* imaginary parts where appropriate. *
+* For the time being just recompute them... *
+* *
+* Input: cpi(13) complex m^2, p^2 *
+* cpipj(10,13) complex diffs *
+* *
+* Output: /ffcots/cfpij4(10,10) complex p.p complex *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ DOUBLE COMPLEX cpi(13),cpipj(10,13)
+*
+* local variables
+*
+ integer i,j,ier0,ii(6)
+ DOUBLE PRECISION piDpj(10,10),sprec
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* #] declarations:
+* #[ compute dotproducts and determinants:
+*
+ ier0 = 0
+ call ffcot4(cfpij4,cpi,cpipj,10,ier0)
+ call ffcel4(cfdl4s,cpi,cfpij4,10,ier0)
+ if ( abs(idot).lt.2 ) then
+ if ( onshel ) then
+* we have to recompute the overall \Delta_3
+ do 10 i=1,6
+ ii(i) = i+4
+ 10 continue
+ do 30 i=1,10
+ do 20 j=1,10
+ piDpj(j,i) = DBLE(cfpij4(j,i))
+ 20 continue
+ 30 continue
+* this prec-juggling should not be necessary, but it is...
+ sprec = precx
+ precx = precc
+ call ffdl3p(fodel3,piDpj,10,ii,ii,ier0)
+ precx = sprec
+ else
+ fodel3 = fdel3
+ endif
+ endif
+*
+* #] compute dotproducts and determinants:
+*###] ffcod4:
+ end
+*###[ ffcif4:
+ subroutine ffcif4(cpipj,luvw,cpi,ier)
+***#[*comment:***********************************************************
+* *
+* Compute the elements 11-13 in xpi and the differences cpipj *
+* Note that the digits lost in cpipj are not counted towards *
+* the total. *
+* *
+* Input: cpi(1:10) complex masses, momenta^2 *
+* *
+* Output: cpi(11:13) complex u and similar vars v,w *
+* luvw(3) logical TRUE if xpi(10+i) has *
+* been computed here *
+* cpipj(10,13) complex xpi(i) - xpi(j) *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ logical luvw(3)
+ DOUBLE COMPLEX cpi(13),cpipj(10,13)
+*
+* local variables
+*
+ integer i,j,ier0,ier1
+ DOUBLE PRECISION xmax,absr,absc
+ DOUBLE COMPLEX cc
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absr(cc) = abs(DBLE(cc))
+ absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
+*
+* #] declarations:
+* #[ get differences:
+* simulate the differences in the masses etc..
+ if ( lwrite ) print *,'ffcif4: input cpi: ',cpi
+ if ( cpi(11) .eq. 0 ) then
+ cpi(11) = cpi(5)+cpi(6)+cpi(7)+cpi(8)-cpi(9)-cpi(10)
+ if ( lwarn ) then
+ xmax = max(absr(cpi(5)),absr(cpi(6)),absr(cpi(7)),
+ + absr(cpi(8)),absr(cpi(9)),absr(cpi(10)))
+ if ( absr(cpi(11)) .lt. xloss*xmax )
+ + call ffwarn(153,ier,absr(cpi(11)),xmax)
+ endif
+ luvw(1) = .TRUE.
+ else
+ luvw(1) = .FALSE.
+ endif
+ if ( cpi(12) .eq. 0 ) then
+ cpi(12) = -cpi(5)+cpi(6)-cpi(7)+cpi(8)+cpi(9)+cpi(10)
+ if ( lwarn ) then
+ xmax = max(absr(cpi(5)),absr(cpi(6)),absr(cpi(7)),
+ + absr(cpi(8)),absr(cpi(9)),absr(cpi(10)))
+ if ( absr(cpi(12)) .lt. xloss*xmax )
+ + call ffwarn(154,ier,absr(cpi(12)),xmax)
+ endif
+ luvw(2) = .TRUE.
+ else
+ luvw(2) = .FALSE.
+ endif
+ if ( cpi(13) .eq. 0 ) then
+ cpi(13) = cpi(5)-cpi(6)+cpi(7)-cpi(8)+cpi(9)+cpi(10)
+ if ( lwarn ) then
+ xmax = max(absr(cpi(5)),absr(cpi(6)),absr(cpi(7)),
+ + absr(cpi(8)),absr(cpi(9)),absr(cpi(10)))
+ if ( absr(cpi(13)) .lt. xloss*xmax )
+ + call ffwarn(155,ier,absr(cpi(13)),xmax)
+ endif
+ luvw(3) = .TRUE.
+ else
+ luvw(3) = .FALSE.
+ endif
+ if ( lwarn ) then
+ do 80 i=1,13
+ if ( i .le. 10 ) cpipj(i,i) = 0
+ do 70 j=1,min(i-1,10)
+ cpipj(j,i) = cpi(j) - cpi(i)
+ if ( i .le. 10 ) then
+ cpipj(i,j) = -cpipj(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 70
+ if ( absc(cpipj(j,i)) .lt. xloss*absc(cpi(i))
+ + .and. cpi(i) .ne. cpi(j) ) then
+ ier0 = 0
+ call ffwarn(135,ier0,absc(cpipj(j,i)),
+ + absc(cpi(i)))
+ if ( lwrite ) print *,'between cpi(',i,
+ + ') and cpi(',j,')'
+ endif
+ 70 continue
+ 80 continue
+ else
+ do 100 i=1,13
+ do 90 j=1,10
+ cpipj(j,i) = cpi(j) - cpi(i)
+ 90 continue
+ 100 continue
+ endif
+* #] get differences:
+*###] ffcif4:
+ end
diff --git a/ff/ffcdb0.f b/ff/ffcdb0.f
new file mode 100644
index 0000000..e09a7f6
--- /dev/null
+++ b/ff/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/ffcdbd.f b/ff/ffcdbd.f
new file mode 100644
index 0000000..5d081e9
--- /dev/null
+++ b/ff/ffcdbd.f
@@ -0,0 +1,474 @@
+*--#[ log:
+* $Id: ffcdbd.f,v 1.4 1997/03/27 21:28:07 gj Exp $
+* $Log: ffcdbd.f,v $
+* Revision 1.4 1997/03/27 21:28:07 gj
+* Added explicit check for mass-divergent boxes
+*
+c Revision 1.3 1995/12/12 12:48:13 gj
+c When ndiv=-1 the D0 returns how divergent it was; E0 and F0 use this info to
+c set the non-divergent ones to zero on output when ndiv>0. Same for E0 in F0.
+c
+c Revision 1.2 1995/11/10 18:53:55 gj
+c Added nasty D0 call
+c
+*--#] log:
+*###[ ffcdir:
+ subroutine ffcdir(cs,cfac,ldone,iir,cpi,cdpipj,ipoin,ndiv,ier)
+***#[*comment:***********************************************************
+* *
+* Check if this 4point function is IRdivergent and if so, get it *
+* using ffcdbd and set ldone to .TRUE., otherwise .FALSE. *
+* the place of the IR divergences is returned in iir: *
+* when iir(i,0) != 0 then iir(i,1) is the photon, iir(i,2-3) the *
+* IR particles and iir(i,4) the other one *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer iir(2,4),ipoin,ier,ndiv
+ logical ldone
+ DOUBLE COMPLEX cs,cfac,cpi(13),cdpipj(10,13)
+*
+* local variables
+*
+ integer i,j,k,l,m,ier0,ii(6),notijk(4,4,4),ir
+ DOUBLE COMPLEX dl3p
+ 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:
+*
+ ir = 1
+ iir(ir,1) = 0
+*
+ do 25 i=1,4
+ do 24 j=1,4
+ if ( j .eq. i ) goto 24
+ if ( abs(DBLE(cdpipj(j,inx(j,i)))) .gt. -nwidth*
+ + DIMAG(cpi(j)) ) goto 24
+ do 23 k=j+1,4
+ if ( k .eq. i ) goto 23
+ if ( abs(DBLE(cdpipj(k,inx(k,i)))) .gt. -nwidth*
+ + DIMAG(cpi(k)) ) goto 23
+ l = notijk(k,j,i)
+ if ( abs(DBLE(cpi(i))) .gt. -xloss*(DIMAG(cpi(k)) +
+ + DIMAG(cpi(j))+DIMAG(cpi(l))) ) goto 25
+*
+ if ( abs(DBLE(cdpipj(l,inx(l,i)))) .le. -nwidth*
+ + DIMAG(cpi(l)) ) then
+ if ( lwrite ) print *,'ffcdir: linearly IR ',
+ + 'divergent ',i,j,k,l,cpi
+ if ( ndiv.eq.-1 ) ndiv = 1
+*
+* if possible use Wim & Ansgard's formulae
+*
+ if ( cpi(i).eq.0 ) then
+ if ( cdpipj(inx(i,j),j).eq.0 .and.
+ + cdpipj(inx(i,k),k).eq.0 ) then
+ call ffcdbd(cs,cfac,cpi,cdpipj,i,j,k,l,
+ + ier)
+ goto 99
+ endif
+ if ( cdpipj(inx(i,j),j).eq.0 .and.
+ + cdpipj(inx(i,l),l).eq.0 ) then
+ call ffcdbd(cs,cfac,cpi,cdpipj,i,j,l,k,
+ + ier)
+ goto 99
+ endif
+ if ( cdpipj(inx(i,k),k).eq.0 .and.
+ + cdpipj(inx(i,l),l).eq.0 ) then
+ call ffcdbd(cs,cfac,cpi,cdpipj,i,k,l,j,
+ + ier)
+ goto 99
+ endif
+ else
+ print *,'ffcdir: error: cannot handle ',
+ + 'finite photon mass yet'
+ ier = ier + 100
+ cs = 0
+ cfac = 1
+ goto 99
+ endif
+*
+* it is thus nasty...
+*
+ call ffcdna(cs,cfac,cpi,cdpipj,ier)
+ goto 99
+ elseif ( onshel .and. ndiv.ge.1 ) then
+ if ( lwrite ) print *,'ffcdir: not divergent ',
+ + 'enough, ndiv = ',ndiv
+ cs = 0
+ cfac = 1
+ goto 99
+ endif
+ if ( lwrite ) print *,'ffcdir: IR divergent ',i,j,k,
+ + l,cpi
+ if ( ndiv.eq.-1 ) ndiv = 0
+*
+* it may be doable by W&A algorithm
+*
+ if ( cdpipj(inx(i,j),j).eq.0 .and.
+ + cdpipj(inx(i,k),k).eq.0 ) then
+ call ffcdbd(cs,cfac,cpi,cdpipj,i,j,k,l,ier)
+ goto 99
+ endif
+*
+* it is just a normal logarithmically divergent D0
+*
+ if ( ir.gt.2 ) then
+ call fferr(70,ier)
+ ir = ir-1
+ endif
+ if ( DIMAG(cpi(j)).ne.0 .or. DIMAG(cpi(k)).ne.0 )
+ + then
+ iir(ir,1) = i
+ iir(ir,2) = j
+ iir(ir,3) = k
+ iir(ir,4) = l
+ ir = ir + 1
+ if ( ir.le.2 ) iir(ir,1) = 0
+ endif
+ 23 continue
+ 24 continue
+ 25 continue
+ ldone = .FALSE.
+ if ( ndiv.eq.-1 ) ndiv = 0
+ return
+ 99 continue
+ if ( ldot .and. ipoin .eq. 4 ) then
+ ier0 = 0
+ call ffcot4(cfpij4,cpi,cdpipj,10,ier0)
+ do 122 l=1,10
+ do 121 m=1,10
+ fpij4(m,l) = DBLE(cfpij4(m,l))
+ 121 continue
+ 122 continue
+ ii(1)= 5
+ ii(2)= 6
+ ii(3)= 7
+ ii(4)= 8
+ ii(5)= 9
+ ii(6)= 10
+ call ffcl3p(dl3p,cfpij4,10,ii,ii,ier0)
+ fodel3 = DBLE(dl3p)
+ fdel3 = fodel3
+ endif
+*
+* and finito
+*
+ ldone = .TRUE.
+ return
+* #] work:
+*###] ffcdir:
+ end
+*###[ ffcdbd:
+ subroutine ffcdbd(cs,cfac,cpi,cpipj,ilam,i1,i4,ic,ier)
+***#[*comment:***********************************************************
+* *
+* The IR divergent fourpoint function with one complex mass *
+* according to Beenakker & Denner, Nucl.Phys.B338(1990)349. *
+* *
+* Input: cpi(13) complex momenta^2 *
+* cpipj(10,13) complex cpi(i)-cpi(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: cs,cfac complex D0 = cs*cfac *
+* ier integer number of digits lost *
+* *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ilam,i1,i4,ic,ier
+ DOUBLE COMPLEX cs,cfac,cpi(13),cpipj(10,13)
+*
+* local variables
+*
+ integer ier0,ier1,ipi12,ip,init,is,i2,i3,i,j,iepss
+ DOUBLE PRECISION absc,xmax,xpi(13),dpipj(10,13),xxs(3),xp,xma,
+ + xmb,d,dfflo1
+ DOUBLE COMPLEX c,xxt(3),xx2(3),xx3(3),xm0,xm1,xm4,xlam,
+ + csi(21),z,zlg,zfflog,zfflo1,zxfflg
+ save init
+*for Absoft
+* DOUBLE COMPLEX csqrt
+* external csqrt
+*
+* 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 *,'ffcdbd: using IR cutoff delta = lam^2 = ',delta
+ endif
+ if ( ltest ) then
+ if ( delta .eq. 0 ) print *,'ffcdbd: error: (IR)delta = 0!'
+ if ( max(ilam,i1,i4,ic) .gt. 4 .or. min(ilam,i1,i4,ic) .lt.
+ + 1 ) print *,'ffcdbd: error: ilam,i1,i4,ic not correct ',
+ + ilam,i1,i4,ic
+ if ( cpi(ilam) .ne. 0 ) print *,'ffcdbd: error: lam != 0 ',
+ + ilam,cpi(ilam)
+ if ( cpipj(i1,inx(ilam,i1)) .ne. 0 ) print *,
+ + 'ffcdbd: error: m1^2 != p1^2 ',i1,inx(ilam,i1),cpi(i1),
+ + cpi(inx(ilam,i1)),cpipj(i1,inx(ilam,i1))
+ if ( cpipj(i4,inx(ilam,i4)) .ne. 0 ) print *,
+ + 'ffcdbd: error: m4^2 != p4^2 ',i4,inx(ilam,i4),cpi(i4),
+ + cpi(inx(ilam,i4)),cpipj(i4,inx(ilam,i4))
+ endif
+ if ( cpi(i1).eq.0 .or. cpi(i4).eq.0 ) then
+ call fferr(98,ier)
+ return
+ endif
+* #] check input:
+* #[ real case:
+ if ( nschem.le.3 ) then
+ do 20 i=1,13
+ xpi(i) = DBLE(cpi(i))
+ do 10 j=1,10
+ dpipj(j,i) = DBLE(cpipj(j,i))
+ 10 continue
+ 20 continue
+ lsmug = .TRUE.
+ c2sisj(ilam,ic) = cpipj(ic,inx(ilam,ic))
+ c2sisj(ic,ilam) = cpipj(ic,inx(ilam,ic))
+ c2sisj(i1,ilam) = 0
+ c2sisj(ilam,i1) = 0
+ c2sisj(i4,ilam) = 0
+ c2sisj(ilam,i4) = 0
+ call ffxdbd(cs,cfac,xpi,dpipj,ilam,i1,i4,ic,ier)
+ lsmug = .FALSE.
+ return
+ endif
+* #] real case:
+* #[ get dimensionless vars:
+*
+ xm0 = sqrt(cpi(ic))
+ xm1 = sqrt(cpi(i1))
+ xm4 = sqrt(cpi(i4))
+ xlam = sqrt(delta)
+*
+* we follow the notation of Wim & Ansgar closely
+*
+ xxt(1) = xm0*xlam/cpipj(ic,inx(ilam,ic))
+ xxt(2) = 1-xxt(1)
+ xxt(3) = 1+xxt(1)
+ ier1 = 0
+ ier0 = 0
+* this one is real!
+ xp = DBLE(cpi(inx(i1,i4)))
+ xma = DBLE(xm1)
+ xmb = DBLE(xm4)
+ call ffxkfn(xxs,iepss,xp,xma,xmb,ier0)
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ call ffckfn(xx2,cpi(inx(i1,ic)),xm1,xm0,ier0)
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ call ffckfn(xx3,cpi(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'
+ print *,'xxt = ',xxt
+ print *,'xxs = ',xxs
+ print *,'xx2 = ',xx2
+ print *,'xx3 = ',xx3
+ endif
+*
+* #] get dimensionless vars:
+* #[ fill array:
+*
+ ipi12 = 0
+ ier1 = 0
+ ier0 = 0
+ zlg = zxfflg(xxs(1),iepss,x0,ier)
+ d = xxs(1)**2
+ if ( abs(d) .lt. xloss ) then
+ csi(1) = 2*zlg*DBLE(dfflo1(d,ier0))
+ else
+ csi(1) = 2*zlg*zxfflg(xxs(2)*xxs(3),-iepss,x0,ier0)
+ endif
+ ier1 = max(ier0,ier1)
+ ier0 = 0
+ csi(2) = -2*zlg*log(xxt(1))
+ ier1 = max(ier0,ier1)
+*
+ ipi12 = ipi12 + 6
+*
+ ier0 = 0
+ call ffzxdl(csi(3),ip,zlg,xxs(1)**2,iepss,ier0)
+ ipi12 = ipi12 + ip
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ z = zfflog(xx2(1),0,c0,ier0)
+ csi(4) = z**2
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ z = zfflog(xx3(1),0,c0,ier0)
+ csi(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(csi(is),ip,zlg,DBLE(xxs(1))*xx2(1)**i2*
+ + xx3(1)**i3,ier0)
+ csi(is) = -csi(is)
+ ipi12 = ipi12 - ip
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ if ( abs(xxs(2)) .gt. xloss ) then
+ csi(is) = -zlg*zxfflg(xxs(1),iepss,x0,ier0)
+ else
+ csi(is) = -zlg*DBLE(dfflo1(xxs(2),ier0))
+ endif
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ csi(is) = -zlg*zfflog(xx2(1)**i2,0,c0,ier0)
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ ier0 = 0
+ csi(is) = -zlg*zfflog(xx3(1)**i3,0,c0,ier0)
+ is = is + 1
+ ier1 = max(ier0,ier1)
+*
+ 100 continue
+ 110 continue
+ ier = ier + ier1
+*
+* #] fill array:
+* #[ sum:
+*
+ cs = 0
+ xmax = 0
+ is = is - 1
+ do 200 i=1,is
+ cs = cs + csi(i)
+ xmax = max(xmax,absc(csi(i)))
+ 200 continue
+ cs = cs + ipi12*DBLE(pi12)
+ if ( lwarn .and. absc(cs) .lt. xloss*xmax )
+ + call ffwarn(177,ier,absc(cs),xmax)
+*
+* #] sum:
+* #[ overall factors:
+*
+ cfac = DBLE(xxs(1))/(xm1*xm4*cpipj(inx(ilam,ic),ic)*
+ + DBLE(xxs(2)*xxs(3)))
+*
+* #] overall factors:
+* #[ print debug info:
+ if ( lwrite ) then
+ print *,'csi = '
+ do 910 i=1,is
+ print *,i,csi(i)
+ 910 continue
+ print *,'cs = ',cs,ipi12
+ print *,'overall factor = ',z
+ print *,'cd0 = ',cs*cfac
+ endif
+* #] print debug info:
+*###] ffcdbd:
+ end
+*###[ ffckfn:
+ subroutine ffckfn(x,cpi,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 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments
+*
+ integer ier
+ DOUBLE COMPLEX x(3),cpi,xm,xmp
+*
+* local variables
+*
+ DOUBLE PRECISION absc
+ DOUBLE COMPLEX c,wortel,cc1,cc2,cc3
+*for Absoft
+* DOUBLE COMPLEX csqrt
+* external csqrt
+*
+* common blocks
+*
+ include 'ff.h'
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+*
+* #] declarations:
+* #[ work:
+*
+ cc1 = cpi - (xm-xmp)**2
+ if ( lwarn .and. absc(cc1) .lt. xloss*max(absc(cpi),absc(xm)**2)
+ + ) then
+ call ffwarn(178,ier,absc(cc1),max(absc(cpi),absc(xm)**2))
+ if ( lwrite ) print *,'need extra input'
+ endif
+ cc2 = 1 - 4*xm*xmp/cc1
+ if ( lwarn .and. absc(cc2) .lt. xloss )
+ + call ffwarn(179,ier,absc(cc1),x1)
+ wortel = sqrt(cc2)
+ cc3 = 1/(1+wortel)
+ x(1) = -4*xm*xmp*cc3**2/cc1
+ x(2) = 2*cc3
+ x(3) = 2*wortel*cc3
+*
+* #] work:
+*###] ffckfn:
+ end
diff --git a/ff/ffcel2.f b/ff/ffcel2.f
new file mode 100644
index 0000000..bb2c05f
--- /dev/null
+++ b/ff/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/ffcel3.f b/ff/ffcel3.f
new file mode 100644
index 0000000..d921ddd
--- /dev/null
+++ b/ff/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/ffcel4.f b/ff/ffcel4.f
new file mode 100644
index 0000000..c3ed94e
--- /dev/null
+++ b/ff/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/ffcel5.f b/ff/ffcel5.f
new file mode 100644
index 0000000..1441c4a
--- /dev/null
+++ b/ff/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/ffceta.f b/ff/ffceta.f
new file mode 100644
index 0000000..b059342
--- /dev/null
+++ b/ff/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/ffcli2.f b/ff/ffcli2.f
new file mode 100644
index 0000000..c1c3571
--- /dev/null
+++ b/ff/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/ffcrr.f b/ff/ffcrr.f
new file mode 100644
index 0000000..6f22aee
--- /dev/null
+++ b/ff/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/ffcxr.f b/ff/ffcxr.f
new file mode 100644
index 0000000..81949b0
--- /dev/null
+++ b/ff/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/ffcxs3.f b/ff/ffcxs3.f
new file mode 100644
index 0000000..ebf1f72
--- /dev/null
+++ b/ff/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/ffcxs4.f b/ff/ffcxs4.f
new file mode 100644
index 0000000..1ec9bc1
--- /dev/null
+++ b/ff/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/ffcxyz.f b/ff/ffcxyz.f
new file mode 100644
index 0000000..d0dce8d
--- /dev/null
+++ b/ff/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/ffdcc0.f b/ff/ffdcc0.f
new file mode 100644
index 0000000..11ae1a1
--- /dev/null
+++ b/ff/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/ffdcxs.f b/ff/ffdcxs.f
new file mode 100644
index 0000000..d8e4874
--- /dev/null
+++ b/ff/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/ffdel2.f b/ff/ffdel2.f
new file mode 100644
index 0000000..a9b1ffa
--- /dev/null
+++ b/ff/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/ffdel3.f b/ff/ffdel3.f
new file mode 100644
index 0000000..9d5c9e7
--- /dev/null
+++ b/ff/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/ffdel4.f b/ff/ffdel4.f
new file mode 100644
index 0000000..2cbea20
--- /dev/null
+++ b/ff/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/ffdel5.f b/ff/ffdel5.f
new file mode 100644
index 0000000..e4d95cc
--- /dev/null
+++ b/ff/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/ffdel6.f b/ff/ffdel6.f
new file mode 100644
index 0000000..1a773ed
--- /dev/null
+++ b/ff/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/ffdl2i.f b/ff/ffdl2i.f
new file mode 100644
index 0000000..b72e5cb
--- /dev/null
+++ b/ff/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/ffdl5p.f b/ff/ffdl5p.f
new file mode 100644
index 0000000..091ca37
--- /dev/null
+++ b/ff/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/ffdxc0.f b/ff/ffdxc0.f
new file mode 100644
index 0000000..f143fc7
--- /dev/null
+++ b/ff/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/fferr.dat b/ff/fferr.dat
new file mode 100644
index 0000000..ca18e83
--- /dev/null
+++ b/ff/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/ffini.f b/ff/ffini.f
new file mode 100644
index 0000000..ea4cc44
--- /dev/null
+++ b/ff/ffini.f
@@ -0,0 +1,16 @@
+* $Id: ffini.f,v 1.1 1996/03/27 08:05:18 gj Exp $
+*
+* glue routine for older versions of FF:
+* define ffinit, ffexit to be equal to ffini, ffexi
+*
+* when using CERN libs do *not* include this file, because ffinit
+* already exists in packlib.
+*
+* All programs written after 17-mar-1996 should work without this file
+*
+ subroutine ffinit
+ call ffini
+ end
+ subroutine ffexit
+ call ffexi
+ end
diff --git a/ff/ffinit.f b/ff/ffinit.f
new file mode 100644
index 0000000..a1499db
--- /dev/null
+++ b/ff/ffinit.f
@@ -0,0 +1,1292 @@
+C$Modified: Mon Dec 22 22:54:38 2008 by uwer $
+* $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 2000,'===================================================='
+ print 2000,' FF 2.0, a package to evaluate one-loop integrals'
+ print 2000,'written by G. J. van Oldenborgh, NIKHEF-H, Amsterdam'
+ print 2000,'===================================================='
+ print 2000,'for the algorithms used see preprint NIKHEF-H 89/17,'
+ print 2000,'New Algorithms for One-loop Integrals, by G.J. van'
+ print 2000,'Oldenborgh and J.A.M. Vermaseren, published in '
+ print 2000,'Zeitschrift fuer Physik C46(1990)425.'
+ print 2000,'===================================================='
+* #] 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 = 2.22044604925031e-16
+ precx = precx*8
+* (take three bits for safety)
+ if ( lwrite ) print 2001,'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
+**** Changed 15.06.06:
+ precc = 2.22044604925031e-16
+ precc = precc*8
+* (take three bits for safety)
+ if ( lwrite ) print 2001,'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 ( xalogm.eq.0 ) xalogm = 1d-300
+******** The above comparision doesn't work, set xclogm by hand:
+ xalogm = 1d-300
+********
+ if ( lwrite ) print 2001,'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 ( xclogm.eq.0 ) xclogm = 1d-300
+******** The above comparision doesn't work, set xclogm by hand:
+ xclogm = 1d-300
+********
+ if ( lwrite ) print 2001,'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 = .TRUE.
+ 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.
+
+ 2000 format (' FF: ',A)
+ 2001 format (' FF: ',A, E20.15)
+*
+* #] 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)
+*
+* first try - my home directory
+ path = 'ff/'
+ fullname = path(1:index(path,' ')-1)//name
+ open(ifile,file=fullname,status='OLD',err=30)
+ return
+ 30 continue
+* second try - the system directory
+ call getenv ('HOME', path)
+** path = '~/lib/fortran/FF/ff/'
+ fullname
+ . = path(1:index(path,' ')-1)//'/src/fortran/FF/ff/'//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/ffperm5.dat b/ff/ffperm5.dat
new file mode 100644
index 0000000..942bf3a
--- /dev/null
+++ b/ff/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/ffrcvr.f b/ff/ffrcvr.f
new file mode 100644
index 0000000..23a34dc
--- /dev/null
+++ b/ff/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/ffs.h b/ff/ffs.h
new file mode 100644
index 0000000..4960abf
--- /dev/null
+++ b/ff/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/fftest.f b/ff/fftest.f
new file mode 100644
index 0000000..01e0252
--- /dev/null
+++ b/ff/fftest.f
@@ -0,0 +1,622 @@
+*###[ fftest:
+ subroutine fftest
+***#[*comment:***************************************************
+* test the two-, three- and fourpoint functions *
+* with values in the file input, in the *
+* following order: *
+* @ 4*true/false (lwrite,ltest,l4also,ldc3c4,lmem) *
+* @ 1/2/3/4 two-, three- or fourpoints *
+* @ one line with arbitrary comment *
+* @ 2/2/0/0 renormalization constants (delta,mu) *
+* @ 1/2/3/4 complex (internal) masses *
+* without brackets *
+* @ 0/1/3/6 external momenta (+s,t) (real) *
+* @ # of times the function has to be *
+* evaluated (for timing purposes) *
+* @ 1/3/6 other momenta or 12345 to enter *
+* new comment, masses and momenta *
+* @ # of times *
+* etc *
+***#]*comment:***************************************************
+* #[ declarations:
+ implicit none
+ integer i,k,npoint,nmom,nren,ier,icon,ifile,ial,ntime,ialsav,
+ + iersav,ier0,ier1,ier2,is1,is2,ip,iinx(6,4),imiss
+ parameter(icon=3)
+ parameter(ifile=1)
+ DOUBLE COMPLEX cpi(20),cqi(20),ca0,cb0,cb1,cb0i(3),cc0,cc1i(2),
+ + cc0i(4),cc0r,cd0,cd1i(3),ce0,cd0i(5),ca0i(2),cdb0,cdb0p,
+ + cb2p,cb2d,cb2i(2),cc,cpp,cb01,cb02
+ DOUBLE COMPLEX cai(5),cbij(4,5,5),ccij(13,5,5),cdi(33,5),ce(126)
+ DOUBLE PRECISION xpi(20),xqi(20),delta,a(2),xma,xmb,t1,t2,fftyd,
+ + xnul,xmax,rloss,absc,eps,del2i(4),odel2i(4)
+ character*79 text
+ logical lsquar,lcon,ldotsa
+ integer inew(10,6),inew5(20,12),irota,ntens,ndiv
+ save inew,inew5,iinx
+ common /ffcut/ delta
+ include 'ff.h'
+ 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/
+ data inew /1,2,3,4,5,6,7,8,9,10,
+ + 4,1,2,3,8,5,6,7,10,9,
+ + 3,4,1,2,7,8,5,6,9,10,
+ + 2,3,4,1,6,7,8,5,10,9,
+ + 4,2,3,1,10,6,9,8,7,5,
+ + 1,3,2,4,9,6,10,8,5,7/
+ data inew5
+ + /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/
+ nevent = 0
+* #] declarations:
+* #[ read input:
+ call ffini
+ open(ifile,file='ffinput',status='old')
+ rewind(ifile)
+ read(ifile,*,end=999,err=999)lwrite
+ read(ifile,*,end=999,err=999)ltest
+ read(ifile,*,end=999,err=999)l4also
+ read(ifile,*,end=999,err=999)ldc3c4
+ read(ifile,*,end=999,err=999)lmem
+ read(ifile,*,end=999,err=999)ldot
+ read(ifile,*,end=999,err=999)lwarn
+ read(ifile,*,end=999,err=999)ial
+ read(ifile,*,end=999,err=999)nschem
+ read(ifile,*,end=999,err=999)nwidth
+ read(ifile,*,end=999,err=999)ndiv
+ if ( nwidth.le.0 ) then
+ onshel = .TRUE.
+ else
+ onshel = .FALSE.
+ endif
+ if (lwrite) print *,'fftest: give debug output'
+ if (ltest) print *,'fftest: test consistency'
+ if (l4also) print *,'fftest: consider 4*4 dilogarithms as well'
+ if (ldc3c4) print *,'fftest: consider the difference of the ',
+ + '3point functions as well'
+ if (lmem) print *,'fftest: use memory'
+ if (ldot) print *,'fftest: calculate dotproducts for tensor ',
+ + 'integrals'
+ if ( lwarn ) print *,'fftest: give warning messages'
+ print *,'sign of root in shift, ial = ',ial
+ print *,'fftest: requested scheme = ',nschem
+ print *,'fftest: requested ndiv = ',ndiv
+ if ( nschem .eq. 1 ) then
+ print *,'(use the real masses everywhere)'
+ elseif ( nschem .eq. 2 ) then
+ print *,'(use the complex mass only in poles)'
+ elseif ( nschem .eq. 3 ) then
+ print *,'(use the complex mass in poles and divergent logs)'
+ elseif ( nschem .eq. 4 ) then
+ print *,'(use the complex mass when there are poles or ',
+ + 'divergent logs)'
+ elseif ( nschem .eq. 5 ) then
+ print *,'(use the complex mass when there are poles, ',
+ + 'divergent logs or (0,m,m) thresholds)'
+ elseif ( nschem .eq. 6 ) then
+ print *,'(use the complex mass when there are poles, ',
+ + 'divergent logs or thresholds)'
+ elseif ( nschem .eq. 7 ) then
+ print *,'(use the complex mass everywhere)'
+ endif
+ if ( onshel ) then
+ print *,'using onshell scheme'
+ else
+ print *,'nwidth = ',nwidth
+ endif
+ if ( lwrite ) then
+ open(icon,file='CON:',status='old',err=11)
+ lcon = .TRUE.
+ goto 13
+ endif
+ 11 continue
+ lcon = .FALSE.
+ 13 continue
+ read(ifile,*,end=999,err=999)npoint
+ print *,'fftest:',npoint,' punts functie gevraagd'
+ if ( npoint .lt. 0 ) then
+ lsquar = .TRUE.
+ npoint = -npoint
+ else
+ lsquar = .FALSE.
+ endif
+ if ( npoint .gt. 10 ) then
+ ntens = npoint/10
+ if ( ntens.gt.0 ) ldot = .TRUE.
+ npoint = mod(npoint,10)
+ endif
+ if (npoint.eq.1) then
+ nmom = 0
+ nren = 2
+ elseif (npoint.eq.2) then
+ nmom = 1
+ nren = 2
+ elseif (npoint.eq.3) then
+ nmom = 3
+ nren = 1
+ elseif (npoint.eq.4) then
+ nmom = 6
+ nren = 1
+ elseif (npoint.eq.5) then
+ nmom = 10
+ nren = 1
+ else
+ print*,'error: npoint=',npoint,' not yet implemented'
+ stop
+ endif
+ 1 continue
+ nevent = nevent + 1
+ isgnal = sign(1,ial)
+ read(ifile,'(a)',end=999,err=999)text
+ if ( lcon ) write(icon,'(a)')text
+ if ( text .eq. 'stop' ) stop
+ print '(3a)','####[ ',text,':'
+ print '(a)','--##[ input: '
+ print *,nren,' renormalisatie variabelen'
+ do 14 i=1,nren
+ read(ifile,*,end=999,err=999)a(i)
+ if (i.eq.1)then
+ if ( lsquar ) then
+ delta = a(1)
+ else
+ delta = a(1)**2
+ endif
+ print *,'delta=',delta
+ endif
+ if (i.eq.2)print *,'mu =',a(2)
+ 14 continue
+ 5 do 2 i=1,npoint
+ if ( lsquar ) then
+ read(ifile,*,end=999,err=999) xma,xmb
+ cpi(i) = DCMPLX(xma,xmb)
+ print *,'massa',i,'^2 =',cpi(i)
+ else
+ read(ifile,*,end=999,err=999) xma,xmb
+ cpi(i) = DCMPLX(xma**2,xma*xmb)
+ print *,'massa',i,'^2 =',cpi(i)
+ endif
+ 2 continue
+ do 12 i=1,nmom
+ if ( lsquar ) then
+ read(ifile,*,end=999,err=999) xma
+ cpi(i+npoint) = DCMPLX(DBLE(xma))
+ print *,'pi(',i,')^2 (B&D)=',cpi(i+npoint)
+ else
+ read(ifile,*,end=999,err=999) xma,xmb
+ if ( xmb.eq.0 ) then
+ cpi(i+npoint) = xma**2
+ elseif ( xma.eq.0 ) then
+ cpi(i+npoint) = -xmb**2
+ else
+ print *,'fftest: error: complex p^2????'
+ cpi(i+npoint) = DCMPLX(xma,xmb)**2
+ endif
+ print *,'cpi(',i,')^2 (B&D)=',cpi(i+npoint)
+ endif
+ 12 continue
+ do 16 i=nmom+npoint+1,20
+ cpi(i) = 0
+ 16 continue
+* #] read input:
+* #[ compute onshell quantities:
+ do 17 i=1,nmom+npoint
+ xpi(i) = DBLE(cpi(i))
+ 17 continue
+ do 19 is1=1,npoint
+ do 18 is2=is1+1,npoint
+ if ( npoint.eq.2 ) then
+ ip = 3
+ elseif ( npoint.eq.3 ) then
+ if ( abs(is1-is2).eq.1 ) then
+ ip = is1+3
+ else
+ ip = is2+3
+ endif
+ elseif ( npoint.eq.4 ) then
+ ip = inx(is1,is2)
+ elseif ( npoint.eq.5 ) then
+ ip = inx5(is1,is2)
+ elseif ( onshel ) then
+ print *,'fftest: cannot yet compute onshell ',
+ + 'momenta for npoint>5'
+ stop
+ endif
+ if ( abs(xpi(is1)-xpi(ip)).lt.-5*DIMAG(cpi(is1))
+ + .and. xpi(is2).lt.-DIMAG(cpi(is1)) ) then
+ xpi(ip) = xpi(is1)
+*why? xpi(is2) = 0
+ elseif ( abs(xpi(is2)-xpi(ip)).lt.-5*DIMAG(cpi(is2))
+ + .and. xpi(is1).lt.-DIMAG(cpi(is2)) ) then
+ xpi(ip) = xpi(is2)
+*why? xpi(is1) = 0
+ endif
+ 18 continue
+ 19 continue
+ if ( onshel .and. nschem.lt.7 ) then
+ print *,'onshell:'
+ do 22 i=1,npoint
+ print *,'massa',i,'^2 =',xpi(i)
+ 22 continue
+ do 32 i=1,nmom
+ print *,'pi(',i,')^2 (B&D)=',xpi(i+npoint)
+ 32 continue
+ endif
+ read(ifile,*,end=999,err=999) k
+ print *,'aantal keer (voor timing): ',k
+ print '(a)','--##] input: '
+ id = 1
+* #] compute onshell quantities:
+* #[ one point function:
+**************the one point function******************
+ if (npoint .eq. 1 ) then
+ if ( k.gt.1 ) t1 = fftyd(1)
+ do 100 i=1,k
+ ier = 0
+ call ffza0(ca0,a(1),a(2),cpi(1),xpi(1),ndiv,ier)
+ 100 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ print '(a,2g23.13,i6)','a0 = ',ca0,ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+* #] one point function:
+* #[ two point function:
+**************the two point function******************
+ elseif (npoint .eq. 2 ) then
+ if ( k.gt.1 ) t1 = fftyd(1)
+ do 200 i=1,k
+ ier = 0
+ call ffzb0(cb0,a(1),a(2),cpi(3),cpi(1),cpi(2),
+ + xpi(3),xpi(1),xpi(2),ndiv,ier)
+ 200 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ print '(a,2g23.13,i6)','b0 = ',cb0,ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'b0 = ',cdb0,ier
+ call ffzdb0(cdb0,cdb0p,cpi(3),cpi(1),cpi(2),
+ + xpi(3),xpi(1),xpi(2),ndiv,ier)
+ print '(a,2g23.13,i6)',' b0''= ',cdb0,ier
+ print '(a,2g23.13,i6)','xp*b0''= ',cdb0p,ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'b0''= ',cdb0,ier
+ if ( .not.onshel .or. nschem.ge.7 ) then
+ xnul = absc(cdb0*cpi(3)-cdb0p)
+ else
+ xnul = absc(cdb0*DBLE(xpi(3))-cdb0p)
+ endif
+ rloss = xloss**3*DBLE(10)**(-mod(ier,50))
+ if ( rloss*xnul .gt. precc*absc(cdb0p) ) print *,
+ + 'fftest: error: p^2*B0'' != p^2*B0'':',cpi(3)*cdb0,
+ + cdb0p,xnul
+ if ( .not.onshel .or. nschem.ge.7 ) then
+*
+* check B0'
+*
+ ldotsa = ldot
+ ldot = .FALSE.
+ eps = 1.e-3
+ cpp = cpi(3)*(1-eps/2)
+ ier = 0
+ call ffzb0(cb01,a(1),a(2),cpp,cpi(1),cpi(2),
+ + xpi(3),xpi(1),xpi(2),ndiv,ier)
+ cpp = cpi(3)*(1+eps/2)
+ ier = 0
+ call ffzb0(cb02,a(1),a(2),cpp,cpi(1),cpi(2),
+ + xpi(3),xpi(1),xpi(2),ndiv,ier)
+ cdb0p = (cb02-cb01)/eps
+ print '(a,2g23.13,i6)','xp*b0''~ ',cdb0p,ier
+ ldot = ldotsa
+ endif
+ if ( ntens .ge. 1 ) then
+ call ffza0(ca0i(1),a(1),a(2),cpi(1),xpi(1),ndiv,ier)
+ call ffza0(ca0i(2),a(1),a(2),cpi(2),xpi(2),ndiv,ier)
+ iersav = ier
+ if ( k.gt.1 ) t1 = fftyd(1)
+ do 210 i=1,k
+ ier = iersav
+ call ffzb1(cb1,cb0,ca0i,cpi(3),cpi(1),cpi(2),cfpij2,
+ + xpi(3),xpi(1),xpi(2),fpij2,ier)
+ 210 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ print '(a,2g23.13,i6)','b1 = ',cb1,ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'b1 = ',cb1,ier
+ if ( ntens.gt.1 ) then
+ if ( k.gt.1 ) t1 = fftyd(1)
+ iersav = ier
+ do 220 i=1,k
+ ier = iersav
+ call ffzb2(cb2p,cb2d,cb1,cb0,ca0i,
+ + cpi(3),cpi(1),cpi(2),cfpij2,
+ + xpi(3),xpi(1),xpi(2),fpij2,ier)
+ 220 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ ier1 = ier
+ print '(a,2g23.13,i6)','b2p= ',cb2p,ier
+ print '(a,2g23.13,i6)','b2d= ',cb2d,ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'b2p= ',cb2p,
+ + ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'b2d= ',cb2d,
+ + ier
+ if ( k.gt.1 ) t1 = fftyd(1)
+ do 230 i=1,k
+ ier = iersav
+ call ffzb2p(cb2i,cb1,cb0,ca0i,
+ + cpi(3),cpi(1),cpi(2),cfpij2,
+ + xpi(3),xpi(1),xpi(2),fpij2,ier)
+ 230 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ ier = max(ier,ier1)
+ print '(a,2g23.13,i6)','b21= ',cb2i(1),ier
+ print '(a,2g23.13,i6)','b22= ',cb2i(2),ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'b21= ',cb2i(1),
+ + ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'b22= ',cb2i(2),
+ + ier
+ rloss = xloss**2*10.d0**(-mod(ier,50))
+ if ( cpi(3).ne.0 ) then
+ if ( .not.onshel .or. nschem.ge.7 ) then
+ xnul = absc(cb2p-cb2d*(1/DBLE(cpi(3)))-cb2i(1))
+ xmax = max(absc(cb2p),absc(cb2i(1)))
+ if ( rloss*xnul .gt. precc*xmax ) print *,
+ + 'fftest: error: B21 != Bp - Bd/xp: ',cb2i(1),
+ + cb2p,cb2d*(1/DBLE(cpi(3))),xnul
+ else
+ xnul = absc(cb2p-cb2d*(1/DBLE(xpi(3)))-cb2i(1))
+ xmax = max(absc(cb2p),absc(cb2i(1)))
+ if ( rloss*xnul .gt. precc*xmax ) print *,
+ + 'fftest: error: B21 != Bp - Bd/xp: ',cb2i(1),
+ + cb2p,cb2d*(1/DBLE(xpi(3))),xnul
+ endif
+ endif
+ xnul = absc(cb2d-cb2i(2))
+ if ( rloss*xnul .gt. precc*absc(cb2i(2)) ) print *,
+ + 'fftest: error: B22 != Bd: ',cb2i(2),cb2d,xnul
+ endif
+ endif
+ call ffwarn(998,ier,x0,x0)
+* #] two point function:
+* #[ three point function:
+**************the three point function****************
+ elseif (npoint .eq. 3 ) then
+ if ( k.gt.1 ) t1 = fftyd(1)
+ if ( lwrite ) write(*,'(a)')' #[ C0:'
+ do 300 i=1,k
+ ier = 0
+ call ffzc0(cc0,cpi,xpi,ndiv,ier)
+ 300 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ if ( lwrite ) write(*,'(a)')' #] C0:'
+ print '(a,2g23.13,i6)','c0 = ',cc0,ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'c0 = ',cc0,ier
+ if ( ntens.ge.1 ) then
+ if ( lwrite ) write(*,'(a)')' #[ B0(1):'
+ ier0 = 0
+ call ffzb0(cb0i(1),a(1),a(2),cpi(4),cpi(1),cpi(2),
+ + xpi(4),xpi(1),xpi(2),ndiv,ier0)
+ if ( lwrite ) write(*,'(a)')' #] B0(1): '
+ if ( lwrite ) write(*,'(a)')' #[ B0(2):'
+ ier1 = 0
+ call ffzb0(cb0i(2),a(1),a(2),cpi(5),cpi(2),cpi(3),
+ + xpi(4),xpi(2),xpi(3),ndiv,ier1)
+ ier2 = 0
+ if ( lwrite ) write(*,'(a)')' #] B0(2): '
+ if ( lwrite ) write(*,'(a)')' #[ B0(3):'
+ call ffzb0(cb0i(3),a(1),a(2),cpi(6),cpi(3),cpi(1),
+ + xpi(4),xpi(3),xpi(1),ndiv,ier2)
+ if ( lwrite ) write(*,'(a)')' #] B0(3): '
+ if ( lwrite ) write(*,'(a)')' #[ C1:'
+ do 310 i=1,k
+ ier = max(ier0,ier1,ier2)
+ call ffzc1(cc1i,cc0,cb0i,cpi,cfpij3,fodel2,xpi,fpij3,
+ + fdel2,ier)
+ 310 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ if ( lwrite ) write(*,'(a)')' #] C1:'
+ print '(a,2g23.13,i6)','c11= ',cc1i(1),ier
+ print '(a,2g23.13,i6)','c12= ',cc1i(2),ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'c11= ',cc1i(1),ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'c12= ',cc1i(2),ier
+ endif
+ call ffwarn(998,ier,x0,x0)
+ if ( lcon ) call flush(icon)
+* #] three point function:
+* #[ four point function:
+**************the four point function*****************
+ elseif (npoint .eq. 4 ) then
+ ntime = 1
+ print '(a,i2)','---#[ rotation 1: isgnal = ',isgnal
+ if ( lcon ) write(icon,'(a,i2,a)')'rotation 1, isgnal = ',
+ + isgnal,':'
+ if ( k.gt.1 ) t1 = fftyd(1)
+ do 400 i=1,k
+ ier = 0
+ ialsav = isgnal
+ call ffzd0(cd0,cpi,xpi,ndiv,ier)
+ 400 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ call ffwarn(998,ier,x0,x0)
+ print '(a,i2)','---#] rotation 1: isgnal = ',isgnal
+ print '(a,2g23.13,i6)','d0 = ',cd0,ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'d0 = ',cd0,ier
+ if ( ntens.ge.1 ) then
+ do 404 imiss=1,4
+ if ( lwrite ) write(*,'(a,i1,a)')' #[ C0(',imiss,'):'
+ do 401 i=1,6
+ xqi(i) = xpi(iinx(i,imiss))
+ 401 continue
+ ier0 = 0
+ call ffzc0(cc0i(imiss),cpi(i),xpi(i),ndiv,ier0)
+ del2i(imiss) = fdel2
+ odel2i(imiss) = fodel2
+ ier = max(ier,ier0)
+ if ( lwrite ) write(*,'(a,i1,a)')' #] C0(',imiss,'): '
+ 404 continue
+ if ( lwrite ) write(*,'(a)')' #[ D1:'
+ do 405 i=1,k
+ call ffzd1(cd1i,cd0,cc0i,cpi,cfpij4,fodel3,odel2i,
+ + xpi,fpij4,fdel3,del2i,ier)
+ 405 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ if ( lwrite ) write(*,'(a)')' #] D1:'
+ print '(a,2g23.13,i6)','d11= ',cd1i(1),ier
+ print '(a,2g23.13,i6)','d12= ',cd1i(2),ier
+ print '(a,2g23.13,i6)','d13= ',cd1i(3),ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'cd1= ',cd1i(1),ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'cd2= ',cd1i(2),ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'cd3= ',cd1i(3),ier
+ endif
+ if ( lcon ) call flush(icon)
+ do 410 i=1,10
+ cqi(i) = cpi(i)
+ xqi(i) = xpi(i)
+ 410 continue
+ 420 continue
+ do 440 irota=2,6
+ do 430 i=1,10
+ cpi(inew(i,irota)) = cqi(i)
+ xpi(inew(i,irota)) = xqi(i)
+ 430 continue
+ print '(a,i1,a,i2)','---#[ rotation ',irota,': isgnal = ',
+ + isgnal
+ if ( lcon ) write(icon,'(a,i1,a,i2,a)')'rotation ',
+ + irota,', isgnal = ',isgnal,':'
+ ier = 0
+ id = id + 1
+ isgnal = ialsav
+ call ffzd0(cd0,cpi,xpi,ndiv,ier)
+ call ffwarn(998,ier,x0,x0)
+ print '(a,i1,a,i2)','---#] rotation ',irota,': isgnal = ',
+ + isgnal
+ print '(a,2g23.13,i6)','d0 = ',cd0,ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'d0 = ',cd0,ier
+ if ( lcon ) call flush(icon)
+ 440 continue
+ k = 1
+* Check independence of root chosen
+ isgnal = -sign(1,ial)
+ ialsav = isgnal
+ if ( ntime .eq. 1 ) then
+ ntime = 2
+ print '(a,i2)','---#[ rotation 1: isgnal = ',isgnal
+ if ( lcon ) write(icon,'(a,i2,a)')'rotation 1, isgnal = ',
+ + isgnal,':'
+ ier = 0
+ id = id + 1
+ call ffzd0(cd0,cqi,xqi,ndiv,ier)
+ call ffwarn(998,ier,x0,x0)
+ print '(a,i2)','---#] rotation 1: isgnal = ',isgnal
+ print '(a,2g23.13,i6)','d0 = ',cd0,ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'d0 = ',cd0,ier
+ if ( lcon ) call flush(icon)
+ goto 420
+ endif
+* #] four point function:
+* #[ five point function:
+**************the five point function*****************
+ elseif ( npoint .eq. 5 ) then
+ ntime = 1
+ print '(a,i2)','---#[ rotation 1: isgnal = ',isgnal
+ if ( lcon ) write(icon,'(a,i2,a)')'rotation 1, isgnal = ',
+ + isgnal,':'
+ if ( k.gt.1 ) t1 = fftyd(1)
+ do 500 i=1,k
+ ier = 0
+ ialsav = isgnal
+ call ffzei(cai,cbij,ccij,cdi,ce, a(1),a(2), cpi,xpi,
+ + ndiv,ntens,ier)
+ ce0 = ce(1)
+ 500 continue
+ if ( k.gt.1 ) t2 = fftyd(2)
+ call ffwarn(998,ier,x0,x0)
+ print '(a,i2)','---#] rotation 1: isgnal = ',isgnal
+ print '(a,2g23.13,i6)','e0 = ',ce0,ier
+ if ( k.gt.1 ) print *,' in ',(t2-t1)/k,'sec'
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'e0 = ',
+ + ce0,ier
+ if ( lcon ) call flush(icon)
+ do 510 i=1,20
+ xqi(i) = xpi(i)
+ cqi(i) = cpi(i)
+ 510 continue
+ 520 continue
+ do 540 irota=2,12
+ do 530 i=1,20
+ if ( inew5(i,irota) .le. 0 ) then
+ xpi(-inew5(i,irota)) = 0
+ cpi(-inew5(i,irota)) = 0
+ else
+ xpi(inew5(i,irota)) = xqi(i)
+ cpi(inew5(i,irota)) = cqi(i)
+ endif
+ 530 continue
+ print '(a,i2,a,i2)','---#[ rotation ',irota,
+ + ': isgnal = ',isgnal
+ if ( lcon ) write(icon,'(a,i2,a,i2,a)')'rotation ',
+ + irota,', isgnal = ',isgnal,':'
+ ier = 0
+ id = id + 1
+ isgnal = ialsav
+ call ffze0(ce0,cd0i,cpi,xpi,ndiv,ier)
+ call ffwarn(998,ier,x0,x0)
+ print '(a,i2,a,i2)','---#] rotation ',irota,
+ + ': isgnal = ',isgnal
+ print '(a,2g23.13,i6)','e0 = ',ce0,ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'e0 = ',
+ + ce0,ier
+ if ( lcon ) call flush(icon)
+ 540 continue
+ k = 1
+* Check independence of root chosen
+ isgnal = -sign(1,ial)
+ ialsav = isgnal
+ if ( ntime .eq. 1 ) then
+ ntime = 2
+ print '(a,i2)','---#[ rotation 1: isgnal = ',isgnal
+ if ( lcon ) write(icon,'(a,i2,a)')
+ + 'rotation 1, isgnal = ',isgnal,':'
+ ier = 0
+ id = id + 1
+ call ffze0(ce0,cd0i,cqi,xqi,ndiv,ier)
+ call ffwarn(998,ier,x0,x0)
+ print '(a,i2)','---#] rotation 1: isgnal = ',isgnal
+ print '(a,2g23.13,i6)','e0 = ',ce0,ier
+ if ( lcon ) write(icon,'(a,2g23.13,i6)')'e0 = ',
+ + ce0,ier
+ if ( lcon ) call flush(icon)
+ goto 520
+ endif
+* #] five point function:
+* #[ exit:
+ else
+ print*,'error: npoint=',npoint,' not yet implemented'
+ return
+ endif
+***************************************************
+ call ffexi
+ if ( npoint .eq. 1 ) goto 5
+ print '(3a)','####] ',text,':'
+ goto 1
+ 999 close(ifile)
+* #] exit:
+*###] fftest:
+ end
diff --git a/ff/fftran.f b/ff/fftran.f
new file mode 100644
index 0000000..07a3bf8
--- /dev/null
+++ b/ff/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/ffwarn.dat b/ff/ffwarn.dat
new file mode 100644
index 0000000..0406692
--- /dev/null
+++ b/ff/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/ffxb0.f b/ff/ffxb0.f
new file mode 100644
index 0000000..31bdf24
--- /dev/null
+++ b/ff/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/ffxb1.f b/ff/ffxb1.f
new file mode 100644
index 0000000..602c4cb
--- /dev/null
+++ b/ff/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/ffxb2p.f b/ff/ffxb2p.f
new file mode 100644
index 0000000..8b6a369
--- /dev/null
+++ b/ff/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/ffxc0.f b/ff/ffxc0.f
new file mode 100644
index 0000000..310a69e
--- /dev/null
+++ b/ff/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/ffxc0i.f b/ff/ffxc0i.f
new file mode 100644
index 0000000..7870b44
--- /dev/null
+++ b/ff/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/ffxc0p.f b/ff/ffxc0p.f
new file mode 100644
index 0000000..5a609df
--- /dev/null
+++ b/ff/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/ffxc1.f b/ff/ffxc1.f
new file mode 100644
index 0000000..c702dac
--- /dev/null
+++ b/ff/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(2).eq.xpi(3) .and. xpi(4).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/ffxd0.f b/ff/ffxd0.f
new file mode 100644
index 0000000..937540e
--- /dev/null
+++ b/ff/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/ffxd0h.f b/ff/ffxd0h.f
new file mode 100644
index 0000000..0641227
--- /dev/null
+++ b/ff/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/ffxd0i.f b/ff/ffxd0i.f
new file mode 100644
index 0000000..4080f33
--- /dev/null
+++ b/ff/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/ffxd0p.f b/ff/ffxd0p.f
new file mode 100644
index 0000000..4805434
--- /dev/null
+++ b/ff/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/ffxd1.f b/ff/ffxd1.f
new file mode 100644
index 0000000..b4df6b9
--- /dev/null
+++ b/ff/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/ffxdb0.f b/ff/ffxdb0.f
new file mode 100644
index 0000000..affe1bf
--- /dev/null
+++ b/ff/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/ffxdbd.f b/ff/ffxdbd.f
new file mode 100644
index 0000000..11d1625
--- /dev/null
+++ b/ff/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/ffxdi.f b/ff/ffxdi.f
new file mode 100644
index 0000000..99e3083
--- /dev/null
+++ b/ff/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/ffxdpv.f b/ff/ffxdpv.f
new file mode 100644
index 0000000..efc68f7
--- /dev/null
+++ b/ff/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/ffxe0.f b/ff/ffxe0.f
new file mode 100644
index 0000000..b6cf9fe
--- /dev/null
+++ b/ff/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/ffxe1.f b/ff/ffxe1.f
new file mode 100644
index 0000000..1fc9c14
--- /dev/null
+++ b/ff/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/ffxf0.f b/ff/ffxf0.f
new file mode 100644
index 0000000..d3988c1
--- /dev/null
+++ b/ff/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/ffxf0h.f b/ff/ffxf0h.f
new file mode 100644
index 0000000..9758134
--- /dev/null
+++ b/ff/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/ffxli2.f b/ff/ffxli2.f
new file mode 100644
index 0000000..e7bf7f8
--- /dev/null
+++ b/ff/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/ffxxyz.f b/ff/ffxxyz.f
new file mode 100644
index 0000000..e9bd707
--- /dev/null
+++ b/ff/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/npoin.f b/ff/npoin.f
new file mode 100644
index 0000000..6856bdb
--- /dev/null
+++ b/ff/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/npointes.f b/ff/npointes.f
new file mode 100644
index 0000000..ad11de7
--- /dev/null
+++ b/ff/npointes.f
@@ -0,0 +1,68 @@
+ program testff
+ include 'ff.h'
+* call ffinit
+* lwrite = .TRUE.
+ call form
+ end
+ subroutine FORM
+ implicit DOUBLE PRECISION (A-H,O-Z)
+ DOUBLE COMPLEX TADMU
+ DOUBLE COMPLEX AA0,B0,B0PM,B1,B1PM,B2,C0,C1,C2,C3,D0,D1,D2,D3,D4
+ COMMON PX(6),RM(4),DEL
+ COMMON B0,B0PM,B1,B1PM,B2(2),C0,C1(2),C2(4),C3(6)
+ COMMON D0,D1(3),D2(7),D3(13),D4(22)
+ DEL=0.d0
+ XM=105.6d0**2
+ TADMU=AA0(XM,DEL)
+ PRINT 1,TADMU
+ 1 FORMAT(1H ,4E20.13)
+ PX(1)=-90000.d0**2
+ RM(1)=105.6d0**2
+ RM(2)=0.d0
+ CALL NPOIN(2)
+ PRINT 1,B0,B0PM,B1PM,B2(1)
+ PX(1)=-105.6d0**2
+ PX(2)=PX(1)
+ PX(5)=-90000.d0**2
+ RM(1)=80000.d0**2
+ RM(2)=0.d0
+ RM(3)=80000.d0**2
+ CALL NPOIN(3)
+ PRINT 1,C0,C1(1)
+ PX(1)=-0.511d0**2
+ PX(2)=PX(1)
+ PX(3)=-105.6d0**2
+ PX(4)=PX(3)
+ PX(5)=-80000.d0**2
+ PX(6)=20000.d0**2
+ RM(1)=90000.d0**2
+ RM(2)=0.511d0**2
+ RM(3)=90000.d0**2
+ RM(4)=105.6d0**2
+ CALL NPOIN(4)
+ PRINT 1,D0,D1(1)
+ P12=-0.511d0**2
+ P22=-105.6d0**2
+ P1P2=0.5d0*(20000.d0**2-P12-P22)
+ P10=40000.d0
+ P20=-40000.d0
+ DELE=2000.d0
+ PM2=0.003d0**2
+ BREM=ALIJ(P22,P12,P1P2,P20,P10,DELE,PM2)
+ PRINT 1,BREM
+ call ffexi
+ STOP
+C
+C THE FOLLOWING OUTPUT IS EXPECTED *********************************
+C 0. .9156199386460E+06
+C-.3100623399361E+02 -.2054369006935E+03 -.5269961187649E-14 -.1218492318111E-08
+C .7255214122160E-20 .6092365170853E-09 -.1033542556010E+02 -.6793071440282E+02
+C-.2272160404013E-21 .1739461728623E-08 .3037109802926E-22 -.1286491875423E-08
+C-.2462904245037E-31 .4952559280190E-18 .1165014267077E-31 -.4571732002934E-18
+C-.8203023744960E-05
+C
+C NUMBERS OF ORDER E-20 ARE TO BE CONSIDERED ZERO.
+C
+C ******************************************************************************
+C
+ END
diff --git a/ff/npointes.out b/ff/npointes.out
new file mode 100644
index 0000000..f9ffdc4
--- /dev/null
+++ b/ff/npointes.out
@@ -0,0 +1,35 @@
+ ====================================================
+ 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.
+ ====================================================
+ ffini: precx = 4.44089209E-16
+ ffini: precc = 4.44089209E-16
+ ffini: xalogm = 4.94065645E-324
+ ffini: xclogm = 4.94065645E-324
+ .0000000000000E+00 .9156199386460E+06
+ NPOIN: warning: D4 is not yet supported
+ NPOIN: warning: B1' seems also not yet supported
+ -.3100623399361E+02 -.2054369006935E+03 -.5269961187649E-14 -.1218492318111E-08
+ .0000000000000E+00 .1997630170032+305 -.1033542556010E+02 -.6793071440282E+02
+ .0000000000000E+00 .1739461728624E-08 .0000000000000E+00 -.1286491875423E-08
+ .0000000000000E+00 .4952559280190E-18 .0000000000000E+00 -.4571732002955E-18
+ ALIJ: error: not implemented
+ .0000000000000E+00
+
+total number of errors and warnings
+===================================
+fferr: no errors
+ffwarn: 1 times 18: ffxb0p: warning: cancellations in equal masses, complex roots, can be avoided.
+ (lost at most a factor 8.20 )
+ffwarn: 1 times 129: zxfflg: warning: taking log of number close to 1, must be cured.
+ (lost at most a factor 9.75 )
+ffwarn: 10 times 163: ffxc1: warning: cancellations in cc1.
+ (lost at most a factor 244. )
+ffwarn: 1 times 164: ffxd1: warning: cancellations in cd1.
+ (lost at most a factor 8.33 )
+
diff --git a/ff/readme.md b/ff/readme.md
new file mode 100644
index 0000000..3266459
--- /dev/null
+++ b/ff/readme.md
@@ -0,0 +1,3 @@
+FF A library for evaluating one-loop integrals, Geert Jan van Oldenborgh.
+https://gjvo.home.xs4all.nl/FF.html
+ffinit.f modified as in hathor
\ No newline at end of file
diff --git a/ff/spence.f b/ff/spence.f
new file mode 100644
index 0000000..e0b281f
--- /dev/null
+++ b/ff/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/hathor/HathorWeakCorrections.cxx b/hathor/HathorWeakCorrections.cxx
new file mode 100644
index 0000000..46a7657
--- /dev/null
+++ b/hathor/HathorWeakCorrections.cxx
@@ -0,0 +1,670 @@
+// $Modified: Mon Feb 3 15:17:55 2014 by puwer $
+#include <cmath>
+#include <iostream>
+#include <string>
+#include <sstream>
+#include <stdlib.h>
+//#include "AbstractHathor.h"
+#include "HathorWeakCorrections.h"
+#include "ff_interface.h"
+
+using namespace std;
+
+#define INFO(_X_) cout << #_X_ << endl;
+#define PRINT(_X_) cout <<"# "<< #_X_ <<" = " << _X_ << endl;
+
+class CheckData {
+public:
+ double ecms,z,res;
+};
+
+class InitLoopIntegrals {
+public:
+ InitLoopIntegrals(){
+#ifdef QCDLOOP
+ qlinit_();
+ INFO("FF [1] and QCDLoop [2] are used to calculate the");
+ INFO("scalar one-loop integrals");
+ INFO("[1] van Oldenborgh,");
+ INFO(" \"FF: A Package To Evaluate One Loop Feynman Diagrams\",");
+ INFO(" Comput.Phys.Commun.66:1-15,1991");
+ INFO("[2] R.Keith Ellis, Giulia Zanderighi,");
+ INFO(" \"Scalar one-loop integrals for QCD\", ");
+ INFO(" JHEP 0802:002,2008");
+ INFO("Please cite this properly when you use this program");
+#else
+ INFO("FF [1] is used to calculate the scalar one-loop integrals");
+ INFO("[1] van Oldenborgh,");
+ INFO(" \"FF: A Package To Evaluate One Loop Feynman Diagrams\",");
+ INFO(" Comput.Phys.Commun.66:1-15,1991");
+ INFO("Please cite this properly when you use this program");
+ ffini_();
+ ffcut_.delta = 0.0;
+#endif
+ }
+};
+
+static InitLoopIntegrals dummy;
+
+WeakCorrections::WeakCorrections(double & mb_, double & mz_,double & mw_,
+ double & mh_,
+ double & alpha_,double & swq_,double & hcq_) :
+ mb(mb_), mz(mz_), mw(mw_),mh(mh_), alpha(alpha_),swq(swq_), hcq(hcq_){
+
+ /*
+ * Set default values:
+ */
+ N = 3.0; alphas = 1.;
+ ggtriangle = ggself = ggbox = ggvertex = 1;
+ GammaH = 0; GammaHq = GammaH*GammaH;
+ setScale(170.);
+ lambdat = 1; lambdat2 = lambdat*lambdat;
+ updateCouplings();
+}
+
+void WeakCorrections::setSwq(double value){
+ swq = value;
+ updateCouplings();
+}
+
+void WeakCorrections::setLambdat(double value){
+ lambdat = value; lambdat2 = lambdat*lambdat;
+ //cout << "Using non-SM value for top-quark Yukawa coupling lambda_t = " << lambdat << endl;
+}
+
+void WeakCorrections::check(void){
+ /*
+ * To make sure that the formulae are correct we compare
+ * with old results produced with the code used for
+ * the respective publications.
+ */
+
+ CheckData gg[] = {{400.,0.4711,-0.0901199730013604},
+ {1000.,0.8,-0.216713029203266},
+ {1400,0.2,-0.040614655540509}};
+
+ CheckData qqup[] = {{400.,0.4711,0.0307124934100407},
+ {1000.,0.8,-0.210832061451692},
+ {1400,0.2,-0.0949539670877666}};
+
+ CheckData qqdown[] = {{400.,0.4711,0.0295240331116438},
+ {1000.,0.8,-0.214186485748532},
+ {1400,0.2,-0.0967086144237238}};
+
+ double alphas_data = 0.106823089396409;
+ double alpha_data = 1./126.3;
+ double hcq_data = 0.389379323e9;
+ double mw_data = 80.385, mt_data = 173.2, mb_data = 4.82,
+ mz_data = 91.1876, mh_data = 126.;
+
+ double hcq_tmp = hcq, alpha_tmp=alpha, swq_tmp=swq,
+ mw_tmp = mw, mb_tmp=mb, mz_tmp=mz, mh_tmp=mh,
+ lambdat_tmp=lambdat;
+
+ // Set all parameters to the values used to produce the data above:
+ mb = mb_data;
+ mz = mz_data;
+ mw = mw_data;
+ mh = mh_data;
+ hcq = hcq_data;
+ swq = 1.0 - (mw*mw)/(mz*mz);
+ alpha = alpha_data;
+ lambdat = 1; lambdat2 = lambdat*lambdat;
+ updateCouplings();
+
+ stringstream s;
+ s.precision(15);
+
+ INFO("Check implementation of weak corrections,");
+ INFO("compare with reference values...");
+ INFO("------------------ Gluon channel -------------------");
+ for(unsigned int i=0;i<sizeof(gg)/3/sizeof(double);i++){
+ double res = dsigmaWeakgg(mt_data,gg[i].ecms*gg[i].ecms, gg[i].z);
+ s.str("");
+ s << "Ratio this_prg/ref: "
+ << alphas_data*alphas_data*res/gg[i].res;
+ INFO(s.str());
+ }
+
+ INFO("----------------- Quark channel --------------------");
+ double up,down;
+ for(unsigned int i=0;i<sizeof(gg)/3/sizeof(double);i++){
+ dsigmaWeakqq(mt_data,gg[i].ecms*gg[i].ecms, gg[i].z,up,down);
+ s.str("");
+ s << "Ratio this_prg/ref: "
+ << alphas_data*alphas_data*up/qqup[i].res << " "
+ << alphas_data*alphas_data*down/qqdown[i].res;
+ INFO(s.str());
+ }
+ // Restore the parameter to saved values:
+ mb = mb_tmp;
+ mz = mz_tmp;
+ mw = mw_tmp;
+ mh = mh_tmp;
+ hcq = hcq_tmp;
+ alpha = alpha_tmp;
+ swq = swq_tmp;
+ lambdat = lambdat_tmp; lambdat2 = lambdat*lambdat;
+ updateCouplings();
+}
+
+
+void WeakCorrections::updateCouplings(void){
+ cwq = 1.-swq;
+ gat = 0.5 / sqrt(swq*cwq) * (0.5);
+ gab = 0.5 / sqrt(swq*cwq) * (-0.5);
+ gvt = 0.5 / sqrt(swq*cwq ) * ( + 0.5 - 2.0 * swq * 2./3. );
+ gvb = 0.5 / sqrt(swq*cwq ) * ( - 0.5 - 2.0 * swq * (-1./3.) );
+ gvt2 = gvt*gvt; gat2=gat*gat;
+ gvb2 = gvb*gvb; gab2=gab*gab;
+ gw2 = 1./8./swq;
+ gw = sqrt(gw2);
+}
+
+void WeakCorrections::printParameters(){
+ cout << "# The following parameters are currently used:" << endl;
+ PRINT(hcq);
+ PRINT(alphas);
+ PRINT(1/alpha);
+ PRINT(swq);
+ PRINT(lambdat);
+ PRINT(mt);
+ PRINT(mb);
+ PRINT(mw);
+ PRINT(mz);
+}
+
+double WeakCorrections::dsigmagg(const double mt_, const double sparton,
+ const double z){
+
+ mt = mt_; mtq = mt*mt;
+
+ double z2=z*z,z4=z2*z2;
+ double beta2 = 1.-4*mtq/sparton, beta4=beta2*beta2, beta=sqrt(beta2);
+ double kappa = M_PI*M_PI*alphas*alphas/(1.-z2*beta2)/(1.-z2*beta2)*
+ (N*N-2+N*N*z2*beta2)/N/(N*N-1.);
+
+ return(beta / 4. / M_PI / sparton * kappa *
+ ( 1.+2*beta2-2*z2*beta2-2*beta4+2*z2*beta4-z4*beta4) * hcq );
+}
+
+double WeakCorrections::dsigmaqq(const double mt_, const double sparton,
+ const double z){
+ mt = mt_; mtq = mt*mt;
+ double beta2 = 1.-4.*mtq/sparton;
+ double beta = sqrt(beta2);
+ return( 1./8. * (N*N-1.)/N/N * M_PI * alphas * alphas
+ * beta / sparton * ( 2 + ( z*z - 1 ) *beta2 ) *hcq );
+}
+
+double WeakCorrections::ReC0m(const double shat, const double mq){
+ const double betam = sqrt(1.0-4.0*mq/shat);
+ return(1.0/2.0/shat
+ * ( pow(log( ( 1.0 + betam ) / ( 1.0 - betam ) ),2)
+ - pow(M_PI,2) ) );
+}
+
+double WeakCorrections::ImC0m(const double shat, const double mq){
+ const double betam = sqrt(1.0-4.0*mq/shat);
+ return(- M_PI/shat * log( ( 1.0 + betam ) / ( 1.0 - betam ) ) );
+}
+
+double WeakCorrections::ggtriangles(const double shat, double z){
+ return( Higgs_s_channel(shat,z) + Z_Chi_s_channel(shat,z) );
+}
+
+double WeakCorrections::Higgs_s_channel(const double shat, double z){
+ const double mbq=mb*mb,mhq=mh*mh,mwq=mw*mw;
+ const double beta2 = 1.0-4.0*mtq/shat;
+ const double beta = sqrt(beta2);
+
+ double C0mtRealPart = ReC0m(shat,mtq);
+ double C0mbRealPart = ReC0m(shat,mbq);
+ double C0mtImPart = ImC0m(shat,mtq);
+ double C0mbImPart = ImC0m(shat,mbq);
+
+ if ( mhq > 4. * mtq ) {
+ if ( mhq == 1000.*1000. ){
+ GammaH = 492.471324;
+ GammaHq = GammaH * GammaH;
+ } else {
+ cout << "Required Higgs width not known" << endl;
+ exit(1);
+ }
+ }
+
+ double sigma0 = M_PI * alphas * alphas
+ / 4.0 / (N*N-1.0) * beta/shat;
+
+ return( sigma0 * alpha / M_PI
+ * mtq / ( swq * mwq )
+ / ( (shat-mhq)*(shat-mhq) + mhq*GammaHq )
+ * beta2 / (1.0 - beta2*z*z)
+ * (
+ ( + mtq * ( shat - 4.0 * mtq ) * C0mtRealPart * lambdat2
+ + mbq * ( shat - 4.0 * mbq ) * C0mbRealPart * lambdat
+ - 2.0 * ( mtq * lambdat2 + mbq * lambdat )
+ ) * (shat-mhq)
+ +
+ ( + mtq * ( shat - 4.0 * mtq ) * C0mtImPart * lambdat2
+ + mbq * ( shat - 4.0 * mbq ) * C0mbImPart * lambdat
+ ) * mh * GammaH
+ )
+ );
+
+}
+
+double WeakCorrections::Z_Chi_s_channel(const double shat, double z){
+
+ const double mbq = mb*mb, mzq = mz*mz;
+ const double beta2 = 1.0-4.0*mtq/shat;
+ const double beta = sqrt(beta2);
+
+ double C0mt = ReC0m(shat,mtq);
+ double C0mb = ReC0m(shat,mbq);
+
+ /*
+ * Note that in the following we used the on-shell relation between
+ * mwq, mzq and swq. Using the MSbar value for swq leads than to an
+ * 1 % effect with respect to the version where the on-shell relation
+ * is not used.
+ */
+ double sigma0 = M_PI * alphas * alphas
+ / 4.0 / (N*N-1.0) * beta/shat;
+
+ return( 16.0 * sigma0 * alpha / M_PI
+ * mtq / ( mzq * ( 1.0 - beta2 * z * z ) )
+ * ( gat*gat*mtq*C0mt + gat*gab*mbq*C0mb ) );
+
+}
+
+double WeakCorrections::ggselfenergies(const double shat, double z){
+
+ const double mwq=mw*mw, mzq=mz*mz,mhq=mh*mh, mbq=mb*mb;
+ double selfenergy_Z = 0, selfenergy_H = 0, selfenergy_W = 0,
+ selfenergy_Phi = 0, selfenergy_Chi = 0;
+
+ double t;
+ const double s = shat;
+ const double N2 = N*N;
+
+ double beta2 = 1.0-4.0*mtq/shat;
+ double beta = sqrt(beta2);
+ double beta3 = beta2*beta;
+ double beta4 = beta2*beta2;
+ double beta5 = beta4*beta;
+ double beta6 = beta4*beta2;
+ double beta7 = beta6*beta;
+ double beta8 = beta6*beta2;
+#include "auto/self.dec"
+
+ double z2 = z*z;
+ double z3 = z2 *z;
+ double z4 = z2 * z2;
+ double z5 = z4*z;
+ double z6 = z4*z2;
+
+ t = mtq - s/2.0 * ( 1.0 - beta*z );
+
+ double sigma0 = M_PI * alphas * alphas
+ / 4.0 / (N*N-1.0) * beta/shat;
+
+ for(int i = 0; i < 2; i++ ) {
+#include "auto/self.cpp"
+ z = -z;
+ z3 = z2 *z;
+ z5 = z4*z;
+ t = mtq - s/2.0*(1.0-beta*z);
+ }
+ return(
+ + selfenergy_H * lambdat2
+ + selfenergy_Z
+ + selfenergy_Phi
+ + selfenergy_W
+ + selfenergy_Chi
+ );
+}
+
+double WeakCorrections::ggvertices(const double shat, double z){
+
+ const double mzq=mz*mz,mwq=mw*mw,mhq=mh*mh,mbq=mb*mb;
+ double Z_vertex, H_vertex, W_vertex,Phi_vertex,Chi_vertex;
+ double Z_svertex, H_svertex, W_svertex,Phi_svertex,Chi_svertex;
+
+ double vertices = 0.0, svertices =0.0;
+ double t;
+ const double s = shat;
+
+ const double N2 = N*N;
+
+ const double beta2 = 1.0-4.0*mtq/shat;
+ const double beta = sqrt(beta2);
+
+
+ const double beta3 = beta2*beta;
+ const double beta4 = beta2*beta2;
+ const double beta5 = beta4*beta;
+ const double beta6 = beta4*beta2;
+ const double beta7 = beta6*beta;
+ const double beta8 = beta6*beta2;
+ const double z2 = z*z;
+ double z3 = z2 *z;
+ const double z4 = z2 * z2;
+ double z5 = z4*z;
+ const double z6 = z4*z2;
+
+#include "auto/vertices.dec"
+
+ t = mtq - s/2.0*(1.0-beta*z);
+
+ double sigma0 = M_PI * alphas * alphas
+ / 4.0 / (N*N-1.0) * beta/shat;
+
+ for(int i = 0; i < 2; i++ ) {
+#include "auto/vertices.cpp"
+ vertices +=
+ + Z_vertex
+ + H_vertex * lambdat2
+ + W_vertex
+ + Phi_vertex
+ + Chi_vertex
+ ;
+ // The s-vertex is taken only once !!!
+ svertices =
+ + Z_svertex
+ + H_svertex * lambdat2
+ + W_svertex
+ + Phi_svertex
+ + Chi_svertex
+ ;
+
+ z = -z;
+ z3 = -z3;
+ z5 = -z5;
+ t = mtq - s/2.0*(1.0-beta*z);
+ }
+
+ return( vertices + svertices );
+}
+
+double WeakCorrections::ggboxes(const double shat, double z){
+
+ const double mzq=mz*mz,mwq=mw*mw,mhq=mh*mh,mbq=mb*mb;
+ double Z_box, H_box, W_box,Phi_box,Chi_box;
+
+ double boxes_sum = 0.0;
+ double t;
+ const double s = shat;
+
+ const double beta = sqrt(1.0-4.0*mtq/shat);
+
+#include "auto/boxes.dec"
+
+ double sigma0 = M_PI * alphas * alphas
+ / 4.0 / (N*N-1.0) * beta/shat;
+
+ t = mtq - s/2.0*(1.0-beta*z);
+ for(int i = 0; i < 2; i++ ) {
+#include "auto/boxes.cpp"
+ boxes_sum += Z_box + H_box * lambdat2 + W_box + Phi_box + Chi_box;
+ z = -z;
+ t = mtq - s/2.0*(1.0-beta*z);
+ }
+
+ return( boxes_sum );
+}
+
+double WeakCorrections::dsigmaWeakgg(const double mt_, const double shat,
+ const double z){
+
+ mt = mt_; mtq=mt*mt;
+ double total = 0;
+
+ if (ggtriangle)
+ total += ggtriangles(shat,z);
+
+ if (ggself)
+ total += ggselfenergies(shat,z);
+
+ if (ggbox)
+ total += ggboxes(shat,z);
+
+ if (ggvertex)
+ total += ggvertices(shat,z);
+
+ return( hcq * total );
+
+}
+
+double WeakCorrections::A(double mq){
+ complex<double> cint;
+ int ierr=0;
+ ffxa0_(cint,0.,mu2,mq,ierr);
+ return mycast(cint);
+}
+
+double WeakCorrections::B(double p1q, double m0q, double m1q){
+ complex<double> cint;
+ int ierr=0;
+ ffxb0_(cint, 0.,mu2,p1q , m0q, m1q, ierr);
+ return mycast(cint);
+}
+
+double WeakCorrections::C(double p1q, double p2q, double p5q,
+ double m0q,double m1q, double m2q){
+ /*
+ * Use FF lib to calculate the finite integral:
+ */
+
+ complex <double> cint;
+ double xxpi[6];
+ int ierr=0;
+ xxpi[0] = m0q;
+ xxpi[1] = m1q;
+ xxpi[2] = m2q;
+ xxpi[3] = p1q;
+ xxpi[4] = p2q;
+ xxpi[5] = p5q;
+ ffxc0_(cint,xxpi,ierr);
+ return mycast( cint);
+}
+
+double WeakCorrections::D(double p1q, double p2q, double p3q, double p4q,
+ double p5q, double p7q,
+ double m0q,double m1q, double m2q, double m3q){
+ /*
+ * Use FF lib to calculate the finite integral:
+ */
+ complex <double> cint;
+ double xxpi[13];
+ int ierr = 0;
+ xxpi[0] = m0q;
+ xxpi[1] = m1q;
+ xxpi[2] = m2q;
+ xxpi[3] = m3q;
+ xxpi[4] = p1q;
+ xxpi[5] = p2q;
+ xxpi[6] = p3q;
+ xxpi[7] = p4q;
+ xxpi[8] = p5q;
+ xxpi[9] = p7q;
+ xxpi[10] = 0.0;
+ xxpi[11] = 0.0;
+ xxpi[12] = 0.0;
+ ffxd0_(cint,xxpi,ierr);
+ return(mycast(cint));
+}
+
+
+double WeakCorrections::diffB0(double pq, double m0, double m1){
+ complex<double> r,cint;
+
+ if ( m0*m1 == 0.0 ) {
+ cout << "wrong arguments in RediffB0, m0, m1 must be non-zero\n";
+ exit(1);
+ }
+ double m0q = m0*m0;
+ double m1q = m1*m1;
+ r = ( m0q+m1q-pq
+ + sqrt( complex<double>( (-pq+m1q-2.0*m0*m1+m0q) *
+ (-pq+m1q+2.0*m0*m1+m0q) ) ) ) /m0/m1/2.0;
+
+ if ( r == complex<double>(1.0,0.0) )
+ cint = - (m0q-m1q)/pq/pq*log(m1/m0) - 1.0/pq*2.0;
+ else
+ cint = - (m0q-m1q)/pq/pq*log(m1/m0)
+ + m0*m1/pq/pq*(1.0/r-r)*log(r)
+ - 1.0/pq*(1.0+(r*r+1.0)/(r*r-1.0)*log(r));
+ return(mycast(cint));
+}
+
+double WeakCorrections::f1(double x) {
+ return(
+ 1.0 + 2.0 * ( + ( 1.0 + log(x) ) * ( 2.0*x + 3. )
+ - 2*pow(1.0+x,2)*(ffli2(1.0+1./x)
+ - M_PI*M_PI/6. )
+ )
+ );
+}
+
+double WeakCorrections::F2xs(const double s, const double z, const double Fe,
+ const double Fm, const double Fb) {
+ double beta2 = 1.0-4.0*mtq/s, beta=sqrt(beta2);
+ double sigma0 = 1./8.*M_PI*alphas*alphas*(N*N-1.)/N/N*beta/s;
+ double dsigmadz = sigma0*(2.-beta2+beta2*z*z);
+
+ return(sigma0*alpha/M_PI*((1.-beta2)/beta2*Fe*(1.-z*z) + Fm*(1.+z*z))
+ + dsigmadz*Fb);
+
+}
+
+
+void WeakCorrections::dsigmaWeakqq(const double mt_, const double s,
+ const double z,double & up, double & down){
+
+
+ /*
+ * Formulae are taken from Kühn,Scharf,Uwer, EPJ C45 (2005) 139
+ *
+ * see also below for a mistake in Eq.(35) and Eq.(36)
+ */
+ mt = mt_; mtq=mt*mt;
+ const double mzq=mz*mz,mwq=mw*mw,mhq=mh*mh,mbq=mb*mb;
+ double rz = mzq/s, rw=mwq/s,rb=mbq/s,rh=mhq/s;
+ double rz2 = rz*rz,rw2=rw*rw, rh2=rh*rh, rb2=rb*rb;
+ double beta2 = 1.0-4.0*mtq/s, beta=sqrt(beta2),
+ beta4=beta2*beta2, beta6=beta4*beta2;
+
+ double Amz = A(mzq);
+ double Amt = A(mtq);
+ double Amw = A(mwq);
+ double Amb = A(mbq);
+ double Amh = A(mhq);
+
+ double B01_34 = B(mtq,mzq,mtq);
+ double B03_13 = B(s,mtq,mtq);
+ double B04_12 = B(mtq,mbq,mwq);
+ double B04_13 = B(s,mbq,mbq);
+ double B05_12 = B(mtq,mtq,mhq);
+
+ double C03 = C(mtq,mtq,s,mtq,mzq,mtq);
+ double C04 = C(mtq,mtq,s,mbq,mwq,mbq);
+ double C05 = C(mtq,mtq,s,mtq,mhq,mtq);
+
+ double F_e_Z = (2.0*rz*(gvt2+gat2) - beta2*(gvt2-3*gat2))*(B03_13-B01_34)
+ + 0.5*((4*rz2-beta2)*(gvt2+gat2)-beta4*(gvt2-3*gat2)
+ + 8*rz*beta2*gat2)*s*C03;
+
+ double F_m_Z = (gvt2+gat2)*(-0.5 + 2./( s*(1-beta2))*(Amz-Amt)
+ -(3./2.+rz/beta2)*B03_13
+ +(2+(rz*(1.-3.*beta2))/(beta2*(1-beta2)))*B01_34
+ -0.5/beta2*(beta2*(1+beta2)
+ + 4*rz*beta2+2*rz2)*s*C03);
+
+ double F_B_Z = alpha/2/M_PI*(2.*rz*(gvt2+gat2)+(1.-beta2)*(gvt2-3*gat2))*s
+ * diffB0(mtq,mz,mt);
+
+
+
+ double F_e_W = gw2*( (1+beta2+4*(rw-rb))*(B04_13-B04_12)
+ + 0.25*(pow(1+beta2+4*(rw-rb),2)-4*beta2)*s*C04);
+
+ double F_m_W = gw2*(-1.+4./( s*(1.-beta2))*(Amw-Amb)
+ + 0.5/(beta2*(1-beta2))
+ *(1.+4*beta2-5*beta4+4*(rw-rb)*(1-3*beta2))*B04_12
+ -0.5/beta2*(1.+5*beta2+4*(rw-rb))*B04_13
+ -0.125/beta2*(1.+10*beta2+5*beta4+8*(rw-rb)
+ +8*beta2*(3*rw-rb)+16*pow(rw-rb,2))*s*C04);
+
+ double F_B_W = -alpha/2/M_PI*gw2*(1.-beta2-4*(rw-rb))*s*diffB0(mtq,mb,mw);
+
+ double F_e_H = gw2*mtq/mwq*(2*(beta2+rh)*(B03_13-B05_12)
+ -(beta2*(1-beta2)-3*rh*beta2-2.*rh2)*s*C05);
+
+ double F_m_H = gw2*mtq/mwq*( -0.5 + 2./( s*(1-beta2))*(Amh-Amt)
+ + (0.5-rh/beta2)*B03_13
+ + rh*(1.-3*beta2)/(beta2*(1-beta2))*B05_12
+ -1./beta2*(beta2*(1.-beta2)+rh2)*s*C05);
+
+ double F_B_H = -alpha/2/M_PI*gw2*mtq/mwq*2*(1-beta2-rh)*s*diffB0(mtq,mt,mh);
+
+
+ double F_e_chi = gat2*mtq/mzq*2*(2*rz*(B03_13-B01_34)+(2*rz+beta2)*rz*s*C03);
+
+ double F_m_chi = gat2*mtq/mzq*(-1.+4/( s*(1.-beta2))*(Amz-Amt)
+ +(1-2*rz/beta2)*B03_13
+ +2*rz*(1-3*beta2)/(beta2*(1-beta2))*B01_34
+ -2*rz2/beta2*s*C03);
+
+ double F_B_chi = alpha/2/M_PI*gat2*mtq/mzq*4*rz*s *diffB0(mtq,mt,mz);
+
+
+ /*
+ * In the journal version there is an error in F_e_phi and F_m_phi
+ * affecting the coefficients of (B04_13-B04_12) in F_e_phi
+ * and B04_13 in F_m_phi
+ */
+ double F_e_phi = gw2/8.*s/mwq*( -(beta4+8*beta2*rb+4*rw*beta2-4*rw-1.
+ -16*rw*rb+16*rb2)*(B04_13-B04_12)
+ +0.25*(1-beta6-3*beta2*(1-beta2)
+ -4*beta4*(rb+2*rw)
+ + 8*beta2*rb+16*(1-beta2)*(rw2-rb2)
+ + 64*rb*pow(rb-rw,2)
+ +4*(2*rw-rb))*s*C04);
+
+ double F_m_phi = gw2/2*s/mwq* (-0.25*(1.-beta2+4*rb)
+ + (1-beta2+4*rb) / ( s*(1-beta2) )*(Amw-Amb)
+ +0.125/(beta2*(1-beta2))*(1-3*beta2)
+ *(1-beta2+4*rb)*(1-beta2+4*(rw-rb))*B04_12
+ -0.125/beta2*(-1+beta2-4*rb)
+ *(3*beta2-4*rw-1+4*rb)*B04_13
+ -1./(32*beta2)*(1+beta2-5*beta4+3*beta6
+ +4*(2*rw-rb)
+ +64*rb*pow(rw-rb,2)
+ +16*rw2*(1-beta2)
+ -16*rb2*(1-5*beta2)
+ +4*beta4*(2*rw+7*rb)
+ -8*beta2*(2*rw+3*rb))*s*C04);
+
+ double F_B_phi = -alpha/16./M_PI*gw2*s/mwq*
+ (pow(1-beta2,2)-4*(1-beta2)*(2*rb+rw)-16*rb*(rw-rb))*s*diffB0(mtq,mb,mw);
+
+
+ double Fe = F_e_Z + F_e_W + F_e_H + F_e_chi + F_e_phi;
+ double Fm = F_m_Z + F_m_W + F_m_H + F_m_chi + F_m_phi;
+ double Fb = F_B_Z + F_B_W + F_B_H + F_B_chi + F_B_phi;
+
+ up=down=F2xs(s,z,Fe,Fm,Fb);
+
+ double sigma0 = 1./8.*M_PI*alphas*alphas*(N*N-1.)/N/N*beta/s;
+ double dsigmadz = sigma0*(2.-beta2+beta2*z*z);
+
+ up += -1./8.*alpha/M_PI*((gvt2+gat2)*f1(rz)+2*gw2*f1(rw)) * 2 *dsigmadz;
+ down += -1./8.*alpha/M_PI*((gvb2+gab2)*f1(rz)+2*gw2*f1(rw)) * 2 *dsigmadz;
+
+ // Convert to pb:
+ up *= hcq;
+ down *= hcq;
+
+
+}
diff --git a/hathor/HathorWeakCorrections.h b/hathor/HathorWeakCorrections.h
new file mode 100644
index 0000000..b25ff74
--- /dev/null
+++ b/hathor/HathorWeakCorrections.h
@@ -0,0 +1,58 @@
+/* $Modified: Thu Jan 23 13:33:40 2014 by uwer $ */
+#ifndef HATHORWEAKCORRECTIONS_H_
+#define HATHORWEAKCORRECTIONS_H_
+#include <complex>
+#include <string>
+
+class WeakCorrections {
+ public:
+ WeakCorrections(double & mb_, double & mz_,double & mw_,double & mh_,
+ double & alpha_,double & swq_,double & hcq_);
+ void printParameters();
+ void setAlphas(double value){alphas = value;}
+ void setAlpha(double value){alpha = value;}
+ void setHcq(double value){hcq = value;}
+ void setLambdat(double value);
+ void setSwq(double value);
+ void updateCouplings(void);
+ double dsigmagg(const double mt, const double sparton, const double z);
+ double dsigmaqq(const double mt, const double sparton, const double z);
+ double dsigmaWeakgg(const double mt, const double shat, const double z);
+ void dsigmaWeakqq(const double mt, const double shat, const double z,
+ double & up, double & down);
+ void check();
+
+ private:
+ int ggtriangle,ggself,ggvertex,ggbox;
+ double N;
+ double GammaH,GammaHq;
+ double &mb,&mz,&mw,&mh,&alpha,&swq,&hcq;
+ double mt,mtq,mu2,alphas,cwq,gvt,gat,gab,gvb,lambdat,lambdat2;
+ double gvt2,gat2,gvb2,gab2,gw,gw2;
+
+ void info(std::string s);
+ void setScale(double value){mu2 = value*value;}
+ double ReC0m(const double shat, const double mq);
+ double ImC0m(const double shat, const double mq);
+ double A(double mq);
+ double B(double p1q, double m0q, double m1q);
+ double C(double p1q, double p2q, double p5q,
+ double m0q,double m1q, double m2q);
+ double D(double p1q, double p2q, double p3q, double p4q,
+ double p5q, double p7q,
+ double m0q,double m1q, double m2q, double m3q);
+ double diffB0(double pq, double m0, double m1);
+ double ggtriangles(const double shat, double z);
+ double Higgs_s_channel(const double shat, double z);
+ double Z_Chi_s_channel(const double shat, double z);
+ double ggselfenergies(const double shat, double z);
+ double ggvertices(const double shat, double z);
+ double ggboxes(const double shat, double z);
+
+ double f1(double x);
+ double F2xs(const double s, const double z, const double Fe,
+ const double Fm, const double Fb);
+ inline double mycast(std::complex<double> cint) {return cint.real();}
+
+};
+#endif
diff --git a/hathor/Makefile.am b/hathor/Makefile.am
new file mode 100644
index 0000000..22a31c8
--- /dev/null
+++ b/hathor/Makefile.am
@@ -0,0 +1,8 @@
+AUTOMAKE_OPTIONS = foreign
+
+AM_CPPFLAGS = -I$(srcdir)/../ff
+
+noinst_LTLIBRARIES = libhathor.la
+libhathor_la_SOURCES = HathorWeakCorrections.cxx
+
+pkginclude_HEADERS = HathorWeakCorrections.h
diff --git a/hathor/auto/boxes.cpp b/hathor/auto/boxes.cpp
new file mode 100644
index 0000000..9afbb8f
--- /dev/null
+++ b/hathor/auto/boxes.cpp
@@ -0,0 +1,1331 @@
+// $Modified: Fri Jun 23 14:05:52 2006 by puwer $
+ t1 = N*N;
+ t4 = t1+t1*beta*z-2.0;
+ t5 = alpha*t4;
+ t6 = sigma0;
+ t7 = D(0.0,0.0,mtq,mtq,s,t,mtq,mtq,mtq,mzq);
+ t8 = t7*beta;
+ t9 = mz*mz;
+ t10 = t9*t9;
+ t11 = s*t10;
+ t12 = gat*gat;
+ t13 = t11*t12;
+ t16 = s*s;
+ t17 = t16*t9;
+ t18 = t17*t12;
+ t21 = gvt*gvt;
+ t22 = t17*t21;
+ t25 = beta*beta;
+ t26 = t25*beta;
+ t27 = t7*t26;
+ t28 = t27*s;
+ t29 = z*z;
+ t30 = t29*t10;
+ t31 = t30*t21;
+ t34 = t25*t25;
+ t35 = t34*t34;
+ t36 = t7*t35;
+ t37 = t16*s;
+ t38 = t29*z;
+ t39 = t37*t38;
+ t40 = t39*t21;
+ t43 = t34*t25;
+ t44 = t7*t43;
+ t45 = t44*t16;
+ t46 = t9*t21;
+ t47 = t46*z;
+ t50 = t34*beta;
+ t51 = t7*t50;
+ t52 = t51*t16;
+ t53 = t9*t29;
+ t54 = t53*t21;
+ t57 = t34*t26;
+ t58 = t7*t57;
+ t59 = t58*t16;
+ t62 = t7*t25;
+ t63 = t62*s;
+ t64 = z*t10;
+ t65 = t64*t21;
+ t68 = t11*t21;
+ t71 = t7*t34;
+ t72 = t71*t16;
+ t73 = t9*t38;
+ t74 = t73*t12;
+ t79 = t30*t12;
+ t82 = t53*t12;
+ t91 = 8.0*t8*t13-8.0*t8*t18-8.0*t8*t22-96.0*t28*t31-8.0*t36*t40+6.0*t45*
+t47-62.0*t52*t54+6.0*t59*t54+88.0*t63*t65-8.0*t51*t68-12.0*t72*t74+4.0*t58*t22
+-32.0*t28*t79-62.0*t52*t82+74.0*t45*t74-90.0*t59*t82-40.0*t51*t13;
+ t92 = t73*t21;
+ t97 = t35*t25;
+ t98 = t7*t97;
+ t99 = t39*t12;
+ t102 = t62*t16;
+ t103 = t9*z;
+ t104 = t103*t12;
+ t107 = t36*t16;
+ t110 = t35*beta;
+ t111 = t7*t110;
+ t112 = t37*t29;
+ t113 = t112*t12;
+ t116 = t44*s;
+ t117 = t10*t12;
+ t118 = t117*z;
+ t125 = t37*z;
+ t126 = t125*t12;
+ t131 = t71*s;
+ t132 = t38*t10;
+ t133 = t132*t21;
+ t140 = t51*s;
+ t145 = t29*t29;
+ t146 = t37*t145;
+ t147 = t146*t12;
+ t152 = 10.0*t45*t92-28.0*t58*t18+3.0*t98*t99+12.0*t102*t104-4.0*t107*t47
+-27.0*t111*t113+40.0*t116*t118+28.0*t107*t104+8.0*t116*t65+25.0*t36*t126+52.0*
+t72*t92+32.0*t131*t133+36.0*t36*t99+44.0*t102*t47-96.0*t140*t79-32.0*t140*t31
+-6.0*t111*t147-14.0*t72*t104;
+ t154 = t9*t145;
+ t155 = t154*t21;
+ t158 = t37*t21;
+ t159 = t158*z;
+ t166 = t10*t9;
+ t167 = t166*t21;
+ t168 = t167*z;
+ t171 = A(mtq);
+ t172 = t171*t26;
+ t175 = t154*t12;
+ t180 = B(mtq,mtq,mzq);
+ t182 = t25*s;
+ t183 = t182*t21;
+ t186 = t166*t12;
+ t187 = t186*z;
+ t190 = t132*t12;
+ t204 = t27*t16;
+ t207 = -4.0*t59*t155-11.0*t36*t159+2.0*t107*t92-8.0*t63*t118+16.0*t71*
+t168-32.0*t172*t12-4.0*t59*t175+2.0*t107*t74+8.0*t180*t38*t183+16.0*t71*t187+
+32.0*t131*t190-2.0*t98*t159-8.0*t52*t155-8.0*t52*t175+6.0*t98*t126-32.0*t27*
+t186*t29+16.0*t204*t82;
+ t208 = C(s,mtq,mtq,mtq,mtq,mzq);
+ t209 = t208*t34;
+ t212 = t208*t16;
+ t213 = t35*z;
+ t217 = t208*s;
+ t218 = t217*t43;
+ t221 = C(0.0,0.0,s,mtq,mtq,mtq);
+ t222 = t221*t25;
+ t223 = t16*z;
+ t224 = t223*t21;
+ t230 = C(0.0,t,mtq,mtq,mtq,mzq);
+ t231 = t230*t50;
+ t232 = t16*t145;
+ t233 = t232*t21;
+ t240 = A(mzq);
+ t241 = t240*t26;
+ t246 = B(t,mtq,mzq);
+ t247 = t246*t35;
+ t248 = s*t38;
+ t249 = t248*t21;
+ t252 = t217*t25;
+ t255 = t180*t34;
+ t256 = t145*z;
+ t257 = t256*s;
+ t258 = t257*t21;
+ t263 = B(s,mtq,mtq);
+ t264 = t263*t26;
+ t267 = t221*t34;
+ t268 = t267*s;
+ t271 = t263*t25;
+ t272 = t248*t12;
+ t275 = t146*t21;
+ t278 = 32.0*t209*t65-10.0*t212*t213*t21+116.0*t218*t74+32.0*t222*t224
+-32.0*t27*t167*t29+26.0*t231*t233-80.0*t204*t54+68.0*t218*t104+32.0*t241*t12+
+8.0*t44*t159-4.0*t247*t249+28.0*t252*t47-8.0*t255*t258-36.0*t255*t249+12.0*t264
+*t155+16.0*t268*t74+6.0*t271*t272-7.0*t58*t275;
+ t281 = t208*t26;
+ t282 = t281*s;
+ t285 = t208*t43;
+ t286 = t16*t256;
+ t287 = t286*t21;
+ t290 = t29*s;
+ t291 = t290*t12;
+ t294 = t209*s;
+ t295 = t256*t9;
+ t296 = t295*t12;
+ t299 = t230*t34;
+ t300 = t16*t38;
+ t301 = t300*t12;
+ t310 = t246*t25;
+ t311 = s*z;
+ t312 = t311*t21;
+ t315 = t246*t34;
+ t318 = t37*t256;
+ t322 = t112*t21;
+ t327 = t246*t50;
+ t328 = t290*t21;
+ t333 = t246*t26;
+ t338 = 136.0*t282*t82+4.0*t285*t287+86.0*t264*t291+48.0*t294*t296+20.0*
+t299*t301+48.0*t62*t187+6.0*t62*t159+48.0*t62*t168-16.0*t310*t312-56.0*t315*
+t312+2.0*t44*t318*t21-45.0*t51*t322-32.0*t172*t21-4.0*t327*t328+27.0*t44*t40
+-8.0*t333*t328-7.0*t58*t147;
+ t349 = t299*s;
+ t354 = t180*beta;
+ t363 = t311*t12;
+ t372 = t25*z;
+ t373 = s*t21;
+ t376 = t38*t25;
+ t379 = t145*t50;
+ t382 = -5.0*t51*t275+2.0*t44*t318*t12-56.0*t282*t54-9.0*t44*t99-t98*t40
+-120.0*t349*t104+64.0*t131*t65-60.0*t354*t54+2.0*t111*t275+3.0*t51*t147+102.0*
+t45*t104-18.0*t271*t363-24.0*t8*t68+9.0*t111*t322+128.0*t131*t118-2.0*t372*t373
++2.0*t376*t373-2.0*t379*t373;
+ t384 = t26*t145;
+ t387 = t34*t38;
+ t388 = s*t12;
+ t391 = t34*z;
+ t402 = t50*s;
+ t403 = t29*t21;
+ t408 = t26*t29;
+ t415 = t50*t29;
+ t418 = t34*t256;
+ t423 = t221*beta;
+ t424 = t16*t12;
+ t427 = t16*t21;
+ t430 = -6.0*t384*t373-2.0*t387*t388-2.0*t391*t373-2.0*t391*t388-2.0*t387*
+t373+2.0*t376*t388-2.0*t372*t388+2.0*t402*t403-6.0*t384*t388+6.0*t408*t388-2.0*
+t379*t388+6.0*t408*t373+2.0*t415*t388+4.0*t418*t373+4.0*t418*t388-8.0*t423*t424
+-8.0*t423*t427;
+ t431 = t10*t21;
+ t434 = t221*t50;
+ t439 = t221*t26;
+ t446 = t221*t57;
+ t461 = t208*t50;
+ t464 = t208*t10;
+ t465 = t38*t21;
+ t468 = z*t12;
+ t471 = z*t21;
+ t474 = t38*t12;
+ t480 = -16.0*t423*t431-2.0*t434*t427-2.0*t434*t424-12.0*t439*t427+4.0*
+t439*t424-16.0*t423*t117+2.0*t446*t427-14.0*t446*t424-16.0*t439*t431-16.0*t439*
+t117-6.0*t212*t50*t21-8.0*t212*t26*t21-6.0*t461*t424+12.0*t464*t465-20.0*t464*
+t468-20.0*t464*t471+12.0*t464*t474+2.0*t212*t57*t21;
+ t484 = t208*t57;
+ t487 = t230*beta;
+ t498 = t230*t26;
+ t505 = t230*t57;
+ t514 = t145*t21;
+ t517 = t171*t34;
+ t518 = t256*t21;
+ t521 = t171*t25;
+ t526 = -6.0*t484*t424+8.0*t487*t424+8.0*t487*t427+16.0*t487*t431+2.0*t231
+*t427+2.0*t231*t424+12.0*t498*t427-4.0*t498*t424+16.0*t487*t117-2.0*t505*t427+
+14.0*t505*t424+16.0*t498*t431+16.0*t498*t117-24.0*t172*t514+16.0*t517*t518+8.0*
+t521*t465+56.0*t172*t403;
+ t529 = t145*t12;
+ t532 = t256*t12;
+ t537 = t29*t12;
+ t552 = t240*t34;
+ t555 = t240*t25;
+ t568 = -48.0*t517*t465-24.0*t172*t529+16.0*t517*t532+8.0*t521*t474+56.0*
+t172*t537-48.0*t517*t474-8.0*t521*t471+32.0*t517*t471-8.0*t521*t468+32.0*t517*
+t468+24.0*t241*t514-16.0*t552*t518-8.0*t555*t465-56.0*t241*t403+48.0*t552*t465+
+24.0*t241*t529-16.0*t552*t532-8.0*t555*t474;
+ t584 = t263*beta;
+ t589 = t263*t9;
+ t602 = t180*t9;
+ t607 = -56.0*t241*t537+32.0*t241*t21+48.0*t552*t474+8.0*t555*t471-32.0*
+t552*t471+8.0*t555*t468-32.0*t552*t468-4.0*t584*t373-4.0*t584*t388+12.0*t589*
+t465+12.0*t589*t474-20.0*t589*t468-20.0*t589*t471-4.0*t264*t373-4.0*t264*t388
+-12.0*t602*t465-12.0*t602*t474;
+ t612 = t180*t26;
+ t617 = t180*t50;
+ t622 = t9*t12;
+ t627 = t180*t57;
+ t636 = t246*beta;
+ t643 = t246*t57;
+ t650 = 20.0*t602*t468+20.0*t602*t471-20.0*t612*t373+12.0*t612*t388-8.0*
+t617*t388-24.0*t612*t46-24.0*t612*t622-8.0*t617*t373-20.0*t627*t388-24.0*t617*
+t46-24.0*t617*t622+12.0*t627*t373+4.0*t636*t373+4.0*t636*t388+32.0*t333*t373
+-12.0*t643*t373+20.0*t643*t388-8.0*t333*t46;
+ t666 = t37*t12;
+ t675 = t16*t29;
+ t676 = t675*t12;
+ t679 = t675*t21;
+ t682 = t300*t21;
+ t687 = s*t9;
+ t688 = t687*t21;
+ t691 = t687*t12;
+ t694 = 24.0*t327*t46+24.0*t327*t622-8.0*t333*t622-8.0*t27*t158-t8*t158
+-16.0*t8*t186-16.0*t8*t167+3.0*t8*t666-6.0*t51*t158+3.0*t58*t158-4.0*t27*t666+
+6.0*t439*t676-42.0*t439*t679+22.0*t267*t682-10.0*t267*t301-24.0*t423*t688+8.0*
+t423*t691;
+ t706 = t263*t34;
+ t711 = t222*s;
+ t716 = t223*t12;
+ t727 = t221*t43;
+ t734 = -t58*t666-2.0*t51*t666-16.0*t27*t186-16.0*t27*t167+2.0*t111*t158
+-6.0*t111*t666-58.0*t706*t272+82.0*t72*t47-16.0*t711*t104+80.0*t711*t47-24.0*
+t267*t716+24.0*t267*t224-24.0*t439*t691+16.0*t222*t716-6.0*t434*t679+42.0*t727*
+t716-6.0*t727*t224-6.0*t434*t676;
+ t740 = t439*s;
+ t755 = t232*t12;
+ t770 = t221*t35;
+ t773 = 48.0*t222*t65+48.0*t222*t118-8.0*t740*t82+96.0*t268*t104-72.0*t740
+*t54-24.0*t439*t688-32.0*t434*t691+32.0*t268*t47-4.0*t434*t233-4.0*t434*t755
+-6.0*t727*t682-40.0*t446*t676+8.0*t446*t679+26.0*t727*t301-32.0*t439*t31-32.0*
+t439*t79-2.0*t770*t224;
+ t780 = t434*s;
+ t796 = t208*beta;
+ t814 = t208*t25;
+ t817 = 14.0*t770*t716+16.0*t267*t65+16.0*t267*t118-72.0*t780*t82+16.0*
+t268*t92+32.0*t727*s*t104-8.0*t780*t54-46.0*t461*t679+18.0*t209*t682+14.0*t285*
+t682-4.0*t796*t688+66.0*t461*t676-16.0*t281*t676+2.0*t212*t387*t12+40.0*t212*
+t391*t21-16.0*t212*t391*t12-34.0*t285*t301+8.0*t814*t224;
+ t822 = t43*z;
+ t845 = t796*s;
+ t860 = 18.0*t212*t822*t12-4.0*t796*t691-8.0*t281*t688-8.0*t281*t691+2.0*
+t212*t822*t21+8.0*t814*t716+12.0*t814*t65+12.0*t814*t118-36.0*t814*t133-36.0*
+t814*t190+4.0*t845*t54-4.0*t252*t92+4.0*t845*t82-80.0*t294*t74-36.0*t252*t104+
+32.0*t294*t104+12.0*t252*t74;
+ t865 = t208*t35;
+ t904 = 22.0*t484*t679-6.0*t461*t233-16.0*t865*t682-4.0*t484*t233-36.0*
+t464*t514*beta+60.0*t464*t537*beta+60.0*t464*t403*beta-36.0*t464*t529*beta-66.0
+*t484*t676-14.0*t212*t379*t12+48.0*t865*t301-4.0*t484*t755-24.0*t281*t679+30.0*
+t212*t213*t12-4.0*t461*t688-4.0*t461*t691-76.0*t281*t31+32.0*t209*t118;
+ t910 = t10*t145;
+ t911 = t910*t21;
+ t916 = t910*t12;
+ t919 = t208*t110;
+ t930 = t43*t256;
+ t936 = t217*t50;
+ t949 = -76.0*t281*t79+56.0*t209*t133+12.0*t281*t911+56.0*t209*t190+12.0*
+t281*t916-2.0*t919*t233+4.0*t865*t287+24.0*t464*t518*t25+24.0*t464*t532*t25+
+20.0*t212*t930*t12+6.0*t919*t755-28.0*t936*t54+48.0*t294*t92+32.0*t294*t47-16.0
+*t282*t155-156.0*t936*t82+16.0*t936*t175;
+ t952 = t286*t12;
+ t955 = t110*t29;
+ t968 = t10*t256;
+ t983 = t295*t21;
+ t986 = t217*t57;
+ t995 = -64.0*t282*t175-12.0*t865*t952-24.0*t212*t955*t12+8.0*t212*t955*
+t21-32.0*t461*t31-32.0*t461*t79+8.0*t461*t911-16.0*t209*t968*t21+8.0*t461*t916
+-16.0*t209*t968*t12+4.0*t218*t47+4.0*t218*t92-16.0*t936*t155+16.0*t294*t983+
+16.0*t986*t175-32.0*t218*t296-64.0*t986*t82+4.0*t498*t676;
+ t1004 = t230*t25;
+ t1005 = t1004*s;
+ t1024 = t230*t43;
+ t1035 = 68.0*t498*t679-60.0*t299*t682+24.0*t487*t688+24.0*t1005*t104-8.0*
+t487*t691-104.0*t1005*t47+26.0*t299*t716-38.0*t299*t224+24.0*t498*t691-22.0*
+t1004*t716-38.0*t1004*t224+40.0*t231*t679-46.0*t1024*t716+2.0*t1024*t224-8.0*
+t231*t676-64.0*t1004*t65-64.0*t1004*t118;
+ t1036 = t498*s;
+ t1061 = t230*t35;
+ t1072 = t231*s;
+ t1075 = -8.0*t1036*t82+152.0*t1036*t54+24.0*t498*t688+32.0*t231*t691-56.0
+*t349*t47-6.0*t231*t755-8.0*t1024*t682+80.0*t505*t676-16.0*t505*t679-40.0*t1024
+*t301+80.0*t498*t31+80.0*t498*t79+6.0*t1061*t224-26.0*t1061*t716-32.0*t299*t65
+-32.0*t299*t118-24.0*t349*t74+168.0*t1072*t82;
+ t1079 = t1024*s;
+ t1100 = t230*t110;
+ t1113 = -88.0*t349*t92-64.0*t1079*t104+40.0*t1072*t54-4.0*t1024*t287-4.0*
+t1024*t952-6.0*t505*t233-36.0*t1061*t301+12.0*t1061*t682+26.0*t505*t755-32.0*
+t299*t133-32.0*t299*t190-4.0*t1100*t679+12.0*t1100*t676+16.0*t231*t31+16.0*t231
+*t79+16.0*t1072*t175-72.0*t1079*t74;
+ t1127 = t402*t21;
+ t1130 = t263*t43;
+ t1133 = t145*s;
+ t1134 = t1133*t21;
+ t1157 = 16.0*t1072*t155+32.0*t505*s*t82-8.0*t1079*t92+14.0*t271*t312-10.0
+*t263*t38*t183-14.0*t263*t145*t1127-12.0*t1130*t249+2.0*t264*t1134-2.0*t706*
+t312-2.0*t706*t363+6.0*t706*t249-36.0*t271*t92-36.0*t271*t74-4.0*t271*t104-4.0*
+t271*t47+4.0*t584*t328+4.0*t584*t291+60.0*t584*t54;
+ t1167 = t263*t50;
+ t1172 = t1133*t12;
+ t1197 = 60.0*t584*t82-36.0*t584*t155-36.0*t584*t175+22.0*t1167*t328-8.0*
+t1130*t312-46.0*t264*t1172+18.0*t1167*t1172-10.0*t264*t328-42.0*t1167*t291+24.0
+*t1130*t363+36.0*t1130*t272+24.0*t706*t92+24.0*t706*t74+16.0*t706*t47+16.0*t706
+*t104+12.0*t264*t175-28.0*t264*t54;
+ t1202 = t43*s*t21;
+ t1205 = t263*t57;
+ t1216 = t257*t12;
+ t1237 = t180*t25;
+ t1240 = -28.0*t264*t82+8.0*t263*t256*t1202-4.0*t1205*t1134+4.0*t706*t258+
+24.0*t271*t983+24.0*t271*t296+8.0*t1205*t328+36.0*t706*t1216-24.0*t1130*t1216
+-24.0*t1205*t291+12.0*t1205*t1172+8.0*t1167*t155+8.0*t1167*t175-16.0*t1167*t54
+-16.0*t1167*t82-16.0*t706*t983-16.0*t706*t296+4.0*t1237*t312;
+ t1245 = t180*t43;
+ t1278 = 16.0*t180*t145*t1127+24.0*t1245*t249+4.0*t612*t1134+76.0*t255*
+t272+48.0*t255*t312-48.0*t255*t363+44.0*t1237*t92+44.0*t1237*t74-8.0*t1237*t272
+-12.0*t1237*t104+36.0*t1237*t363-12.0*t1237*t47-4.0*t354*t328-4.0*t354*t291
+-60.0*t354*t82+36.0*t354*t155+36.0*t354*t175;
+ t1316 = -4.0*t617*t328-28.0*t1245*t312+52.0*t612*t1172-108.0*t612*t291
+-48.0*t617*t1172+4.0*t612*t328+124.0*t617*t291+4.0*t1245*t363-56.0*t1245*t272
+-88.0*t255*t92-88.0*t255*t74+32.0*t255*t47+32.0*t255*t104-36.0*t612*t155-36.0*
+t612*t175+92.0*t612*t54+92.0*t612*t82-8.0*t180*t256*t1202;
+ t1343 = t180*t35;
+ t1354 = -4.0*t627*t1134-24.0*t1237*t983-24.0*t1237*t296+4.0*t627*t328
+-40.0*t255*t1216+24.0*t1245*t1216-12.0*t627*t291+12.0*t627*t1172+16.0*t617*t54+
+16.0*t617*t82+32.0*t255*t983+32.0*t255*t296+4.0*t1343*t249-8.0*t1343*t312+24.0*
+t1343*t363-12.0*t1343*t272-8.0*t1245*t92;
+ t1361 = t246*t43;
+ t1392 = -8.0*t1245*t74+16.0*t1245*t47+16.0*t1245*t104+4.0*t1361*t258+4.0*
+t1361*t1216-4.0*t315*t272-16.0*t315*t104-16.0*t1361*t47-16.0*t1361*t104+8.0*
+t1361*t92+8.0*t1361*t74-8.0*t327*t155-8.0*t327*t175-8.0*t333*t54-8.0*t333*t82+
+8.0*t310*t47+8.0*t310*t104-16.0*t315*t47;
+ t1430 = 12.0*t247*t272+36.0*t643*t291-12.0*t643*t328-68.0*t327*t291-20.0*
+t1361*t363+8.0*t1361*t272-24.0*t247*t363+8.0*t247*t312-24.0*t643*t1172+16.0*
+t315*t92+16.0*t315*t74+44.0*t315*t249+8.0*t333*t291+24.0*t327*t1172-24.0*t1361*
+t249+40.0*t315*t363-16.0*t310*t363+44.0*t1361*t312;
+ t1467 = 8.0*t643*t1134-8.0*t327*t1134+10.0*t71*t40-2.0*t71*t99-12.0*t27*
+t322+4.0*t58*t322-32.0*t27*t68-6.0*t62*t126-14.0*t51*t18-32.0*t27*t13+6.0*t27*
+t18-26.0*t27*t22-14.0*t51*t22+13.0*t71*t126-4.0*t44*t126+33.0*t71*t159+7.0*t51*
+t113-24.0*t58*t113;
+ t1474 = 1/N;
+ t1477 = beta*z;
+ t1479 = pow(-1.0+t1477,2.0);
+ t1480 = 1/t1479;
+ t1482 = 1/(1.0+t1477);
+ t1483 = t1480*t1482;
+ t1484 = 1./M_PI;
+ t1486 = 1/s;
+ t1487 = 1/beta;
+ t1491 = 1/(-1.0-t25+2.0*t1477);
+ t1492 = t1486*t1487*t1491;
+ Z_box = t5*t6*(t773+t91+t430+t382+t1354+t480+t568+t1197+t607+t817+t650+
+t338+t694+t1240+t526+t152+t860+t904+t207+t949+t1075+t1113+t1392+t734+t1278+t278
++t1316+t1035+t1430+t1467+t995+t1157)*t1474*t1483*t1484*t1492/8.0;
+ t1498 = (beta-1.0)*(beta+1.0)*alpha;
+ t1499 = t4*t6;
+ t1500 = mh*mh;
+ t1501 = t1500*t1500;
+ t1506 = B(mtq,mtq,mhq);
+ t1507 = t1506*s;
+ t1511 = 24.0*t172*t145;
+ t1512 = A(mhq);
+ t1513 = t1512*t25;
+ t1516 = t263*t1500;
+ t1520 = 8.0*t521*z;
+ t1521 = t434*t16;
+ t1523 = t1506*t1500;
+ t1526 = t423*t16;
+ t1528 = t263*s;
+ t1530 = 4.0*t1528*t26;
+ t1532 = 4.0*t1528*beta;
+ t1533 = D(0.0,0.0,mtq,mtq,s,t,mtq,mtq,mtq,mhq);
+ t1534 = t1533*t26;
+ t1539 = t1533*t50;
+ t1540 = t675*t1500;
+ t1543 = t1528*t376;
+ t1545 = t1528*t387;
+ t1547 = -16.0*t439*t1501-16.0*t423*t1501+12.0*t1507*t26-t1511+8.0*t1513*z
++12.0*t1516*t38-t1520+10.0*t1521+20.0*t1523*z-12.0*t1526-t1530-t1532-3.0*t1534*
+t37-12.0*t1523*t38-14.0*t1539*t1540-6.0*t1543-34.0*t1545;
+ t1549 = 6.0*t1528*t391;
+ t1550 = C(0.0,t,mtq,mtq,mtq,mhq);
+ t1551 = t1550*t35;
+ t1554 = C(s,mtq,mtq,mtq,mtq,mhq);
+ t1555 = t1554*t16;
+ t1560 = t1512*t34;
+ t1565 = t1512*t26;
+ t1575 = 32.0*t517*z;
+ t1577 = 48.0*t517*t38;
+ t1579 = 56.0*t172*t29;
+ t1581 = 8.0*t521*t38;
+ t1583 = 16.0*t517*t256;
+ t1584 = t1550*t26;
+ t1587 = t1550*t57;
+ t1590 = t1550*beta;
+ t1593 = t1549-18.0*t1551*t223+2.0*t1555*t26-20.0*t1516*z-32.0*t1560*z+
+48.0*t1560*t38-56.0*t1565*t29-8.0*t1513*t38-16.0*t1560*t256+24.0*t1565*t145+
+t1575-t1577+t1579+t1581+t1583+16.0*t1584*t1501+10.0*t1587*t16+16.0*t1590*t1501;
+ t1597 = t1550*t50;
+ t1602 = t1533*t110;
+ t1605 = t1501*t1500;
+ t1608 = t1533*beta;
+ t1613 = t402*t29;
+ t1614 = 2.0*t1613;
+ t1615 = B(t,mtq,mhq);
+ t1619 = t1615*t57;
+ t1622 = t1615*t50;
+ t1625 = t1506*t50;
+ t1628 = t1506*t26;
+ t1637 = t1554*t1501;
+ t1640 = -8.0*t1584*t16-10.0*t1597*t16+12.0*t1590*t16-4.0*t1602*t37-16.0*
+t1534*t1605-16.0*t1608*t1605-2.0*t1608*t37+t1614-4.0*t1615*beta*s+12.0*t1619*s+
+24.0*t1622*t1500-24.0*t1625*t1500-24.0*t1628*t1500-8.0*t1507*t50+8.0*t1507*beta
+-4.0*t1555*t57-20.0*t1637*z;
+ t1645 = s*t26;
+ t1646 = t1645*t145;
+ t1647 = 6.0*t1646;
+ t1648 = t1533*t57;
+ t1651 = s*t34;
+ t1652 = t1651*t38;
+ t1653 = 2.0*t1652;
+ t1654 = t182*z;
+ t1655 = 2.0*t1654;
+ t1656 = t1651*t256;
+ t1657 = 4.0*t1656;
+ t1658 = beta*t29;
+ t1660 = 4.0*t1528*t1658;
+ t1661 = s*t1500;
+ t1662 = t1661*t29;
+ t1665 = t1133*t1500;
+ t1668 = t1550*t43;
+ t1669 = t248*t1500;
+ t1672 = t1528*t372;
+ t1674 = t1550*t25;
+ t1675 = t311*t1500;
+ t1678 = t402*t145;
+ t1679 = 2.0*t1678;
+ t1680 = t1645*t29;
+ t1681 = 6.0*t1680;
+ t1686 = t446*t16;
+ t1688 = 12.0*t1637*t38-2.0*t1555*t50-t1647+2.0*t1648*t37-t1653-t1655+
+t1657+t1660+24.0*t1587*t1662+16.0*t1597*t1665-56.0*t1668*t1669-2.0*t1672+56.0*
+t1674*t1675-t1679+t1681-48.0*t1584*t1662+24.0*t727*t1675-10.0*t1686;
+ t1691 = t182*t38;
+ t1692 = 2.0*t1691;
+ t1697 = t1550*t34;
+ t1704 = t1506*t25;
+ t1705 = t1500*z;
+ t1708 = t1500*t38;
+ t1713 = t43*t38;
+ t1730 = t1692-48.0*t1668*t1675+120.0*t1597*t1662-8.0*t1697*t1669+44.0*
+t1587*t675+60.0*t1507*t415-12.0*t1704*t1705+44.0*t1704*t1708+16.0*t1507*t384
+-44.0*t1507*t1713+12.0*t1507*t822-48.0*t1507*t408-4.0*t1507*t1658-4.0*t1507*
+t372+4.0*t1507*t376+48.0*t1507*t387-24.0*t1507*t391;
+ t1733 = t1528*t418;
+ t1735 = t57*t145;
+ t1738 = t57*t29;
+ t1741 = t1500*t256;
+ t1746 = t1500*t145;
+ t1749 = t1500*t29;
+ t1762 = t1528*t379;
+ t1764 = t1528*t415;
+ t1770 = t1528*t384;
+ t1772 = -16.0*t1528*t930+12.0*t1733+8.0*t1528*t1735-16.0*t1528*t1738-16.0
+*t706*t1741+24.0*t271*t1741+8.0*t1167*t1746-16.0*t1167*t1749-28.0*t264*t1749+
+12.0*t264*t1746-36.0*t584*t1746+24.0*t706*t1708+16.0*t706*t1705+18.0*t1762-34.0
+*t1764-4.0*t271*t1705-36.0*t271*t1708-10.0*t1770;
+ t1778 = t1528*t408;
+ t1786 = t1651*z;
+ t1787 = 2.0*t1786;
+ t1788 = t1615*t26;
+ t1791 = 32.0*t172;
+ t1806 = t1533*t34;
+ t1807 = t1605*z;
+ t1810 = 24.0*t1528*t1713+16.0*t1528*t822+38.0*t1778+5.0*t1539*t37+8.0*
+t439*t16-12.0*t1507*t57-t1787-8.0*t1788*t1500-t1791+26.0*t1555*t387-40.0*t1555*
+t408+14.0*t1555*t372-42.0*t1555*t1713+66.0*t1555*t415-72.0*t1697*t1675-18.0*
+t1555*t391+16.0*t1806*t1807;
+ t1816 = t1501*t29;
+ t1819 = s*t1501;
+ t1822 = t770*t223;
+ t1824 = t1501*z;
+ t1831 = t1501*t38;
+ t1834 = t1615*t35;
+ t1837 = t1615*t43;
+ t1840 = t1615*t25;
+ t1849 = t35*t38;
+ t1856 = -32.0*t1534*t1605*t29-4.0*t1602*t146+16.0*t1597*t1816-32.0*t1539*
+t1819+10.0*t1822+16.0*t267*t1824-32.0*t439*t1816-24.0*t434*t1661-32.0*t1697*
+t1831+8.0*t1834*t248+4.0*t1837*t257+8.0*t1840*t311-12.0*t1622*t290+8.0*t1837*
+t248-20.0*t1837*t311-8.0*t1507*t1849+16.0*t1507*t213+16.0*t1507*t930;
+ t1866 = t1506*t43;
+ t1871 = t1506*t34;
+ t1882 = t1506*beta;
+ t1897 = -16.0*t1507*t418+8.0*t1507*t1735-8.0*t1507*t1738-8.0*t1866*t1708+
+16.0*t1866*t1705+32.0*t1871*t1741-24.0*t1704*t1741+16.0*t1625*t1749+92.0*t1628*
+t1749-36.0*t1628*t1746-60.0*t1882*t1749+36.0*t1882*t1746-88.0*t1871*t1708+32.0*
+t1871*t1705-24.0*t1507*t379+60.0*t1637*t1658-16.0*t1590*t1661;
+ t1921 = t35*t256;
+ t1925 = t110*t16;
+ t1935 = t256*t25;
+ t1938 = t1554*t50;
+ t1941 = -64.0*t1674*t1824+8.0*t1584*t1661+18.0*t1587*t232-8.0*t1697*t300
+-52.0*t1597*t675-42.0*t1674*t223+40.0*t1584*t675+50.0*t1697*t223-10.0*t1668*
+t223+8.0*t1550*t110*t675-4.0*t1668*t286-8.0*t1555*t1921+4.0*t1554*t145*t1925
+-16.0*t1554*t110*t675+8.0*t1555*t930-34.0*t1555*t1738+24.0*t1637*t1935-32.0*
+t1938*t1816;
+ t1943 = t1554*t34;
+ t1947 = t1501*t145;
+ t1950 = t145*beta;
+ t1953 = t1533*t25;
+ t1956 = t727*t300;
+ t1958 = t446*t675;
+ t1961 = 4.0*t434*t232;
+ t1968 = t267*t300;
+ t1970 = t434*t675;
+ t1972 = t222*t223;
+ t1974 = t439*t675;
+ t1976 = t267*t223;
+ t1978 = t727*t223;
+ t1980 = t1533*t43;
+ t1983 = -16.0*t1943*t1501*t256+8.0*t1938*t1947-36.0*t1637*t1950+48.0*
+t1953*t1807+18.0*t1956-28.0*t1958-t1961+16.0*t423*t1661+48.0*t222*t1824-8.0*
+t439*t1661-2.0*t1968+18.0*t1970+32.0*t1972-14.0*t1974-44.0*t1976+18.0*t1978+2.0
+*t1980*t318;
+ t1984 = t1533*t97;
+ t1991 = t1615*t34;
+ t2021 = 4.0*t1984*t125-3.0*t1539*t146+60.0*t584*t1749+8.0*t1991*t311-4.0*
+t1788*t290-16.0*t1619*t1133-16.0*t1834*t311+80.0*t1584*t1816-32.0*t1697*t1824+
+24.0*t1597*t1661+24.0*t1619*t290-16.0*t1837*t1705+8.0*t1837*t1708+16.0*t1991*
+t1708-8.0*t1622*t1746-8.0*t1788*t1749+32.0*t1565+8.0*t1840*t1705;
+ t2046 = t1554*t26;
+ t2058 = t35*t16;
+ t2061 = -16.0*t1991*t1705-18.0*t1602*t112-19.0*t1980*t125-24.0*t1551*t300
+-8.0*t1668*t300+64.0*t267*t1675+11.0*t1953*t125+2.0*t1597*t232+22.0*t1539*t112
+-19.0*t1534*t112+11.0*t1806*t39-76.0*t2046*t1816+32.0*t1943*t1824+12.0*t2046*
+t1947+56.0*t1943*t1831-4.0*t1938*t1661+32.0*t1554*t38*t2058;
+ t2067 = t1554*beta;
+ t2070 = t1554*t25;
+ t2077 = t16*t1500;
+ t2082 = t1533*t35;
+ t2103 = 20.0*t1554*t35*t223-8.0*t1555*t379-4.0*t2067*t1661+12.0*t2070*
+t1824-36.0*t2070*t1831-8.0*t2046*t1661-20.0*t1648*t2077-3.0*t1648*t146+23.0*
+t2082*t39+2.0*t1984*t39-16.0*t1980*t39+14.0*t2082*t125-16.0*t1534*t1819+14.0*
+t1534*t2077+6.0*t1539*t2077-5.0*t1648*t112+16.0*t1608*t1819-12.0*t1608*t2077;
+ t2105 = t223*t1500;
+ t2108 = t311*t1501;
+ t2113 = t300*t1500;
+ t2130 = t290*t1501;
+ t2135 = t232*t1500;
+ t2145 = -54.0*t1806*t2105-32.0*t1953*t2108+8.0*t1534*t1540-12.0*t1806*
+t2113+58.0*t1980*t2105+58.0*t1980*t2113-66.0*t1648*t1540+24.0*t1953*t2105+2.0*
+t2082*t2113+32.0*t1980*t2108+20.0*t2082*t2105-16.0*t1534*t2130+96.0*t1806*t2108
+-8.0*t1539*t2135-4.0*t1648*t2135+32.0*t1806*t248*t1501-80.0*t1539*t2130;
+ t2156 = t1554*t43;
+ t2157 = t257*t1500;
+ t2160 = t1554*t57;
+ t2185 = -72.0*t1943*t1669+112.0*t2046*t1662+24.0*t1943*t1675+4.0*t2067*
+t1662-28.0*t2070*t1675-24.0*t2156*t2157+12.0*t2160*t1665+16.0*t1938*t1665+88.0*
+t2156*t1669-48.0*t2160*t1662+24.0*t1943*t2157-116.0*t1938*t1662+52.0*t2156*
+t1675-28.0*t2046*t1665+16.0*t267*t1669-56.0*t434*t1662-40.0*t222*t1675+8.0*t439
+*t1662;
+ t2193 = 1/swq;
+ t2195 = mw*mw;
+ t2196 = 1/t2195;
+ t2198 = t1487*t1491;
+ t2200 = t1483*t2193*t2196*t1484*t2198;
+ H_box = -t1498*t1499*(t1547+t1593+t1640+t1688+t1730+t1772+t1810+t1856+
+t1897+t1941+t1983+t2021+t2061+t2103+t2145+t2185)*t1474*t2200/256.0;
+ t2203 = t5*t6;
+ t2204 = C(0.0,0.0,s,mbq,mbq,mbq);
+ t2205 = t2204*t57;
+ t2208 = B(mtq,mbq,mwq);
+ t2209 = t2208*s;
+ t2212 = C(0.0,t,mtq,mbq,mbq,mwq);
+ t2213 = t2212*t26;
+ t2214 = mb*mb;
+ t2215 = t2214*t2214;
+ t2220 = C(s,mtq,mtq,mbq,mbq,mwq);
+ t2221 = t2195*t2195;
+ t2222 = t2220*t2221;
+ t2225 = B(t,mbq,mwq);
+ t2226 = t2225*t26;
+ t2230 = D(0.0,0.0,mtq,mtq,s,t,mbq,mbq,mbq,mwq);
+ t2231 = t2230*t110;
+ t2233 = t2220*t16;
+ t2236 = t2230*t26;
+ t2237 = t2215*t2214;
+ t2240 = A(mbq);
+ t2241 = t2240*t25;
+ t2244 = t2230*beta;
+ t2247 = A(mwq);
+ t2248 = t2247*t26;
+ t2252 = t2247*t34;
+ t2255 = -4.0*t2205*t16-32.0*t2209*t50+64.0*t2213*t2215-12.0*t2209*t38+
+48.0*t2222*t38+32.0*t2226*t2214+8.0*t1613-t2231*t37-4.0*t2233*t57+64.0*t2236*
+t2237-32.0*t2241*z+64.0*t2244*t2237-224.0*t2248*t29-24.0*t1646+192.0*t2252*t38;
+ t2259 = t2204*t26;
+ t2264 = t2247*t25;
+ t2267 = t2204*beta;
+ t2270 = t2204*t50;
+ t2273 = t2208*t2195;
+ t2276 = B(s,mbq,mbq);
+ t2277 = t2276*t2214;
+ t2282 = t2212*beta;
+ t2285 = t2276*s;
+ t2294 = -128.0*t2252*z-8.0*t1652-64.0*t2259*t2221-64.0*t2252*t256-32.0*
+t2264*t38-64.0*t2267*t2215-12.0*t2270*t16+80.0*t2273*z-48.0*t2277*t38-20.0*
+t2233*t50+28.0*t2282*t16-20.0*t2285*z-7.0*t2244*t37-64.0*t2259*t2215-40.0*t2209
+*t26;
+ t2296 = t2208*t2214;
+ t2311 = t2225*beta;
+ t2314 = t2230*t57;
+ t2326 = 48.0*t2296*t38-48.0*t2273*t38+64.0*t2282*t2221-36.0*t2259*t16+
+36.0*t2213*t16-8.0*t1654+16.0*t1656+32.0*t2264*z+16.0*t2311*s-4.0*t2314*t37+
+56.0*t2226*s-8.0*t1678+80.0*t2277*z+12.0*t2285*t38-16.0*t2285*t26;
+ t2327 = t2220*t2215;
+ t2331 = t2240*t34;
+ t2334 = t2225*t50;
+ t2337 = t2240*t26;
+ t2340 = t2208*t26;
+ t2346 = t2276*t2195;
+ t2359 = t2225*t57;
+ t2362 = t2208*t50;
+ t2365 = 48.0*t2327*t38+24.0*t1680+64.0*t2331*t256+32.0*t2334*s-96.0*t2337
+*t145-96.0*t2340*t2195+96.0*t2296*t26+8.0*t1691+48.0*t2346*t38-80.0*t2222*z+
+224.0*t2337*t29-192.0*t2331*t38+3.0*t2233*t38+64.0*t2282*t2215-8.0*t2359*s-96.0
+*t2362*t2195;
+ t2374 = t2230*t50;
+ t2381 = t2212*t57;
+ t2393 = t2212*t34;
+ t2394 = s*t2195;
+ t2395 = t2394*z;
+ t2398 = t2220*t26;
+ t2399 = t2221*t145;
+ t2404 = -16.0*t2236*t37-80.0*t2346*z+96.0*t2296*t50-12.0*t2374*t37-5.0*
+t2233*z+32.0*t2241*t38+4.0*t2381*t16-28.0*t2267*t16-8.0*t1786-96.0*t2334*t2214+
+128.0*t2331*z-4.0*t2233*beta-288.0*t2393*t2395+48.0*t2398*t2399-16.0*t2285*beta
+;
+ t2413 = t2212*t50;
+ t2416 = t675*t2195;
+ t2421 = t675*t2214;
+ t2426 = t2230*t34;
+ t2427 = t223*t2195;
+ t2432 = t2230*t25;
+ t2433 = t2432*s;
+ t2434 = z*t2195;
+ t2435 = t2434*t2214;
+ t2438 = t16*t2214;
+ t2439 = t2438*z;
+ t2442 = t2394*t2214;
+ t2445 = t311*t2215;
+ t2448 = -32.0*t2226*t2195+96.0*t2248*t145-80.0*t2327*z+64.0*t2213*t2221+
+32.0*t2413*t2394-256.0*t2236*t2416+8.0*t2209*t57+152.0*t2374*t2421+232.0*t2236*
+t2421+220.0*t2426*t2427+96.0*t2334*t2195-416.0*t2433*t2435-164.0*t2432*t2439+
+192.0*t2236*t2442+112.0*t2432*t2445;
+ t2450 = s*t2215;
+ t2451 = t2450*t29;
+ t2456 = t311*t2221;
+ t2461 = t2426*s;
+ t2464 = t2195*t2214;
+ t2465 = t2464*t38;
+ t2468 = t2230*t35;
+ t2471 = t300*t2214;
+ t2474 = t2221*t2214;
+ t2475 = t2474*z;
+ t2478 = t2195*t2215;
+ t2479 = t2478*z;
+ t2482 = s*t2214;
+ t2483 = t2482*t145;
+ t2486 = t2482*t29;
+ t2489 = t2394*t145;
+ t2492 = t29*t2195;
+ t2493 = t2492*t2214;
+ t2498 = -256.0*t2236*t2451+180.0*t2432*t2427+304.0*t2432*t2456+96.0*t2244
+*t2442-512.0*t2461*t2435-352.0*t2461*t2465-12.0*t2468*t2439-8.0*t2468*t2471
+-576.0*t2432*t2475+576.0*t2432*t2479-64.0*t2413*t2483-320.0*t2413*t2486+64.0*
+t2413*t2489-640.0*t2213*t2493+256.0*t2393*t2465;
+ t2503 = t2214*t29;
+ t2516 = t2208*t34;
+ t2517 = t2195*t38;
+ t2526 = t2208*beta;
+ t2531 = t2214*z;
+ t2536 = -64.0*t2267*t2221-136.0*t2334*t290+32.0*t2226*t2503-32.0*t2226*
+t2492-64.0*t2236*t2450+58.0*t2426*t125-68.0*t2236*t112+37.0*t2432*t125-352.0*
+t2516*t2517-368.0*t2296*t408+40.0*t2209*t384+368.0*t2340*t2492+240.0*t2526*
+t2503+144.0*t2296*t384-128.0*t2516*t2531-240.0*t2526*t2492;
+ t2544 = t2204*t43;
+ t2547 = t2204*t34;
+ t2552 = t2204*t25;
+ t2553 = z*t2215;
+ t2560 = z*t2221;
+ t2573 = t29*t2221;
+ t2576 = 128.0*t2267*t2464-64.0*t2267*t2394+28.0*t2544*t223+68.0*t2547*
+t223-88.0*t2259*t675+192.0*t2552*t2553-16.0*t2270*t232+40.0*t2547*t300+192.0*
+t2552*t2560+92.0*t2552*t223-96.0*t2259*t2394+64.0*t2259*t2482+64.0*t2547*t2560
+-32.0*t2270*t2394-128.0*t2259*t2573;
+ t2577 = t2204*t35;
+ t2580 = t29*t2215;
+ t2595 = t2220*s;
+ t2596 = t2214*t38;
+ t2611 = 4.0*t2577*t223-128.0*t2259*t2580+64.0*t2270*t2482+64.0*t2547*
+t2553+128.0*t2259*t2464-16.0*t2205*t675+24.0*t2544*t300-32.0*t2398*t2394-24.0*
+t2595*t2596-15.0*t2233*t376+32.0*t2398*t2482-81.0*t2233*t408+47.0*t2233*t387+
+35.0*t2233*t822+37.0*t2233*t372;
+ t2619 = beta*t2214;
+ t2622 = t2220*t25;
+ t2623 = t2215*t38;
+ t2628 = t2220*beta;
+ t2635 = t2220*t2195;
+ t2644 = t2220*t35;
+ t2647 = t2220*t50;
+ t2650 = 19.0*t2233*t1658+11.0*t2233*t1713+81.0*t2233*t391+16.0*t2595*
+t2619-144.0*t2622*t2623+40.0*t2595*t2531-16.0*t2628*t2394-40.0*t2595*t2434+24.0
+*t2595*t2517-96.0*t2635*t2596+48.0*t2622*t2560+48.0*t2622*t2553+160.0*t2635*
+t2531+12.0*t2644*t223-16.0*t2647*t2394;
+ t2658 = t2214*t145;
+ t2671 = t2220*t34;
+ t2680 = t2215*t145;
+ t2685 = t2221*t38;
+ t2688 = 18.0*t2220*t38*t2058-7.0*t2233*t384+16.0*t2647*t2482-144.0*t2526*
+t2658+164.0*t2209*t415-28.0*t2209*t379-24.0*t2209*t1935-21.0*t2233*t379-9.0*
+t2233*t1950+128.0*t2671*t2553+224.0*t2671*t2623+240.0*t2327*t1658-144.0*t2327*
+t1950+48.0*t2398*t2680-304.0*t2398*t2580-144.0*t2622*t2685;
+ t2695 = t2230*t43;
+ t2698 = t300*t2195;
+ t2701 = t290*t2221;
+ t2710 = t248*t2221;
+ t2713 = t2450*t38;
+ t2716 = t2450*t145;
+ t2719 = t232*t2214;
+ t2728 = 32.0*t2647*t2680+6.0*t2233*t1935-136.0*t2695*t2471+168.0*t2426*
+t2698-352.0*t2236*t2701-192.0*t2426*t2475+96.0*t2374*t2442+12.0*t2413*t16+128.0
+*t2426*t2710+32.0*t2695*t2713-64.0*t2374*t2716+96.0*t2374*t2719-160.0*t2374*
+t2701+192.0*t2426*t2479+224.0*t2426*t2713;
+ t2735 = t2394*t38;
+ t2738 = t2394*t29;
+ t2741 = t2374*s;
+ t2744 = t2464*t145;
+ t2749 = t2695*s;
+ t2754 = t2195*t145;
+ t2759 = t2478*t29;
+ t2762 = t2474*t29;
+ t2767 = 12.0*t2468*t2427+48.0*t2695*t2445+48.0*t2695*t2456-288.0*t2393*
+t2735+288.0*t2413*t2738+352.0*t2741*t2493+64.0*t2741*t2744+20.0*t2209*z-96.0*
+t2749*t2435-32.0*t2749*t2465-144.0*t2340*t2754+88.0*t2695*t2698-384.0*t2236*
+t2759+384.0*t2236*t2762-56.0*t2314*t2416;
+ t2777 = t2212*t25;
+ t2782 = t2212*t43;
+ t2783 = t2482*t38;
+ t2787 = t34*t2214*t38;
+ t2790 = t2464*t256;
+ t2793 = t2482*z;
+ t2802 = t2236*s;
+ t2807 = -192.0*t2374*t2451+64.0*t2314*t2421-232.0*t2374*t2416+224.0*t2426
+*t2445-120.0*t2777*t223-208.0*t2426*t2471+96.0*t2782*t2783-72.0*t2595*t2787+
+128.0*t2671*t2790-32.0*t2552*t2793+32.0*t2381*t2738+256.0*t2393*t2435-64.0*
+t2782*t2395+608.0*t2802*t2493-52.0*t2695*t2439;
+ t2810 = t232*t2195;
+ t2821 = t2276*t25;
+ t2826 = t2394*t256;
+ t2829 = t2220*t57;
+ t2844 = 100.0*t2695*t2427-48.0*t2374*t2810+16.0*t2314*t2719-96.0*t2782*
+t2735+96.0*t2782*t2793-128.0*t2413*t2493-16.0*t2821*t2434-56.0*t2270*t675+48.0*
+t2671*t2826+16.0*t2829*t2489+448.0*t2213*t2738-288.0*t2777*t2395+160.0*t2270*
+t2486-128.0*t2547*t2435-55.0*t2233*t415+192.0*t2547*t2395;
+ t2869 = t2212*t35;
+ t2879 = 64.0*t2547*t2735-224.0*t2259*t2738-384.0*t2552*t2435-224.0*t2547*
+t2793+96.0*t2259*t2486+224.0*t2552*t2395-64.0*t2547*t2783+64.0*t2398*t2486+
+168.0*t2671*t2395-60.0*t2426*t2439-8.0*t2869*t223+288.0*t2426*t2456-96.0*t2270*
+t2738-64.0*t2544*t2793+128.0*t2248;
+ t2892 = t34*t2195*t38;
+ t2905 = t2619*t29;
+ t2908 = beta*t2195;
+ t2909 = t2908*t29;
+ t2914 = 8.0*t2695*t318+256.0*t2259*t2493+128.0*t2516*t2434+96.0*t2622*
+t2783-112.0*t2398*t2738-128.0*t2337+120.0*t2595*t2892-152.0*t2671*t2793+48.0*
+t2622*t2395-256.0*t2671*t2435-96.0*t2622*t2435+288.0*t2622*t2465-136.0*t2595*
+t2905+136.0*t2595*t2909-32.0*t2622*t2793;
+ t2922 = t2215*t256;
+ t2939 = t2212*t110;
+ t2949 = 22.0*t2233*t930-128.0*t2647*t2580+96.0*t2327*t1935-64.0*t2671*
+t2922-304.0*t2398*t2573+224.0*t2671*t2685-13.0*t2233*t1735+128.0*t2671*t2560
+-144.0*t2222*t1950-35.0*t2233*t1738+240.0*t2222*t1658+4.0*t2939*t675-4.0*t2233*
+t1921-128.0*t2647*t2573+2.0*t2220*t145*t1925;
+ t2954 = t2220*t110;
+ t2959 = t2221*t256;
+ t2984 = 96.0*t2222*t1935+8.0*t2233*t418-8.0*t2954*t675+32.0*t2647*t2399
+-64.0*t2671*t2959-16.0*t2782*t286-128.0*t2393*t2560+64.0*t2413*t2580-64.0*t2413
+*t2482+320.0*t2213*t2573-128.0*t2213*t2464+320.0*t2213*t2580-128.0*t2393*t2553
+-128.0*t2393*t2623-80.0*t2782*t300-16.0*t2869*t300;
+ t3017 = 24.0*t2381*t232+44.0*t2381*t675+56.0*t2413*t232-128.0*t2393*t300
+-256.0*t2777*t2553-256.0*t2777*t2560-64.0*t2213*t2482+124.0*t2413*t675-104.0*
+t2393*t223+96.0*t2213*t2394+180.0*t2213*t675-128.0*t2282*t2464-40.0*t2782*t223+
+64.0*t2282*t2394-40.0*t2285*t384;
+ t3018 = t2276*beta;
+ t3049 = -144.0*t3018*t2754+16.0*t2285*t822+24.0*t2285*t1713+64.0*t2285*
+t408-36.0*t2285*t1950+16.0*t2277*t372+76.0*t2285*t1658+144.0*t2277*t376+8.0*
+t2285*t372-144.0*t2821*t2517-56.0*t2285*t376+12.0*t2285*t391-44.0*t2285*t387
+-128.0*t2393*t2685+64.0*t2413*t2573;
+ t3053 = t2276*t34;
+ t3054 = t2195*t256;
+ t3057 = t2276*t50;
+ t3084 = 64.0*t2277*t418-64.0*t3053*t3054-64.0*t3057*t2492+96.0*t2821*
+t3054+64.0*t3057*t2503-32.0*t3057*t2658-16.0*t2285*t1738+40.0*t2285*t418+8.0*
+t2285*t1735-28.0*t2285*t415+24.0*t2285*t1935+4.0*t2285*t379+96.0*t3053*t2517+
+144.0*t3018*t2658+112.0*t2277*t408;
+ t3085 = t2276*t26;
+ t3100 = t2214*t256;
+ t3113 = t2208*t25;
+ t3120 = 48.0*t3085*t2754-48.0*t2277*t384+64.0*t3053*t2434+240.0*t3018*
+t2492-240.0*t3018*t2503-112.0*t3085*t2492+32.0*t3057*t2754-96.0*t2821*t3100
+-16.0*t2285*t930+44.0*t2209*t391+48.0*t2296*t372-76.0*t2209*t1658-52.0*t2209*
+t387+176.0*t3113*t2517+48.0*t2209*t372-48.0*t3113*t2434;
+ t3154 = 56.0*t2209*t376-176.0*t2296*t376-96.0*t3053*t2596-64.0*t3053*
+t2531+144.0*t2526*t2754+16.0*t2209*t1713+352.0*t2516*t2596+36.0*t2209*t1950
+-64.0*t2209*t822-56.0*t2209*t408-80.0*t2622*t2735-448.0*t2671*t2465+608.0*t2398
+*t2493-96.0*t2398*t2744-480.0*t2635*t2905;
+ t3155 = t2220*t43;
+ t3168 = t2658*beta;
+ t3173 = t3100*t25;
+ t3188 = -128.0*t3155*t2783+264.0*t2647*t2486+128.0*t3155*t2735-64.0*t2398
+*t2489+80.0*t3155*t2395-8.0*t2647*t2489+288.0*t2635*t3168-8.0*t2647*t2483-192.0
+*t2635*t3173+16.0*t2398*t2483-280.0*t2647*t2738+72.0*t2595*t3168+256.0*t2647*
+t2493-64.0*t2647*t2744-64.0*t2829*t2738;
+ t3192 = t2482*t256;
+ t3204 = t25*t2195*t256;
+ t3207 = t2908*t145;
+ t3216 = t2221*t2195;
+ t3225 = -32.0*t3155*t2826-16.0*t2671*t3192+32.0*t3155*t3192-16.0*t2829*
+t2483+64.0*t2829*t2486-48.0*t2595*t3173+48.0*t2595*t3204-72.0*t2595*t3207+64.0*
+t2777*t2793+224.0*t2393*t2783-32.0*t2381*t2486-64.0*t2236*t3216-224.0*t2213*
+t2486+288.0*t2393*t2793+512.0*t2777*t2435;
+ t3232 = t2225*t25;
+ t3235 = t2225*t34;
+ t3244 = s*t2221;
+ t3247 = t2225*t43;
+ t3250 = t2225*t35;
+ t3259 = t16*t2195;
+ t3264 = 32.0*t2544*t2395-20.0*t2233*t26-32.0*t2334*t2754+32.0*t3232*t2434
+-64.0*t3235*t2434-64.0*t3235*t2596+44.0*t2244*t2438-16.0*t2244*t2450-80.0*t2244
+*t3244+32.0*t3247*t2517-16.0*t3250*t311+16.0*t3247*t257-24.0*t2359*t1133+30.0*
+t2695*t125-44.0*t2374*t3259-76.0*t2236*t3259;
+ t3297 = 28.0*t2236*t2438-4.0*t2374*t2438-128.0*t2236*t3244-44.0*t2244*
+t3259-80.0*t3155*t2793+32.0*t2334*t2658-64.0*t3247*t2434+192.0*t2244*t2474
+-192.0*t2244*t2478-6.0*t2231*t112+192.0*t2236*t2474-56.0*t3235*t311-32.0*t3247*
+t2596+64.0*t3235*t2531+64.0*t3235*t2517;
+ t3328 = t2208*t43;
+ t3331 = 24.0*t2334*t1133+48.0*t2359*t290+48.0*t3247*t311-40.0*t3247*t248+
+64.0*t3247*t2531-32.0*t3232*t2531-40.0*t2209*t418+16.0*t2209*t1735-32.0*t2209*
+t1738+128.0*t2516*t3054+64.0*t2362*t2492-128.0*t2296*t418-64.0*t2362*t2503-8.0*
+t2226*t290+96.0*t3235*t248-32.0*t3328*t2517;
+ t3335 = t3216*z;
+ t3338 = t2237*z;
+ t3341 = t2230*t97;
+ t3343 = t2237*t29;
+ t3367 = 64.0*t3328*t2434+64.0*t2426*t3335-64.0*t2426*t3338+t3341*t125+
+128.0*t2236*t3343-48.0*t2374*t2450-128.0*t2236*t3216*t29-64.0*t3328*t2531+32.0*
+t3328*t2596-8.0*t2209*t1849+16.0*t2209*t213+96.0*t3113*t3100-96.0*t3113*t3054
+-12.0*t2314*t3259+12.0*t2314*t2438;
+ t3400 = 192.0*t2432*t3335-24.0*t2374*t146-192.0*t2432*t3338-48.0*t2374*
+t3244+14.0*t2468*t39-192.0*t2236*t2478-16.0*t2314*t146-70.0*t2374*t112+10.0*
+t2468*t125-32.0*t2314*t112+54.0*t2426*t39+8.0*t3250*t248+44.0*t2695*t39-56.0*
+t3232*t311-64.0*t2244*t3216-80.0*t2296*z;
+ t3409 = t1482*t2193;
+ W_box = t2203*(t2536+t3084+t2365+t3264+t2404+t2448+t3120+t3049+t2498+
+t3297+t3154+t2914+t2728+t3188+t2576+t3331+t2611+t3225+t2650+t3367+t2688+t2255+
+t3400+t2767+t2294+t2807+t2844+t2879+t2949+t2984+t3017+t2326)*t1474*t1480*t3409*
+t1484*t1492/128.0;
+ t3413 = t35*t26;
+ t3414 = t2230*t3413;
+ t3415 = t16*t16;
+ t3417 = t2208*t16;
+ t3430 = t2220*t37;
+ t3433 = t2220*t2237;
+ t3440 = t2208*t2215;
+ t3445 = -t3414*t3415+40.0*t3417*t26+8.0*t2213*t37-40.0*t3417*t57+40.0*
+t2359*t16-384.0*t2362*t2215+4.0*t2628*t37-3.0*t3430*t38-192.0*t3433*t38-20.0*
+t3417*z-40.0*t2226*t16-192.0*t3440*t38-8.0*t2334*t16;
+ t3454 = t2215*t2215;
+ t3457 = t16*t34;
+ t3460 = t16*t43;
+ t3463 = t16*t57;
+ t3468 = t16*t25;
+ t3473 = t16*t26;
+ t3478 = 320.0*t3433*z-8.0*t2381*t37+8.0*t2413*t37-128.0*t2226*t2215-256.0
+*t2244*t3454-16.0*t3457*t256+16.0*t3460*t256-8.0*t3463*t145+8.0*t3463*t29-8.0*
+t3468*t38+16.0*t3457*t38-24.0*t3473*t29+8.0*t3468*z;
+ t3484 = t16*t50;
+ t3491 = t2276*t16;
+ t3496 = t2276*t2215;
+ t3501 = t2225*t110;
+ t3510 = -8.0*t3460*z-8.0*t3460*t38+16.0*t3484*t29+12.0*t3417*t38+384.0*
+t2334*t2215+16.0*t3491*beta+20.0*t3491*z+192.0*t3496*t38+320.0*t3440*z-8.0*
+t3501*t16+92.0*t2398*t112+16.0*t2311*t16-320.0*t3496*z;
+ t3513 = t3415*t29;
+ t3520 = t2240*t50;
+ t3529 = t2204*t110;
+ t3542 = 512.0*t2337*t2214-6.0*t3414*t3513-384.0*t2340*t2215-16.0*t3491*
+t50-128.0*t3520*s+128.0*t2337*s-256.0*t2213*t2237-256.0*t2282*t2237-4.0*t3529*
+t37+256.0*t2259*t2237-32.0*t3417*beta+256.0*t2267*t2237+8.0*t2205*t37-8.0*t2259
+*t37;
+ t3551 = t2208*t110;
+ t3558 = t2247*t50;
+ t3570 = -8.0*t2270*t37+t2231*t3415+t2236*t3415-4.0*t2954*t37+8.0*t3551*
+t16-128.0*t2248*s-256.0*t2236*t3454+128.0*t3558*s+4.0*t2939*t37+5.0*t3430*z+
+24.0*t3473*t145-t2644*t125-12.0*t3491*t38;
+ t3571 = s*t3216;
+ t3572 = t3571*z;
+ t3577 = t2215*t2221;
+ t3582 = t3415*t38;
+ t3595 = t16*t2221;
+ t3598 = t3454*z;
+ t3603 = 64.0*t2695*t3572-16.0*t2829*t3259-768.0*t2244*t3577+24.0*t3417*
+t50+14.0*t2468*t3582-512.0*t2248*t2214-4.0*t2374*t3415+3.0*t2244*t3415-80.0*
+t3053*t2395-240.0*t2285*t2909-48.0*t2314*t3595+256.0*t2426*t3598+48.0*t2236*
+t3595;
+ t3609 = t3415*z;
+ t3616 = t2247*t43;
+ t3619 = t16*t2215;
+ t3634 = -128.0*t3232*t2793-48.0*t2285*t2517-4.0*t2468*t3609+5.0*t3341*
+t3609+12.0*t2267*t37-64.0*t3616*t257+32.0*t2314*t3619-76.0*t3491*t1658-64.0*
+t2821*t2553-24.0*t2233*t2517-36.0*t3491*t1713-128.0*t2622*t2456-128.0*t3232*
+t2435;
+ t3637 = t3415*t256;
+ t3642 = t37*t2214;
+ t3645 = t2237*t2195;
+ t3666 = -20.0*t2233*t2531-8.0*t2695*t3637-16.0*t2374*t3595-16.0*t2314*
+t3642+768.0*t2244*t3645-32.0*t402*t2503+96.0*t1645*t2658+32.0*t402*t2658+256.0*
+t2259*t2474-16.0*t3529*t112-512.0*t2267*t2478+256.0*t2267*t2474+64.0*t2267*
+t3244+64.0*t2267*t2450;
+ t3696 = 48.0*t2267*t2438-8.0*t2544*t125-16.0*t2270*t2438+16.0*t2259*t2438
++32.0*t2259*t3259+40.0*t2547*t125+56.0*t2259*t112-32.0*t2270*t112-40.0*t2547*
+t39-8.0*t2205*t112+8.0*t2577*t125+16.0*t2544*t39-76.0*t3491*t387;
+ t3709 = t3415*t145;
+ t3725 = 12.0*t2695*t3609+1024.0*t2671*t2479-10.0*t2231*t3513-64.0*t3235*
+t300+64.0*t3085*t2482+256.0*t2252*t3100-16.0*t2231*t3709+108.0*t3491*t408-16.0*
+t2244*t3642-512.0*t2236*t3454*t29+128.0*t3155*t2456+80.0*t2285*t2434-17.0*t2432
+*t3609;
+ t3753 = 32.0*t2374*t3642+32.0*t2236*t3642-12.0*t3417*t1735-768.0*t2236*
+t3577+32.0*t1651*t2531-96.0*t1645*t2503-32.0*t182*t2596+32.0*t182*t2531+32.0*
+t1651*t2596-12.0*t2282*t37+8.0*t2468*t3637-576.0*t2821*t2623-44.0*t2552*t125;
+ t3758 = t3216*t2214;
+ t3783 = -64.0*t1651*t3100+24.0*t2374*t3709+256.0*t2236*t3758+64.0*t2393*
+t2439+512.0*t2259*t3343+100.0*t3491*t376+768.0*t2432*t3598+24.0*t2577*t39-512.0
+*t2259*t2478-64.0*t2270*t3244+16.0*t2205*t2438-32.0*t2205*t3259-64.0*t2270*
+t2450+16.0*t2270*t146;
+ t3795 = t2237*t38;
+ t3814 = 4.0*t2204*t97*t125-256.0*t2547*t3338+40.0*t2233*t2434+16.0*t2628*
+t3259+576.0*t2622*t3795-192.0*t2622*t3338-64.0*t2628*t2450-34.0*t2622*t125+32.0
+*t2647*t2438-86.0*t2671*t39+6.0*t3155*t125+20.0*t2829*t112-66.0*t2647*t112;
+ t3843 = 64.0*t2398*t2438+60.0*t3155*t39+12.0*t2671*t125-16.0*t2647*t3259
+-15.0*t2644*t39-48.0*t2595*t2685-80.0*t2595*t2553+48.0*t2595*t2623-19.0*t2628*
+t112+26.0*t2622*t39-192.0*t2222*t2596-640.0*t2635*t2553+320.0*t2222*t2531+384.0
+*t2327*t2517;
+ t3865 = t2220*t97;
+ t3872 = 12.0*t2233*t2596+80.0*t2595*t2560-128.0*t2398*t2450-19.0*t2954*
+t112+16.0*t2398*t3259-16.0*t2829*t146-32.0*t2829*t2438-64.0*t2647*t2450+38.0*
+t2647*t146+1216.0*t2398*t3343+12.0*t3865*t125-512.0*t2671*t3338-14.0*t3155*t318
+;
+ t3901 = 18.0*t3865*t39-7.0*t2954*t146+9.0*t3430*t1950+576.0*t3433*t1950
+-16.0*t2205*t146-768.0*t2552*t3338+320.0*t2340*t2483-96.0*t3053*t2793+96.0*
+t2209*t3204+192.0*t3328*t2793-120.0*t2671*t2427+96.0*t2544*t2427+48.0*t2544*
+t2439+36.0*t2236*t3513;
+ t3934 = 640.0*t2259*s*t2493-128.0*t2282*t2442-64.0*t2552*t2445+128.0*
+t2267*t2442-512.0*t2552*s*t2435+128.0*t2259*t2442-256.0*t2259*t2451-272.0*t2552
+*t2439-32.0*t2552*t2427-192.0*t2552*t2456-96.0*t2270*t2421+96.0*t2259*t2416+
+512.0*t2259*t2421;
+ t3939 = t2671*s;
+ t3948 = t2547*s;
+ t3964 = -64.0*t2547*t2698+96.0*t3057*t2483-384.0*t3939*t2465+128.0*t2393*
+t2427-16.0*t2547*t2439-96.0*t2547*t2427-256.0*t3948*t2435+128.0*t2270*s*t2493
+-256.0*t3948*t2465+64.0*t2544*t2456-16.0*t2577*t2439+64.0*t2544*t2445+512.0*
+t2547*t2479;
+ t3992 = -128.0*t2270*t2701+64.0*t2270*t2719-1024.0*t2259*t2759+64.0*t2544
+*t2698+512.0*t2259*t2762-96.0*t2205*t2416-256.0*t2270*t2451+256.0*t2547*t2713
+-256.0*t2547*t2475+128.0*t2259*t2701+96.0*t2544*t2471+256.0*t2547*t2445-32.0*
+t2205*t2421;
+ t4009 = t2220*t3413;
+ t4022 = -352.0*t2547*t2471+128.0*t2547*t2456+1536.0*t2552*t2479-768.0*
+t2552*t2475-896.0*t2671*t3795-960.0*t3433*t1658-26.0*t2398*t146+10.0*t2644*t318
+-8.0*t4009*t112+512.0*t2647*t3343+2.0*t4009*t146-4.0*t3865*t318-6.0*t3430*t1935
+-384.0*t3433*t1935;
+ t4025 = t2237*t145;
+ t4053 = -128.0*t2647*t4025+256.0*t2671*t2237*t256+14.0*t2671*t318-256.0*
+t2213*t2474+24.0*t2939*t112+512.0*t2282*t2478-256.0*t2282*t2474-64.0*t2282*
+t3244-64.0*t2282*t2450-48.0*t2282*t2438+16.0*t2413*t2438-16.0*t2213*t2438-32.0*
+t2213*t3259;
+ t4068 = t2212*t97;
+ t4083 = 56.0*t2777*t125-48.0*t2393*t125-100.0*t2213*t112+72.0*t2413*t112+
+96.0*t2393*t39-48.0*t2782*t39+1024.0*t2777*t3338-16.0*t4068*t39-32.0*t2869*t39+
+32.0*t2381*t146+512.0*t2213*t2478+24.0*t2939*t146+64.0*t2413*t3244-16.0*t2381*
+t2438;
+ t4103 = t2240*t43;
+ t4112 = -192.0*t2398*t4025-512.0*t2331*t2531-224.0*t2337*t290+224.0*t3520
+*t290+96.0*t2337*t1133-96.0*t3520*t1133-896.0*t2337*t2503+384.0*t2337*t2658
+-64.0*t2331*t257+64.0*t4103*t257-256.0*t2331*t3100+128.0*t2264*t2596-128.0*
+t2264*t2531;
+ t4141 = 32.0*t2264*t248-128.0*t3616*t311+192.0*t3616*t248-224.0*t2252*
+t248-768.0*t2252*t2596+160.0*t2252*t311+512.0*t2252*t2531+224.0*t2248*t290
+-224.0*t3558*t290-96.0*t2248*t1133+96.0*t3558*t1133+896.0*t2248*t2503-384.0*
+t2248*t2658+64.0*t2252*t257;
+ t4173 = 320.0*t2346*t2531-192.0*t2346*t2596+192.0*t3085*t2680-448.0*t3085
+*t2580+960.0*t3496*t1658-576.0*t3496*t1950+256.0*t3053*t2553+384.0*t3053*t2623+
+20.0*t3491*t379+36.0*t3491*t1950-92.0*t3491*t384+16.0*t2276*t35*t223+24.0*t2276
+*t38*t2058;
+ t4202 = -44.0*t3491*t1738+28.0*t3491*t1735-256.0*t3053*t2922+384.0*t3496*
+t1935-256.0*t3057*t2580+128.0*t3057*t2680-8.0*t3491*t930-24.0*t3491*t1935+48.0*
+t3491*t418-16.0*t2276*t110*t675+8.0*t2276*t145*t1925-16.0*t3491*t1921+96.0*
+t2359*t2394;
+ t4230 = -124.0*t3417*t391+36.0*t3417*t415+76.0*t3417*t1658-36.0*t3417*
+t1713+44.0*t3417*t822+100.0*t3417*t372-148.0*t3417*t408+140.0*t3417*t387-100.0*
+t3417*t376+192.0*t2340*t2482+96.0*t2340*t2394-80.0*t2209*t2434+48.0*t2209*t2517
+;
+ t4259 = -128.0*t2209*t2619+704.0*t3113*t2623-192.0*t3113*t2553-320.0*
+t2273*t2531+192.0*t2273*t2596-576.0*t2340*t2680+1472.0*t2340*t2580-960.0*t3440*
+t1658+576.0*t3440*t1950+512.0*t2516*t2553-1408.0*t2516*t2623-60.0*t3417*t379
+-36.0*t3417*t1950+92.0*t3417*t384;
+ t4264 = t2208*t35;
+ t4269 = t2208*t38;
+ t4291 = 128.0*t2362*t2482-16.0*t4264*t223+384.0*t2340*t2464-8.0*t4269*
+t2058+68.0*t3417*t1738+512.0*t2516*t2922-384.0*t3440*t1935+256.0*t2362*t2580+
+24.0*t3417*t930+24.0*t3417*t1935-48.0*t3417*t418-32.0*t3551*t675+16.0*t2208*
+t145*t1925;
+ t4296 = t2208*t57;
+ t4323 = 256.0*t3328*t2553-128.0*t3328*t2623-192.0*t4296*t2482+16.0*t2208*
+t97*t223+384.0*t2362*t2464-8.0*t4269*t97*t16-96.0*t4296*t2394-16.0*t3247*t286
+-128.0*t2334*t2394+48.0*t3501*t675-72.0*t3247*t223+128.0*t3235*t223+40.0*t2226*
+t675+32.0*t2226*t2394;
+ t4337 = t2225*t97;
+ t4352 = -384.0*t2226*t2482-40.0*t3232*t223-64.0*t2334*t675+128.0*t3232*
+t2553-16.0*t2359*t232+64.0*t2311*t2482+8.0*t4337*t300-16.0*t4337*t223+40.0*
+t2334*t232-24.0*t2359*t675+72.0*t3247*t300-16.0*t3250*t300-24.0*t3501*t232;
+ t4381 = -256.0*t3235*t2553+256.0*t3235*t2623-128.0*t2334*t2680+16.0*t3250
+*t286+128.0*t2226*t2464-384.0*t2334*t2464+192.0*t2359*t2482-256.0*t3247*t2553+
+128.0*t3247*t2623-128.0*t2226*t2580+3.0*t2426*t3609+32.0*t2381*t3259+64.0*t2413
+*t2450-56.0*t2413*t146;
+ t4414 = -1280.0*t2213*t3343-8.0*t4068*t125+512.0*t2393*t3338+16.0*t2782*
+t318-16.0*t2869*t318+512.0*t2393*t3795+4.0*t2212*t3413*t112-256.0*t2413*t3343
+-128.0*t2241*t2596+128.0*t2241*t2531-32.0*t2241*t248+32.0*t2241*t311+128.0*
+t4103*t311;
+ t4435 = t2398*s;
+ t4442 = -192.0*t4103*t248+224.0*t2331*t248+768.0*t2331*t2596-160.0*t2331*
+t311+136.0*t2622*t2698-32.0*t2264*t311+384.0*t2622*t2445-864.0*t2398*t2451+
+304.0*t2628*t2451-136.0*t2628*t2416+512.0*t4435*t2493+64.0*t2644*t2439+80.0*
+t2644*t2427;
+ t4456 = t2647*s;
+ t4461 = t3155*s;
+ t4472 = -64.0*t3155*t2445+88.0*t2644*t2471-36.0*t2829*t2719+8.0*t2647*
+t2810-160.0*t3155*t2713-384.0*t3939*t2435+320.0*t4456*t2493-80.0*t2647*t2716
+-64.0*t4461*t2435-64.0*t4461*t2465+192.0*t2622*t2710-448.0*t2622*t2713+400.0*
+t2671*t2445;
+ t4501 = -368.0*t2671*t2710+128.0*t2398*t2442-80.0*t2671*t2456+232.0*t2647
+*t2416+56.0*t3155*t2427+60.0*t2398*t2421-192.0*t2622*t2475+384.0*t2622*t2479
+-136.0*t2671*t2698+404.0*t2647*t2421-180.0*t2671*t2471+152.0*t2398*t2416-56.0*
+t2622*t2427-12.0*t2622*t2439;
+ t4517 = t2622*s;
+ t4520 = t2474*t38;
+ t4533 = -148.0*t3155*t2471-268.0*t2671*t2439-64.0*t2628*s*t2493-20.0*
+t3155*t2439-104.0*t3155*t2698+560.0*t2671*t2713-320.0*t4517*t2435+576.0*t2622*
+t4520+64.0*t2628*t2442+576.0*t2222*t3168-64.0*t2954*t2416-128.0*t2829*t2701+
+768.0*t2327*t3204;
+ t4539 = t286*t2214;
+ t4564 = -128.0*t2213*t2442+128.0*t2782*s*t2465+64.0*t2782*t4539-512.0*
+t2516*t2790+64.0*t4296*t2738+128.0*t3328*t2826-224.0*t2516*t2826+64.0*t4296*
+t2483-64.0*t4296*t2486-128.0*t2516*t3192+128.0*t2644*t2698+8.0*t2829*t2810+
+192.0*t4517*t2465+224.0*t3155*t2710;
+ t4566 = t3244*t145;
+ t4576 = t2474*t145;
+ t4579 = t2680*t2195;
+ t4584 = t2623*t2195;
+ t4597 = 16.0*t2647*t4566-192.0*t2398*t4566+512.0*t2398*t2716+144.0*t2595*
+t2399*beta-192.0*t2398*t4576+384.0*t2398*t4579-896.0*t2671*t4520+1792.0*t2671*
+t4584+72.0*t2233*t3207-104.0*t2398*t2810+140.0*t2647*t2719-176.0*t2647*t2701+
+60.0*t2233*t2905;
+ t4618 = t286*t2195;
+ t4628 = 1216.0*t2398*t2762-2432.0*t2398*t2759-184.0*t2829*t2416-512.0*
+t2671*t2475+128.0*t4456*t2744-108.0*t2829*t2421+544.0*t2398*t2701-80.0*t2647*
+t2451+64.0*t2647*t2442-48.0*t2233*t3204+64.0*t2671*t4618+t2230*t35*t34*t3609
+-60.0*t3491*t372-1024.0*t2647*t2759;
+ t4636 = t2450*t256;
+ t4662 = -8.0*t3155*t4539+512.0*t2647*t2762+64.0*t3155*t4636+128.0*t2829*
+t2451+8.0*t2954*t2719-16.0*t2644*t4539+16.0*t3155*t4618-32.0*t2829*t2716-32.0*
+t2954*t2421-28.0*t2233*t2596*t25-36.0*t2233*t3168-240.0*t2595*t2573*beta+1920.0
+*t2635*t2580*beta;
+ t4684 = t3244*t256;
+ t4693 = -960.0*t2222*t2905-1152.0*t2327*t3207-128.0*t4435*t2744+24.0*
+t2233*t3173-12.0*t2233*t2658*t26+96.0*t2595*t2922*t25-384.0*t2222*t3173-96.0*
+t2595*t2959*t25-288.0*t2671*t4636+160.0*t2671*t4684-64.0*t3155*t4684+32.0*t2829
+*t4566+16.0*t2954*t2810;
+ t4724 = -32.0*t2644*t4618+28.0*t3491*t822-128.0*t2647*t4576+256.0*t2671*
+t2474*t256+256.0*t2647*t4579-512.0*t2671*t2922*t2195-6.0*t2314*t3513-16.0*t3484
+*t145-144.0*t2595*t2680*beta+64.0*t2285*t2619-4.0*t3491*t391+32.0*t2244*t3619+
+64.0*t2244*t3571;
+ t4753 = 240.0*t2209*t2909-64.0*t2374*t3619+960.0*t2273*t2905+32.0*t2777*
+t2427+256.0*t2777*t2456+576.0*t2213*t2451+288.0*t2777*t2439-688.0*t2213*t2421
+-80.0*t2413*t2421-128.0*t2213*t2416-64.0*t2236*t3619+10.0*t2695*t3582-8.0*t2314
+*t3709-14.0*t2374*t3513;
+ t4758 = t37*t2195;
+ t4783 = 16.0*t2244*t3595+12.0*t2244*t4758+256.0*t2244*t3758+14.0*t3341*
+t3582+2560.0*t2213*t2759-768.0*t2393*t2713+512.0*t2393*t2475+192.0*t2381*t2416
+-1280.0*t2213*t2762-320.0*t2213*t2701+256.0*t2413*t2451+160.0*t2393*t2698-64.0*
+t2782*t2471;
+ t4814 = 1024.0*t2777*t2475-2048.0*t2777*t2479-96.0*t2413*t2416+800.0*
+t2393*t2471-128.0*t2393*t2456-256.0*t2393*t2445+112.0*t2381*t2421-96.0*t2782*
+t2427-1152.0*t2213*s*t2493-32.0*t2782*t2439+640.0*t2777*s*t2435-128.0*t2782*
+t2710+512.0*t2413*t2759+64.0*t2381*t2701;
+ t4828 = t2413*s;
+ t4835 = t2393*s;
+ t4844 = 16.0*t2939*t2421-1024.0*t2393*t4584+64.0*t2381*t2810-96.0*t2869*
+t2698+512.0*t2393*t4520-256.0*t2413*t2762-256.0*t4828*t2744+256.0*t2413*t2716+
+28.0*t3491*t415+384.0*t4835*t2435-384.0*t4828*t2493+896.0*t4835*t2465-64.0*
+t2374*t3571;
+ t4871 = t2276*t43;
+ t4874 = 128.0*t2393*t2710-64.0*t2413*t2810-96.0*t2869*t2471+96.0*t2381*
+t2719-64.0*t2869*t2427-416.0*t2413*t2719+256.0*t2413*t2701-1024.0*t2393*t2479
+-128.0*t2782*t2456-64.0*t2782*t2698+144.0*t2285*t3207+256.0*t3057*t2493-128.0*
+t3057*t2744+96.0*t4871*t2735;
+ t4905 = 192.0*t4871*t2783+128.0*t4871*t2793-416.0*t3085*t2483-48.0*t3057*
+t2738-192.0*t3085*t2489-224.0*t3057*t2486-1152.0*t2622*t4584+16.0*t3057*t2489+
+64.0*t4871*t2395+576.0*t2821*t2465-256.0*t3053*t2435-384.0*t3053*t2465-960.0*
+t2346*t2905;
+ t4932 = 448.0*t3085*t2493+576.0*t2346*t3168-192.0*t3085*t2744-224.0*t2285
+*t2787+64.0*t2821*t2435-64.0*t2285*t2905-64.0*t2821*t2395+544.0*t3085*t2486+
+288.0*t2821*t2783+352.0*t3085*t2738-352.0*t2821*t2793-240.0*t2285*t2892+192.0*
+t2821*t2735;
+ t4938 = t3244*t2214;
+ t4961 = 32.0*t2939*t2416-64.0*t2381*t2451+128.0*t2244*t4938-704.0*t3113*
+t2465-512.0*t2516*t2435+1408.0*t2516*t2465+192.0*t3113*t2435+64.0*t2209*t2905+
+576.0*t2209*t2787-256.0*t3113*t2783-608.0*t2340*t2738+448.0*t3113*t2793+528.0*
+t2209*t2892;
+ t4974 = t2276*t57;
+ t4991 = -96.0*t2285*t3204-224.0*t3113*t2735-768.0*t2516*t2793+128.0*t3113
+*t2395-176.0*t2516*t2395-576.0*t2340*t2486-128.0*t4974*t2486+192.0*t3053*t3192
+-128.0*t4871*t3192+32.0*t4974*t2489+64.0*t4974*t2483-192.0*t2432*t3572-64.0*
+t4974*t2738-64.0*t4871*t2826;
+ t5018 = t675*t2215;
+ t5021 = 160.0*t3053*t2826+256.0*t3053*t2790-384.0*t2346*t3173-32.0*t4264*
+t2735+128.0*t3328*t3192-256.0*t3328*t2435+128.0*t3328*t2465+64.0*t4264*t2395
+-128.0*t3250*t2793-128.0*t2359*t2483-128.0*t3247*t2465-64.0*t3247*t3192-288.0*
+t2374*t5018;
+ t5022 = t2438*t2195;
+ t5025 = t223*t2215;
+ t5028 = t3642*z;
+ t5031 = t39*t2214;
+ t5034 = t112*t2214;
+ t5055 = 16.0*t2374*t5022+96.0*t2432*t5025-16.0*t2695*t5028-296.0*t2426*
+t5031+264.0*t2374*t5034-256.0*t3328*t2783-384.0*t2362*t2483+304.0*t2362*t2738
+-144.0*t2209*t3207-256.0*t2362*t2493+384.0*t2273*t3173+576.0*t2362*t2486-320.0*
+t3328*t2735-1472.0*t2340*t2493;
+ t5083 = -576.0*t2273*t3168+576.0*t2340*t2744+64.0*t3328*t2395-144.0*t2362
+*t2489+288.0*t2340*t2489+256.0*t3247*t2435+192.0*t2359*t2486-32.0*t2359*t2489+
+32.0*t3250*t2735-64.0*t3250*t2395+64.0*t3250*t2783+32.0*t2226*t2738+1024.0*
+t3235*t2793;
+ t5112 = 256.0*t2226*t2486+96.0*t3235*t2395-32.0*t3232*t2395-64.0*t4264*
+t2783+128.0*t4264*t2793-32.0*t2334*t2738-64.0*t3235*t2735-576.0*t3235*t2783
+-192.0*t2426*t5028+256.0*t3247*t2783+32.0*t3247*t2735-576.0*t2334*t2486-448.0*
+t3247*t2793-38.0*t2426*t3582;
+ t5136 = t125*t2195;
+ t5139 = t223*t2221;
+ t5142 = t3758*z;
+ t5145 = 136.0*t2236*t5034+256.0*t3235*t2435+16.0*t2432*t5028-256.0*t3235*
+t2465+128.0*t2334*t2744+32.0*t2577*t2427+768.0*t2236*t3645+32.0*t2334*t2489+
+128.0*t2226*t2493-72.0*t2314*t5034-8.0*t2695*t5136-112.0*t2426*t5139-768.0*
+t2432*t5142;
+ t5146 = t3577*z;
+ t5149 = t3645*z;
+ t5154 = t300*t2215;
+ t5163 = t146*t2214;
+ t5170 = t675*t2221;
+ t5173 = s*t2237;
+ t5174 = t5173*z;
+ t5179 = 2304.0*t2432*t5146-2304.0*t2432*t5149+192.0*t2314*t5018-160.0*
+t2695*t5154+16.0*t2314*t5022+32.0*t2468*t5028-56.0*t2695*t5031+192.0*t2374*
+t5163-8.0*t2231*t5034+40.0*t2468*t5031+224.0*t2236*t5170-256.0*t2426*t5174+80.0
+*t2236*t5022;
+ t5187 = t39*t2195;
+ t5190 = t112*t2195;
+ t5195 = t2450*t2195;
+ t5198 = t5173*t29;
+ t5201 = t5173*t38;
+ t5212 = -64.0*t2695*t5025+176.0*t2695*t5139+128.0*t2374*t4938-104.0*t2426
+*t5187-80.0*t2314*t5190+16.0*t2695*t5187-64.0*t2374*t5195+384.0*t2374*t5198
+-896.0*t2426*t5201+864.0*t2426*t5154-64.0*t2374*t5170+128.0*t2426*t3572+12.0*
+t3341*t5136;
+ t5243 = -256.0*t2426*t5142-2048.0*t2802*t2759+56.0*t2468*t5136+1088.0*
+t2433*t2479+800.0*t2236*t16*t2493-432.0*t2432*t16*t2435+896.0*t2236*t5198-672.0
+*t2236*t5018-8.0*t2426*t5136-256.0*t2236*t5195+40.0*t2374*t5190+384.0*t2334*
+t2483+96.0*t2236*t5190+384.0*t2426*t5025;
+ t5271 = t3571*t29;
+ t5276 = 256.0*t2236*t4938-192.0*t2244*t5195-52.0*t2432*t5136-112.0*t2432*
+t5139-256.0*t2432*t5174+80.0*t2244*t5022+768.0*t2426*t5146+512.0*t2741*t2762+
+512.0*t2236*t3758*t29-1536.0*t2236*t3577*t29+1536.0*t2236*t3645*t29+128.0*t2236
+*t5271-64.0*t2468*t5154;
+ t5277 = t232*t2215;
+ t5289 = t300*t2221;
+ t5294 = t146*t2195;
+ t5306 = t2468*t16;
+ t5309 = t2695*t16;
+ t5312 = 128.0*t2314*t5277-48.0*t2314*t5163-32.0*t2695*t318*t2214-8.0*
+t3341*t5031+16.0*t2231*t5163-128.0*t2426*t5289-160.0*t2314*t5170+48.0*t2374*
+t5294+88.0*t2468*t5187-48.0*t2314*t5294-128.0*t2695*t5201+256.0*t2374*t5173*
+t145-16.0*t5306*t2435-48.0*t5309*t2435;
+ t5316 = t2374*t16;
+ t5327 = t2314*t16;
+ t5342 = -768.0*t2461*t2475+288.0*t5316*t2493-640.0*t2433*t2475+48.0*t2468
+*t5139-768.0*t2426*t5149-32.0*t2468*t5025+64.0*t5327*t2493-160.0*t5309*t2465+
+1024.0*t2802*t2762-768.0*t2741*t2759+1408.0*t2461*t4584-128.0*t2749*t2475+64.0*
+t2749*t2479;
+ t5351 = t2426*t16;
+ t5372 = -320.0*t2374*t5277+128.0*t2695*t5289-128.0*t2374*t5271+896.0*
+t2461*t2479-576.0*t5351*t2465-272.0*t5351*t2435-12.0*t2231*t4758-56.0*t2231*
+t5190+128.0*t5316*t2744-32.0*t5306*t2465+64.0*t5327*t2744-512.0*t2461*t4520+
+128.0*t2749*t4584-256.0*t2741*t4579;
+ Phi_box = -t2203*(t3901+t5112+t3445+t4628+t4141+t5145+t3510+t4874+t4472+
+t5179+t3542+t4173+t3570+t5243+t4905+t4662+t5276+t4932+t3666+t5312+t4693+t3696+
+t3725+t5342+t5372+t3603+t4724+t3783+t3753+t3478+t4961+t5212+t3814+t4230+t4753+
+t3843+t4597+t4783+t4991+t3872+t4533+t4259+t3934+t5021+t3964+t3992+t4202+t4844+
+t4022+t4291+t4053+t3634+t5055+t4323+t4083+t4112+t4814+t4352+t4381+t4414+t4442+
+t4501+t5083+t4564)*t1474*t1480*t3409*t2196*t1484*t1486*t2198/1024.0;
+ t5394 = -t1511-t1520+2.0*t1521-4.0*t1526-t1530-t1532+8.0*t555*z-14.0*
+t1543-2.0*t1545+t1549+t1575-t1577+t1579+t1581+t1583;
+ t5413 = t1614-t51*t37-t1647-t1653-t1655+t1657-20.0*t589*z-4.0*t636*s+
+t1660-8.0*t333*t9+24.0*t327*t9-4.0*t643*s+16.0*t333*s-24.0*t617*t9-2.0*t212*t50
++14.0*t1672;
+ t5415 = t180*s;
+ t5446 = 4.0*t5415*t57-24.0*t612*t9+20.0*t602*z-12.0*t602*t38-8.0*t5415*
+t50-4.0*t5415*t26+48.0*t552*t38-56.0*t241*t29-8.0*t555*t38-16.0*t552*t256+24.0*
+t241*t145-16.0*t8*t166+4.0*t487*t16+16.0*t498*t10+2.0*t505*t16;
+ t5465 = -2.0*t231*t16+16.0*t487*t10-t1679+t1681-2.0*t1686+t1692+12.0*t589
+*t38-4.0*t1733+2.0*t1762-2.0*t1764+14.0*t1770-10.0*t1778-16.0*t423*t10-4.0*t461
+*t687-t1787-32.0*t552*z;
+ t5473 = t687*z;
+ t5486 = -t1791-20.0*t464*z+12.0*t464*t38-t27*t37+32.0*t267*t5473-2.0*t212
+*t26+2.0*t1822+2.0*t1956-4.0*t1958-t1961+14.0*t1968+2.0*t1970+16.0*t1972-22.0*
+t1974-4.0*t1976;
+ t5502 = t311*t10;
+ t5519 = 2.0*t1978-16.0*t1167*t53-16.0*t439*t10+8.0*t5415*t379-16.0*t315*
+t103+8.0*t222*t5473+8.0*t5415*t408+6.0*t212*t1713+16.0*t62*t5502-16.0*t27*t166+
+32.0*t209*t64+4.0*t814*t5473+8.0*t5415*beta+6.0*t71*t125-4.0*t1024*t286+24.0*
+t209*t5473;
+ t5551 = 20.0*t285*t5473-40.0*t299*t5473-36.0*t271*t73-4.0*t271*t103+16.0*
+t706*t103+24.0*t706*t73-28.0*t264*t53+12.0*t264*t154+60.0*t584*t53-36.0*t584*
+t154+8.0*t1167*t154-16.0*t706*t295+24.0*t271*t295+24.0*t5415*t391-8.0*t5415*
+t387;
+ t5584 = 12.0*t5415*t376-20.0*t5415*t372-4.0*t5415*t1658+12.0*t814*t64-4.0
+*t5415*t822-4.0*t5415*t1713-8.0*t5415*t384-4.0*t5415*t415+44.0*t1237*t73-12.0*
+t1237*t103+32.0*t255*t103-88.0*t255*t73+92.0*t612*t53-36.0*t612*t154-60.0*t354*
+t53+36.0*t354*t154;
+ t5618 = 32.0*t255*t295+16.0*t617*t53-24.0*t1237*t295+16.0*t1245*t103-8.0*
+t1245*t73+12.0*t1361*t311-8.0*t1361*t248+20.0*t327*t290+8.0*t310*t311+4.0*t1361
+*t257-40.0*t315*t311-12.0*t333*t290-16.0*t327*t1133+24.0*t315*t248-16.0*t1361*
+t103;
+ t5649 = -8.0*t333*t53+8.0*t310*t103+8.0*t1361*t73+16.0*t315*t73+3.0*t44*
+t125+t62*t125-5.0*t27*t112+9.0*t71*t39-3.0*t58*t112+10.0*t44*t39-2.0*t27*t17
+-16.0*t27*t11-4.0*t8*t17+t36*t39-3.0*t58*t146-16.0*t51*t11;
+ t5651 = t166*z;
+ t5682 = 48.0*t62*t5651-32.0*t27*t166*t29+16.0*t71*t5651-4.0*t58*t17-7.0*
+t51*t146+2.0*t44*t318-8.0*t439*t687+48.0*t222*t64-8.0*t434*t687+16.0*t267*t64
+-32.0*t439*t30-2.0*t51*t17-8.0*t327*t154+32.0*t241-8.0*t1024*t300;
+ t5685 = t675*t9;
+ t5688 = t300*t9;
+ t5691 = t17*z;
+ t5698 = t290*t10;
+ t5703 = t232*t9;
+ t5721 = -12.0*t51*t112-18.0*t58*t5685+26.0*t44*t5688+18.0*t44*t5691+20.0*
+t71*t5688+64.0*t71*t5502-48.0*t27*t5698+2.0*t36*t5688-4.0*t58*t5703-8.0*t51*
+t5703-48.0*t51*t5698+32.0*t71*t248*t10+16.0*t44*t5502+4.0*t36*t5691-30.0*t51*
+t5685+10.0*t71*t5691;
+ t5726 = t687*t29;
+ t5733 = t687*t38;
+ t5740 = t687*t145;
+ t5757 = -24.0*t27*t5685+32.0*t498*t5726-16.0*t1024*t5473+56.0*t231*t5726
+-40.0*t299*t5733+8.0*t505*t5726-24.0*t1024*t5733+16.0*t231*t5740+16.0*t281*
+t5726-8.0*t814*t5733+4.0*t796*t5726-8.0*t209*t5733+32.0*t285*t5733-52.0*t461*
+t5726-4.0*t281*t5740;
+ t5760 = t257*t9;
+ t5791 = 4.0*t484*t5740-8.0*t285*t5760-16.0*t484*t5726+8.0*t209*t5760+16.0
+*t62*t5691-24.0*t439*t5726+8.0*t727*t5473-24.0*t434*t5726+16.0*t267*t5733-8.0*
+t1004*t5473+8.0*t498*t687+2.0*t299*t223-2.0*t1024*t223+32.0*t498*t675-18.0*
+t1004*t223+4.0*t231*t675;
+ t5823 = -32.0*t299*t300+2.0*t505*t232+18.0*t231*t232+4.0*t505*t675-64.0*
+t1004*t64+8.0*t231*t687-2.0*t1061*t223-32.0*t299*t64+80.0*t498*t30+16.0*t231*
+t30-32.0*t299*t132-36.0*t814*t132+10.0*t212*t391-14.0*t212*t415-8.0*t281*t687;
+ t5856 = 2.0*t212*t372-8.0*t212*t408+10.0*t212*t387-4.0*t212*t379-4.0*t796
+*t687+56.0*t209*t132+12.0*t281*t910-76.0*t281*t30+60.0*t464*t1658-36.0*t464*
+t1950+8.0*t461*t910-16.0*t209*t968-32.0*t461*t30+24.0*t464*t1935-2.0*t212*t1738
++4.0*t212*t822;
+ Chi_box = -t1498*t1499*(t5394+t5413+t5446+t5465+t5486+t5519+t5551+t5584+
+t5618+t5649+t5682+t5721+t5757+t5791+t5823+t5856)*t1474*t2200/256.0;
diff --git a/hathor/auto/boxes.dec b/hathor/auto/boxes.dec
new file mode 100644
index 0000000..adecdf2
--- /dev/null
+++ b/hathor/auto/boxes.dec
@@ -0,0 +1,83 @@
+/*
+* This is an automatically created file, don't edit!
+* File created on Fri Jun 23 14:05:07 CEST 2006
+* by ../../DefVarsC.pl
+*/;
+double t1,t10,t1004,t1005,t102,t1024,t103,t1035,t1036,t104,t1061,t107;
+double t1072,t1075,t1079,t11,t110,t1100,t111,t1113,t112,t1127,t113;
+double t1130,t1133,t1134,t1157,t116,t1167,t117,t1172,t118,t1197,t12;
+double t1202,t1205,t1216,t1237,t1240,t1245,t125,t126,t1278,t13,t131;
+double t1316,t132,t133,t1343,t1354,t1361,t1392,t140,t1430,t145,t146;
+double t1467,t147,t1474,t1477,t1479,t1480,t1482,t1483,t1484,t1486;
+double t1487,t1491,t1492,t1498,t1499,t1500,t1501,t1506,t1507,t1511;
+double t1512,t1513,t1516,t152,t1520,t1521,t1523,t1526,t1528,t1530;
+double t1532,t1533,t1534,t1539,t154,t1540,t1543,t1545,t1547,t1549,t155;
+double t1550,t1551,t1554,t1555,t1560,t1565,t1575,t1577,t1579,t158;
+double t1581,t1583,t1584,t1587,t159,t1590,t1593,t1597,t16,t1602,t1605;
+double t1608,t1613,t1614,t1615,t1619,t1622,t1625,t1628,t1637,t1640;
+double t1645,t1646,t1647,t1648,t1651,t1652,t1653,t1654,t1655,t1656;
+double t1657,t1658,t166,t1660,t1661,t1662,t1665,t1668,t1669,t167,t1672;
+double t1674,t1675,t1678,t1679,t168,t1680,t1681,t1686,t1688,t1691;
+double t1692,t1697,t17,t1704,t1705,t1708,t171,t1713,t172,t1730,t1733;
+double t1735,t1738,t1741,t1746,t1749,t175,t1762,t1764,t1770,t1772;
+double t1778,t1786,t1787,t1788,t1791,t18,t180,t1806,t1807,t1810,t1816;
+double t1819,t182,t1822,t1824,t183,t1831,t1834,t1837,t1840,t1849,t1856;
+double t186,t1866,t187,t1871,t1882,t1897,t190,t1921,t1925,t1935,t1938;
+double t1941,t1943,t1947,t1950,t1953,t1956,t1958,t1961,t1968,t1970;
+double t1972,t1974,t1976,t1978,t1980,t1983,t1984,t1991,t2021,t204;
+double t2046,t2058,t2061,t2067,t207,t2070,t2077,t208,t2082,t209,t21;
+double t2103,t2105,t2108,t2113,t212,t213,t2130,t2135,t2145,t2156,t2157;
+double t2160,t217,t218,t2185,t2193,t2195,t2196,t2198,t22,t2200,t2203;
+double t2204,t2205,t2208,t2209,t221,t2212,t2213,t2214,t2215,t222,t2220;
+double t2221,t2222,t2225,t2226,t223,t2230,t2231,t2233,t2236,t2237,t224;
+double t2240,t2241,t2244,t2247,t2248,t2252,t2255,t2259,t2264,t2267;
+double t2270,t2273,t2276,t2277,t2282,t2285,t2294,t2296,t230,t231,t2311;
+double t2314,t232,t2326,t2327,t233,t2331,t2334,t2337,t2340,t2346,t2359;
+double t2362,t2365,t2374,t2381,t2393,t2394,t2395,t2398,t2399,t240;
+double t2404,t241,t2413,t2416,t2421,t2426,t2427,t2432,t2433,t2434;
+double t2435,t2438,t2439,t2442,t2445,t2448,t2450,t2451,t2456,t246;
+double t2461,t2464,t2465,t2468,t247,t2471,t2474,t2475,t2478,t2479,t248;
+double t2482,t2483,t2486,t2489,t249,t2492,t2493,t2498,t25,t2503,t2516;
+double t2517,t252,t2526,t2531,t2536,t2544,t2547,t255,t2552,t2553,t256;
+double t2560,t257,t2573,t2576,t2577,t258,t2580,t2595,t2596,t26,t2611;
+double t2619,t2622,t2623,t2628,t263,t2635,t264,t2644,t2647,t2650,t2658;
+double t267,t2671,t268,t2680,t2685,t2688,t2695,t2698,t27,t2701,t271;
+double t2710,t2713,t2716,t2719,t272,t2728,t2735,t2738,t2741,t2744;
+double t2749,t275,t2754,t2759,t2762,t2767,t2777,t278,t2782,t2783,t2787;
+double t2790,t2793,t28,t2802,t2807,t281,t2810,t282,t2821,t2826,t2829;
+double t2844,t285,t286,t2869,t287,t2879,t2892,t29,t290,t2905,t2908;
+double t2909,t291,t2914,t2922,t2939,t294,t2949,t295,t2954,t2959,t296;
+double t2984,t299,t30,t300,t301,t3017,t3018,t3049,t3053,t3054,t3057;
+double t3084,t3085,t31,t310,t3100,t311,t3113,t312,t3120,t315,t3154;
+double t3155,t3168,t3173,t318,t3188,t3192,t3204,t3207,t3216,t322,t3225;
+double t3232,t3235,t3244,t3247,t3250,t3259,t3264,t327,t328,t3297,t3328;
+double t333,t3331,t3335,t3338,t3341,t3343,t3367,t338,t34,t3400,t3409;
+double t3413,t3414,t3415,t3417,t3430,t3433,t3440,t3445,t3454,t3457;
+double t3460,t3463,t3468,t3473,t3478,t3484,t349,t3491,t3496,t35,t3501;
+double t3510,t3513,t3520,t3529,t354,t3542,t3551,t3558,t3570,t3571;
+double t3572,t3577,t3582,t3595,t3598,t36,t3603,t3609,t3616,t3619,t363;
+double t3634,t3637,t3642,t3645,t3666,t3696,t37,t3709,t372,t3725,t373;
+double t3753,t3758,t376,t3783,t379,t3795,t38,t3814,t382,t384,t3843;
+double t3865,t387,t3872,t388,t39,t3901,t391,t3934,t3939,t3948,t3964;
+double t3992,t4,t40,t4009,t402,t4022,t4025,t403,t4053,t4068,t408,t4083;
+double t4103,t4112,t4141,t415,t4173,t418,t4202,t423,t4230,t424,t4259;
+double t4264,t4269,t427,t4291,t4296,t43,t430,t431,t4323,t4337,t434;
+double t4352,t4381,t439,t44,t4414,t4435,t4442,t4456,t446,t4461,t4472;
+double t45,t4501,t4517,t4520,t4533,t4539,t4564,t4566,t4576,t4579,t4584;
+double t4597,t46,t461,t4618,t4628,t4636,t464,t465,t4662,t468,t4684;
+double t4693,t47,t471,t4724,t474,t4753,t4758,t4783,t480,t4814,t4828;
+double t4835,t484,t4844,t487,t4871,t4874,t4905,t4932,t4938,t4961,t4974;
+double t498,t4991,t5,t50,t5018,t5021,t5022,t5025,t5028,t5031,t5034;
+double t505,t5055,t5083,t51,t5112,t5136,t5139,t514,t5142,t5145,t5146;
+double t5149,t5154,t5163,t517,t5170,t5173,t5174,t5179,t518,t5187,t5190;
+double t5195,t5198,t52,t5201,t521,t5212,t5243,t526,t5271,t5276,t5277;
+double t5289,t529,t5294,t53,t5306,t5309,t5312,t5316,t532,t5327,t5342;
+double t5351,t537,t5372,t5394,t54,t5413,t5415,t5446,t5465,t5473,t5486;
+double t5502,t5519,t552,t555,t5551,t5584,t5618,t5649,t5651,t568,t5682;
+double t5685,t5688,t5691,t5698,t57,t5703,t5721,t5726,t5733,t5740,t5757;
+double t5760,t5791,t58,t5823,t584,t5856,t589,t59,t6,t602,t607,t612;
+double t617,t62,t622,t627,t63,t636,t64,t643,t65,t650,t666,t675,t676;
+double t679,t68,t682,t687,t688,t691,t694,t7,t706,t71,t711,t716,t72;
+double t727,t73,t734,t74,t740,t755,t770,t773,t780,t79,t796,t8,t814;
+double t817,t82,t822,t845,t860,t865,t9,t904,t91,t910,t911,t916,t919;
+double t92,t930,t936,t949,t952,t955,t968,t97,t98,t983,t986,t99,t995;
diff --git a/hathor/auto/self.cpp b/hathor/auto/self.cpp
new file mode 100644
index 0000000..6c0bcb2
--- /dev/null
+++ b/hathor/auto/self.cpp
@@ -0,0 +1,355 @@
+// $Modified: Sat Oct 21 14:03:46 2006 by puwer $
+ t3 = N2*beta*z-2.0+N2;
+ t4 = alpha*t3;
+ t5 = sigma0;
+ t6 = t4*t5;
+ t7 = s*beta2;
+ t8 = 2.0*t7;
+ t9 = mzq*beta2;
+ t10 = 4.0*t9;
+ t11 = beta6*mzq;
+ t12 = 4.0*t11;
+ t13 = mzq*beta4;
+ t14 = 2.0*t13;
+ t15 = s*beta;
+ t16 = t15*z;
+ t17 = 4.0*t16;
+ t18 = beta5*z3;
+ t20 = 6.0*t18*mzq;
+ t21 = beta5*z5;
+ t23 = 2.0*t21*mzq;
+ t24 = s*beta8;
+ t25 = t24*z2;
+ t26 = 3.0*t25;
+ t27 = s*beta6;
+ t28 = t27*z4;
+ t29 = 3.0*t28;
+ t32 = 4.0*mzq*beta5*z;
+ t33 = s*beta5;
+ t34 = t33*z5;
+ t35 = 4.0*t34;
+ t36 = t13*z2;
+ t37 = 2.0*t36;
+ t40 = 6.0*mzq*beta3*z;
+ t41 = t27*z6;
+ t42 = s*beta4;
+ t43 = t42*z2;
+ t44 = 7.0*t43;
+ t45 = t42*z4;
+ t47 = t27*z2;
+ t48 = -t8-t10+t12-t14+t17+t20-t23+t26-t29-t32-t35+t37+t40+t41-t44+5.0*t45
+-t47;
+ t49 = s*beta7;
+ t50 = t49*z5;
+ t52 = t49*z;
+ t54 = t33*z;
+ t56 = t33*z3;
+ t58 = s*beta3;
+ t59 = t58*z;
+ t60 = 2.0*t59;
+ t61 = t58*z3;
+ t63 = t49*z3;
+ t66 = 6.0*t11*z2;
+ t68 = 2.0*t11*z4;
+ t69 = t7*z2;
+ t70 = 4.0*t69;
+ t71 = t24*z4;
+ t72 = beta3*z3;
+ t74 = 6.0*t72*mzq;
+ t75 = t9*z2;
+ t76 = 4.0*t75;
+ t78 = 2.0*t24;
+ t79 = 2.0*s;
+ t80 = 2.0*t50+4.0*t52-8.0*t54+16.0*t56+t60-10.0*t61-6.0*t63-t66+t68+t70-
+t71-t74+t76+4.0*t42-t78-t79+t27;
+ t82 = B(t,mtq,mzq);
+ t84 = gvt*gvt;
+ t87 = 1/s;
+ t88 = beta*z;
+ t89 = -1.0+t88;
+ t90 = t89*t89;
+ t92 = 1/t90/t89;
+ t95 = 1/(1.0+t88);
+ t96 = t87*t92*t95;
+ t97 = 1/N;
+ t100 = 1/(-1.0-beta2+2.0*t88);
+ t102 = 1./M_PI;
+ t104 = t96*t97*t100*t102;
+ t107 = B(mtq,mtq,mzq);
+ t109 = 10.0*t13;
+ t110 = 2.0*t28;
+ t111 = 18.0*t36;
+ t112 = -t7+t10+t12-t109-t20+t23+t26+t110+t32+t111-t40+t44-t45;
+ t113 = 8.0*t47;
+ t114 = 2.0*t69;
+ t115 = 12.0*t75;
+ t116 = 3.0*t42;
+ t117 = 4.0*mzq;
+ t118 = beta4*z4;
+ t120 = 4.0*t118*mzq;
+ t121 = 5.0*t27;
+ t122 = -t113-t66+t68-t114-t71+t74-t115-t116-t78+s+t117-t120+t121;
+ t126 = beta-1.0;
+ t127 = 1/t126;
+ t129 = beta+1.0;
+ t130 = 1/t129;
+ t131 = t130*t102;
+ t133 = t96*t97*t127*t131;
+ t136 = 2.0*mzq;
+ t139 = beta2*z2;
+ t140 = 3.0*t139;
+ t141 = 2.0*beta2;
+ t142 = beta3*z;
+ t143 = 2.0*beta4;
+ t144 = beta4*z2;
+ t145 = 3.0*t144;
+ t146 = -t140+t141-t142+1.0+t88-t118-t143+t145;
+ t149 = diffB0(mtq,mt,mz);
+ t151 = 1/t90;
+ t153 = t95*t97;
+ t154 = t153*t102;
+ t158 = A(mtq);
+ t159 = A(mzq);
+ t160 = -t158+t159;
+ t162 = t118-t145+beta4+t140-beta2-1.0;
+ t166 = t5*t3*alpha*t87;
+ t168 = 1/t89;
+ t173 = t168*t95*t97*t100*t127*t131;
+ t176 = 9.0*t25;
+ t179 = -t8+t10-t12+t14+t17-t20+t23+t176+t29+t32-t35-t37-t40-t41-5.0*t43-
+t45-7.0*t47;
+ t184 = 6.0*t61;
+ t186 = 3.0*t71;
+ t188 = 6.0*t24;
+ t189 = 3.0*t27;
+ t190 = 6.0*t50+12.0*t52-16.0*t54+24.0*t56-t60-t184-18.0*t63+t66-t68+t70-
+t186+t74-t76+8.0*t42-t188-t79+t189;
+ t193 = gat*gat;
+ t199 = 3.0*t7;
+ t203 = t199+t10+t12-t109-t20+t23-t176-6.0*t28+t32+t111-t40-21.0*t43+3.0*
+t45;
+ t207 = 3.0*s;
+ t209 = 24.0*t47-t66+t68+6.0*t69+t186+t74-t115+9.0*t42+t188-t207+t117-t120
+-15.0*t27;
+ selfenergy_Z += t6*(t48+t80)*t82*t84*t104/2.0+t107*t84*(t112+t122)*t6*t133
+/2.0+t4*t5*(t7-t136-s)*t146*t84*t149*t151*t154/4.0-2.0*t84*t160*t162*t166*t173-
+t6*(t179+t190)*t82*t193*t104/2.0+t107*t193*(t203+t209)*t6*t133/2.0-t4*t5*(t199+
+t136-t207)*t146*t193*t149*t151*t154/4.0-2.0*t193*t160*t162*t166*t173;
+ t230 = 2.0*t16;
+ t232 = 2.0*t34;
+ t242 = -t7+t230+6.0*t25+t29-t232-t41-2.0*t43-2.0*t45-5.0*t47+4.0*t50+8.0*
+t52-10.0*t54+14.0*t56-t60-2.0*t61-12.0*t63+t114;
+ t247 = mhq*beta4;
+ t249 = mhq*beta6;
+ t251 = mhq*beta2;
+ t253 = mhq*beta5;
+ t254 = t253*z;
+ t256 = t253*z3;
+ t258 = t247*z2;
+ t260 = mhq*beta3;
+ t261 = t260*z;
+ t263 = t253*z5;
+ t265 = t249*z4;
+ t267 = t251*z2;
+ t269 = t260*z3;
+ t271 = t249*z2;
+ t273 = -2.0*t71+5.0*t42-4.0*t24-s+2.0*t27+2.0*t247-4.0*t249+4.0*t251+4.0*
+t254-6.0*t256-2.0*t258-6.0*t261+2.0*t263-2.0*t265-4.0*t267+6.0*t269+6.0*t271;
+ t275 = B(t,mtq,mhq);
+ t279 = 1/swq;
+ t280 = t102*t279;
+ t281 = mw*mw;
+ t282 = 1/t281;
+ t283 = t280*t282;
+ t285 = t100*t92*t153;
+ t286 = t283*t285;
+ t289 = t5*t102;
+ t291 = t7-t26-t110-t44+t45+t113+t114+t71+t116+t78-s-t121-5.0*t247;
+ t304 = 2.0*mhq+2.0*t249+2.0*t251+2.0*t254-3.0*t256+9.0*t258-3.0*t261+t263
++t265-6.0*t267+3.0*t269-3.0*t271-2.0*t247*z4;
+ t309 = B(mtq,mtq,mhq);
+ t312 = t279*t282;
+ t313 = t312*t97;
+ t322 = diffB0(mtq,mt,mh);
+ t330 = A(mhq);
+ t334 = t4*t95;
+ t336 = t97*t168;
+ t338 = t336*t100*t283;
+ selfenergy_H += t6*t126*t129*(t242+t273)*t275*t286/64.0-t289*t3*(t291+t304
+)*alpha*t309*t92*t95*t313/32.0+t6*s*t126*t129*(mhq-s+t7)*t146*t322*t153*t151*
+t282*t280/64.0-(t158-t330)*t162*t5*t334*t338/16.0;
+ t341 = 4.0*mwq;
+ t342 = 4.0*mbq;
+ t347 = diffB0(mtq,mb,mw);
+ t365 = B(t,mbq,mwq);
+ t367 = t279*t87;
+ t372 = mbq*beta2;
+ t374 = mbq*beta5;
+ t377 = z4*beta6;
+ t386 = mbq*beta4;
+ t391 = 8.0*t372-12.0*t374*z3-4.0*t377*mwq+24.0*t139*mwq-12.0*t72*mwq-t8
+-4.0*t21*mwq-8.0*t386*z4-8.0*mwq*beta2+t26+t28;
+ t395 = 6.0*t56;
+ t399 = -t34-t43-4.0*t47+t50+2.0*t52-5.0*t54+t395+3.0*t59-3.0*t61-3.0*t63+
+t114-t71;
+ t401 = mbq*beta6;
+ t406 = mbq*beta3;
+ t417 = t42-t78+t189+8.0*t401-20.0*t386+20.0*beta4*mwq-12.0*t406*z+8.0*
+t374*z+4.0*t374*z5+12.0*t406*z3-24.0*t372*z2;
+ t422 = z2*beta6;
+ t442 = -12.0*t401*z2+4.0*t401*z4+12.0*t422*mwq-8.0*beta5*mwq*z+36.0*t386*
+z2+8.0*t118*mwq+12.0*t142*mwq-36.0*t144*mwq+12.0*t18*mwq-8.0*mwq+8.0*mbq-8.0*
+beta6*mwq;
+ t445 = B(mtq,mbq,mwq);
+ t457 = A(mwq);
+ t458 = A(mbq);
+ t460 = (t457-t458)*t162;
+ selfenergy_W += -t4*t5*(t341-t342-s+t7)*t146*t347*t279*t151*t154/32.0+t5*(
+z+1.0)*(-1.0+z)*beta2*t4*(-2.0-beta2+t72+t143-t144-2.0*t142+3.0*t88)*(-t7+t230-
+s-t341+t342)*t365*t102*t367*t285/16.0-t6*(t391+t399+t417+t442)*t445*t102*t92*
+t95*t279*t87*t127*t130*t97/16.0-t460*t5*t4*t367*t173/2.0;
+ t466 = s*s;
+ t467 = t466*beta4;
+ t468 = s*mbq;
+ t469 = t468*beta2;
+ t470 = 8.0*t469;
+ t471 = t466*beta2;
+ t472 = 2.0*t471;
+ t473 = t7*mwq;
+ t475 = mbq*mwq;
+ t477 = mwq*s;
+ t479 = mb*mb;
+ t480 = t479*t479;
+ t482 = 8.0*t468;
+ t491 = t480*beta6;
+ t492 = 32.0*t491;
+ t493 = t466*beta8;
+ t494 = t480*beta2;
+ t495 = 32.0*t494;
+ t497 = t480*beta4;
+ t501 = beta*beta;
+ t502 = t501*t501;
+ t503 = t502*t502;
+ t505 = t466*t503*beta;
+ t506 = t505*z;
+ t510 = t467*z2;
+ t512 = -t492+t493+t495-16.0*t468+16.0*t497-t467-16.0*t469-8.0*t473+6.0*
+t506+6.0*t467*z4-5.0*t510;
+ t514 = 2.0*t471*z2;
+ t515 = t466*beta6;
+ t516 = t515*z4;
+ t519 = t466*t503*t501;
+ t520 = t519*z4;
+ t521 = t466*beta5;
+ t522 = t521*z5;
+ t523 = t480*beta5;
+ t525 = 48.0*t523*z3;
+ t526 = t494*z2;
+ t529 = 16.0*t491*z4;
+ t530 = t497*z2;
+ t532 = t480*beta3;
+ t534 = 48.0*t532*z;
+ t536 = 48.0*t491*z2;
+ t537 = t466*beta3;
+ t538 = t537*z3;
+ t540 = t514-11.0*t516-t520-t522-t525-32.0*t526-t529-16.0*t530-t534+t536
+-7.0*t538;
+ t542 = t468*beta6;
+ t545 = 3.0*t519*z2;
+ t546 = t505*z5;
+ t550 = t505*z3;
+ t555 = 16.0*t468*beta8;
+ t556 = t42*mwq;
+ t558 = t27*mwq;
+ t561 = 8.0*t24*mwq;
+ t563 = 16.0*t523*z5;
+ t564 = 8.0*t542+t545+3.0*t546+2.0*t515*z6-9.0*t550-2.0*t493*z6-t555+4.0*
+t556+12.0*t558-t561+t563;
+ t566 = 32.0*t523*z;
+ t567 = t515*z2;
+ t569 = t493*z2;
+ t571 = t466*beta7;
+ t572 = t571*z3;
+ t574 = t521*z;
+ t576 = t521*z3;
+ t579 = 2.0*t571*z5;
+ t580 = t468*beta4;
+ t582 = t493*z4;
+ t584 = t571*z;
+ t587 = 32.0*t372*mwq;
+ t589 = 48.0*t532*z3;
+ t590 = t566+5.0*t567-5.0*t569+11.0*t572-4.0*t574+5.0*t576-t579+32.0*t580+
+6.0*t582-9.0*t584-t587+t589;
+ t593 = t386*mwq;
+ t596 = 32.0*t401*mwq;
+ t597 = z2*mwq;
+ t598 = t42*t597;
+ t600 = z5*mwq;
+ t602 = 4.0*t33*t600;
+ t603 = z4*mwq;
+ t605 = 4.0*t24*t603;
+ t606 = z*mwq;
+ t608 = 8.0*t49*t606;
+ t609 = z3*mwq;
+ t611 = 12.0*t58*t609;
+ t613 = 12.0*t49*t609;
+ t614 = t27*t603;
+ t619 = -16.0*t593+t596-t472-4.0*t598-t602-t605+t608-t611-t613+4.0*t614+
+32.0*t15*z*mbq;
+ t621 = 48.0*t406*t609;
+ t623 = 48.0*t406*t606;
+ t624 = t386*t597;
+ t627 = 32.0*t374*t606;
+ t629 = 16.0*t374*t600;
+ t631 = 48.0*t374*t609;
+ t632 = t372*t597;
+ t635 = 48.0*t401*t597;
+ t637 = 16.0*t401*t603;
+ t638 = t468*t118;
+ t640 = beta5*z;
+ t645 = -t621+t623+16.0*t624-t627-t629+t631+32.0*t632-t635+t637+40.0*t638
+-64.0*t468*t640-32.0*t468*t21;
+ t649 = t468*t139;
+ t651 = t468*t422;
+ t657 = t468*t377;
+ t670 = 8.0*t468*beta8*z4;
+ t674 = -80.0*t468*t72+32.0*t649-8.0*t651+128.0*t468*t18+16.0*t468*t142
+-24.0*t657-48.0*t468*beta7*z3+8.0*t468*beta6*z6+32.0*t468*beta7*z-t670+16.0*
+t468*beta7*z5;
+ t676 = 56.0*t468*t144;
+ t679 = 24.0*t468*beta8*z2;
+ t681 = 4.0*t49*t600;
+ t683 = 12.0*t24*t597;
+ t685 = 24.0*t33*t609;
+ t686 = t27*t597;
+ t689 = 20.0*t33*t606;
+ t691 = 12.0*t58*t606;
+ t692 = t7*t597;
+ t694 = t537*z;
+ t696 = 2.0*t519;
+ t698 = -t676+t679+t681+t683+t685-16.0*t686-t689+t691+8.0*t692+7.0*t694-
+t696+4.0*t515;
+ t708 = t95*t102;
+ t722 = -t492+5.0*t493-t495+t482+32.0*t475+80.0*t497-3.0*t467+8.0*t477-
+t470+2.0*t506+3.0*t510-t514-t516-t520+t522+t525+96.0*t526-t529-144.0*t530+t534;
+ t737 = -t563-t566+3.0*t567-7.0*t569+9.0*t572+8.0*t574-9.0*t576-t579-24.0*
+t580+2.0*t582-7.0*t584;
+ t747 = t611+t613+12.0*t614+t621-t623+144.0*t624+t627+t629-t631-96.0*t632-
+t635;
+ t764 = -t685-48.0*t686+t689-t691-24.0*t692-3.0*t694-t696-2.0*t515+32.0*
+t497*z4-8.0*t477*t118-32.0*t475*t118;
+ selfenergy_Phi += t6*(t467+t470-t472+4.0*t473+t466-16.0*t475-4.0*t477+16.0
+*t480-t482)*t146*t347*t312*t151*t154/256.0+t6*(t512+t540+t564+t590+t619+t645+
+t674+t698)*t365*t279*t282*t87*t100*t92*t97*t708/128.0+t6*(t472-32.0*t480+t536+
+3.0*t538+40.0*t542+t545-t561-3.0*t550-t555+t546-t589+t596+60.0*t598+t587+t602-
+t605-t608-16.0*t649-8.0*t638+t637+16.0*t657+t676+t679-t681+t683+t722+t737+28.0*
+t558+t764-t670+t747-64.0*t651-80.0*t593-28.0*t556)*t445*t102*t92*t312*t87*t127*
+t130*t153/128.0+t460*(-t342-s+t7)*t5*t4*t312*t87*t100*t336*t95*t127*t131/16.0;
+ t792 = -t7-t10+t12-t14+t230+t20-t23-t29-t32-t232+t37+t40+t41;
+ t796 = -4.0*t43+4.0*t45+t47-2.0*t54+t395+t60-t184-t66+t68+t114-t74+t76+
+t42-s;
+ t814 = -3.0*t422+2.0*beta6+t377+2.0*t640-3.0*t18+t21-2.0*t118+9.0*t144
+-5.0*beta4+3.0*t72-3.0*t142+t141-6.0*t139+2.0;
+ selfenergy_Chi += -t5*t129*t126*t4*(t792+t796)*t82*t286/64.0-t289*t3*mzq*
+t814*alpha*t107*t92*t95*t313/32.0+t5*alpha*t126*t129*t146*s*mzq*t3*t149*t312*
+t151*t97*t708/64.0+t162*t160*t5*t334*t338/16.0;
diff --git a/hathor/auto/self.dec b/hathor/auto/self.dec
new file mode 100644
index 0000000..9a47330
--- /dev/null
+++ b/hathor/auto/self.dec
@@ -0,0 +1,29 @@
+/*
+* This is an automatically created file, don't edit!
+* File created on Thu Jul 20 21:55:16 CEST 2006
+* by ./DefVarsC.pl
+*/;
+double t10,t100,t102,t104,t107,t109,t11,t110,t111,t112,t113,t114,t115;
+double t116,t117,t118,t12,t120,t121,t122,t126,t127,t129,t13,t130,t131;
+double t133,t136,t139,t14,t140,t141,t142,t143,t144,t145,t146,t149,t15;
+double t151,t153,t154,t158,t159,t16,t160,t162,t166,t168,t17,t173,t176;
+double t179,t18,t184,t186,t188,t189,t190,t193,t199,t20,t203,t207,t209;
+double t21,t23,t230,t232,t24,t242,t247,t249,t25,t251,t253,t254,t256;
+double t258,t26,t260,t261,t263,t265,t267,t269,t27,t271,t273,t275,t279;
+double t28,t280,t281,t282,t283,t285,t286,t289,t29,t291,t3,t304,t309;
+double t312,t313,t32,t322,t33,t330,t334,t336,t338,t34,t341,t342,t347;
+double t35,t36,t365,t367,t37,t372,t374,t377,t386,t391,t395,t399,t4,t40;
+double t401,t406,t41,t417,t42,t422,t43,t44,t442,t445,t45,t457,t458;
+double t460,t466,t467,t468,t469,t47,t470,t471,t472,t473,t475,t477,t479;
+double t48,t480,t482,t49,t491,t492,t493,t494,t495,t497,t5,t50,t501;
+double t502,t503,t505,t506,t510,t512,t514,t515,t516,t519,t52,t520,t521;
+double t522,t523,t525,t526,t529,t530,t532,t534,t536,t537,t538,t54,t540;
+double t542,t545,t546,t550,t555,t556,t558,t56,t561,t563,t564,t566,t567;
+double t569,t571,t572,t574,t576,t579,t58,t580,t582,t584,t587,t589,t59;
+double t590,t593,t596,t597,t598,t6,t60,t600,t602,t603,t605,t606,t608;
+double t609,t61,t611,t613,t614,t619,t621,t623,t624,t627,t629,t63,t631;
+double t632,t635,t637,t638,t640,t645,t649,t651,t657,t66,t670,t674,t676;
+double t679,t68,t681,t683,t685,t686,t689,t69,t691,t692,t694,t696,t698;
+double t7,t70,t708,t71,t72,t722,t737,t74,t747,t75,t76,t764,t78,t79;
+double t792,t796,t8,t80,t814,t82,t84,t87,t88,t89,t9,t90,t92,t95,t96;
+double t97;
diff --git a/hathor/auto/vertices.cpp b/hathor/auto/vertices.cpp
new file mode 100644
index 0000000..b800d9b
--- /dev/null
+++ b/hathor/auto/vertices.cpp
@@ -0,0 +1,520 @@
+ t1 = C(mtq,0.0,t,mzq,mtq,mtq);
+ t2 = gvt*gvt;
+ t4 = beta-1.0;
+ t5 = t4*t4;
+ t6 = beta+1.0;
+ t7 = t6*t6;
+ t8 = t5*t7;
+ t9 = t8*s;
+ t13 = N2+N2*beta*z-2.0;
+ t14 = alpha*t13;
+ t15 = sigma0;
+ t16 = t14*t15;
+ t17 = 1./M_PI;
+ t18 = beta*z;
+ t19 = -1.0+t18;
+ t20 = t19*t19;
+ t21 = 1/t20;
+ t23 = 1/N;
+ t24 = t17*t21*t23;
+ t25 = t16*t24;
+ t28 = beta4*mzq;
+ t29 = 6.0*t28;
+ t30 = mzq*beta6;
+ t31 = 8.0*t30;
+ t32 = s*beta2;
+ t33 = 3.0*t32;
+ t34 = s*beta6;
+ t35 = s*beta4;
+ t37 = beta2*mzq;
+ t38 = 8.0*t37;
+ t39 = s*beta;
+ t40 = t39*z;
+ t41 = 3.0*t40;
+ t42 = s*beta8;
+ t43 = t42*z4;
+ t44 = 2.0*t43;
+ t45 = t42*z2;
+ t46 = 6.0*t45;
+ t47 = 2.0*mzq;
+ t48 = 2.0*s;
+ t50 = beta5*mzq*z;
+ t51 = 10.0*t50;
+ t52 = t28*z2;
+ t53 = 8.0*t52;
+ t54 = t32*z2;
+ t56 = t37*z2;
+ t57 = 4.0*t56;
+ t58 = s*beta5;
+ t59 = t58*z;
+ t60 = 13.0*t59;
+ t61 = s*beta7;
+ t62 = t61*z;
+ t64 = t35*z4;
+ t66 = -t29+t31-t33+t34+6.0*t35-t38+t41-t44+t46+t47-t48-t51+t53+7.0*t54+
+t57-t60+7.0*t62+10.0*t64;
+ t67 = t34*z4;
+ t68 = 6.0*t67;
+ t71 = 2.0*mzq*beta*z;
+ t72 = t35*z2;
+ t74 = 4.0*t42;
+ t75 = z5*beta5;
+ t77 = 4.0*t75*mzq;
+ t78 = beta3*z3;
+ t80 = 12.0*t78*mzq;
+ t83 = 12.0*z3*mzq*beta5;
+ t84 = t34*z6;
+ t85 = 2.0*t84;
+ t86 = t61*z5;
+ t88 = t61*z3;
+ t90 = t58*z5;
+ t91 = 8.0*t90;
+ t92 = s*beta3;
+ t93 = t92*z3;
+ t95 = t58*z3;
+ t96 = 26.0*t95;
+ t97 = t34*z2;
+ t99 = t92*z;
+ t100 = 7.0*t99;
+ t102 = 4.0*t30*z4;
+ t104 = 12.0*t30*z2;
+ t106 = beta3*mzq*z;
+ t107 = 16.0*t106;
+ t108 = -t68-t71-18.0*t72-t74-t77-t80+t83+t85+4.0*t86-12.0*t88-t91-14.0*
+t93+t96+3.0*t97+t100+t102-t104+t107;
+ t110 = B(t,mtq,mzq);
+ t114 = 2.0*t18;
+ t115 = -1.0-beta2+t114;
+ t116 = 1/t115;
+ t117 = 1/s;
+ t120 = 1/(1.0+t18);
+ t123 = 1/t20/t19;
+ t126 = t116*t117*t120*t17*t123*t23;
+ t129 = B(mtq,mtq,mzq);
+ t131 = 22.0*t28;
+ t134 = 16.0*t37;
+ t135 = 6.0*t50;
+ t136 = 32.0*t52;
+ t137 = 2.0*t54;
+ t138 = 20.0*t56;
+ t139 = -t131+t31-t32+9.0*t34-5.0*t35+t134+t40-t44+t46+t47+s+t135+t136-
+t137-t138;
+ t140 = 3.0*t59;
+ t141 = 2.0*t64;
+ t143 = 10.0*t72;
+ t145 = 8.0*t28*z4;
+ t147 = 3.0*t99;
+ t148 = 8.0*t106;
+ t149 = t140-t62-t141+4.0*t67-t71+t143-t145-t74+t77+t80-t83-14.0*t97-t147+
+t102-t104-t148;
+ t153 = 1/t6;
+ t154 = 1/t4;
+ t156 = t153*t154*t117;
+ t157 = t120*t17;
+ t158 = t123*t23;
+ t160 = t156*t157*t158;
+ t163 = A(mtq);
+ t165 = beta5*z;
+ t167 = beta3*z;
+ t169 = beta4*z4;
+ t171 = 2.0*beta2;
+ t173 = beta4*z2;
+ t176 = beta2*z2;
+ t178 = beta5*z3;
+ t180 = t18-3.0*t165+4.0*t167-1.0+2.0*t169+beta4-t171-6.0*t78-4.0*t173-2.0
+*t75+4.0*t176+6.0*t178;
+ t183 = t14*t15*t116;
+ t185 = t21*t23;
+ t187 = t156*t157*t185;
+ t190 = A(mzq);
+ t196 = t15*t13;
+ t197 = -s+t32-t47;
+ t202 = -3.0*t176+t171-t167+t18+1.0-t169-2.0*beta4+3.0*t173;
+ t205 = diffB0(mtq,mt,mz);
+ t212 = t6*alpha;
+ t214 = t196*t24;
+ t217 = gat*gat;
+ t223 = 7.0*t34;
+ t225 = 6.0*t43;
+ t226 = 18.0*t45;
+ t229 = -t29+t31+5.0*t32-t223-10.0*t35-t38+t41+t225-t226+t47-t48-t51+t53-
+t54+t57+35.0*t59-25.0*t62+t141;
+ t230 = 6.0*t72;
+ t231 = 12.0*t42;
+ t234 = 2.0*t93;
+ t236 = 11.0*t97;
+ t237 = 9.0*t99;
+ t238 = -t68-t71+t230+t231-t77-t80+t83+t85-12.0*t86+36.0*t88+t91+t234-38.0
+*t95+t236-t237+t102-t104+t107;
+ t249 = 6.0*t54;
+ t250 = -t131+t31-9.0*t32-31.0*t34+27.0*t35+t134+t40+t225-t226+t47+s+t135+
+t136+t249-t138;
+ t255 = t140-t62+6.0*t64-12.0*t67-t71-30.0*t72-t145+t231+t77+t80-t83+42.0*
+t97-t147+t102-t104-t148;
+ t271 = 3.0*s;
+ t272 = -t271+t33+t47;
+ Z_vertex = -t1*t2*t9*t25/4.0-t16*(t66+t108)*t110*t2*t126/2.0-t129*t2*(
+t139+t149)*t16*t160/2.0+2.0*t2*t163*t180*t183*t187-2.0*t2*t190*t180*t183*t187-
+t196*alpha*t197*t202*t2*t205*t120*t24/2.0+t2*t4*t212*t214/2.0-t1*t217*t9*t25/
+4.0-t16*(t229+t238)*t110*t217*t126/2.0-t129*t217*(t250+t255)*t16*t160/2.0+2.0*
+t217*t163*t180*t183*t187-2.0*t217*t190*t180*t183*t187+t196*alpha*t272*t202*t217
+*t205*t120*t24/2.0+t217*t4*t212*t214/2.0;
+ t285 = 1/swq;
+ t286 = t185*t285;
+ t287 = t16*t286;
+ t288 = mw*mw;
+ t289 = 1/t288;
+ t290 = t289*t17;
+ t291 = t290*t5;
+ t294 = s*s;
+ t295 = C(mtq,0.0,t,mhq,mtq,mtq);
+ t301 = t4*t6;
+ t304 = 4.0*t43;
+ t305 = 12.0*t45;
+ t308 = 4.0*t64;
+ t309 = 8.0*t42;
+ t312 = 4.0*t90;
+ t313 = -t33+5.0*t34+8.0*t35+t40-t304+t305+t54-23.0*t59+17.0*t62-t308+t68-
+t309-t85+8.0*t86-24.0*t88-t312-t234;
+ t314 = mhq*beta3;
+ t316 = 12.0*t314*z3;
+ t317 = mhq*beta2;
+ t318 = t317*z2;
+ t320 = mhq*beta6;
+ t322 = 4.0*t320*z4;
+ t323 = t314*z;
+ t326 = 12.0*t320*z2;
+ t329 = 2.0*mhq*beta*z;
+ t330 = mhq*beta4;
+ t331 = t330*z2;
+ t333 = mhq*beta5;
+ t334 = t333*z;
+ t337 = 12.0*t333*z3;
+ t339 = 4.0*t333*z5;
+ t342 = 8.0*t320;
+ t343 = 2.0*mhq;
+ t344 = t96-t236+t99+t316-4.0*t318-t322-16.0*t323+t326+t329-8.0*t331+10.0*
+t334-t337+t339+6.0*t330+8.0*t317-t342-t343;
+ t346 = B(t,mtq,mhq);
+ t350 = t158*t285;
+ t353 = t350*t290*t116*t120;
+ t356 = t15*t23;
+ t358 = t14*t356*t123;
+ t359 = t285*t289;
+ t360 = t359*t17;
+ t366 = -t33-21.0*t34+17.0*t35+t40+t304-t305-s+t249+t140-t62+t308-8.0*t67
+-24.0*t72+t309+30.0*t97;
+ t375 = -t147+t316-20.0*t318+t322-8.0*t323-t326-t329+32.0*t331+6.0*t334-
+t337+t339-22.0*t330+16.0*t317+t342+t343-8.0*t330*z4;
+ t378 = B(mtq,mtq,mhq);
+ t384 = mhq-s+t32;
+ t388 = diffB0(mtq,mt,mh);
+ t391 = t359*t185;
+ t397 = t196*t120;
+ t401 = t116*t17*t289*t286;
+ t403 = t163*t180*alpha*t397*t401/16.0;
+ t404 = A(mhq);
+ t411 = t14*t356*t21;
+ t414 = t411*t360*t9/64.0;
+ H_vertex = t287*t291*t7*(beta2+t114-3.0)*t294*t295/128.0-t16*t301*(t313+
+t344)*t346*t353/64.0+t358*t360*(t366+t375)*t120*t378/64.0-t16*s*t4*t6*t384*t202
+*t388*t157*t391/32.0-t403+t404*t180*alpha*t397*t401/16.0-t414;
+ t415 = t285*t17;
+ t418 = C(mtq,0.0,t,mwq,mbq,mbq);
+ t424 = 3.0*t35;
+ t431 = -t33+t34-t424+5.0*t40+t44-t46-t271+8.0*t54+9.0*t59-13.0*t62+12.0*
+t64-10.0*t67;
+ t435 = 2.0*t90;
+ t438 = mbq*beta2;
+ t440 = beta6*mwq;
+ t441 = 16.0*t440;
+ t442 = mbq*beta6;
+ t443 = 16.0*t442;
+ t444 = -t143+t74+4.0*t84-6.0*t86+18.0*t88-t435-18.0*t93+4.0*t97+t100+16.0
+*t438+t441-t443;
+ t446 = beta2*mwq;
+ t448 = mwq*beta4;
+ t450 = mbq*beta4;
+ t452 = 4.0*mwq;
+ t453 = 4.0*mbq;
+ t454 = beta5*mwq;
+ t456 = 24.0*t454*z3;
+ t458 = 8.0*t440*z4;
+ t460 = 24.0*t440*z2;
+ t463 = 4.0*mwq*beta*z;
+ t464 = beta3*mwq;
+ t465 = t464*z;
+ t467 = t454*z;
+ t469 = t448*z2;
+ t471 = -16.0*t446-12.0*t448+12.0*t450+t452-t453+t456+t458-t460-t463+32.0*
+t465-20.0*t467+16.0*t469;
+ t472 = t446*z2;
+ t474 = mbq*beta5;
+ t476 = 24.0*t474*z3;
+ t478 = 8.0*t474*z5;
+ t479 = mbq*beta3;
+ t481 = 24.0*t479*z3;
+ t483 = 8.0*t442*z4;
+ t485 = 24.0*t442*z2;
+ t486 = t479*z;
+ t488 = t438*z2;
+ t490 = t450*z2;
+ t492 = t474*z;
+ t494 = mbq*beta;
+ t496 = 4.0*t494*z;
+ t498 = 8.0*t454*z5;
+ t500 = 24.0*t464*z3;
+ t501 = 8.0*t472-t476+t478+t481-t483+t485-32.0*t486-8.0*t488-16.0*t490+
+20.0*t492+t496-t498-t500;
+ t506 = t117*t120;
+ t507 = B(t,mbq,mwq);
+ t512 = B(mtq,mbq,mwq);
+ t515 = -t33-t223+t424+t40+t44-t46+t271-t249+t60-5.0*t62-2.0*t67+t230;
+ t518 = 6.0*t93;
+ t524 = t74-2.0*t86+6.0*t88+t435+t518-12.0*t95+6.0*t97-t237-32.0*t438+t441
+-t443+32.0*t446-44.0*t448;
+ t531 = 44.0*t450+t452-t453-t456+t458-t460-t463-16.0*t465+12.0*t467+64.0*
+t469-40.0*t472+t476;
+ t540 = -t478-t481-t483+t485+16.0*t486+40.0*t488-64.0*t490-12.0*t492+t496+
+t498+t500-16.0*t169*mwq+16.0*t169*mbq;
+ t547 = t154*t117;
+ t548 = t547*t120;
+ t553 = t452-t453-s+t32;
+ t557 = diffB0(mtq,mb,mw);
+ t563 = A(mbq);
+ t566 = t116*t153;
+ t567 = t196*t566;
+ t570 = t548*t415*t185;
+ t573 = A(mwq);
+ W_vertex = t411*t415*t4*t6*mbq*t418/4.0-t16*t350*t17*(t431+t444+t471+t501
+)*t116*t506*t507/16.0-t512*(t515+t524+t531+t540)*alpha*t196*t153*t548*t415*t158
+/16.0+t196*alpha*t553*t202*t557*t120*t17*t286/16.0+t563*t180*alpha*t567*t570/
+2.0-t573*t180*alpha*t567*t570/2.0+t14*t356*t21*t285*t17*t4*t6/8.0;
+ t595 = mb*mb;
+ t596 = t595*t595;
+ t599 = 16.0*t596*beta*z;
+ t600 = beta*beta;
+ t601 = t600*t600;
+ t602 = t601*t601;
+ t604 = t294*t602*beta;
+ t605 = t604*z;
+ t607 = mbq*s;
+ t609 = 8.0*t607*t18;
+ t611 = t35*z4*mbq;
+ t613 = s*mwq;
+ t615 = 4.0*t613*t18;
+ t616 = mwq*z;
+ t617 = t92*t616;
+ t619 = mwq*z2;
+ t620 = t35*t619;
+ t622 = t613*t176;
+ t624 = t607*t167;
+ t628 = t607*t173;
+ t630 = t294+t599+13.0*t605-t609+80.0*t611-t615+36.0*t617+8.0*t620+8.0*
+t622+88.0*t624+40.0*t607*t176-144.0*t628;
+ t631 = t607*t165;
+ t633 = beta6*z2;
+ t634 = t607*t633;
+ t636 = beta8*z2;
+ t638 = 48.0*t607*t636;
+ t639 = beta8*z4;
+ t641 = 16.0*t607*t639;
+ t642 = beta6*z4;
+ t643 = t607*t642;
+ t646 = t607*beta7*z;
+ t649 = 48.0*t178*t613;
+ t650 = t58*t616;
+ t652 = t633*t613;
+ t654 = t61*t616;
+ t656 = beta7*z3;
+ t658 = 24.0*t656*t613;
+ t659 = beta7*z5;
+ t661 = 8.0*t659*t613;
+ t662 = -104.0*t631+40.0*t634+t638-t641-48.0*t643+56.0*t646+t649-52.0*t650
+-40.0*t652+20.0*t654-t658+t661;
+ t665 = 24.0*t636*t613;
+ t667 = 8.0*t639*t613;
+ t669 = 24.0*t78*t613;
+ t671 = 8.0*t75*t613;
+ t672 = t642*t613;
+ t676 = 32.0*t474*z5*mwq;
+ t677 = t438*t619;
+ t679 = t479*t616;
+ t681 = z3*mwq;
+ t683 = 96.0*t479*t681;
+ t685 = 96.0*t474*t681;
+ t686 = t450*t619;
+ t688 = t474*t616;
+ t690 = t665-t667-t669-t671+8.0*t672-t676+32.0*t677+128.0*t679-t683+t685+
+64.0*t686-80.0*t688;
+ t692 = 16.0*t494*t616;
+ t693 = z4*mwq;
+ t695 = 32.0*t442*t693;
+ t697 = 96.0*t442*t619;
+ t712 = t602*t600;
+ t713 = t294*t712;
+ t714 = 4.0*t713;
+ t715 = t596*beta6;
+ t716 = 64.0*t715;
+ t717 = t294*beta8;
+ t719 = t294*beta6;
+ t721 = -t692+t695-t697+32.0*t607*t659-96.0*t607*t656-64.0*t607*t75-80.0*
+t92*z3*mbq+16.0*t607*beta6*z6+176.0*t607*t178-t714-t716+3.0*t717+8.0*t719;
+ t724 = t596*beta2;
+ t726 = t294*beta4;
+ t728 = t294*beta2;
+ t730 = t613*beta4;
+ t732 = t607*beta4;
+ t734 = t728*z2;
+ t738 = t294*beta3;
+ t739 = t738*z;
+ t744 = t294*beta*z;
+ t746 = t32*mwq;
+ t748 = t607*beta2;
+ t749 = 24.0*t748;
+ t750 = 64.0*t724-4.0*t726-4.0*t728+4.0*t730+32.0*t732+4.0*t734-14.0*t726*
+z2+18.0*t739+12.0*t726*z4-3.0*t744-20.0*t746-t749;
+ t751 = 16.0*t596;
+ t752 = 4.0*t613;
+ t754 = 16.0*mbq*mwq;
+ t755 = t596*beta4;
+ t757 = t596*beta3;
+ t758 = t757*z;
+ t760 = t607*beta6;
+ t763 = 32.0*t607*beta8;
+ t765 = 96.0*t757*z3;
+ t766 = t596*beta5;
+ t768 = 32.0*t766*z5;
+ t770 = 96.0*t766*z3;
+ t772 = 32.0*t715*z4;
+ t773 = t724*z2;
+ t775 = -t751+t752+t754+48.0*t755-128.0*t758+8.0*t760-t763+t765+t768-t770-
+t772-32.0*t773;
+ t777 = t755*z2;
+ t780 = 96.0*t715*z2;
+ t781 = t34*mwq;
+ t784 = 16.0*t42*mwq;
+ t785 = t294*z4;
+ t786 = t785*beta8;
+ t788 = t294*beta5;
+ t789 = t788*z;
+ t791 = t766*z;
+ t793 = t294*beta7;
+ t795 = 4.0*t793*z5;
+ t797 = 2.0*t788*z5;
+ t798 = t793*z;
+ t800 = t793*z3;
+ t802 = t604*z3;
+ t804 = -64.0*t777+t780+28.0*t781-t784+12.0*t786-6.0*t789+80.0*t791-t795-
+t797-22.0*t798+26.0*t800-18.0*t802;
+ t806 = 2.0*t785*t712;
+ t808 = 6.0*t713*z2;
+ t809 = t450*mwq;
+ t811 = t438*mwq;
+ t814 = 64.0*t442*mwq;
+ t815 = t717*z2;
+ t817 = t788*z3;
+ t819 = t738*z3;
+ t821 = t719*z2;
+ t823 = t785*beta6;
+ t829 = t604*z5;
+ t831 = -t806+t808-48.0*t809-64.0*t811+t814-14.0*t815+2.0*t817-10.0*t819+
+18.0*t821-22.0*t823+4.0*t719*z6-4.0*t717*z6+6.0*t829;
+ t853 = -t294+t599+5.0*t605+t609-16.0*t611-t615-12.0*t617+104.0*t620-40.0*
+t622-24.0*t624+48.0*t628;
+ t861 = 24.0*t631-96.0*t634+t638-t641+32.0*t643-8.0*t646-t649+28.0*t650
+-88.0*t652-12.0*t654+t658;
+ t866 = -t661+t665-t667+t669+t671+24.0*t672+t676-160.0*t677-64.0*t679+t683
+-t685;
+ t871 = 8.0*t607;
+ t874 = 256.0*t686+48.0*t688-t692+t695-t697-t714-t716+11.0*t717-6.0*t719-
+t871-128.0*t724-6.0*t726;
+ t883 = 6.0*t728-76.0*t730-56.0*t732-2.0*t734-10.0*t739+t744+28.0*t746+
+t749-t751+t752+t754;
+ t890 = 176.0*t755+64.0*t758+72.0*t760-t763-t765-t768+t770-t772+160.0*t773
+-256.0*t777+t780+60.0*t781;
+ t898 = -t784+4.0*t786+22.0*t789-48.0*t791-t795+t797-18.0*t798+18.0*t800
+-6.0*t802-t806+t808;
+ t913 = -176.0*t809+128.0*t811+t814-16.0*t815-18.0*t817+6.0*t819+12.0*t821
+-2.0*t823+2.0*t829-16.0*t35*t693-64.0*t450*t693+64.0*t755*z4;
+ t924 = 8.0*t748;
+ t925 = 4.0*t746;
+ t927 = -t754+t751-t871+t924-t752+t925-2.0*t728+t294+t726;
+ t935 = t32-t453-s;
+ t941 = t547*t157*t391;
+ Phi_vertex = t287*t290*t4*t6*(-t32+4.0*t40+t453-t271)*mbq*t418/32.0-t16*(
+t630+t662+t690+t721+t750+t775+t804+t831)*t507*t116*t506*t23*t123*t285*t290/
+128.0-t16*t158*t359*t17*(t853+t861+t866+t874+t883+t890+t898+t913)*t120*t547*
+t153*t512/128.0-t16*t927*t202*t557*t157*t289*t286/128.0-t563*t935*t180*alpha*
+t567*t941/16.0+t573*t935*t180*t15*t14*t566*t941/16.0-t411*t360*t301*t935/64.0;
+ t963 = t29-t31+t32+t34+t38+t40-t47+t51-t53-3.0*t54-t57+t59+t62-8.0*t64;
+ t967 = t68+t71+12.0*t72+t77+t80-t83-t85+t312+t518-6.0*t95-7.0*t97-t100-
+t102+t104-t107;
+ t974 = -t131+t31+t32-t34+t35+t134+t40+t47-s+t135+t136+t137-t138;
+ t977 = t140-t62-t71-4.0*t72-t145+t77+t80-t83+2.0*t97-t147+t102-t104-t148;
+ t990 = s*mzq;
+ Chi_vertex = -t287*t291*t7*t115*t294*t1/128.0-t16*t301*(t963+t967)*t110*
+t353/64.0+t358*t360*(t974+t977)*t120*t129/64.0-t403+t190*t180*t15*t14*t120*t401
+/16.0-t16*t990*t301*t202*t205*t157*t391/32.0-t414;
+ t999 = N*t4*t6;
+ t1000 = z2*alpha;
+ t1001 = t1000*t15;
+ t1002 = t999*t1001;
+ t1003 = mz*mz;
+ t1004 = t1003*t1003;
+ t1005 = 4.0*t1004;
+ t1007 = 1/t19;
+ t1010 = t117*t17;
+ t1011 = C(mtq,mtq,s,mtq,mzq,mtq);
+ t1018 = (-t47+t32)*t2;
+ t1020 = t1007*t120;
+ t1021 = t1020*t1010;
+ t1024 = B(s,mtq,mtq);
+ t1045 = (t33+t47)*t217;
+ Z_svertex = t1002*(-t1005+t728+t726)*t1007*t120*t1010*t2*t1011/2.0-t1002*
+t1018*t129*t1021+t1002*t1018*t1024*t1021+t1002*beta2*t197*t205*t2*t1007*t157/
+2.0-t1002*(-t728+t1005+8.0*t990*beta2+3.0*t726)*t217*t1011*t1021/2.0+t1002*
+t1045*t129*t1021-t1002*t1045*t1024*t1021-t1002*beta2*t272*t205*t217*t1007*t157/
+2.0;
+ t1060 = t8*N*t1001;
+ t1061 = t359*t1007;
+ t1065 = mh*mh;
+ t1066 = t1065*t1065;
+ t1069 = C(mtq,mtq,s,mtq,mhq,mtq);
+ t1075 = t32+mhq;
+ t1086 = N*z2;
+ t1087 = alpha*t15;
+ t1090 = t359*t1020;
+ t1091 = t17*beta2;
+ H_svertex = t1060*t1061*t157*(t726-t728+3.0*mhq*s*beta2+2.0*t1066)*t1069/
+32.0-t1060*t1061*t157*t1075*t378/16.0+t1060*t1061*t157*t1075*t1024/16.0+t9*
+t1086*t1087*t1090*t1091*t384*t388/32.0;
+ t1097 = 2.0*t39;
+ t1103 = C(mtq,mtq,s,mbq,mwq,mbq);
+ t1110 = t1020*t117;
+ t1111 = t32+t452-t453+s;
+ t1117 = B(s,mbq,mbq);
+ W_svertex = t999*t1000*t15*(-t32+t1097-s-t452+t453)*(t32+t1097+s+t452-
+t453)*t1103*t1007*t506*t415/32.0+t1002*t1110*t415*t1111*t512/8.0-t1002*t1110*
+t415*t1111*t1117/8.0-t1002*t1020*t285*t1091*t553*t557/16.0;
+ t1129 = t294*s;
+ t1131 = t294*mwq;
+ t1136 = t294*mbq;
+ t1139 = t288*t288;
+ t1144 = s*t596;
+ t1160 = t1129*beta6+8.0*t1131*beta4-3.0*t1129*beta4+4.0*t1136*beta4+16.0*
+t32*t1139-8.0*t1136*beta2-16.0*t1144*beta2+3.0*t1129*beta2-64.0*t596*t595+128.0
+*t596*mwq-64.0*mbq*t1139-8.0*t1131-16.0*s*t1139+16.0*t1144-t1129+4.0*t1136;
+ t1172 = t999*t1000*t15*(t726+t924+t925-t294+t751-t754-t752);
+ t1186 = t289*t1007;
+ Phi_svertex = t999*t1000*t15*t1160*t1103*t285*t289*t1021/256.0-t1172*t512
+*t285*t289*t1021/64.0+t1172*t1117*t285*t289*t1021/64.0+t999*t1000*t15*t285*
+t1186*t120*t1091*t927*t557/128.0;
+ t1193 = t1086*t5;
+ t1194 = t7*mzq;
+ t1196 = t1193*t1194*t1087;
+ t1205 = t1193*t1194*alpha;
+ t1207 = t15*t289*t285;
+ Chi_svertex = t1196*(t32+t47)*t1011*t285*t1186*t157/32.0-t1205*t1207*
+t1020*t17*t129/16.0+t1205*t1207*t1020*t17*t1024/16.0+t1196*t1090*t17*s*beta2*
+t205/32.0;
diff --git a/hathor/auto/vertices.dec b/hathor/auto/vertices.dec
new file mode 100644
index 0000000..4fcfca4
--- /dev/null
+++ b/hathor/auto/vertices.dec
@@ -0,0 +1,40 @@
+/*
+* This is an automatically created file, don't edit!
+* File created on Thu Jul 20 22:34:43 CEST 2006
+* by ./DefVarsC.pl
+*/;
+double t1,t100,t1000,t1001,t1002,t1003,t1004,t1005,t1007,t1010,t1011;
+double t1018,t102,t1020,t1021,t1024,t104,t1045,t106,t1060,t1061,t1065;
+double t1066,t1069,t107,t1075,t108,t1086,t1087,t1090,t1091,t1097,t110;
+double t1103,t1110,t1111,t1117,t1129,t1131,t1136,t1139,t114,t1144,t115;
+double t116,t1160,t117,t1172,t1186,t1193,t1194,t1196,t120,t1205,t1207;
+double t123,t126,t129,t13,t131,t134,t135,t136,t137,t138,t139,t14,t140;
+double t141,t143,t145,t147,t148,t149,t15,t153,t154,t156,t157,t158,t16;
+double t160,t163,t165,t167,t169,t17,t171,t173,t176,t178,t18,t180,t183;
+double t185,t187,t19,t190,t196,t197,t2,t20,t202,t205,t21,t212,t214;
+double t217,t223,t225,t226,t229,t23,t230,t231,t234,t236,t237,t238,t24;
+double t249,t25,t250,t255,t271,t272,t28,t285,t286,t287,t288,t289,t29;
+double t290,t291,t294,t295,t30,t301,t304,t305,t308,t309,t31,t312,t313;
+double t314,t316,t317,t318,t32,t320,t322,t323,t326,t329,t33,t330,t331;
+double t333,t334,t337,t339,t34,t342,t343,t344,t346,t35,t350,t353,t356;
+double t358,t359,t360,t366,t37,t375,t378,t38,t384,t388,t39,t391,t397;
+double t4,t40,t401,t403,t404,t41,t411,t414,t415,t418,t42,t424,t43,t431;
+double t435,t438,t44,t440,t441,t442,t443,t444,t446,t448,t45,t450,t452;
+double t453,t454,t456,t458,t46,t460,t463,t464,t465,t467,t469,t47,t471;
+double t472,t474,t476,t478,t479,t48,t481,t483,t485,t486,t488,t490,t492;
+double t494,t496,t498,t5,t50,t500,t501,t506,t507,t51,t512,t515,t518;
+double t52,t524,t53,t531,t54,t540,t547,t548,t553,t557,t56,t563,t566;
+double t567,t57,t570,t573,t58,t59,t595,t596,t599,t6,t60,t600,t601,t602;
+double t604,t605,t607,t609,t61,t611,t613,t615,t616,t617,t619,t62,t620;
+double t622,t624,t628,t630,t631,t633,t634,t636,t638,t639,t64,t641,t642;
+double t643,t646,t649,t650,t652,t654,t656,t658,t659,t66,t661,t662,t665;
+double t667,t669,t67,t671,t672,t676,t677,t679,t68,t681,t683,t685,t686;
+double t688,t690,t692,t693,t695,t697,t7,t71,t712,t713,t714,t715,t716;
+double t717,t719,t72,t721,t724,t726,t728,t730,t732,t734,t738,t739,t74;
+double t744,t746,t748,t749,t75,t750,t751,t752,t754,t755,t757,t758,t760;
+double t763,t765,t766,t768,t77,t770,t772,t773,t775,t777,t78,t780,t781;
+double t784,t785,t786,t788,t789,t791,t793,t795,t797,t798,t8,t80,t800;
+double t802,t804,t806,t808,t809,t811,t814,t815,t817,t819,t821,t823;
+double t829,t83,t831,t84,t85,t853,t86,t861,t866,t871,t874,t88,t883;
+double t890,t898,t9,t90,t91,t913,t92,t924,t925,t927,t93,t935,t941,t95;
+double t96,t963,t967,t97,t974,t977,t99,t990,t999;

File Metadata

Mime Type
text/x-diff
Expires
Sat, May 3, 5:40 AM (5 h, 24 m)
Storage Engine
local-disk
Storage Format
Raw Data
Storage Handle
c7/60/fd458a1345231e9c4a0459c288aa
Default Alt Text
(1 MB)

Event Timeline