! miscellaneous utilities
module kernels
implicit none
contains

subroutine volume_strain(s, v, w, n)
real, intent(in) :: s(n), v(n)
real, intent(out) :: w(n)
integer, intent(in) :: n
integer :: i
do i = 1, n
    w(i) = s(i) * v(i)
end do
end subroutine

subroutine shear_strain1(s, v, w, n)
real, intent(in) :: s(n), v(n)
real, intent(out) :: w(n)
integer, intent(in) :: n
integer :: i
do i = 1, n
    w(i) = s(i) * v(i) * 0.5
end do
end subroutine

subroutine shear_strain2(s, v, w, n)
real, intent(in) :: s(n), v(n)
real, intent(inout) :: w(n)
integer, intent(in) :: n
integer :: i
do i = 1, n
    w(i) = w(i) + s(i) * v(i) * 0.5
end do
end subroutine

end module


c---------------------------------------------------------------------
c compute the roots-of-unity array that will be used for subsequent FFTs.
c---------------------------------------------------------------------
      PURE extrinsic (hpf_local) subroutine CompExp (n, exponent)

      implicit none
      integer, intent(in) :: n
      double complex, dimension(:), intent(inout) :: exponent

      interface
        pure extrinsic (hpf_local) integer function ilog2 (n)
          integer, intent(in) :: n
        end function ilog2
      end interface
      integer m,nu,ku,i,j,ln
      double precision t, ti, pi
      data pi /3.141592653589793238d0/

      nu = n
      m = ilog2(n)
      exponent(1) = m
      ku = 2
      ln = 1
      do j = 1, m
         t = pi / ln
         do i = 0, ln - 1
            ti = i * t
            exponent(i+ku) = dcmplx(cos(ti),sin(ti))
         enddo
         ku = ku + ln
         ln = 2 * ln
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------
c---------------------------------------------------------------------

      pure extrinsic (hpf_local) integer function ilog2(n)
      implicit none
      integer, intent( in) :: n

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      integer nn, lg
      if (n .eq. 1) then
         ilog2=0
         return
      endif
      lg = 1
      nn = 2
      do while (nn .lt. n)
         nn = nn*2
         lg = lg+1
      end do
      ilog2 = lg
      return
      end
c---------------------------------------------------------------------
c---------------------------------------------------------------------
       extrinsic (HPF)
     * subroutine compute_initial_conditions(u0,d1,d2,d3)

      double complex, dimension(:,:,:), intent(inout) :: u0
      integer, intent(in) :: d1,d2,d3
      double precision x0, start, an, dummy
      double precision, dimension(d3) :: RanStarts
!hpf$    template grid(d3)
!hpf$    distribute(block) :: grid
!hpf$    align(*,*,:) with grid :: u0
!hpf$    align(:) with grid :: RanStarts
      interface
        pure extrinsic(HPF) SUBROUTINE VRanComp (N, X, A, Y,m)
          implicit none
          integer, intent(in) :: n,m
          double precision, intent(inout) :: x, a
          double complex, dimension(N), intent(out) :: y
	end SUBROUTINE VRanComp
      end interface
      integer i,j,k
      double precision seed, a
      parameter (seed = 314159265.d0, a = 1220703125.d0)
      external randlc
      double precision randlc

      start = seed
c---------------------------------------------------------------------
c Jump to the starting element for our first plane.
c---------------------------------------------------------------------
      call ipow46(a, 0, an)
      dummy = randlc(start, an)
      call ipow46(a, 2*d1*d2, an)
c---------------------------------------------------------------------
c Go through by z planes filling in one square at a time.
c---------------------------------------------------------------------
      RanStarts(1) = start
      do k = 2, d3
         dummy = randlc(start, an)
         RanStarts(k) = start
      end do

!HPF$ independent
      do k = 1, d3
         do j = 1, d1
           call VRanComp(d1,RanStarts(k),a,u0(j,:,k),d2)
         end do
         if (k .ne. d3) dummy = randlc(start, an)
      end do
      return
      end
