CS    REAL FUNCTION DAW(XX)
      DOUBLE PRECISION FUNCTION DAW(XX)
C----------------------------------------------------------------------
C
C This function program evaluates Dawson's integral,
C
C                       2  / x   2
C                     -x   |    t
C             F(x) = e     |   e    dt
C                          |
C                          / 0
C
C   for a real argument x.
C
C   The calling sequence for this function is
C
C                   Y=DAW(X)
C
C   The main computation uses rational Chebyshev approximations
C   published in Math. Comp. 24, 171-178 (1970) by Cody, Paciorek
C   and Thacher.  This transportable program is patterned after the
C   machine-dependent FUNPACK program DDAW(X), but cannot match that
C   version for efficiency or accuracy.  This version uses rational
C   approximations that are theoretically accurate to about 19
C   significant decimal digits.  The accuracy achieved depends on the
C   arithmetic system, the compiler, the intrinsic functions, and
C   proper selection of the machine-dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   XINF   = largest positive machine number
C   XMIN   = the smallest positive machine number.
C   EPS    = smallest positive number such that 1+eps > 1.
C            Approximately  beta**(-p), where beta is the machine
C            radix and p is the number of significant base-beta
C            digits in a floating-point number.
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   XMAX   = absolute argument beyond which DAW(X) underflows.
C            XMAX = min(0.5/xmin, xinf).
C   XSMALL = absolute argument below DAW(X)  may be represented
C            by X.  We recommend XSMALL = sqrt(eps).
C   XLARGE = argument beyond which DAW(X) may be represented by
C            1/(2x).  We recommend XLARGE = 1/sqrt(eps).
C
C     Approximate values for some important machines are
C
C                        beta  p     eps     xmin       xinf
C
C  CDC 7600      (S.P.)    2  48  7.11E-15  3.14E-294  1.26E+322
C  CRAY-1        (S.P.)    2  48  7.11E-15  4.58E-2467 5.45E+2465
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)    2  24  1.19E-07  1.18E-38   3.40E+38
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)    2  53  1.11D-16  2.23E-308  1.79D+308
C  IBM 3033      (D.P.)   16  14  1.11D-16  5.40D-79   7.23D+75
C  VAX 11/780    (S.P.)    2  24  5.96E-08  2.94E-39   1.70E+38
C                (D.P.)    2  56  1.39D-17  2.94D-39   1.70D+38
C   (G Format)   (D.P.)    2  53  1.11D-16  5.57D-309  8.98D+307
C
C                         XSMALL     XLARGE     XMAX
C
C  CDC 7600      (S.P.)  5.96E-08   1.68E+07  1.59E+293
C  CRAY-1        (S.P.)  5.96E-08   1.68E+07  5.65E+2465
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)  2.44E-04   4.10E+03  4.25E+37
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  1.05E-08   9.49E+07  2.24E+307
C  IBM 3033      (D.P.)  3.73D-09   2.68E+08  7.23E+75
C  VAX 11/780    (S.P.)  2.44E-04   4.10E+03  1.70E+38
C                (D.P.)  3.73E-09   2.68E+08  1.70E+38
C   (G Format)   (D.P.)  1.05E-08   9.49E+07  8.98E+307
C
C*******************************************************************
C*******************************************************************
C
C Error Returns
C
C  The program returns 0.0 for |X| > XMAX.
C
C Intrinsic functions required are:
C
C     ABS
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 9, 1992
C
C----------------------------------------------------------------------
      INTEGER I
CS    REAL
      DOUBLE PRECISION
     1     FRAC,HALF,ONE,ONE225,P1,P2,P3,P4,Q1,Q2,Q3,Q4,SIX25,
     2     SUMP,SUMQ,TWO5,W2,X,XX,Y,XLARGE,XMAX,XSMALL,ZERO
      DIMENSION P1(10),P2(10),P3(10),P4(10),Q1(10),Q2(9),Q3(9),Q4(9)
C----------------------------------------------------------------------
C  Mathematical constants.
C----------------------------------------------------------------------
CS    DATA ZERO,HALF,ONE/0.0E0,0.5E0,1.0E0/,
CS   1     SIX25,ONE225,TWO5/6.25E0,12.25E0,25.0E0/
      DATA ZERO,HALF,ONE/0.0D0,0.5D0,1.0D0/,
     1     SIX25,ONE225,TWO5/6.25D0,12.25D0,25.0D0/
C----------------------------------------------------------------------
C  Machine-dependent constants
C----------------------------------------------------------------------
CS    DATA XSMALL/2.44E-04/, XLARGE/4.10E+03/, XMAX/4.25E+37/
      DATA XSMALL/1.05D-08/, XLARGE/9.49D+07/, XMAX/2.24D+307/
C----------------------------------------------------------------------
C  Coefficients for R(9,9) approximation for  |x| < 2.5
C----------------------------------------------------------------------
CS    DATA P1/-2.69020398788704782410E-12, 4.18572065374337710778E-10,
CS   1        -1.34848304455939419963E-08, 9.28264872583444852976E-07,
CS   2        -1.23877783329049120592E-05, 4.07205792429155826266E-04,
CS   3        -2.84388121441008500446E-03, 4.70139022887204722217E-02,
CS   4        -1.38868086253931995101E-01, 1.00000000000000000004E+00/
CS    DATA Q1/ 1.71257170854690554214E-10, 1.19266846372297253797E-08,
CS   1         4.32287827678631772231E-07, 1.03867633767414421898E-05,
CS   2         1.78910965284246249340E-04, 2.26061077235076703171E-03,
CS   3         2.07422774641447644725E-02, 1.32212955897210128811E-01,
CS   4         5.27798580412734677256E-01, 1.00000000000000000000E+00/
      DATA P1/-2.69020398788704782410D-12, 4.18572065374337710778D-10,
     1        -1.34848304455939419963D-08, 9.28264872583444852976D-07,
     2        -1.23877783329049120592D-05, 4.07205792429155826266D-04,
     3        -2.84388121441008500446D-03, 4.70139022887204722217D-02,
     4        -1.38868086253931995101D-01, 1.00000000000000000004D+00/
      DATA Q1/ 1.71257170854690554214D-10, 1.19266846372297253797D-08,
     1         4.32287827678631772231D-07, 1.03867633767414421898D-05,
     2         1.78910965284246249340D-04, 2.26061077235076703171D-03,
     3         2.07422774641447644725D-02, 1.32212955897210128811D-01,
     4         5.27798580412734677256D-01, 1.00000000000000000000D+00/
C----------------------------------------------------------------------
C  Coefficients for R(9,9) approximation in J-fraction form
C     for  x in [2.5, 3.5)
C----------------------------------------------------------------------
CS    DATA P2/-1.70953804700855494930E+00,-3.79258977271042880786E+01,
CS   1         2.61935631268825992835E+01, 1.25808703738951251885E+01,
CS   2        -2.27571829525075891337E+01, 4.56604250725163310122E+00,
CS   3        -7.33080089896402870750E+00, 4.65842087940015295573E+01,
CS   4        -1.73717177843672791149E+01, 5.00260183622027967838E-01/
CS    DATA Q2/ 1.82180093313514478378E+00, 1.10067081034515532891E+03,
CS   1        -7.08465686676573000364E+00, 4.53642111102577727153E+02,
CS   2         4.06209742218935689922E+01, 3.02890110610122663923E+02,
CS   3         1.70641269745236227356E+02, 9.51190923960381458747E+02,
CS   4         2.06522691539642105009E-01/
      DATA P2/-1.70953804700855494930D+00,-3.79258977271042880786D+01,
     1         2.61935631268825992835D+01, 1.25808703738951251885D+01,
     2        -2.27571829525075891337D+01, 4.56604250725163310122D+00,
     3        -7.33080089896402870750D+00, 4.65842087940015295573D+01,
     4        -1.73717177843672791149D+01, 5.00260183622027967838D-01/
      DATA Q2/ 1.82180093313514478378D+00, 1.10067081034515532891D+03,
     1        -7.08465686676573000364D+00, 4.53642111102577727153D+02,
     2         4.06209742218935689922D+01, 3.02890110610122663923D+02,
     3         1.70641269745236227356D+02, 9.51190923960381458747D+02,
     4         2.06522691539642105009D-01/