c---------------------------------------------------------------------
c---------------------------------------------------------------------

      pure extrinsic(HPF) SUBROUTINE VRanComp(N, X, A, Y,m)
      implicit none

      integer, intent(in) :: n,m
      double precision, intent(inout) :: x, a
      double complex, dimension(m), intent(out) :: y

      integer*8 i246m1, Lx, La, i
      double precision d2m46, Re, Im

      parameter(d2m46=0.5d0**46)

      data i246m1 /0/

      if ( i246m1.EQ.0 ) then
           i246m1 = '00003FFFFFFFFFFF'x
      endif

      Lx = X
      La = A
      do i = 1, m
         Lx   = iand(Lx*La,i246m1)
         Re = d2m46*dble(Lx)
         Lx   = iand(Lx*La,i246m1)
         Im = d2m46*dble(Lx)
         y(i) = dcmplx ( Re, Im)
      end do
      x = dble(Lx)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine ipow46(a, exponent, result)
c---------------------------------------------------------------------
c compute a^exponent mod 2^46
c---------------------------------------------------------------------

      implicit none
      double precision a, result, dummy, q, r
      integer exponent, n, n2
      external randlc
      double precision randlc
c---------------------------------------------------------------------
c Use
c   a^n = a^(n/2)*a^(n/2) if n even else
c   a^n = a*a^(n-1)       if n odd
c---------------------------------------------------------------------
      result = 1
      if (exponent .eq. 0) return
      q = a
      r = 1
      n = exponent

      do while (n .gt. 1)
         n2 = n/2
         if (n2 * 2 .eq. n) then
            dummy = randlc(q, q)
            n = n2
         else
            dummy = randlc(r, q)
            n = n-1
         endif
      end do
      dummy = randlc(r, q)
      result = r
      return
      end

c---------------------------------------------------------------------
      extrinsic (HPF)
     >subroutine CalculateChecksum(csum,iterN,u,d1,d2,d3)
        implicit none
        integer, intent (in) :: iterN
        double complex, dimension(:,:,:), intent(in) :: u
        integer, intent (in) :: d1, d2, d3
        double complex, intent (out) :: csum
!hpf$   template grid(d3)
!hpf$   distribute(block) :: grid
!hpf$   align(*,*,:) with grid :: u
      integer i, i1, ii, ji, ki
      integer dl1,dl2,dl3
      dl1=d1-1
      dl2=d2
      dl3=d3
      csum = dcmplx (0.0, 0.0)
      do i = 1, 1024
        i1 = i - 1
        ii = mod (i1, dl2) + 1
        ji = mod (3 * i1, dl1) + 1
        ki = mod (5 * i1, dl3) + 1
        csum = csum + u(ji,ii,ki)
      end do
      csum = csum/dble(dl1*dl2*dl3)
      print*,'T =',iterN,' checksum =',csum
      return
      end


        !COMPILER-GENERATED INTERFACE MODULE: Tue May  2 15:02:02 2017
        MODULE NORMAL__genmod
          INTERFACE
            PURE FUNCTION NORMAL(MEAN,VAR,L)
              REAL(KIND=8), INTENT(IN) :: MEAN
              REAL(KIND=8), INTENT(IN) :: VAR
              REAL(KIND=8), INTENT(IN) :: L
              REAL(KIND=8) :: NORMAL
            END FUNCTION NORMAL
          END INTERFACE
        END MODULE NORMAL__genmod


module mtprng
!---------------------------------------------------------------------
! From the Algorithmic Conjurings of Scott Robert Ladd comes...
!---------------------------------------------------------------------
!
!  mtprng.f90 (a Fortran 95 module)
!
!  An implementation of the Mersenne Twister algorithm for generating
!  psuedo-random sequences.
!
!  History
!  -------
!   1.0.0   Initial release
!
!   1.1.0   6 February 2002
!           Updated to support algorithm revisions posted
!           by Matsumoto and Nishimura on 26 January 2002
!
!   1.5.0   12 December 2003
!           Added to hypatia project
!           Minor style changes
!           Tightened code
!           Now state based; no static variables
!           Removed mtprng_rand_real53
!
!   2.0.0   4 January 2004
!           Corrected erroneous unsigned bit manipulations
!           Doubled resolution by using 64-bit math
!           Added mtprng_rand64
!
!  ORIGINAL ALGORITHM COPYRIGHT
!  ============================
!  Copyright (C) 1997,2002 Makoto Matsumoto and Takuji Nishimura.
!  Any feedback is very welcome. For any question, comments, see
!  http://www.math.keio.ac.jp/matumoto/emt.html or email
!  matumoto@math.keio.ac.jp
!---------------------------------------------------------------------
!
!  COPYRIGHT NOTICE, DISCLAIMER, and LICENSE:
!
!  This notice applies *only* to this specific expression of this
!  algorithm, and does not imply ownership or invention of the
!  implemented algorithm.
!
!  If you modify this file, you may insert additional notices
!  immediately following this sentence.
!
!  Copyright 2001, 2002, 2004 Scott Robert Ladd.
!  All rights reserved, except as noted herein.
!
!  This computer program source file is supplied "AS IS". Scott Robert
!  Ladd (hereinafter referred to as "Author") disclaims all warranties,
!  expressed or implied, including, without limitation, the warranties
!  of merchantability and of fitness for any purpose. The Author
!  assumes no liability for direct, indirect, incidental, special,
!  exemplary, or consequential damages, which may result from the use
!  of this software, even if advised of the possibility of such damage.
!
!  The Author hereby grants anyone permission to use, copy, modify, and
!  distribute this source code, or portions hereof, for any purpose,
!  without fee, subject to the following restrictions:
!
!      1. The origin of this source code must not be misrepresented.
!
!      2. Altered versions must be plainly marked as such and must not
!         be misrepresented as being the original source.
!
!      3. This Copyright notice may not be removed or altered from any
!         source or altered source distribution.
!
!  The Author specifically permits (without fee) and encourages the use
!  of this source code for entertainment, education, or decoration. If
!  you use this source code in a product, acknowledgment is not required
!  but would be appreciated.
!
!  Acknowledgement:
!      This license is based on the wonderful simple license that
!      accompanies libpng.
!
!-----------------------------------------------------------------------
!
!  For more information on this software package, please visit
!  Scott's web site, Coyote Gulch Productions, at:
!
!      http://www.coyotegulch.com
!
!-----------------------------------------------------------------------

    use stdtypes

    implicit none

    !------------------------------------------------------------------------------
    ! Everything is private unless explicitly made public
    private

    public :: mtprng_state, &
              mtprng_init, mtprng_init_by_array, &
              mtprng_rand64, mtprng_rand, mtprng_rand_range, &
              mtprng_rand_real1, mtprng_rand_real2, mtprng_rand_real3

    !------------------------------------------------------------------------------
    ! Constants
    integer(INT32), parameter :: N = 624_INT32
    integer(INT32), parameter :: M = 397_INT32

    !------------------------------------------------------------------------------
    ! types
    type mtprng_state
        integer(INT32)                   :: mti = -1
        integer(INT64), dimension(0:N-1) :: mt
    end type