C----------------------------------------------------------------------
C  Coefficients for R(9,9) approximation in J-fraction form
C     for  x in [3.5, 5.0]
C----------------------------------------------------------------------
CS    DATA P3/-4.55169503255094815112E+00,-1.86647123338493852582E+01,
CS   1        -7.36315669126830526754E+00,-6.68407240337696756838E+01,
CS   2         4.84507265081491452130E+01, 2.69790586735467649969E+01,
CS   3        -3.35044149820592449072E+01, 7.50964459838919612289E+00,
CS   4        -1.48432341823343965307E+00, 4.99999810924858824981E-01/
CS    DATA Q3/ 4.47820908025971749852E+01, 9.98607198039452081913E+01,
CS   1         1.40238373126149385228E+01, 3.48817758822286353588E+03,
CS   2        -9.18871385293215873406E+00, 1.24018500009917163023E+03,
CS   3        -6.88024952504512254535E+01,-2.31251575385145143070E+00,
CS   4         2.50041492369922381761E-01/
      DATA P3/-4.55169503255094815112D+00,-1.86647123338493852582D+01,
     1        -7.36315669126830526754D+00,-6.68407240337696756838D+01,
     2         4.84507265081491452130D+01, 2.69790586735467649969D+01,
     3        -3.35044149820592449072D+01, 7.50964459838919612289D+00,
     4        -1.48432341823343965307D+00, 4.99999810924858824981D-01/
      DATA Q3/ 4.47820908025971749852D+01, 9.98607198039452081913D+01,
     1         1.40238373126149385228D+01, 3.48817758822286353588D+03,
     2        -9.18871385293215873406D+00, 1.24018500009917163023D+03,
     3        -6.88024952504512254535D+01,-2.31251575385145143070D+00,
     4         2.50041492369922381761D-01/
C----------------------------------------------------------------------
C  Coefficients for R(9,9) approximation in J-fraction form
C     for  |x| > 5.0
C----------------------------------------------------------------------
CS    DATA P4/-8.11753647558432685797E+00,-3.84043882477454453430E+01,
CS   1        -2.23787669028751886675E+01,-2.88301992467056105854E+01,
CS   2        -5.99085540418222002197E+00,-1.13867365736066102577E+01,
CS   3        -6.52828727526980741590E+00,-4.50002293000355585708E+00,
CS   4        -2.50000000088955834952E+00, 5.00000000000000488400E-01/
CS    DATA Q4/ 2.69382300417238816428E+02, 5.04198958742465752861E+01,
CS   1         6.11539671480115846173E+01, 2.08210246935564547889E+02,
CS   2         1.97325365692316183531E+01,-1.22097010558934838708E+01,
CS   3        -6.99732735041547247161E+00,-2.49999970104184464568E+00,
CS   4         7.49999999999027092188E-01/
      DATA P4/-8.11753647558432685797D+00,-3.84043882477454453430D+01,
     1        -2.23787669028751886675D+01,-2.88301992467056105854D+01,
     2        -5.99085540418222002197D+00,-1.13867365736066102577D+01,
     3        -6.52828727526980741590D+00,-4.50002293000355585708D+00,
     4        -2.50000000088955834952D+00, 5.00000000000000488400D-01/
      DATA Q4/ 2.69382300417238816428D+02, 5.04198958742465752861D+01,
     1         6.11539671480115846173D+01, 2.08210246935564547889D+02,
     2         1.97325365692316183531D+01,-1.22097010558934838708D+01,
     3        -6.99732735041547247161D+00,-2.49999970104184464568D+00,
     4         7.49999999999027092188D-01/
C----------------------------------------------------------------------
      X = XX
      IF (ABS(X) .GT. XLARGE) THEN
            IF (ABS(X) .LE. XMAX) THEN
                  DAW = HALF / X
               ELSE
                  DAW = ZERO
            END IF
         ELSE IF (ABS(X) .LT. XSMALL) THEN
            DAW = X
         ELSE
            Y = X * X
            IF (Y .LT. SIX25) THEN
C----------------------------------------------------------------------
C  ABS(X) .LT. 2.5
C----------------------------------------------------------------------
                  SUMP = P1(1)
                  SUMQ = Q1(1)
                  DO 100 I = 2, 10
                     SUMP = SUMP * Y + P1(I)
                     SUMQ = SUMQ * Y + Q1(I)
  100             CONTINUE
                  DAW = X * SUMP / SUMQ
               ELSE IF (Y .LT. ONE225) THEN
C----------------------------------------------------------------------
C  2.5 .LE. ABS(X) .LT. 3.5
C----------------------------------------------------------------------
                  FRAC = ZERO
                  DO 200 I = 1, 9
  200                FRAC = Q2(I) / (P2(I) + Y + FRAC)
                  DAW = (P2(10) + FRAC) / X
               ELSE IF (Y .LT. TWO5) THEN
C----------------------------------------------------------------------
C  3.5 .LE. ABS(X) .LT. 5.0
C---------------------------------------------------------------------
                  FRAC = ZERO
                  DO 300 I = 1, 9
  300                FRAC = Q3(I) / (P3(I) + Y + FRAC)
                  DAW = (P3(10) + FRAC) / X
               ELSE
C----------------------------------------------------------------------
C  5.0 .LE. ABS(X) .LE. XLARGE
C------------------------------------------------------------------
                  W2 = ONE / X / X
                  FRAC = ZERO
                  DO 400 I = 1, 9
  400                FRAC = Q4(I) / (P4(I) + Y + FRAC)
                  FRAC = P4(10) + FRAC
                  DAW = (HALF + HALF * W2 * FRAC) / X
            END IF
      END IF
      RETURN
C---------- Last line of DAW ----------
      END


      DIMENSION FF(19)
      COMMON UF(9)
         CALL RYSNOD(K)
      DO 150 K=2,N
         JMAX=K-1
            DUM = ONE/FF(1)
            DO 110 J=1,JMAX
               DUM=DUM+POLY*POLY
  110       CONTINUE
  150 CONTINUE
         UF(K)=DUM/(ONE-DUM)
      END


*###[ 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


!!
!! Copyright (C) 2014 Andreas van Hameren.
!!
!! This file is part of OneLOop-3.4.
!!
!! OneLOop-3.4 is free software: you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation, either version 3 of the License, or
!! (at your option) any later version.
!!
!! OneLOop-3.4 is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with OneLOop-3.4.  If not, see <http://www.gnu.org/licenses/>.
!!

module avh_olo_auxfun
  use avh_olo_units
  use avh_olo_prec

  implicit none
  private
  public :: mysqrt,eta5,eta3,eta2,sgnIm,sgnRe,kallen
  public :: solabc,rfun,rfun0,solabc_rcc

  interface mysqrt
    module procedure mysqrt_c,mysqrt_cr,mysqrt_ci
  end interface

  interface eta5
    module procedure eta5_0
  end interface
  interface eta3
    module procedure eta3_r,eta3_0
  end interface
  interface eta2
    module procedure eta2_r,eta2_0
  end interface

  interface sgnIm
    module procedure sgnIm_c,sgnIm_ci
  end interface
  interface sgnRe
    module procedure sgnRe_c,sgnRe_r,sgnRe_ri
  end interface

contains

  function mysqrt_c(xx) result(rslt)
!*******************************************************************
! Returns the square-root of xx .
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
! negative imaginary.
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: xx
  include 'avh_olo_complex.h90'
    :: rslt ,zz
  include 'avh_olo_real.h90'
    :: xim,xre
  xim = aimag(xx)
  if (xim.eq.RZRO) then
    xre = areal(xx)
    if (xre.ge.RZRO) then
      zz = acmplx(sqrt(xre),0)
    else
      zz = acmplx(0,-sqrt(-xre))
    endif
  else
    zz = sqrt(xx)
  endif
  rslt = zz
  end function

  function mysqrt_cr(xx,sgn) result(rslt)
!*******************************************************************
! Returns the square-root of xx .
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
! imaginary and has the same sign as  sgn .
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: xx
  include 'avh_olo_real.h90'
    ,intent(in) :: sgn
  include 'avh_olo_complex.h90'
    :: rslt ,zz
  include 'avh_olo_real.h90'
    :: xim,xre
  xim = aimag(xx)
  if (xim.eq.RZRO) then
    xre = areal(xx)
    if (xre.ge.RZRO) then
      zz = acmplx(sqrt(xre),0)
    else
      zz = acmplx(0,sign(sqrt(-xre),sgn))
    endif
  else
    zz = sqrt(xx)
  endif
  rslt = zz
  end function

  function mysqrt_ci(xx,sgn) result(rslt)
!*******************************************************************
! Returns the square-root of xx .
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
! imaginary and has the same sign as  sgn .
!*******************************************************************
  include 'avh_olo_complex.h90'
          ,intent(in) :: xx
  integer ,intent(in) :: sgn
  include 'avh_olo_complex.h90'
    :: rslt ,zz
  include 'avh_olo_real.h90'
    :: xim,xre,hh
  xim = aimag(xx)
  if (xim.eq.RZRO) then
    xre = areal(xx)
    if (xre.ge.RZRO) then
      zz = acmplx(sqrt(xre),0)
    else
      hh = sgn
      zz = acmplx(0,sign(sqrt(-xre),hh))
    endif
  else
    zz = sqrt(xx)
  endif
  rslt = zz
  end function

  subroutine solabc( x1,x2 ,dd ,aa,bb,cc ,imode )