contains
    !--------------------------------------------------------------------------
    !  Initializes the generator with "seed"
    subroutine mtprng_init(seed, state)

        ! arguments
        integer(INT32),     intent(in)  :: seed
        type(mtprng_state), intent(out) :: state

        ! working storage
        integer :: i
        integer(INT64) :: s, b

        ! save seed
        state%mt(0) = seed

        ! Set the seed using values suggested by Matsumoto & Nishimura, using
        !   a generator by Knuth. See original source for details.
        do i = 1, N - 1
            state%mt(i) = iand(4294967295_INT64,1812433253_INT64 * ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64)) + i)
        end do

        state%mti = N

    end subroutine mtprng_init

    !--------------------------------------------------------------------------
    ! Initialize with an array of seeds
    subroutine mtprng_init_by_array(init_key, state)

        ! arguments
        integer(INT32), dimension(:), intent(in) :: init_key
        type(mtprng_state), intent(out) :: state

        ! working storage
        integer :: key_length
        integer :: i
        integer :: j
        integer :: k

        call mtprng_init(19650218_INT32,state)

        i = 1
        j = 0
        key_length = size(init_key)

        do k = max(N,key_length), 0, -1
            state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1664525_INT64))) + init_key(j) + j

            i = i + 1
            j = j + 1

            if (i >= N) then
                state%mt(0) = state%mt(N-1)
                i = 1
            end if

            if (j >= key_length) j = 0
        end do

        do k = N-1, 0, -1
            state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1566083941_INT64))) - i

            i = i + 1

            if (i>=N) then
                state%mt(0) = state%mt(N-1)
                i = 1
            end if
        end do

        state%mt(0) = 1073741824_INT64 ! 0x40000000, assuring non-zero initial array

    end subroutine mtprng_init_by_array

    !--------------------------------------------------------------------------
    !   Obtain the next 32-bit integer in the psuedo-random sequence
    function mtprng_rand64(state) result(r)

        ! arguments
        type(mtprng_state), intent(inout) :: state

        !return type
        integer(INT64) :: r

        ! internal constants
        integer(INT64), dimension(0:1), parameter :: mag01 = (/ 0_INT64, -1727483681_INT64 /)

        ! Period parameters
        integer(INT64), parameter :: UPPER_MASK =  2147483648_INT64
        integer(INT64), parameter :: LOWER_MASK =  2147483647_INT64

        ! Tempering parameters
        integer(INT64), parameter :: TEMPERING_B = -1658038656_INT64
        integer(INT64), parameter :: TEMPERING_C =  -272236544_INT64

        ! Note: variable names match those in original example
        integer(INT32) :: kk

        ! Generate N words at a time
        if (state%mti >= N) then
            ! The value -1 acts as a flag saying that the seed has not been set.
            if (state%mti == -1) call mtprng_init(4357_INT32,state)

            ! Fill the mt array
            do kk = 0, N - M - 1
                r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK))
                state%mt(kk) = ieor(ieor(state%mt(kk + M),ishft(r,-1_INT64)),mag01(iand(r,1_INT64)))
            end do

            do kk = N - M, N - 2
                r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK))
                state%mt(kk) = ieor(ieor(state%mt(kk + (M - N)),ishft(r,-1_INT64)),mag01(iand(r,1_INT64)))
            end do

            r = ior(iand(state%mt(N-1),UPPER_MASK),iand(state%mt(0),LOWER_MASK))
            state%mt(N-1) = ieor(ieor(state%mt(M-1),ishft(r,-1)),mag01(iand(r,1_INT64)))

            ! Start using the array from first element
            state%mti = 0
        end if

        ! Here is where we actually calculate the number with a series of
        !   transformations
        r = state%mt(state%mti)
        state%mti = state%mti + 1

        r = ieor(r,ishft(r,-11))
        r = iand(4294967295_INT64,ieor(r,iand(ishft(r, 7),TEMPERING_B)))
        r = iand(4294967295_INT64,ieor(r,iand(ishft(r,15),TEMPERING_C)))
        r = ieor(r,ishft(r,-18))

    end function mtprng_rand64

    !--------------------------------------------------------------------------
    !   Obtain the next 32-bit integer in the psuedo-random sequence
    function mtprng_rand(state) result(r)

        ! arguments
        type(mtprng_state), intent(inout) :: state

        !return type
        integer(INT32) :: r

        ! working storage
        integer(INT64) :: x

        ! done
        x = mtprng_rand64(state)

        if (x > 2147483647_INT64) then
            r = x - 4294967296_INT64
        else
            r = x
        end if

    end function mtprng_rand

    !---------------------------------------------------------------------------
    !   Obtain a psuedorandom integer in the range [lo,hi]
    function mtprng_rand_range(state, lo, hi) result(r)

        ! arguments
        type(mtprng_state), intent(inout) :: state
        integer, intent(in) :: lo
        integer, intent(in) :: hi

        ! return type
        integer(INT32) :: r

        ! Use real value to caluclate range
        r = lo + floor((hi - lo + 1.0_IEEE64) * mtprng_rand_real2(state))

    end function mtprng_rand_range

    !--------------------------------------------------------------------------
    !   Obtain a psuedorandom real number in the range [0,1], i.e., a number
    !   greater than or equal to 0 and less than or equal to 1.
    function mtprng_rand_real1(state) result(r)

        ! arguments
        type(mtprng_state), intent(inout) :: state

        ! return type
        real(IEEE64) :: r

        ! Local constant; precalculated to avoid division below
        real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967295.0_IEEE64

        ! compute
        r = real(mtprng_rand64(state),IEEE64) * factor

    end function mtprng_rand_real1

    !--------------------------------------------------------------------------
    !   Obtain a psuedorandom real number in the range [0,1), i.e., a number
    !   greater than or equal to 0 and less than 1.
    function mtprng_rand_real2(state) result(r)

        ! arguments
        type(mtprng_state), intent(inout) :: state

        ! return type
        real(IEEE64) :: r

        ! Local constant; precalculated to avoid division below
        real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967296.0_IEEE64

        ! compute
        r = real(mtprng_rand64(state),IEEE64) * factor

    end function mtprng_rand_real2

    !--------------------------------------------------------------------------
    !   Obtain a psuedorandom real number in the range (0,1), i.e., a number
    !   greater than 0 and less than 1.
    function mtprng_rand_real3(state) result(r)

        ! arguments
        type(mtprng_state), intent(inout) :: state

        ! return type
        real(IEEE64) :: r

        ! Local constant; precalculated to avoid division below
        real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967296.0_IEEE64

        r = (real(mtprng_rand64(state),IEEE64) + 0.5_IEEE64) * factor

    end function mtprng_rand_real3

end module mtprng


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


      real*8 function interp2 (a1, a2, av, t1, t2)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 To calculate particle time delay using type curves.
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.10 [10086-STN-2.10-00]
!D2
!D2 Initial implementation: 05-MAY-99, Programmer: Zora Dash
!D2
!D2 $Log:   /pvcs.config/fehm90/src/interp2.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:24   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:09:22   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:10:36   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:31:06   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:04:38   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!**********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.5 Cell-based particle-tracking module
!D3 2.3.6 Streamline particle-tracking module
!D3
!**********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!**********************************************************************
! Return the interpolated time value

      real*8 a1, a2, av, t1, t2, adj

      adj = (dlog10 (av) - dlog10 (a1)) / (dlog10 (a2) - dlog10 (a1))
      interp2 = t1 + adj * (t2 - t1)
      return
      end


c
c
c
c     =====================================================
       subroutine qinit(meqn,mbc,mx,my,xcorn,ycorn,
     &                   dx,dy,q,maux,aux,lstgrd,irr)
c     =====================================================
c
c     # Set initial conditions for q.
c     # rotated channel problem
c
       use amr_module
       implicit double precision (a-h,o-z)

       dimension q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
       dimension aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)
       integer irr(1-mbc:mx+mbc, 1-mbc:my+mbc)

       common /moredata/ sloc

c
c      mach 10 flow 30 degree ramp
c
       pi = 3.14159265358979d0
c      alpha = 30.d0 * pi/180.d0
       alpha = pi/6.d0
       dxhalf = 0.5d0*dx
       dyhalf = 0.5d0*dy
       timeInit = 0.d0

       rhol = 8.d0
       ul   = cos(alpha)*8.25d0
       vl   = -sin(alpha)*8.25d0
       pl   = 116.5d0

       rhor = 1.4d0
       ur   = 0.d0
       vr   = 0.d0
       pr   = 1.0d0