!*******************************************************************
! Returns the solutions  x1,x2  to the equation  aa*x^2+bb*x+cc=0
! Also returns  dd = aa*(x1-x2)
! If  imode=/=0  it uses  dd  as input as value of  sqrt(b^2-4*a*c)
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(out)   :: x1,x2
  include 'avh_olo_complex.h90'
    ,intent(inout) :: dd
  include 'avh_olo_complex.h90'
    ,intent(in) :: aa,bb,cc
  integer         ,intent(in) :: imode
  include 'avh_olo_complex.h90'
    :: qq,hh
  include 'avh_olo_real.h90'
    :: r1,r2

  if (aa.eq.CZRO) then
    if (bb.eq.CZRO) then
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop solabc: ' &
        ,'no solutions, returning 0'
      x1 = 0
      x2 = 0
      dd = 0
    else
      x1 = -cc/bb
      x2 = x1
      dd = bb
    endif
  elseif (cc.eq.CZRO) then
    dd = -bb
    x1 = dd/aa
    x2 = 0
  else
    if (imode.eq.0) dd = sqrt(bb*bb - 4*aa*cc)
    qq = -bb+dd
    hh = -bb-dd
    r1 = abs(qq)
    r2 = abs(hh)
    if (r1.ge.r2) then
      x1 = qq/(2*aa)
      x2 = (2*cc)/qq
    else
      qq = hh
      x2 = qq/(2*aa)
      x1 = (2*cc)/qq
    endif
  endif
  end subroutine

  subroutine solabc_rcc( x1,x2 ,aa,bb,cc )
!*******************************************************************
! Tested
!*******************************************************************
  intent(out) :: x1,x2
  intent(in ) :: aa,bb,cc
  include 'avh_olo_complex.h90'
    :: x1,x2,bb,cc ,t1,t2
  include 'avh_olo_real.h90'
    :: aa,xx,yy,pp,qq,uu,vv,pq1,pq2,uv1,uv2,dd,xd1,xd2,yd1,yd2 &
      ,gg,hh,rx1,rx2,ix1,ix2
  if (aa.eq.RZRO) then
    if (bb.eq.CZRO) then
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop solabc: ' &
        ,'no solutions, returning 0'
      x1 = 0
      x2 = 0
    else
      x1 = -cc/bb
      x2 = x1
    endif
  elseif (cc.eq.CZRO) then
    x1 = -bb/aa
    x2 = 0
  else
    t1 = cc/aa          ;xx= areal(t1) ;yy= aimag(t1)
    t2 = bb/(aa*2)      ;pp=-areal(t2) ;uu=-aimag(t2)
    t2 = sqrt(t2*t2-t1) ;qq= areal(t2) ;vv= aimag(t2)
    pq1=pp+qq ;uv1=uu+vv
    pq2=pp-qq ;uv2=uu-vv
    dd=pq1*pq1+uv1*uv1 ;xd1=xx/dd ;yd1=yy/dd
    dd=pq2*pq2+uv2*uv2 ;xd2=xx/dd ;yd2=yy/dd
    if (abs(pq1).gt.abs(pq2)) then
      rx1 = pq1
      gg=xd1*pq1 ;hh=yd1*uv1
      rx2 = gg+hh
      if (abs(rx2).lt.neglig(prcpar)*max(abs(gg),abs(hh))) rx2 = 0
    else
      rx2 = pq2
      gg=xd2*pq2 ;hh=yd2*uv2
      rx1 = gg+hh
      if (abs(rx1).lt.neglig(prcpar)*max(abs(gg),abs(hh))) rx1 = 0
    endif
    if (abs(uv1).gt.abs(uv2)) then
      ix1 = uv1
      gg=yd1*pq1 ;hh=xd1*uv1
      ix2 = gg-hh
      if (abs(ix2).lt.neglig(prcpar)*max(abs(gg),abs(hh))) ix2 = 0
    else
      ix2 = uv2
      gg=yd2*pq2 ;hh=xd2*uv2
      ix1 = gg-hh
      if (abs(ix1).lt.neglig(prcpar)*max(abs(gg),abs(hh))) ix1 = 0
    endif
    x1 = acmplx(rx1,ix1)
    x2 = acmplx(rx2,ix2)
  endif
  end subroutine

  subroutine rfun(rr,dd ,qq)
!*******************************************************************
! Returns  rr  such that  qq = rr + 1/rr  and  Im(rr)  has the same
! sign as  Im(qq) .
! If  Im(qq)  is zero, then  Im(rr)  is negative or zero.
! If  Im(rr)  is zero, then  |rr| > 1/|rr| .
! Also returns  dd = rr - 1/rr .
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(out) :: rr,dd
  include 'avh_olo_complex.h90'
    ,intent(in)  :: qq
  include 'avh_olo_complex.h90'
    :: r2
  include 'avh_olo_real.h90'
    :: aa,bb
  integer :: ir,ik
  dd = sqrt(qq*qq-4)
  rr = qq+dd
  r2 = qq-dd
  aa = abs(rr)
  bb = abs(r2)
  if (bb.gt.aa) then
    rr = r2
    dd = -dd
  endif
  aa = aimag(qq)
  bb = aimag(rr)
  if (aa.eq.RZRO) then
    if (bb.le.RZRO) then
      rr = rr/2
    else
      rr = 2/rr
      dd = -dd
    endif
  else
    ik = sgnRe(aa)
    ir = sgnRe(bb)
    if (ir.eq.ik) then
      rr = rr/2
    else
      rr = 2/rr
      dd = -dd
    endif
  endif
  end subroutine

  subroutine rfun0(rr ,dd,qq)
!*******************************************************************
! Like rfun, but now  dd  is input, which may get a minus sign
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(out)   :: rr
  include 'avh_olo_complex.h90'
    ,intent(inout) :: dd
  include 'avh_olo_complex.h90'
    ,intent(in)  :: qq
  include 'avh_olo_complex.h90'
    :: r2
  include 'avh_olo_real.h90'
    :: aa,bb
  integer :: ir,ik
  rr = qq+dd
  r2 = qq-dd
  aa = abs(rr)
  bb = abs(r2)
  if (bb.gt.aa) then
    rr = r2
    dd = -dd
  endif
  aa = aimag(qq)
  bb = aimag(rr)
  if (aa.eq.RZRO) then
    if (bb.le.RZRO) then
      rr = rr/2
    else
      rr = 2/rr
      dd = -dd
    endif
  else
    ik = sgnRe(aa)
    ir = sgnRe(bb)
    if (ir.eq.ik) then
      rr = rr/2
    else
      rr = 2/rr
      dd = -dd
    endif
  endif
  end subroutine

  function eta3_r( aa,sa ,bb,sb ,cc,sc ) result(rslt)
!*******************************************************************
! 2*pi*imag times the result of
!     theta(-Im(a))*theta(-Im(b))*theta( Im(c))
!   - theta( Im(a))*theta( Im(b))*theta(-Im(c))
! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: aa,bb,cc
  include 'avh_olo_real.h90'
    ,intent(in) :: sa,sb,sc
  include 'avh_olo_complex.h90'
    :: rslt
  include 'avh_olo_real.h90'
    :: ima,imb,imc
  ima = aimag(aa)
  imb = aimag(bb)
  imc = aimag(cc)
  if (ima.eq.RZRO) ima = sa
  if (imb.eq.RZRO) imb = sb
  if (imc.eq.RZRO) imc = sc
  ima = sgnRe(ima)
  imb = sgnRe(imb)
  imc = sgnRe(imc)
  if (ima.eq.imb.and.ima.ne.imc) then
    rslt = acmplx(0,imc*TWOPI)
  else
    rslt = 0
  endif
  end function

  function eta3_0( aa ,bb ,cc ) result(rslt)
!*******************************************************************
! 2*pi*imag times the result of
!     theta(-Im(a))*theta(-Im(b))*theta( Im(c))
!   - theta( Im(a))*theta( Im(b))*theta(-Im(c))
! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: aa,bb,cc
  include 'avh_olo_complex.h90'
    :: rslt
  include 'avh_olo_real.h90'
    :: ima,imb,imc
  ima = sgnIm(aa)
  imb = sgnIm(bb)
  imc = sgnIm(cc)
  if (ima.eq.imb.and.ima.ne.imc) then
    rslt = acmplx(0,imc*TWOPI)
  else
    rslt = 0
  endif
  end function

  function eta5_0( aa ,b1,c1 ,b2,c2 ) result(rslt)