c      do 20 i=1,mx
c      do 20 j=1,my
c      uncomment next 2 lines to initialize ghost cells too.
c      helps with plotting
       do 20 i=1-mbc,mx+mbc
       do 20 j=1-mbc,my+mbc
          kuse = irr(i,j)
          if (kuse .ne. -1 .and. kuse .ne. lstgrd) then
             xcen = xcirr(kuse)
             ycen = ycirr(kuse)
          else
             xcen = xcorn + (i-0.5d0)*dx
             ycen = ycorn + (j-0.5d0)*dy
          endif

          ! cellave approach, for regular cells only
          !call cellave(xcen-dxhalf,ycen-dyhalf,dx,dy,wl,timeInit)

          ! for this cells y, where is shock in x
          !rho = (1.d0-wl)*rhor + wl*rhol
          !u   = (1.d0-wl)*ur   + wl*ul
          !v   = (1.d0-wl)*vr   + wl*vl
          !p   = (1.d0-wl)*pr   + wl*pl
          !q(1,i,j) = rho
          !q(2,i,j) = rho * u
          !q(3,i,j) = rho * v
          !q(4,i,j) = p/.4d0 + 0.5d0*rho*(u*u+v*v)
          !go to 20

          !pointwise approach
          xshock =  sloc + ycen/sqrt(3.0d0)
          if (xcen .lt. xshock) then
            q(1,i,j) = rhol
            q(2,i,j) = rhol * ul
            q(3,i,j) = rhol * vl
            q(4,i,j) = pl/.4d0 + 0.5d0*rhol*(ul**2 + vl**2)
          else
            q(1,i,j) = rhor
            q(2,i,j) = rhor * ur
            q(3,i,j) = rhor * vr
            q(4,i,j) = pr/.4d0 + 0.5d0*rhor*(ur**2 + vr**2)
          endif
  20   continue

       return
       end


CS    REAL FUNCTION BESEK1(X)
      DOUBLE PRECISION FUNCTION BESEK1(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order one
C   multiplied by the exponential function, for arguments
C   XLEAST .LE. ARG .LE. XMAX.
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION
     1    X, RESULT
C--------------------------------------------------------------------
      JINT = 2
      CALL CALCK1(X,RESULT,JINT)
      BESEK1 = RESULT
      RETURN
C---------- Last line of BESEK1 ----------
      END


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine  txinvr

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c block-diagonal matrix-vector multiplication
c---------------------------------------------------------------------

       include 'header.h'

       integer c, i, j, k
       double precision t1, t2, t3, ac, ru1, uu, vv, ww, r1, r2, r3,
     >                  r4, r5, ac2inv

c---------------------------------------------------------------------
c      loop over all cells owned by this node
c---------------------------------------------------------------------
       do   c = 1, ncells
          do    k = start(3,c), cell_size(3,c)-end(3,c)-1
             do    j = start(2,c), cell_size(2,c)-end(2,c)-1
                do    i = start(1,c), cell_size(1,c)-end(1,c)-1

                   ru1 = rho_i(i,j,k,c)
                   uu = us(i,j,k,c)
                   vv = vs(i,j,k,c)
                   ww = ws(i,j,k,c)
                   ac = speed(i,j,k,c)
                   ac2inv = ainv(i,j,k,c)*ainv(i,j,k,c)

                   r1 = rhs(i,j,k,1,c)
                   r2 = rhs(i,j,k,2,c)
                   r3 = rhs(i,j,k,3,c)
                   r4 = rhs(i,j,k,4,c)
                   r5 = rhs(i,j,k,5,c)

                   t1 = c2 * ac2inv * ( qs(i,j,k,c)*r1 - uu*r2  -
     >                  vv*r3 - ww*r4 + r5 )
                   t2 = bt * ru1 * ( uu * r1 - r2 )
                   t3 = ( bt * ru1 * ac ) * t1

                   rhs(i,j,k,1,c) = r1 - t1
                   rhs(i,j,k,2,c) = - ru1 * ( ww*r1 - r4 )
                   rhs(i,j,k,3,c) =   ru1 * ( vv*r1 - r3 )
                   rhs(i,j,k,4,c) = - t2 + t3
                   rhs(i,j,k,5,c) =   t2 + t3
                end do
             end do
          end do
       end do

       return
       end