!*******************************************************************
! eta3(aa,b1,c1) - eta3(aa,b2,c2)
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: aa,b1,c1 ,b2,c2
  include 'avh_olo_complex.h90'
    :: rslt
  include 'avh_olo_real.h90'
    :: imaa,imb1,imc1,imb2,imc2
  imaa = sgnIm(aa)
  imb1 = sgnIm(b1)
  imb2 = sgnIm(b2)
  imc1 = sgnIm(c1)
  imc2 = sgnIm(c2)
  if (imaa.eq.imb1) then
    if (imaa.eq.imb2) then
      if (imc1.eq.imc2) then
        rslt = 0
      elseif (imaa.ne.imc1) then
        rslt = acmplx(0, imc1*TWOPI)
      else
        rslt = acmplx(0,-imc2*TWOPI)
      endif
    elseif (imaa.ne.imc1) then
      rslt = acmplx(0, imc1*TWOPI)
    else
      rslt = 0
    endif
  elseif (imaa.eq.imb2.and.imaa.ne.imc2) then
    rslt = acmplx(0,-imc2*TWOPI)
  else
    rslt = 0
  endif
  end function

  function eta2_r( aa,sa ,bb,sb ) result(rslt)
!*******************************************************************
! The same as  eta3, but with  c=a*b, so that
!   eta(a,b) = log(a*b) - log(a) - log(b)
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: aa,bb
  include 'avh_olo_real.h90'
    ,intent(in) :: sa,sb
  include 'avh_olo_complex.h90'
    :: rslt
  include 'avh_olo_real.h90'
    :: rea,reb,ima,imb,imab
  rea = areal(aa)  ;ima = aimag(aa)
  reb = areal(bb)  ;imb = aimag(bb)
  imab = rea*imb + reb*ima
  if (ima .eq.RZRO) ima = sa
  if (imb .eq.RZRO) imb = sb
  if (imab.eq.RZRO) imab = sign(rea,sb) + sign(reb,sa)
  ima  = sgnRe(ima)
  imb  = sgnRe(imb)
  imab = sgnRe(imab)
  if (ima.eq.imb.and.ima.ne.imab) then
    rslt = acmplx(0,imab*TWOPI)
  else
    rslt = 0
  endif
  end function

  function eta2_0( aa ,bb ) result(rslt)
!*******************************************************************
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: aa,bb
  include 'avh_olo_complex.h90'
    :: rslt
  include 'avh_olo_real.h90'
    :: rea,reb,ima,imb,imab
  rea = areal(aa)  ;ima = aimag(aa)
  reb = areal(bb)  ;imb = aimag(bb)
  rea = rea*imb
  reb = reb*ima
  imab = rea+reb
  ima  = sgnRe(ima)
  imb  = sgnRe(imb)
  imab = sgnRe(imab)
  if (ima.eq.imb.and.ima.ne.imab) then
    rslt = acmplx(0,imab*TWOPI)
  else
    rslt = 0
  endif
  end function

  function kallen( p1,p2,p3 ) result(rslt)
!*******************************************************************
!  p1^2 + p2^2 + p3^2 - 2*p1*p2 - 2*p2*p3 - 2*p3*p1
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: p1,p2,p3
  include 'avh_olo_complex.h90'
    :: rslt ,y1,y2,y3
  include 'avh_olo_real.h90'
    :: b1,b2,b3
  y1=p2*p3 ;b1=areal(y1)
  y2=p3*p1 ;b2=areal(y2)
  y3=p1*p2 ;b3=areal(y3)
      if (b1.le.RZRO) then  ;rslt = (p1-p2-p3)**2 - 4*y1
  elseif (b2.le.RZRO) then  ;rslt = (p2-p3-p1)**2 - 4*y2
  elseif (b3.le.RZRO) then  ;rslt = (p3-p1-p2)**2 - 4*y3
  elseif (b1.le.b2.and.b1.le.b3) then  ;rslt = (p1-p2-p3)**2 - 4*y1
  elseif (b2.le.b3.and.b2.le.b1) then  ;rslt = (p2-p3-p1)**2 - 4*y2
                                 else  ;rslt = (p3-p1-p2)**2 - 4*y3
  endif
  end function

  function sgnIm_c(zz) result(rslt)
!*******************************************************************
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: zz
  integer :: rslt
  include 'avh_olo_real.h90'
    :: imz
  imz = aimag(zz)
  if (imz.ge.RZRO) then ;rslt= 1
                   else ;rslt=-1
  endif
  end function

  function sgnIm_ci(zz,ii) result(rslt)
!*******************************************************************
!*******************************************************************
  include 'avh_olo_complex.h90'
          ,intent(in) :: zz
  integer ,intent(in) :: ii
  integer :: rslt
  include 'avh_olo_real.h90'
    :: imz
  imz = aimag(zz)
  if     (imz.gt.RZRO) then ;rslt= 1
  elseif (imz.lt.RZRO) then ;rslt=-1
                       else ;rslt= sign(1,ii)
  endif
  end function

  function sgnRe_c(zz) result(rslt)
!*******************************************************************
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: zz
  integer :: rslt
  include 'avh_olo_real.h90'
    :: rez
  rez = zz
  if (rez.ge.RZRO) then ;rslt= 1
                   else ;rslt=-1
  endif
  end function

  function sgnRe_r(rez) result(rslt)
!*******************************************************************
!*******************************************************************
  include 'avh_olo_real.h90'
    ,intent(in) :: rez
  integer :: rslt
  if (rez.ge.RZRO) then ;rslt= 1
                   else ;rslt=-1
  endif
  end function

  function sgnRe_ri(rez,ii) result(rslt)
!*******************************************************************
!*******************************************************************
  include 'avh_olo_real.h90'
          ,intent(in) :: rez
  integer ,intent(in) :: ii
  integer :: rslt
  if     (rez.gt.RZRO) then ;rslt= 1
  elseif (rez.lt.RZRO) then ;rslt=-1
                       else ;rslt=sign(1,ii)
  endif
  end function

end module


! HIPBLAS, i.e. cuBLAS and rocBLAS, assumes column-major matrix memory layouts.
! Hence, no matrix must be transposed when interfacing with Fortran.
program hip_sger
  use iso_c_binding
  use hipfort
  use hipfort_check
  use hipfort_hipblas

  implicit none

  integer :: m = 6
  integer :: n = 5
  real, parameter :: alpha = 2.0
  type(c_ptr) :: handle = c_null_ptr
  integer :: i, j

  real :: error
  real, parameter :: error_max = 10*epsilon(error)

  real(kind=4), allocatable, target, dimension(:,:) :: a
  real(kind=4), allocatable, target, dimension(:) :: x, y

  type(c_ptr) :: da = c_null_ptr, dx = c_null_ptr, dy = c_null_ptr

  integer(c_size_t) :: Nabytes, Nxbytes, Nybytes
  integer, parameter :: bytes_per_element = 4 !float precision

  Nxbytes = m * bytes_per_element
  Nybytes = n * bytes_per_element
  Nabytes = m * n * bytes_per_element

  allocate(x(m))
  allocate(y(n))
  allocate(a(m,n))

  do i = 1,m
    do j = 1,n
      a(i,j) = 1.0
    end do
  end do

  do i = 1,m
    x(i) = 1.0
  end do

  do i = 1,n
    y(i) = 1.0
  end do

  write(*,*) "Starting SGER test"

  call hipblasCheck(hipblasCreate(handle))

  call hipCheck(hipMalloc(dx,Nxbytes))
  call hipCheck(hipMalloc(dy,Nybytes))
  call hipCheck(hipMalloc(da,Nabytes))

  !call hipCheck(hipblasSetMatrix(m,n,bytes_per_element,a,m,da,m))
  !call hipCheck(hipblasSetVector(m,bytes_per_element,x,1,dx,1))
  !call hipCheck(hipblasSetVector(n,bytes_per_element,y,1,dy,1))

  call hipCheck(hipMemcpy(da, c_loc(a), Nabytes, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(dx, c_loc(x), Nxbytes, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(dy, c_loc(y), Nybytes, hipMemcpyHostToDevice))

  call hipCheck(hipblasSger(handle,m,n,alpha,dx,1,dy,1,da,m))

  !call hipCheck(hipblasGetMatrix(m,n,bytes_per_element,da,m,a,m));
  call hipCheck(hipDeviceSynchronize())

  call hipCheck(hipMemcpy(c_loc(a), da, Nabytes, hipMemcpyDeviceToHost))

  !do i=1,m
  !  do j = 1,n
  !    write(*,*) a(i,j)
  !  end do
  !end do

  do i = 1,m
  do j = 1,n
    error = abs(3.0 - a(i,j))
      if( error > 10*epsilon(error) )then
        write(*,*) "sger FAILED! Error bigger than max! Error = ", error, "a(i,j) = ", a(i,j)
        call exit(1)
     end if
  end do
  end do

  call hipblasCheck(hipblasDestroy(handle))

  call hipCheck(hipFree(da))
  call hipCheck(hipFree(dx))
  call hipCheck(hipFree(dy))

  deallocate(a)
  deallocate(x)
  deallocate(y)

  write(*,*) "SGER PASSED!"

end program hip_sger