!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program xtess
!
!    Test driver of "tess", the double precision Fortran subroutine to compute
!    the gravitational potential/acceleration vector/gradient tensor of a tesseroid.
!
!    Reference:
!           Fukushima T (2018) Accurate computation of gravitational field of a tesseroid.
!                Journal of Geodesy 92(12):1371–1386, doi:10.1007/s00190-018-1126-2
!
implicit integer (i-n)
implicit real*8 (a-h,o-z)
!
PI=atan(1.d0)*4.d0
raddeg=PI/180.d0
delta=1.d-16
write (*,"(a15,1pe15.7)") "# delta=", delta
!
!    A sample tesseroid covering an eastern Himalaya: size 1 deg x 1 deg x 50 km
!      (Note) Mt. Everest: h = 8.848 km, phi = 27 deg 59 min, lat = 86 deg 55 min
!
R0=6380.d0
HB=-40.d0
HT=10.d0
PhiS=27.d0*raddeg
PhiN=28.d0*raddeg
FlamW=86.d0*raddeg
FlamE=87.d0*raddeg
!
!   Test evaluation points are along a radial straight line
!    passing through the geometrical center of the tesseroid
!
phi=27.5d0*raddeg
flam=86.5d0*raddeg
!
write (*,"(a15,1p3e15.7)") "# R0,HT,HB=",R0,HT,HB
write (*,"(a15,1p2e15.7)") "# PhiN,PhiS=",PhiN/raddeg,PhiS/raddeg
write (*,"(a15,1p2e15.7)") "# LamdaE,LamdaW=",FlamE/raddeg,FlamW/raddeg
write (*,"(a15,1p2e15.7)") "# phi,lambda=",phi/raddeg,flam/raddeg
!
write (*,"(a15,a25)") "# H","V"
write (*,"(a15,3a25)") "#","gPhi","gLambda","gH"
write (*,"(a15,3a25)") "#","GammaPhiPhi","GammaPhiLambda","GammaPhiH"
write (*,"(a15,3a25)") "#","GammaLambdaLambda","GammaLambdaH","GammaHH"
!
!    Compute the field along a radial line passing through the tesseroid
!
call cpu_time(time_begin)
dH=10.d0
do m=-10,29
    h=(dble(m)+0.5d0)*dH
!
    call tess(PhiN,PhiS,FlamE,FlamW,HT,HB,R0,delta, &
        phi,flam,h, &
        v,gPhi,gLam,gH,ggPhiPhi,ggPhiLam,ggPhiH,ggLamLam,ggLamH,ggHH)
    write (*,"(1pe15.7,1pe25.15)") h,v
    write (*,"(15x,1p3e25.15)") gPhi,gLam,gH
    write (*,"(15x,1p3e25.15)") ggPhiPhi,ggPhiLam,ggPhiH
    write (*,"(15x,1p3e25.15)") ggLamLam,ggLamH,ggHH
enddo
call cpu_time(time_end)
write(*,*) "The total time is",time_end-time_begin,"seconds."
!
stop
end program xtess
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine tess(PhiN0,PhiS0,FlamE0,FlamW0,HT0,HB0,R00,delta0,phi,flam,h, &
    v,gPhi,gLam,gH,ggPhiPhi,ggPhiLam,ggPhiH,ggLamLam,ggLamH,ggHH)
!
!    The double precision Fortran subroutine to compute
!    the gravitational potential, V, the gravitational acceleration vector, g,
!    and the gravity gradient tensor, Gamma, of a tesseroid.
!
!    Input parameters:
!      PhiN0: Latitude of the north end point of the tesseroid
!      PhiS0: Latitude of the south end point of the tesseroid, PhiS0 < PhiN0
!      FlamE0: Longitude of the east end point of the tesseroid
!      FlamW0: Longitude of the west end point of the tesseroid, FlamW0 < FlamE0
!      HT0: Height of the top end point of the tesseroid
!      HB0: Height of the bottom end point of the tesseroid, HB0 < HT0
!      R00: Radius of the reference spherical surface from which H is counted
!      delta0: the relative error tolerance (typical value is 1d-9 or 1d-12)
!    Input variables:
!      phi: Latitude of the evaluation point
!      flam: Longitude of the evaluation point
!      h: Height from the reference sphere of the evaluation point
!        (Note) We adopted "km" as the unit of h as well as HT0 and HB0.
!               But any unit is OK if R00 is expressed in the same unit.
!    Output variables:
!      v: Normalized gravitational potential at the evaluation point
!        (Note) normalization constant: V0 = G rho R00^2
!      gPhi: Latitude component of normalized gravitational acceleration vector
!      gLam: Longitude component of normalized gravitational acceleration vector
!      gH: Height component of normalized gravitational acceleration vector
!        (Note) normalization constant: g0 = G rho R00
!      ggPhiPhi: Latitude-latitude component of normalized Gamma
!      ggPhiLam: Latitude-longitude component of normalized Gamma
!      ggPhiH: Latitude-height component of normalized Gamma
!      ggLamLam: Longitude-longitude component of normalized Gamma
!      ggLamH: Longitude-height component of normalized Gamma
!      ggHH: Height-height component of normalized Gamma
!        (Note) normalization constant: Gamma0 = G rho
!
implicit integer (i-n)
implicit real*8 (a-h,o-z)
!
!    One should declare "vtess" as an external function name
!
external vtess
!
!    Common blocks for passing the parameters and indirect variables
!
real*8 eps
common /epsV/eps
real*8 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /paramV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*8 delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
common /deltaV/delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
!
!    Store the input variables into common blocks
!    so that the subprograms can refer them indirectly
!
PhiN=PhiN0
PhiS=PhiS0
FlamE=FlamE0
FlamW=FlamW0
HT=HT0
HB=HB0
R0=R00
!
!    Calculate parameters of numerical integration and differentiation
!
eps=delta0
delta=delta0
delta1=delta**(1.d0/3.d0)
delta2=sqrt(sqrt(delta))
!
!    Compute tesseroid-dependent constants beforehand
!
deltaH=HT-HB
deltaPhi=PhiN-PhiS
deltaFlam=FlamE-FlamW
beta=deltaH/R0
RC=R0+(HT+HB)*0.5d0
PhiC=(PhiN+PhiS)*0.5d0
FlamC=(FlamE+FlamW)*0.5d0
sinPhiC=sin(PhiC)
cosPhiC=cos(PhiC)
!
!    Compute evaluation-point-dependent constants beforehand
!
r=R0+h
sinphi=sin(phi)
cosphi=cos(phi)
cosdlam=cos(flam-FlamC)
scale0=0.5d0*sqrt(deltaH*deltaH+RC*RC*(deltaPhi*deltaPhi &
    +cosPhiC*cosPhiC*deltaFlam*deltaFlam))
scale1=sqrt(r*r+RC*RC-2.d0*RC*r*(sinphi*sinPhiC+cosphi*cosPhiC*cosdlam))
scale=max(scale0,scale1)
d1h=scale*delta1
! add d1phi, d1lam
d1phi=d1h/r
d1lam=d1h/(r*cosphi)
d2h=scale*delta2
! add d2phi, d2lam
d2phi=d2h/r
d2lam=d2h/(r*cosphi)
!
!    Compute the gravitational potential by numerical integration
!
v=vtess(phi,flam,h)
!
!    Compute the gravitational acceleration vector by numerical differentiation
!
call gtess(vtess,phi,flam,h,v,gPhi,gLam,gH)
!
!    Compute the gravity gradient tensor by numerical differentiation
!
call ggtess(vtess,phi,flam,h,v,gPhi,gLam,gH, &
    ggPhiPhi,ggPhiLam,ggPhiH,ggLamLam,ggLamH,ggHH)
!
return;end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*8 function vtess(phi,flam,h)
!
!    The double precision Fortran function to compute
!    the gravitational potential by the conditional split quadrature method
!
implicit integer (i-n)
implicit real*8 (a-h,o-z)
!
!    One should declare "stess" as an external function name
!
external stess
!
!    Common blocks for passing the parameters and indirect variables
!
real*8 eps
common /epsV/eps
real*8 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /paramV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*8 phi0,flam0,h0,xiN,xiS,etaE,etaW
common /argV/phi0,flam0,h0,xiN,xiS,etaE,etaW
real*8 alpha,gamma,zetaT,zetaB,sigma,fmu
common /paramV2/alpha,gamma,zetaT,zetaB,sigma,fmu
!
!    Store the input variables into common blocks
!    so that the subprograms can refer them indirectly
!
phi0=phi
flam0=flam
h0=h
!
!    Compute tesseroid-dependent constants beforehand
!
xiN=PhiN-phi
xiS=PhiS-phi
etaE=FlamE-flam
etaW=FlamW-flam
!
!    Compute evaluation-point-dependent constants beforehand
!
alpha=1.d0+h/R0
gamma=cos(phi)
zetaB=(HB-h)/R0
zetaT=zetaB+beta
!
!    Conditional split quadrature of latitude line integration
!
if(xiS.lt.0.d0.and.xiN.gt.0.d0) then
    call dqde(stess,xiS,0.d0,eps,v1)
    call dqde(stess,0.d0,xiN,eps,v2)
    v=v1+v2
else
    call dqde(stess,xiS,xiN,eps,v)
endif
vtess=v
!
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*8 function stess(xi)
!
!    The double precision Fortran function to compute
!    the latitude line integral requried in "vtess"
!
implicit integer (i-n)
implicit real*8 (a-h,o-z)
!
!    One should declare "vkern" as an external function name
!
external vkern
!
!    Common blocks for passing the parameters and indirect variables
!
real*8 eps
common /epsV/eps
real*8 phi0,flam0,h0,xiN,xiS,etaE,etaW
common /argV/phi0,flam0,h0,xiN,xiS,etaE,etaW
real*8 alpha,gamma,zetaT,zetaB,sigma,fmu
common /paramV2/alpha,gamma,zetaT,zetaB,sigma,fmu
!
!    Compute latitude-dependent constants beforehand
!
sigma=cos(phi0+xi)
fmu=sin(xi*0.5d0)
!
!    Conditional split quadrature of longitude line integration
!
if(etaW.lt.0.d0.and.etaE.gt.0.d0) then
    call dqde1(vkern,etaW,0.d0,eps,s1)
    call dqde1(vkern,0.d0,etaE,eps,s2)
    s=s1+s2
else
    call dqde1(vkern,etaW,etaE,eps,s)
endif
stess=s
!
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*8 function vkern(eta)
!
!    The double precision Fortran function to compute
!    the kernel function expressed in a cancellation-free form
!
implicit integer (i-n)
implicit real*8 (a-h,o-z)
!
!    Common blocks for passing the parameters and indirect variables
!
real*8 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /paramV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*8 alpha,gamma,zetaT,zetaB,sigma,fmu
common /paramV2/alpha,gamma,zetaT,zetaB,sigma,fmu
!
!    Cancellation-free computation of the kernel function
!
fnu=sin(eta*0.5d0)
B=2.d0*alpha*(fmu*fmu+gamma*sigma*fnu*fnu)
A=B*(2.d0*alpha-B)
C=(alpha-B)*(alpha-B)-A*0.5d0
D=0.5d0*(zetaT+4.d0*alpha-3.d0*B)
ST=sqrt(A+(B+zetaT)*(B+zetaT))
SB=sqrt(A+(B+zetaB)*(B+zetaB))
T=(zetaT+zetaB+2.d0*B)/(ST+SB)
if(zetaB+B.lt.0.d0) then
    fl=dlog1p((1.d0+T)*beta*(-zetaB-B+SB)/A)
else
    fl=dlog1p((1.d0+T)*beta/(zetaB+B+SB))
endif
vkern=sigma*(C*fl+beta*(D*T+SB*0.5d0))
!
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine gtess(vtess,phi,flam,h,v,gPhi,gLam,gH)
!
!    Compute the gravitational acceleration vector by the conditional switch
!    of the central and single-sided second order finite difference formulas
!
implicit integer (i-n)
implicit real*8 (a-h,o-z)
!
!    Common blocks for passing the parameters and indirect variables
!
real*8 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /paramV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*8 delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
common /deltaV/delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
!
!    Compute conmponent-independent variables beorehand
!
r=R0+h
c=cos(phi)
!
!   Compute gPhi
!
if((flam.ge.FlamW.and.flam.le.FlamE).and.(h.ge.HB.and.h.le.HT)) then
    if((phi.gt.PhiS.and.phi-d1phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d1phi.lt.PhiN)) then
        gPhi=(-vtess(phi+2.d0*d1phi,flam,h)+4.d0*vtess(phi+d1phi,flam,h)-3.d0*v)/(2.d0*d1phi)
    elseif((phi.lt.PhiS.and.phi+d1phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d1phi.gt.PhiN)) then
        gPhi=(vtess(phi-2.d0*d1phi,flam,h)-4.d0*vtess(phi-d1phi,flam,h)+3.d0*v)/(2.d0*d1phi)
    else
        gPhi=(vtess(phi+d1phi,flam,h)-vtess(phi-d1phi,flam,h))/(2.d0*d1phi)
    endif
else
    gPhi=(vtess(phi+d1phi,flam,h)-vtess(phi-d1phi,flam,h))/(2.d0*d1phi)
endif
gPhi=gPhi/r
!
!   Compute gLam
!
if((phi.ge.PhiS.and.phi.le.PhiN).and.(h.ge.HB.and.h.le.HT)) then
    if((flam.gt.FlamW.and.flam-d1lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d1lam.lt.FlamE)) then
        gLam=(-vtess(phi,flam+2.d0*d1lam,h)+4.d0*vtess(phi,flam+d1lam,h)-3.d0*v)/(2.d0*d1lam)
    elseif((flam.lt.FlamW.and.flam+d1lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d1lam.gt.FlamE)) then
        gLam=(vtess(phi,flam-2.d0*d1lam,h)-4.d0*vtess(phi,flam-d1lam,h)+3.d0*v)/(2.d0*d1lam)
    else
        gLam=(vtess(phi,flam+d1lam,h)-vtess(phi,flam-d1lam,h))/(2.d0*d1lam)
    endif
else
    gLam=(vtess(phi,flam+d1lam,h)-vtess(phi,flam-d1lam,h))/(2.d0*d1lam)
endif
gLam=gLam/(r*c)
!
!   Compute gH
!
if((phi.ge.PhiS.and.phi.le.PhiN).and.(flam.ge.FlamW.and.flam.le.FlamE)) then
    if((h.gt.HB.and.h-d1h.lt.HB).or.(h.gt.HT.and.h-d1h.lt.HT)) then
        gH=(-vtess(phi,flam,h+2.d0*d1h)+4.d0*vtess(phi,flam,h+d1h)-3.d0*v)/(2.d0*d1h)
    elseif((h.lt.HB.and.h+d1h.gt.HB).or.(h.lt.HT.and.h+d1h.gt.HT)) then
        gH=(vtess(phi,flam,h-2.d0*d1h)-4.d0*vtess(phi,flam,h-d1h)+3.d0*v)/(2.d0*d1h)
    else
        gH=(vtess(phi,flam,h+d1h)-vtess(phi,flam,h-d1h))/(2.d0*d1h)
    endif
else
    gH=(vtess(phi,flam,h+d1h)-vtess(phi,flam,h-d1h))/(2.d0*d1h)
endif
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ggtess(vtess,phi,flam,h,v,gPhi,gLam,gH, &
    ggPhiPhi,ggPhiLam,ggPhiH,ggLamLam,ggLamH,ggHH)
!
!    Compute the gravity gradient tensor by the conditional switch
!    of the central and single-sided second order finite difference formulas
!
implicit integer (i-n)
implicit real*8 (a-h,o-z)
!
!    Common blocks for passing the parameters and indirect variables
!
real*8 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /paramV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*8 delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
common /deltaV/delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
!
!    Compute conmponent-independent variables beorehand
!
r=R0+h
c=cos(phi)
t=tan(phi)
!
!   Compute ggPhiPhi
!
if((flam.ge.FlamW.and.flam.le.FlamE).and.(h.ge.HB.and.h.le.HT)) then
    if((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)) then
        ggPhiPhi=(-vtess(phi+3.d0*d2phi,flam,h)+4.d0*vtess(phi+2.d0*d2phi,flam,h) &
            -5.d0*vtess(phi+d2phi,flam,h)+2.d0*v)/(d2phi*d2phi)
    elseif((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)) then
        ggPhiPhi=(-vtess(phi-3.d0*d2phi,flam,h)+4.d0*vtess(phi-2.d0*d2phi,flam,h) &
            -5.d0*vtess(phi-d2phi,flam,h)+2.d0*v)/(d2phi*d2phi)
    else
        ggPhiPhi=(vtess(phi+d2phi,flam,h)-2.d0*v+vtess(phi-d2phi,flam,h))/(d2phi*d2phi)
    endif
else
    ggPhiPhi=(vtess(phi+d2phi,flam,h)-2.d0*v+vtess(phi-d2phi,flam,h))/(d2phi*d2phi)
endif
ggPhiPhi=ggPhiPhi/(r*r)+gH/r
!
!   Compute ggLamLam
!
if((phi.ge.PhiS.and.phi.le.PhiN).and.(h.ge.HB.and.h.le.HT)) then
    if((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE)) then
        ggLamLam=(-vtess(phi,flam+3.d0*d2lam,h)+4.d0*vtess(phi,flam+2.d0*d2lam,h) &
            -5.d0*vtess(phi,flam+d2lam,h)+2.d0*v)/(d2lam*d2lam)
    elseif((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE)) then
        ggLamLam=(-vtess(phi,flam-3.d0*d2lam,h)+4.d0*vtess(phi,flam-2.d0*d2lam,h) &
            -5.d0*vtess(phi,flam-d2lam,h)+2.d0*v)/(d2lam*d2lam)
    else
        ggLamLam=(vtess(phi,flam+d2lam,h)-2.d0*v+vtess(phi,flam-d2lam,h))/(d2lam*d2lam)
    endif
else
    ggLamLam=(vtess(phi,flam+d2lam,h)-2.d0*v+vtess(phi,flam-d2lam,h))/(d2lam*d2lam)
endif
ggLamLam=ggLamLam/(r*r*c*c)+(gH-gPhi*t)/r
!
!   Compute ggHH
!
if((phi.ge.PhiS.and.phi.le.PhiN).and.(flam.ge.FlamW.and.flam.le.FlamE)) then
    if((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT)) then
        ggHH=(-vtess(phi,flam,h+3.d0*d2h)+4.d0*vtess(phi,flam,h+2.d0*d2h) &
            -5.d0*vtess(phi,flam,h+d2h)+2.d0*v)/(d2h*d2h)
    elseif((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT)) then
        ggHH=(-vtess(phi,flam,h-3.d0*d2h)+4.d0*vtess(phi,flam,h-2.d0*d2h) &
            -5.d0*vtess(phi,flam,h-d2h)+2.d0*v)/(d2h*d2h)
    else
        ggHH=(vtess(phi,flam,h+d2h)-2.d0*v+vtess(phi,flam,h-d2h))/(d2h*d2h)
    endif
else
    ggHH=(vtess(phi,flam,h+d2h)-2.d0*v+vtess(phi,flam,h-d2h))/(d2h*d2h)
endif
!
!   Compute ggPhiLam
!
if(h.ge.HB.and.h.le.HT) then
    if(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE))) then
        ggPhiLam=(vtess(phi+2.d0*d2phi,flam+2.d0*d2lam,h) &
            -4.d0*vtess(phi+2.d0*d2phi,flam+d2lam,h)+3.d0*vtess(phi+2.d0*d2phi,flam,h) &
            -4.d0*vtess(phi+d2phi,flam+2.d0*d2lam,h)+16.d0*vtess(phi+d2phi,flam+d2lam,h) &
            -12.d0*vtess(phi+d2phi,flam,h)+3.d0*vtess(phi,flam+2.d0*d2lam,h) &
            -12.d0*vtess(phi,flam+d2lam,h)+9.d0*v)/(4.d0*d2phi*d2lam)
    elseif(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE))) then
        ggPhiLam=-(vtess(phi+2.d0*d2phi,flam-2.d0*d2lam,h) &
            -4.d0*vtess(phi+2.d0*d2phi,flam-d2lam,h)+3.d0*vtess(phi+2.d0*d2phi,flam,h) &
            -4.d0*vtess(phi+d2phi,flam-2.d0*d2lam,h)+16.d0*vtess(phi+d2phi,flam-d2lam,h) &
            -12.d0*vtess(phi+d2phi,flam,h)+3.d0*vtess(phi,flam-2.d0*d2lam,h) &
            -12.d0*vtess(phi,flam-d2lam,h)+9.d0*v)/(4.d0*d2phi*d2lam)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE))) then
        ggPhiLam=-(vtess(phi-2.d0*d2phi,flam+2.d0*d2lam,h) &
            -4.d0*vtess(phi-2.d0*d2phi,flam+d2lam,h)+3.d0*vtess(phi-2.d0*d2phi,flam,h) &
            -4.d0*vtess(phi-d2phi,flam+2.d0*d2lam,h)+16.d0*vtess(phi-d2phi,flam+d2lam,h) &
            -12.d0*vtess(phi-d2phi,flam,h)+3.d0*vtess(phi,flam+2.d0*d2lam,h) &
            -12.d0*vtess(phi,flam+d2lam,h)+9.d0*v)/(4.d0*d2phi*d2lam)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE))) then
        ggPhiLam=(vtess(phi-2.d0*d2phi,flam-2.d0*d2lam,h) &
            -4.d0*vtess(phi-2.d0*d2phi,flam-d2lam,h)+3.d0*vtess(phi-2.d0*d2phi,flam,h) &
            -4.d0*vtess(phi-d2phi,flam-2.d0*d2lam,h)+16.d0*vtess(phi-d2phi,flam-d2lam,h) &
            -12.d0*vtess(phi-d2phi,flam,h)+3.d0*vtess(phi,flam-2.d0*d2lam,h) &
            -12.d0*vtess(phi,flam-d2lam,h)+9.d0*v)/(4.d0*d2phi*d2lam)
    elseif(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((flam+d2lam.lt.FlamW).or.(flam-d2lam.gt.FlamE).or. &
        (flam-d2lam.gt.FlamW.and.flam+d2lam.lt.FlamE))) then
        ggPhiLam=(-vtess(phi+2.d0*d2phi,flam+d2lam,h)+vtess(phi+2.d0*d2phi,flam-d2lam,h) &
            +4.d0*vtess(phi+d2phi,flam+d2lam,h)-4.d0*vtess(phi+d2phi,flam-d2lam,h) &
            -3.d0*vtess(phi,flam+d2lam,h)+3.d0*vtess(phi,flam-d2lam,h))/(4.d0*d2phi*d2lam)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((flam+d2lam.lt.FlamW).or.(flam-d2lam.gt.FlamE).or. &
        (flam-d2lam.gt.FlamW.and.flam+d2lam.lt.FlamE))) then
        ggPhiLam=(vtess(phi-2.d0*d2phi,flam+d2lam,h)-vtess(phi-2.d0*d2phi,flam-d2lam,h) &
            -4.d0*vtess(phi-d2phi,flam+d2lam,h)+4.d0*vtess(phi-d2phi,flam-d2lam,h) &
            +3.d0*vtess(phi,flam+d2lam,h)-3.d0*vtess(phi,flam-d2lam,h))/(4.d0*d2phi*d2lam)
    elseif(((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or. &
        (flam.gt.FlamE.and.flam-d2lam.lt.FlamE)).and. &
        ((phi+d2phi.lt.PhiS).or.(phi-d2phi.gt.PhiN).or.(phi-d2phi.gt.PhiS.and.phi+d2phi.lt.PhiN))) then
        ggPhiLam=(-vtess(phi+d2phi,flam+2.d0*d2lam,h)+vtess(phi-d2phi,flam+2.d0*d2lam,h) &
            +4.d0*vtess(phi+d2phi,flam+d2lam,h)-4.d0*vtess(phi-d2phi,flam+d2lam,h) &
            -3.d0*vtess(phi+d2phi,flam,h)+3.d0*vtess(phi-d2phi,flam,h))/(4.d0*d2phi*d2lam)
    elseif(((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or. &
        (flam.lt.FlamE.and.flam+d2lam.gt.FlamE)).and. &
        ((phi+d2phi.lt.PhiS).or.(phi-d2phi.gt.PhiN).or.(phi-d2phi.gt.PhiS.and.phi+d2phi.lt.PhiN))) then
        ggPhiLam=-(-vtess(phi+d2phi,flam-2.d0*d2lam,h)+vtess(phi-d2phi,flam-2.d0*d2lam,h) &
            +4.d0*vtess(phi+d2phi,flam-d2lam,h)-4.d0*vtess(phi-d2phi,flam-d2lam,h) &
            -3.d0*vtess(phi+d2phi,flam,h)+3.d0*vtess(phi-d2phi,flam,h))/(4.d0*d2phi*d2lam)
    else
        ggPhiLam=(vtess(phi+d2phi,flam+d2lam,h)-vtess(phi-d2phi,flam+d2lam,h) &
            -vtess(phi+d2phi,flam-d2lam,h)+vtess(phi-d2phi,flam-d2lam,h))/(4.d0*d2phi*d2lam)
    endif
else
    ggPhiLam=(vtess(phi+d2phi,flam+d2lam,h)-vtess(phi-d2phi,flam+d2lam,h) &
        -vtess(phi+d2phi,flam-d2lam,h)+vtess(phi-d2phi,flam-d2lam,h))/(4.d0*d2phi*d2lam)
endif
ggPhiLam=ggPhiLam/(r*r*c)+gLam*t/r
!
!   Compute ggPhiH
!
if(flam.ge.FlamW.and.flam.le.FlamE) then
    if(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT))) then
        ggPhiH=(vtess(phi+2.d0*d2phi,flam,h+2.d0*d2h)-4.d0*vtess(phi+2.d0*d2phi,flam,h+d2h) &
            +3.d0*vtess(phi+2.d0*d2phi,flam,h)-4.d0*vtess(phi+d2phi,flam,h+2.d0*d2h) &
            +16.d0*vtess(phi+d2phi,flam,h+d2h)-12.d0*vtess(phi+d2phi,flam,h) &
            +3.d0*vtess(phi,flam,h+2.d0*d2h)-12.d0*vtess(phi,flam,h+d2h)+9.d0*v)/(4.d0*d2phi*d2h)
    elseif(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT))) then
        ggPhiH=-(vtess(phi+2.d0*d2phi,flam,h-2.d0*d2h)-4.d0*vtess(phi+2.d0*d2phi,flam,h-d2h) &
            +3.d0*vtess(phi+2.d0*d2phi,flam,h)-4.d0*vtess(phi+d2phi,flam,h-2.d0*d2h) &
            +16.d0*vtess(phi+d2phi,flam,h-d2h)-12.d0*vtess(phi+d2phi,flam,h) &
            +3.d0*vtess(phi,flam,h-2.d0*d2h)-12.d0*vtess(phi,flam,h-d2h)+9.d0*v)/(4.d0*d2phi*d2h)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT))) then
        ggPhiH=-(vtess(phi-2.d0*d2phi,flam,h+2.d0*d2h)-4.d0*vtess(phi-2.d0*d2phi,flam,h+d2h) &
            +3.d0*vtess(phi-2.d0*d2phi,flam,h)-4.d0*vtess(phi-d2phi,flam,h+2.d0*d2h) &
            +16.d0*vtess(phi-d2phi,flam,h+d2h)-12.d0*vtess(phi-d2phi,flam,h) &
            +3.d0*vtess(phi,flam,h+2.d0*d2h)-12.d0*vtess(phi,flam,h+d2h)+9.d0*v)/(4.d0*d2phi*d2h)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT))) then
        ggPhiH=(vtess(phi-2.d0*d2phi,flam,h-2.d0*d2h)-4.d0*vtess(phi-2.d0*d2phi,flam,h-d2h) &
            +3.d0*vtess(phi-2.d0*d2phi,flam,h)-4.d0*vtess(phi-d2phi,flam,h-2.d0*d2h) &
            +16.d0*vtess(phi-d2phi,flam,h-d2h)-12.d0*vtess(phi-d2phi,flam,h) &
            +3.d0*vtess(phi,flam,h-2.d0*d2h)-12.d0*vtess(phi,flam,h-d2h)+9.d0*v)/(4.d0*d2phi*d2h)
    elseif(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((h+d2h.lt.HB).or.(h-d2h.gt.HT).or.(h-d2h.gt.HB.and.h+d2h.lt.HT))) then
        ggPhiH=(-vtess(phi+2.d0*d2phi,flam,h+d2h)+vtess(phi+2.d0*d2phi,flam,h-d2h) &
            +4.d0*vtess(phi+d2phi,flam,h+d2h)-4.d0*vtess(phi+d2phi,flam,h-d2h) &
            -3.d0*vtess(phi,flam,h+d2h)+3.d0*vtess(phi,flam,h-d2h))/(4.d0*d2phi*d2h)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((h+d2h.lt.HB).or.(h-d2h.gt.HT).or.(h-d2h.gt.HB.and.h+d2h.lt.HT))) then
        ggPhiH=-(-vtess(phi-2.d0*d2phi,flam,h+d2h)+vtess(phi-2.d0*d2phi,flam,h-d2h) &
            +4.d0*vtess(phi-d2phi,flam,h+d2h)-4.d0*vtess(phi-d2phi,flam,h-d2h) &
            -3.d0*vtess(phi,flam,h+d2h)+3.d0*vtess(phi,flam,h-d2h))/(4.d0*d2phi*d2h)
    elseif(((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT)).and.((phi+d2phi.lt.PhiS) &
        .or.(phi-d2phi.gt.PhiN).or.(phi-d2phi.gt.PhiS.and.phi+d2phi.lt.PhiN))) then
        ggPhiH=(-vtess(phi+d2phi,flam,h+2.d0*d2h)+vtess(phi-d2phi,flam,h+2.d0*d2h) &
            +4.d0*vtess(phi+d2phi,flam,h+d2h)-4.d0*vtess(phi-d2phi,flam,h+d2h) &
            -3.d0*vtess(phi+d2phi,flam,h)+3.d0*vtess(phi-d2phi,flam,h))/(4.d0*d2phi*d2h)
    elseif(((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT)).and.((phi+d2phi.lt.PhiS) &
        .or.(phi-d2phi.gt.PhiN).or.(phi-d2phi.gt.PhiS.and.phi+d2phi.lt.PhiN))) then
        ggPhiH=-(-vtess(phi+d2phi,flam,h-2.d0*d2h)+vtess(phi-d2phi,flam,h-2.d0*d2h) &
            +4.d0*vtess(phi+d2phi,flam,h-d2h)-4.d0*vtess(phi-d2phi,flam,h-d2h) &
            -3.d0*vtess(phi+d2phi,flam,h)+3.d0*vtess(phi-d2phi,flam,h))/(4.d0*d2phi*d2h)
    else
        ggPhiH=(vtess(phi+d2phi,flam,h+d2h)-vtess(phi-d2phi,flam,h+d2h) &
            -vtess(phi+d2phi,flam,h-d2h)+vtess(phi-d2phi,flam,h-d2h))/(4.d0*d2phi*d2h)
    endif
else
    ggPhiH=(vtess(phi+d2phi,flam,h+d2h)-vtess(phi-d2phi,flam,h+d2h) &
        -vtess(phi+d2phi,flam,h-d2h)+vtess(phi-d2phi,flam,h-d2h))/(4.d0*d2phi*d2h)
endif
ggPhiH=ggPhiH/r-gPhi/r
!
!   Compute ggLamH
!
if(phi.ge.PhiS.and.phi.le.PhiN) then
    if(((flam.gt.FlamW.and.flam-d2flam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2flam.lt.FlamE)).and. &
        ((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT))) then
        ggLamH=(vtess(phi,flam+2.d0*d2lam,h+2.d0*d2h)-4.d0*vtess(phi,flam+2.d0*d2lam,h+d2h) &
            +3.d0*vtess(phi,flam+2.d0*d2lam,h)-4.d0*vtess(phi,flam+d2lam,h+2.d0*d2h) &
            +16.d0*vtess(phi,flam+d2lam,h+d2h)-12.d0*vtess(phi,flam+d2lam,h) &
            +3.d0*vtess(phi,flam,h+2.d0*d2h)-12.d0*vtess(phi,flam,h+d2h)+9.d0*v)/(4.d0*d2lam*d2h)
    elseif(((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE)).and. &
        ((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT))) then
        ggLamH=-(vtess(phi,flam+2.d0*d2lam,h-2.d0*d2h)-4.d0*vtess(phi,flam+2.d0*d2lam,h-d2h) &
            +3.d0*vtess(phi,flam+2.d0*d2lam,h)-4.d0*vtess(phi,flam+d2lam,h-2.d0*d2h) &
            +16.d0*vtess(phi,flam+d2lam,h-d2h)-12.d0*vtess(phi,flam+d2lam,h) &
            +3.d0*vtess(phi,flam,h-2.d0*d2h)-12.d0*vtess(phi,flam,h-d2h)+9.d0*v)/(4.d0*d2lam*d2h)
    elseif(((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE)).and. &
        ((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT))) then
        ggLamH=-(vtess(phi,flam-2.d0*d2lam,h+2.d0*d2h)-4.d0*vtess(phi,flam-2.d0*d2lam,h+d2h) &
            +3.d0*vtess(phi,flam-2.d0*d2lam,h)-4.d0*vtess(phi,flam-d2lam,h+2.d0*d2h) &
            +16.d0*vtess(phi,flam-d2lam,h+d2h)-12.d0*vtess(phi,flam-d2lam,h) &
            +3.d0*vtess(phi,flam,h+2.d0*d2h)-12.d0*vtess(phi,flam,h+d2h)+9.d0*v)/(4.d0*d2lam*d2h)
    elseif(((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE)).and. &
        ((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT))) then
        ggLamH=(vtess(phi,flam-2.d0*d2lam,h-2.d0*d2h)-4.d0*vtess(phi,flam-2.d0*d2lam,h-d2h) &
            +3.d0*vtess(phi,flam-2.d0*d2lam,h)-4.d0*vtess(phi,flam-d2lam,h-2.d0*d2h) &
            +16.d0*vtess(phi,flam-d2lam,h-d2h)-12.d0*vtess(phi,flam-d2lam,h) &
            +3.d0*vtess(phi,flam,h-2.d0*d2h)-12.d0*vtess(phi,flam,h-d2h)+9.d0*v)/(4.d0*d2lam*d2h)
    elseif(((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE)).and. &
        ((h+d2h.lt.HB).or.(h-d2h.gt.HT).or.(h-d2h.gt.HB.and.h+d2h.lt.HT))) then
        ggLamH=(-vtess(phi,flam+2.d0*d2lam,h+d2h)+vtess(phi,flam+2.d0*d2lam,h-d2h) &
            +4.d0*vtess(phi,flam+d2lam,h+d2h)-4.d0*vtess(phi,flam+d2lam,h-d2h) &
            -3.d0*vtess(phi,flam,h+d2h)+3.d0*vtess(phi,flam,h-d2h))/(4.d0*d2lam*d2h)
    elseif(((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE)).and. &
        ((h+d2h.lt.HB).or.(h-d2h.gt.HT).or.(h-d2h.gt.HB.and.h+d2h.lt.HT))) then
        ggLamH=-(-vtess(phi,flam-2.d0*d2lam,h+d2h)+vtess(phi,flam-2.d0*d2lam,h-d2h) &
            +4.d0*vtess(phi,flam-d2lam,h+d2h)-4.d0*vtess(phi,flam-d2lam,h-d2h) &
            -3.d0*vtess(phi,flam,h+d2h)+3.d0*vtess(phi,flam,h-d2h))/(4.d0*d2lam*d2h)
    elseif(((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT)).and.((flam+d2lam.lt.FlamW).or. &
        (flam-d2lam.gt.FlamE).or.(flam-d2lam.gt.FlamW.and.flam+d2lam.lt.FlamE))) then
        ggLamH=(-vtess(phi,flam+d2lam,h+2.d0*d2h)+vtess(phi,flam-d2lam,h+2.d0*d2h) &
            +4.d0*vtess(phi,flam+d2lam,h+d2h)-4.d0*vtess(phi,flam-d2lam,h+d2h) &
            -3.d0*vtess(phi,flam+d2lam,h)+3.d0*vtess(phi,flam-d2lam,h))/(4.d0*d2lam*d2h)
    elseif(((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT)).and.((flam+d2lam.lt.FlamW).or. &
        (flam-d2lam.gt.FlamE).or.(flam-d2lam.gt.FlamW.and.flam+d2lam.lt.FlamE))) then
        ggLamH=-(-vtess(phi,flam+d2lam,h-2.d0*d2h)+vtess(phi,flam-d2lam,h-2.d0*d2h) &
            +4.d0*vtess(phi,flam+d2lam,h-d2h)-4.d0*vtess(phi,flam-d2lam,h-d2h) &
            -3.d0*vtess(phi,flam+d2lam,h)+3.d0*vtess(phi,flam-d2lam,h))/(4.d0*d2lam*d2h)
    else
        ggLamH=(vtess(phi,flam+d2lam,h+d2h)-vtess(phi,flam-d2lam,h+d2h) &
            -vtess(phi,flam+d2lam,h-d2h)+vtess(phi,flam-d2lam,h-d2h))/(4.d0*d2lam*d2h)
    endif
else
    ggLamH=(vtess(phi,flam+d2lam,h+d2h)-vtess(phi,flam-d2lam,h+d2h) &
        -vtess(phi,flam+d2lam,h-d2h)+vtess(phi,flam-d2lam,h-d2h))/(4.d0*d2lam*d2h)
endif
ggLamH=ggLamH/(r*c)-gLam/r
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine dqde(f,a,b,delta0,s)
!
!   The subroutine to compute a given integral by the double precision
!    double exponential (DE) quadrature rule.
!
!    Reference: Fukushima (2017) Precise and fast computation of gravitational
!      field of general finite body and its application to gravitational study
!      of asteroid Eros. Astron J. in printing
!
!    Input function/variables:
!      f(t): a function to be integrated
!      a: the lower end point of the integration interval
!      b: the upper end point of the integration interval
!      delta0: the relative error tolerance (typically 1d-15)
!    Output variable:
!      s: the definite integral, s=int_a^b f(t) dt
!        (Note) "errd" is the latest relative error estimate o "s"
!
real*8 f,a,b,delta0,s
integer MMAX
real*8 SAFETY,TWOPI
parameter (MMAX=1024,SAFETY=10.d0)
parameter (TWOPI=6.2831853071795865d0)
integer m
real*8 delta,hmax,deltax,factor,deltah,h0,eph,emh,deltat,apb,bma,sr,h
real*8 sprev,srprev,t,ep,em,eppem,xw,xa,wg,fa,fb,fapfb,errt
real*8 errh,errd
delta=max(1.d-16,min(0.01d0,delta0))
if(delta.gt.1.d-4) then
    hmax=2.75d0+(-log10(delta))*0.75d0
elseif(delta.gt.1.d-6) then
    hmax=3.75d0+(-log10(delta))*0.5d0
elseif(delta.gt.1.d-10) then
    hmax=5.25d0+(-log10(delta))*0.25d0
else
    hmax=6.5d0+(-log10(delta))*0.125d0
endif
deltax=SAFETY*delta
factor=1.d0-log(deltax)
deltah=sqrt(deltax)
h0=hmax/factor
eph=exp(h0)
emh=1.d0/eph
deltat=exp(-emh*factor)
apb=a+b
bma=b-a
sr=f(apb*0.5d0)*(bma*0.25d0)
s=sr*(2.d0*TWOPI)
err=abs(s)*deltat
h=2.d0*h0
m=1
1 continue
    sprev=s
    srprev=sr
    t=h*0.5d0
2 continue
        em=exp(t)
        ep=TWOPI*em
        em=TWOPI/em
3 continue
            eppem=ep+em
            xw=1.d0/(1.d0+exp(ep-em))
            xa=bma*xw
            wg=xa*(1.d0-xw)
            fa=f(a+xa)*wg
            fb=f(b-xa)*wg
            fapfb=fa+fb
            sr=sr+fapfb
            s=s+fapfb*eppem
            errt=(abs(fa)+abs(fb))*eppem
            if(m.eq.1) err=err+errt*deltat
            ep=ep*eph
            em=em*emh
            if(errt.gt.err.or.xw.gt.deltah) goto 3
        t=t+h
        if(t.lt.h0) goto 2
    if(m.eq.1) then
        errh=(err/deltat)*deltah*h0
        errd=1.d0+2.d0*errh
    else
        errd=h*(abs(s-2.d0*sprev)+4.d0*abs(sr-2.d0*srprev))
    endif
    h=h*0.5d0
    m=m*2
    if(errd.gt.errh.and.m.lt.MMAX) goto 1
!if(errd.gt.errh) write(*,*)"(dqde) Required too many grids: >", MMAX
s=s*h
return;end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine dqde1(f,a,b,delta0,s)
!
!    The first copy of "dqde" to be used in computing the internal
!    line integral called by "dqde"
!
real*8 f,a,b,delta0,s
integer MMAX
real*8 SAFETY,TWOPI
parameter (MMAX=1024,SAFETY=10.d0)
parameter (TWOPI=6.2831853071795865d0)
integer m
real*8 delta,hmax,deltax,factor,deltah,h0,eph,emh,deltat,apb,bma,sr,h
real*8 sprev,srprev,t,ep,em,eppem,xw,xa,wg,fa,fb,fapfb,errt
real*8 errh,errd
delta=max(1.d-16,min(0.01d0,delta0))
if(delta.gt.1.d-4) then
    hmax=2.75d0+(-log10(delta))*0.75d0
elseif(delta.gt.1.d-6) then
    hmax=3.75d0+(-log10(delta))*0.5d0
elseif(delta.gt.1.d-10) then
    hmax=5.25d0+(-log10(delta))*0.25d0
else
    hmax=6.5d0+(-log10(delta))*0.125d0
endif
deltax=SAFETY*delta
factor=1.d0-log(deltax)
deltah=sqrt(deltax)
h0=hmax/factor
eph=exp(h0)
emh=1.d0/eph
deltat=exp(-emh*factor)
apb=a+b
bma=b-a
sr=f(apb*0.5d0)*(bma*0.25d0)
s=sr*(2.d0*TWOPI)
err=abs(s)*deltat
h=2.d0*h0
m=1
1 continue
    sprev=s
    srprev=sr
    t=h*0.5d0
2 continue
        em=exp(t)
        ep=TWOPI*em
        em=TWOPI/em
3 continue
            eppem=ep+em
            xw=1.d0/(1.d0+exp(ep-em))
            xa=bma*xw
            wg=xa*(1.d0-xw)
            fa=f(a+xa)*wg
            fb=f(b-xa)*wg
            fapfb=fa+fb
            sr=sr+fapfb
            s=s+fapfb*eppem
            errt=(abs(fa)+abs(fb))*eppem
            if(m.eq.1) err=err+errt*deltat
            ep=ep*eph
            em=em*emh
            if(errt.gt.err.or.xw.gt.deltah) goto 3
        t=t+h
        if(t.lt.h0) goto 2
    if(m.eq.1) then
        errh=(err/deltat)*deltah*h0
        errd=1.d0+2.d0*errh
    else
        errd=h*(abs(s-2.d0*sprev)+4.d0*abs(sr-2.d0*srprev))
    endif
    h=h*0.5d0
    m=m*2
    if(errd.gt.errh.and.m.lt.MMAX) goto 1
!if(errd.gt.errh) write(*,*)"(dqde1) Required too many grids: >", MMAX
s=s*h
return;end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*8 function dlog1p(x0)
!
!    The double precision Fortran function to compute precisely log1p(x),
!    a special logarithm function defined as log1p(x) = ln(1+x),
!    by the (7,6) rational minimax approximation evaluated by Estrin's scheme
!
!    Reference: Fukushima (2017) Precise and fast computation of gravitational
!      field of general finite body and its application to gravitational study
!      of asteroid Eros. Astron J. in printing
!
real*8 x0,x1,x2,x4,a1,a2,a3,a4,a5,a6,a7,b1,b2,b3,b4,b5,b6
parameter (a1=0.99999999999999999405d0,a2=2.45235728562912886048d0)
parameter (a3=2.17053627298972253249d0,a4=0.83928994566440838378d0)
parameter (a5=0.13520496594993836479d0,a6=0.00682631751459270270d0)
parameter (a7=0.00002291289324181940d0)
parameter (b1=2.95235728562912599232d0,b2=3.31338158247117791600d0)
parameter (b3=1.76186164168333482938d0,b4=0.44976458082070468584d0)
parameter (b5=0.04896199808811261680d0,b6=0.00157389087429218809d0)
if(x0.lt.-0.5d0.or.x0.gt.1.d0) then
    dlog1p=log(1.d0+x0)
elseif(x0.lt.0.d0) then
    x1=-x0/(1.d0+x0)
    x2=x1*x1; x4=x2*x2
    dlog1p=-x1*(((a1+x1*a2)+x2*(a3+x1*a4))+x4*((a5+x1*a6)+x2*a7)) &
        /(((1.d0+x1*b1)+x2*(b2+x1*b3))+x4*((b4+x1*b5)+x2*b6))
else
    x1=x0
    x2=x1*x1; x4=x2*x2
    dlog1p=x1*(((a1+x1*a2)+x2*(a3+x1*a4))+x4*((a5+x1*a6)+x2*a7)) &
        /(((1.d0+x1*b1)+x2*(b2+x1*b3))+x4*((b4+x1*b5)+x2*b6))
endif
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!    Output of "xtess"
!      (Note) It took 3.568 s at a PC with an Intel Core i5-10400 running at 2.90 GHz
!      The ifort version is
!           Intel(R) Fortran Intel(R) 64 Compiler Classic for applications running on
!            Intel(R) 64, Version 2021.4.0 Build 20210910_000000
!            Copyright (C) 1985-2021 Intel Corporation.  All rights reserved.
!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!        # delta=  1.0000000E-16
!     # R0,HT,HB=  6.3800000E+03  1.0000000E+01 -4.0000000E+01
!    # PhiN,PhiS=  2.8000000E+01  2.7000000E+01
! # LamdaE,LamdaW  8.7000000E+01  8.6000000E+01
!   # phi,lambda=  2.7500000E+01  8.6500000E+01
!             # H                        V
!               #                     gPhi                  gLambda                       gH
!               #              GammaPhiPhi           GammaPhiLambda                GammaPhiH
!               #        GammaLambdaLambda             GammaLambdaH                  GammaHH
!  -9.5000000E+01    1.522385430859932E-04
!                   -6.913732182770679E-10    0.000000000000000E+00    1.564130608898578E-06
!                   -1.387341662716454E-08    0.000000000000000E+00   -1.613894697029786E-11
!                   -1.505917753693464E-08    0.000000000000000E+00    2.893259481144160E-08
!  -8.5000000E+01    1.694526871210555E-04
!                   -8.747066001775616E-10    0.000000000000000E+00    1.892198142307468E-06
!                   -1.760580950749764E-08    0.000000000000000E+00   -2.066058851304799E-11
!                   -1.943435020150582E-08    0.000000000000000E+00    3.704016020364891E-08
!  -7.5000000E+01    1.903905934236350E-04
!                   -1.106672542712507E-09    0.000000000000000E+00    2.312822513933105E-06
!                   -2.233996420953945E-08    0.000000000000000E+00   -2.578804971985919E-11
!                   -2.516840640266663E-08    0.000000000000000E+00    4.750836836462066E-08
!  -6.5000000E+01    2.161011857153642E-04
!                   -1.389893134484920E-09    0.000000000000000E+00    2.851074036457655E-06
!                   -2.812502336397519E-08    0.000000000000000E+00   -3.071408279579221E-11
!                   -3.244537518351365E-08    0.000000000000000E+00    6.057039583336358E-08
!  -5.5000000E+01    2.478880058505530E-04
!                   -1.715013458072009E-09    0.000000000000000E+00    3.531846611828729E-06
!                   -3.475500622664502E-08    0.000000000000000E+00   -3.383415931884386E-11
!                   -4.112692458673271E-08    0.000000000000000E+00    7.588192820201063E-08
!  -4.5000000E+01    2.872708844104648E-04
!                   -2.053259639166731E-09    0.000000000000000E+00    4.371789329760953E-06
!                   -4.161825034453409E-08    0.000000000000000E+00   -3.297612891861420E-11
!                   -5.045690145966183E-08    0.000000000000000E+00    9.207514074757049E-08
!  -3.5000000E+01    3.319910086311147E-04
!                   -2.355567528758799E-09    0.000000000000000E+00    3.825615688241572E-06
!                   -4.793266758434474E-08    0.000000000000000E+00   -2.649421427519882E-11
!                   -5.920230924283715E-08    0.000000000000000E+00   -2.015876831867747E-07
!  -2.5000000E+01    3.603747131612369E-04
!                   -2.564755213201883E-09    0.000000000000000E+00    1.869421744025771E-06
!                   -5.251553452557477E-08    0.000000000000000E+00   -1.457160314363856E-11
!                   -6.555716477278904E-08    0.000000000000000E+00   -1.906499670213037E-07
!  -1.5000000E+01    3.696350462514114E-04
!                   -2.636222132600265E-09    0.000000000000000E+00   -1.064260798473823E-08
!                   -5.421371523781516E-08    0.000000000000000E+00    5.471010114351434E-13
!                   -6.787327496614387E-08    0.000000000000000E+00   -1.866356603343685E-07
!  -5.0000000E+00    3.601669342163731E-04
!                   -2.554314977920890E-09    0.000000000000000E+00   -1.889139936098946E-06
!                   -5.272632315536577E-08    0.000000000000000E+00    1.551673604698940E-11
!                   -6.568213752785291E-08    0.000000000000000E+00   -1.903142199554053E-07
!   5.0000000E+00    3.316111352803727E-04
!                   -2.337440063229249E-09    0.000000000000000E+00   -3.839348173993404E-06
!                   -4.846251165299864E-08    0.000000000000000E+00    2.705997748246749E-11
!                   -5.959167367262047E-08    0.000000000000000E+00   -2.006684780520396E-07
!   1.5000000E+01    2.868101440205006E-04
!                   -2.031662182754119E-09    0.000000000000000E+00   -4.374218164388472E-06
!                   -4.215634363810153E-08    0.000000000000000E+00    3.311074245470626E-11
!                   -5.084513496897725E-08    0.000000000000000E+00    9.300147090783754E-08
!   2.5000000E+01    2.474382990881564E-04
!                   -1.693806956102326E-09    0.000000000000000E+00   -3.528159772641221E-06
!                   -3.499501983026314E-08    0.000000000000000E+00    3.364904182370082E-11
!                   -4.124207840873123E-08    0.000000000000000E+00    7.623710370309283E-08
!   3.5000000E+01    2.157004300813909E-04
!                   -1.371418617690112E-09    0.000000000000000E+00   -2.845439875551469E-06
!                   -2.820499777133556E-08    0.000000000000000E+00    3.038054237659985E-11
!                   -3.243694585604362E-08    0.000000000000000E+00    6.064194108788116E-08
!   4.5000000E+01    1.900473207915234E-04
!                   -1.091721125483427E-09    0.000000000000000E+00   -2.307151583258427E-06
!                   -2.234592357243641E-08    0.000000000000000E+00    2.543375054579544E-11
!                   -2.511765420452311E-08    0.000000000000000E+00    4.746358413013454E-08
!   5.5000000E+01    1.691630798625039E-04
!                   -8.631048686893352E-10    0.000000000000000E+00   -1.887193033025766E-06
!                   -1.758321987787706E-08    0.000000000000000E+00    2.035095600256552E-11
!                   -1.937716647911629E-08    0.000000000000000E+00    3.696038720953256E-08
!   6.5000000E+01    1.519948957924415E-04
!                   -6.825568352191813E-10    0.000000000000000E+00   -1.559945026069056E-06
!                   -1.384333888277125E-08    0.000000000000000E+00    1.589237553727608E-11
!                   -1.500835554828129E-08    0.000000000000000E+00    2.885169681223171E-08
!   7.5000000E+01    1.377280082166444E-04
!                   -5.424089048682221E-10    0.000000000000000E+00   -1.303706863264856E-06
!                   -1.095668253283118E-08    0.000000000000000E+00    1.227887763567634E-11
!                   -1.172281702557548E-08    0.000000000000000E+00    2.267949631251105E-08
!   8.5000000E+01    1.257414395776617E-04
!                   -4.342889686494518E-10    0.000000000000000E+00   -1.101402778726971E-06
!                   -8.741568381379833E-09    0.000000000000000E+00    9.468292438805019E-12
!                   -9.254182417357096E-09    0.000000000000000E+00    1.799575571025114E-08
!   9.5000000E+01    1.155637184360951E-04
!                   -3.508161513851574E-10    0.000000000000000E+00   -9.400780632304917E-07
!                   -7.039686218393687E-09    0.000000000000000E+00    7.324354890423470E-12
!                   -7.389355216278842E-09    0.000000000000000E+00    1.442904793831886E-08
!   1.0500000E+02    1.068357959386216E-04
!                   -2.860576710892528E-10    0.000000000000000E+00   -8.100601082309440E-07
!                   -5.725034047993713E-09    0.000000000000000E+00    5.702126053128496E-12
!                   -5.968287512329931E-09    0.000000000000000E+00    1.169332748275438E-08
!   1.1500000E+02    9.928233337092832E-05
!                   -2.354546021701575E-10    0.000000000000000E+00   -7.041574277348270E-07
!                   -4.701624500135331E-09    0.000000000000000E+00    4.474584025759874E-12
!                   -4.874110373984178E-09    0.000000000000000E+00    9.575735816747436E-09
!   1.2500000E+02    9.269027708860816E-05
!                   -1.955797189911766E-10    0.000000000000000E+00   -6.170099768474632E-07
!                   -3.897812949189702E-09    0.000000000000000E+00    3.542400537102165E-12
!                   -4.022352420927403E-09    0.000000000000000E+00    7.920162281693801E-09
!   1.3500000E+02    8.689312433613942E-05
!                   -1.638765583241871E-10    0.000000000000000E+00   -5.445976435581539E-07
!                   -3.260546215008756E-09    0.000000000000000E+00    2.829427591902128E-12
!                   -3.351998343546536E-09    0.000000000000000E+00    6.612546761117837E-09
!   1.4500000E+02    8.175942046629851E-05
!                   -1.384428279847095E-10    0.000000000000000E+00   -4.838801342575158E-07
!                   -2.750557418695443E-09    0.000000000000000E+00    2.280796792454220E-12
!                   -2.818773289387068E-09    0.000000000000000E+00    5.569327072645579E-09
!   1.5500000E+02    7.718433330381285E-05
!                   -1.178576263805883E-10    0.000000000000000E+00   -4.325366577204661E-07
!                   -2.338664157789807E-09    0.000000000000000E+00    1.854285025140093E-12
!                   -2.390291633013819E-09    0.000000000000000E+00    4.728959785590588E-09
!   1.6500000E+02    7.308344678779011E-05
!                   -1.010541140283743E-10    0.000000000000000E+00   -3.887784140609058E-07
!                   -2.003069219405086E-09    0.000000000000000E+00    1.519812238302657E-12
!                   -2.042663757693794E-09    0.000000000000000E+00    4.045729979582435E-09
!   1.7500000E+02    6.938815426986298E-05
!                   -8.722588597628442E-11    0.000000000000000E+00   -3.512132394062391E-07
!                   -1.727335616477760E-09    0.000000000000000E+00    1.255906451289698E-12
!                   -1.758079035653547E-09    0.000000000000000E+00    3.485411979109969E-09
!   1.8500000E+02    6.604220927845390E-05
!                   -7.575765865429726E-11    0.000000000000000E+00   -3.187473619604029E-07
!                   -1.498995215177525E-09    0.000000000000000E+00    1.045428043545681E-12
!                   -1.523136694338215E-09    0.000000000000000E+00    3.022127700543810E-09
!   1.9500000E+02    6.299911914505276E-05
!                   -6.617793643013534E-11    0.000000000000000E+00   -2.905135869657135E-07
!                   -1.308481303347506E-09    0.000000000000000E+00    8.765125655926792E-13
!                   -1.327638445985104E-09    0.000000000000000E+00    2.636124214433246E-09
!   2.0500000E+02    6.022015719417070E-05
!                   -5.812005495505718E-11    0.000000000000000E+00   -2.658183543989876E-07
!                   -1.148424994398436E-09    0.000000000000000E+00    7.396755563497527E-13
!                   -1.163772150947790E-09    0.000000000000000E+00    2.312197498129573E-09
!   2.1500000E+02    5.767283276742131E-05
!                   -5.129894108907559E-11    0.000000000000000E+00   -2.441023741318757E-07
!                   -1.013065908463235E-09    0.000000000000000E+00    6.283734005544198E-13
!                   -1.025472579591845E-09    0.000000000000000E+00    2.038536126255646E-09
!   2.2500000E+02    5.532970311618965E-05
!                   -4.549044064644129E-11    0.000000000000000E+00   -2.249110992991893E-07
!                   -8.978890411845543E-10    0.000000000000000E+00    5.364593306069736E-13
!                   -9.080018056729546E-10    0.000000000000000E+00    1.805888654870618E-09
!   2.3500000E+02    5.316744283951857E-05
!                   -4.051510235621125E-11    0.000000000000000E+00   -2.078723716149099E-07
!                   -7.993187908752558E-10    0.000000000000000E+00    4.610017534929314E-13
!                   -8.076273023942558E-10    0.000000000000000E+00    1.606946455241786E-09
!   2.4500000E+02    5.116610904202790E-05
!                   -3.623089786692503E-11    0.000000000000000E+00   -1.926793662914099E-07
!                   -7.145049240937218E-10    0.000000000000000E+00    3.979006828440654E-13
!                   -7.213785011799856E-10    0.000000000000000E+00    1.435880398535937E-09
!   2.5500000E+02    4.930855649651253E-05
!                   -3.252367186377769E-11    0.000000000000000E+00   -1.790774573945117E-07
!                   -6.411533743202616E-10    0.000000000000000E+00    3.452533832472083E-13
!                   -6.468769976923290E-10    0.000000000000000E+00    1.288030321855556E-09
!   2.6500000E+02    4.757996872078616E-05
!                   -2.929998531591678E-11    0.000000000000000E+00   -1.668540276783255E-07
!                   -5.774118135315439E-10    0.000000000000000E+00    3.006504582226094E-13
!                   -5.822096625358964E-10    0.000000000000000E+00    1.159621502090200E-09
!   2.7500000E+02    4.596747933454624E-05
!                   -2.648481734175485E-11    0.000000000000000E+00   -1.558305006477632E-07
!                   -5.217721829911791E-10    0.000000000000000E+00    2.631475967484596E-13
!                   -5.258162497034863E-10    0.000000000000000E+00    1.047588811765136E-09
!   2.8500000E+02    4.445986426369507E-05
!                   -2.401586769430745E-11    0.000000000000000E+00   -1.458560633796081E-07
!                   -4.729990065137357E-10    0.000000000000000E+00    2.313102070370440E-13
!                   -4.764254683839667E-10    0.000000000000000E+00    9.494264761434548E-10
!   2.9500000E+02    4.304728994459756E-05
!                   -2.184207958790653E-11    0.000000000000000E+00   -1.368026879008472E-07
!                   -4.300722232546555E-10    0.000000000000000E+00    2.039687899127268E-13
!                   -4.329933246963261E-10    0.000000000000000E+00    8.630634503472928E-10
!  The total time is   3.56755400000000      seconds.
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


! =====================================================
SUBROUTINE clawpack5_rpt2_euler4(ixy,imp,maxm,meqn,mwaves,maux, &
     mbc,mx,ql,qr,aux1,aux2,aux3,asdq,bmasdq,bpasdq)
! =====================================================
      implicit double precision (a-h,o-z)
!
!     # Riemann solver in the transverse direction for the Euler equations.
!     # Split asdq (= A^* \Delta q, where * = + or -)
!     # into down-going flux difference bmasdq (= B^- A^* \Delta q)
!     #    and up-going flux difference bpasdq (= B^+ A^* \Delta q)
!
!     # Uses Roe averages and other quantities which were
!     # computed in rpn2eu and stored in the common block comroe.
!
      dimension     ql(meqn, 1-mbc:maxm+mbc)
      dimension     qr(meqn, 1-mbc:maxm+mbc)
      dimension   asdq(meqn, 1-mbc:maxm+mbc)
      dimension bmasdq(meqn, 1-mbc:maxm+mbc)
      dimension bpasdq(meqn, 1-mbc:maxm+mbc)
!
      common /cparam/  gamma
      dimension waveb(4,3),sb(3)
      parameter (maxm2 = 602)  !# assumes at most 200x200 grid with mbc=2
!
      double precision u2v2(-6:maxm2+7), &
            u(-6:maxm2+7),v(-6:maxm2+7),enth(-6:maxm2+7),a(-6:maxm2+7), &
            g1a2(-6:maxm2+7),euv(-6:maxm2+7)

      if (mbc > 7 .OR. maxm2 < maxm) then
         write(6,*) 'need to increase maxm2 or 7 in rpn'
         stop
      endif
!
      gamma1 = gamma - 1.d0

      if (ixy.eq.1) then
          mu = 2
          mv = 3
        else
          mu = 3
          mv = 2
        endif
!
!     # compute the Roe-averaged variables needed in the Roe solver.
!     # These are stored in the common block comroe since they are
!     # later used in routine rpt2eu to do the transverse wave splitting.
!
      do 10 i = 2-mbc, mx+mbc
         rhsqrtl = dsqrt(qr(1,i-1))
         rhsqrtr = dsqrt(ql(1,i))
         pl = gamma1*(qr(4,i-1) - 0.5d0*(qr(2,i-1)**2 + &
             qr(3,i-1)**2)/qr(1,i-1))
         pr = gamma1*(ql(4,i) - 0.5d0*(ql(2,i)**2 + &
             ql(3,i)**2)/ql(1,i))
         rhsq2 = rhsqrtl + rhsqrtr
         u(i) = (qr(mu,i-1)/rhsqrtl + ql(mu,i)/rhsqrtr) / rhsq2
         v(i) = (qr(mv,i-1)/rhsqrtl + ql(mv,i)/rhsqrtr) / rhsq2
         enth(i) = (((qr(4,i-1)+pl)/rhsqrtl &
                  + (ql(4,i)+pr)/rhsqrtr)) / rhsq2
         u2v2(i) = u(i)**2 + v(i)**2
         a2 = gamma1*(enth(i) - .5d0*u2v2(i))
         a(i) = dsqrt(a2)
         g1a2(i) = gamma1 / a2
         euv(i) = enth(i) - u2v2(i)
   10    continue
!
         do 20 i = 2-mbc, mx+mbc
            a3 = g1a2(i) * (euv(i)*asdq(1,i) &
                  + u(i)*asdq(mu,i) + v(i)*asdq(mv,i) - asdq(4,i))
            a2 = asdq(mu,i) - u(i)*asdq(1,i)
            a4 = (asdq(mv,i) + (a(i)-v(i))*asdq(1,i) - a(i)*a3) &
                   / (2.d0*a(i))
            a1 = asdq(1,i) - a3 - a4
!
            waveb(1,1) = a1
            waveb(mu,1) = a1*u(i)
            waveb(mv,1) = a1*(v(i)-a(i))
            waveb(4,1) = a1*(enth(i) - v(i)*a(i))
            sb(1) = v(i) - a(i)
!
            waveb(1,2) = a3
            waveb(mu,2) = a3*u(i) + a2
            waveb(mv,2) = a3*v(i)
            waveb(4,2) = a3*0.5d0*u2v2(i) + a2*u(i)
            sb(2) = v(i)
!
            waveb(1,3) = a4
            waveb(mu,3) = a4*u(i)
            waveb(mv,3) = a4*(v(i)+a(i))
            waveb(4,3) = a4*(enth(i)+v(i)*a(i))
            sb(3) = v(i) + a(i)
!
!           # compute the flux differences bmasdq and bpasdq
!
            do 30 m=1,meqn
               bmasdq(m,i) = 0.d0
               bpasdq(m,i) = 0.d0
               do 30 mw=1,3
                  bmasdq(m,i) = bmasdq(m,i) &
                              + dmin1(sb(mw), 0.d0) * waveb(m,mw)
                  bpasdq(m,i) = bpasdq(m,i) &
                              + dmax1(sb(mw), 0.d0) * waveb(m,mw)
   30             continue
!
   20       continue
!
      return
      end


SUBROUTINE ANALYT( cP, cS, rho, Medium, N1 )

  !     Munk profile

  !     Returns
  !        cS, cP, rho at depths i*h i = 1, N
  !        Depths of interfaces

  IMPLICIT NONE
  INTEGER,           INTENT(IN)  :: Medium, N1
  REAL     (KIND=8), INTENT(OUT) :: rho( * )
  COMPLEX  (KIND=8), INTENT(OUT) :: cP( * ), cS( * )
  INTEGER                        :: i, N
  REAL     (KIND=8), PARAMETER   :: eps = 0.00737
  REAL     (KIND=8)              :: h, x, z

  N = N1 - 1

  SELECT CASE ( Medium )

  CASE ( 1 )   ! THE OCEAN
     h = 5000.0 / N
     DO i = 1, N1
        z = ( i - 1 ) * h
        x = 2.0 * ( z - 1300.0 ) / 1300.0
        cP(  i ) = 1500.0 * ( 1.0 + eps * ( x - 1.0 + EXP( -x ) ) )
        cS(  i ) = 0.0
        rho( i ) = 1.0
     END DO
     RETURN

  CASE ( 2 )   ! THE FLUID HALF-SPACE
     cP(  1 ) = 1551.91
     cS(  1 ) = 0.0
     rho( 1 ) = 1.0E20
     RETURN

  CASE( 9 )  ! AN ELASTIC LAYER
     h = 1000.0 / N
     z = 5000.0

     DO i = 1,N+1
        cP( i ) = 4700.0 + ( z - 5000.0 ) / 10.0
        cS( i ) = 2000.0 + ( z - 5000.0 ) / 10.0
        cP( i ) = 4700.0
        cS( i ) = 2000.0
        rho( i ) = 2.0
        z = z + h
     END DO
  END SELECT

END SUBROUTINE ANALYT


C     Subroutine to calculate the Kirchhoff stress given by the fibre reinforced
C     modified anisotropic (MA) hyperelastic constitutive law.
C
C     15-Aug-2018
C     David Nolan
C
      SUBROUTINE kstress_calc(DGRAD, C10, D1, xkap, xk1, xk2, XKIRCH,
     1 XJ, XAMAT, XI1, XI2, XI4, NPT, NANISO, iter)
C
      INCLUDE 'ABA_PARAM.INC'
C
      INTENT(IN) :: DGRAD, C10, D1, xkap, xk1, xk2, XAMAT, NANISO, iter
      INTENT(OUT):: XKIRCH, XJ, XI1, XI2, XI4
C
      DIMENSION DGRAD(3,3), BMAT(3,3), XKIRCH(3,3), XAMAT(3,2),
     1 B2MAT(3,3), XA(3), a_curnt(3), aoa(3,3), XANISOK(3,3),
     2 XANISOTOT(3,3), XI4(2)
C
      PARAMETER(ZERO=0.D0, ONE=1.D0, TWO=2.D0, THREE=3.D0)
C
C LOCAL ARRAYS
C ----------------------------------------------------------------
C DGRAD     - the deformation gradient
C BMAT      - left Cauchy-Green deformation tensor
C XKIRCH    - Kirchhoff stress
C XAMAT     - array containing fibre vectors
C B2MAT     - square of the B tensor
C XA        - fibre vector in the reference configuration
C a_curnt   - fibre vector in the current configuration
C aoa       - fibre structural tensor
C XANISOK   - anisotropic Kirchhoff stress for a given fibre family
C XANISOTOT - total anisotropic Kirchhoff stress
C XI4       - array storing the fibre invariant
C ----------------------------------------------------------------
C
C
C     Determinant of the deformation gradient
      XJ=DGRAD(1, 1)*DGRAD(2, 2)*DGRAD(3, 3)
     1   -DGRAD(1, 2)*DGRAD(2, 1)*DGRAD(3, 3)
     2   +DGRAD(1, 2)*DGRAD(2, 3)*DGRAD(3, 1)
     3   +DGRAD(1, 3)*DGRAD(3, 2)*DGRAD(2, 1)
     4   -DGRAD(1, 3)*DGRAD(3, 1)*DGRAD(2, 2)
     5   -DGRAD(2, 3)*DGRAD(3, 2)*DGRAD(1, 1)
C
C
C     Calculate left Cauchy-Green deformation tensor
      BMAT = MATMUL(DGRAD,TRANSPOSE(DGRAD))
C
C
C-----------------------------------------------------------------------
C     CALCULCATE THE INVARIANTS
C-----------------------------------------------------------------------
C
C     I1 invariant
      XI1 = BMAT(1,1)+BMAT(2,2)+BMAT(3,3)
C
C     Square of the B matrix
      B2MAT = MATMUL(BMAT,BMAT)
C
C     Trace of B squared
      TRB2 = B2MAT(1,1)+B2MAT(2,2)+B2MAT(3,3)
C
C     I2 invariant
      XI2 = 0.5*((XI1**2.0) - TRB2)
C
C     I3 invariant
      XI3=BMAT(1, 1)*BMAT(2, 2)*BMAT(3, 3)
     1   -BMAT(1, 2)*BMAT(2, 1)*BMAT(3, 3)
     2   +BMAT(1, 2)*BMAT(2, 3)*BMAT(3, 1)
     3   +BMAT(1, 3)*BMAT(3, 2)*BMAT(2, 1)
     4   -BMAT(1, 3)*BMAT(3, 1)*BMAT(2, 2)
     5   -BMAT(2, 3)*BMAT(3, 2)*BMAT(1, 1)
C
C
C--------------------------------------------------------------------
C     CALCULATE THE ISOTROPIC PORTION OF THE KIRCHHOFF STRESS
C--------------------------------------------------------------------
C
C     PART 1
      COEFF1 = TWO*C10/(XJ**(TWO/THREE))
C
C     KIRCHHOFF STRESS PART 2
C
      TRBMAT= COEFF1*(BMAT(1,1)+BMAT(2,2)+BMAT(3,3))/THREE
C
C     KIRCHHOFF STRESS PART 1
C
      XKIRCH = COEFF1 * BMAT
C
C     SUBTRACT THE PART 2
C
      DO I = 1,3
        XKIRCH(I,I) = XKIRCH(I,I) - TRBMAT
      END DO
C
C     FORM VOLUMETRIC PART, 3
C
      COEFF3 = 2*(XJ-ONE)*XJ/D1
C
C     ADD TO THE PREVIOUS PARTS
C
      DO I = 1,3
        XKIRCH(I,I) = XKIRCH(I,I) + COEFF3
      END DO
C
C
C
C--------------------------------------------------------------------
C     CALCULATE THE ANISOTROPIC PORTION OF THE KIRCH STRESS
C--------------------------------------------------------------------
C
C     Zero the matrix
      DO I=1,3
        DO J=1,3
          XANISOTOT(I,J) = ZERO
        END DO
      END DO
C
C--------------------------------------------------------------------
C     Loop over the number of fibre families
C--------------------------------------------------------------------
      DO IANISO = 1,NANISO
C
C         Fibre vector in reference configuration
          XA = XAMAT(1:3,IANISO);
C
C         Calculate fibre vector in current configuration: a = F*A
          a_curnt = MATMUL(DGRAD,XA)
C
C         Calculate structural tensor: a \otimes a
          DO i=1,3
              DO j=1,3
                aoa(i,j) = a_curnt(i) * a_curnt(j)
              ENDDO
          ENDDO
C
C         Calculate the fibre invariant
          XI4(IANISO) = aoa(1,1) + aoa(2,2) + aoa(3,3)
C
C         The fibres only contribute to stress when in tension
          IF (XI4(IANISO)>ONE) THEN
C
C             Calculate the various parts of the equation for kirch stress
              p1 = 2.0*xk1;
C
              p2 = XI4(IANISO) - 1.0
C
              p3 = xk2*(p2**TWO)
C
              p4 = exp(p3)
C
              XANISOK = p1*p2*p4*aoa
C
C             Sum the stress over the fibre families
              XANISOTOT = XANISOTOT + XANISOK
C
          END IF
C
      END DO
C
C     Add the isotropic and anisotropic parts
      XKIRCH = XKIRCH + XANISOTOT
C
      RETURN
      END SUBROUTINE kstress_calc

Lesson C - fibre reinforced anistropic models/Abaqus/kstress_calc.f


!@sum  RES_M53 Resolution info for 53 layer, 4x5 strat model
!@+    (top at .002 mb, GWDRAG)
!@auth Original Development Team
!@ver  1.0

      MODULE RESOLUTION
!@sum  RESOLUTION contains horiz/vert resolution variables
!@auth Original Development Team
!@ver  1.0
      IMPLICIT NONE
      SAVE
!@var IM,JM longitudinal and latitudinal number of grid boxes
!@var LM number of vertical levels
!@var LS1 Layers LS1->LM: constant pressure levels, L<LS1: sigma levels
      INTEGER, PARAMETER :: IM=72 ,JM=46, LM=53, LS1=27

!@var PSF,PMTOP global mean surface, model top pressure  (mb)
!@var PTOP pressure at interface level sigma/const press coord syst (mb)
      REAL*8, PARAMETER :: PSF=984.d0, PTOP = 154.d0, PMTOP=2.0576514d-3
!@var PSFMPT,PSTRAT pressure due to troposhere,stratosphere
      REAL*8, PARAMETER :: PSFMPT=PSF-PTOP, PSTRAT=PTOP-PMTOP

!@var PLbot pressure levels at bottom of layers (mb)
      REAL*8, PARAMETER, DIMENSION(LM+1) :: PLbot = (/
     t     PSF,   954d0,  924d0,  894d0,  864d0,  834d0,  804d0,  774d0,
     t     744d0, 714d0,  680d0,  636d0,  591d0,  545d0,  500d0,  457d0,
     t     417d0, 381d0,  348d0,  318d0,  290d0,  264d0,  240d0,  217d0,
     t     195d0, 174d0,                               ! Pbot L=1,26
     1     PTOP,                                       !      L=LS1
     s     135d0, 117d0,  100d0,   84d0,   69d0,   55d0,   42d0,   30d0,
     s      19d0,  10d0, 7.1043d0, 5.04711d0, 3.58563d0, 2.54734d0,
     s     1.80971d0, 1.28567d0, 0.913382d0, 0.561994d0, 0.316003d0,
     s     0.177995d0, 0.1d0, 0.0562045d0, 0.0315979d0, 0.0178033d0,
     s     0.01d0, 0.00518932d0, PMTOP /)              !      L=..,LM+1

C**** KEP depends on whether stratos. EP flux diagnostics are calculated
C**** If dummy EPFLUX is used set KEP=0, otherwise KEP=21
!@param KEP number of lat/height E-P flux diagnostics
      INTEGER, PARAMETER :: KEP=21

C**** Based on model top, determine how much of stratosphere is resolved
C****         PMTOP >= 10 mb,    ISTRAT = 0
C**** 1 mb <= PMTOP <  10 mb,    ISTRAT = 1
C****         PMTOP <   1 mb,    ISTRAT = 2
      INTEGER, PARAMETER :: ISTRAT = 2

      END MODULE RESOLUTION

C**** The vertical resolution also determines whether
C**** stratospheric wave drag will be applied or not.
C**** This resolution is for a stratospheric model and so must be used
C**** in conjunction with the strat. modules


!---Solve transient temperature equation
!
!---Input: n - element number
!          nl_iter - nonlinear iteration counter
!---Output:
!

subroutine solve_temperature_euler(n,nl_iter)

    USE flags_M
    USE material_info_M
    USE mesh_info_M
    USE time_info_M
    USE global_parameters_M
    USE solution_vectors_M
    USE element_matrices_M

    use Mod_SetupOutputFiles

implicit none

!---Dummy
    integer, intent(in) :: n
    integer, intent(in) :: nl_iter

!---Local
    integer  :: i, j, length
    real(dp) :: temperature_eval
    real(dp), dimension(3)   :: rhs_final_vec,elem_vec_w_left,&
                                A_inv_times_q_wl, elem_vec_q_temp,&
                                A_inv_times_q_wl_vec,A_inv_U_W_times_T_vec,&
                                U_W_times_T
    real(dp) :: volume, heat_capacity_eval, density_eval,&
                salt_mass, q_prime, length_core
    real(dp), dimension(3)   :: U_times_T_vec,Wr_times_T_vec,Wl_times_T_vec,A_inv_times_rhs_vec
    real(dp)  :: temperature_reduction_intial

!---Inversion routine parameters
    integer :: lda, info, lwork
    integer,  dimension(3)   :: ipiv
    real(dp), dimension(3)   :: work

!---Size of matrix 3x3
    length = 3

!---Initialize inversion routine
    ipiv   = 0
    work   = 0.0
    lda    = length
    lwork  = length

!---Temperature reduction over the heat exchanger
    if(t0 == 0.0) then
        temperature_reduction        = 100.0_dp
    end if

    if(MSRE_problem .eqv. .TRUE.) then

        temperature_reduction = 27.78_dp

    end if

    temperature_reduction_intial = 100.0_dp

!---Temperature SOLVE
    rhs_final_vec        = 0.0_dp
    elem_vec_q_temp      = 0.0_dp
    elem_vec_w_left      = 0.0_dp
    U_W_times_T          = 0.0_dp
    A_inv_times_q_wl_vec = 0.0_dp

!---Calc 1/rho*C_p * q'''
    elem_vec_q_temp = 0.0

    temperature_eval = 0.0
    !---Get temperature over element
    do j = 1, nodes_per_elem
        !---valuate density based on temperature
        temperature_eval = temperature_eval + vol_int(j)*temperature_soln_new(n,j)
    end do

!---Have density be flat over element
    call density_corr(temperature_eval, density_eval)

!---Loop over all nodes in element
    do j = 1, nodes_per_elem

        call heat_capacity_corr(temperature_eval, heat_capacity_eval)

        q_prime = total_power_initial*power_amplitude_prev*(&
                  spatial_power_frac_fcn(n,j)/spatial_area_fcn(n,j))

        elem_vec_q_temp(j) = elem_vec_q(j)*q_prime*(1.0_dp/(density_eval*heat_capacity_eval))
    end do

!---[U*T^k-1]
    U_times_T_vec = 0.0_dp
    U_times_T_vec = matmul( elem_matrix_U,temperature_soln_prev(n,:) )

!---[W_r*T^k-l]
    Wr_times_T_vec(:) = 0.0_dp
    do i = 1, nodes_per_elem
        Wr_times_T_vec(i) = interp_fcn_rhs(i)*velocity_soln_new(n,3)*temperature_soln_prev(n,3)
    end do

!---[W_l*T^k-1_e-1
    Wl_times_T_vec(:) = 0.0_dp
    !---First element
    if( n == 1 ) then
        do i = 1, nodes_per_elem
            Wl_times_T_vec(i) = interp_fcn_lhs(i)*velocity_soln_new(n,3)*&
                                temperature_soln_prev(num_elem,3)
        end do
    end if

!---All other elements
    if( n > 1 ) then
        do i = 1, nodes_per_elem
            Wl_times_T_vec(i) = interp_fcn_lhs(i)*velocity_soln_new(n,3)*&
                                temperature_soln_prev(n-1,3)
        end do
    end if

    rhs_final_vec = 0.0_dp
!---Add up all RHS vectors
    do i = 1, nodes_per_elem
        rhs_final_vec(i) =  elem_vec_q_temp(i) + U_times_T_vec(i) - Wr_times_T_vec(i) + &
                            Wl_times_T_vec(i)
    end do

    A_inv_times_rhs_vec = 0.0_dp
!---A^-1 *(q + w_l)
    A_inv_times_rhs_vec = matmul(inverse_A_matrix,rhs_final_vec)

!---Forward Euler
    if(td_method_type == 0) then

    end if

!---Backward Euler
    if(td_method_type == 1) then
        do i = 1, nodes_per_elem
            temperature_soln_new(n,i) = temperature_soln_starting(n,i) + &
                  delta_t*( A_inv_times_rhs_vec(i) )
        end do
    end if

    if( t0 > 0.0) then
        if(feedback_method == 7) then
            ! Heat exchanger overcooling scenario
            temperature_reduction = temperature_reduction_intial + &
                                    flow_reduction_percent*temperature_reduction_intial*&
                                    (1.0 - exp(time_constant*t0))
            !if( temperature_reduction > flow_reduction_percent*temperature_reduction_intial) then
            !    temperature_reduction = temperature_reduction_intial  + &
            !    flow_reduction_percent*temperature_reduction_intial*(1.0 - exp(time_constant*t0))
            !end if
        end if

    !---Simulate heatexchanger undercooling scenario
        if(feedback_method == 8) then
            temperature_reduction = temperature_reduction_intial - &
                                    flow_reduction_percent*temperature_reduction_intial*&
                                    (1.0 - exp(time_constant*t0))

            !if( temperature_reduction >  flow_reduction_percent*&
            !                            temperature_reduction_intial) then
            !    temperature_reduction = temperature_reduction_intial*exp(time_constant*t0)
            !
            !end if
        end if
    end if

!---Fix delta T across heat exchanger
    do j = 1, nodes_per_elem
        !---Start heat exchanger
        if ( Heat_Exchanger_Start <= n  .and.  n < Heat_Exchanger_End) then
            temperature_soln_new(n,j) = (temperature_reduction)/&
            (Heat_Exchanger_End - Heat_Exchanger_Start)* &
            (global_coord(Heat_Exchanger_End-1,3)  - global_coord(n,j) ) - temperature_reduction + &
            temperature_soln_new(Heat_Exchanger_Start-1,1)
        end if
    end do

!---Temperature in intermediary piping
    if( n > Fuel_Outlet_End .and. n < Heat_Exchanger_Start)  then
        do j = 1, nodes_per_elem
            temperature_soln_new(n,j) = temperature_soln_new(Fuel_Outlet_End,j)
        end do
    end if
    !!---Temperature remains constant after the heat exchanger.  I.e. no more lost heat
        if( n > Heat_Exchanger_End) then
        do j = 1, nodes_per_elem
            temperature_soln_new(n,j) = temperature_soln_new(Heat_Exchanger_End,j)
        end do
    end if

    Temperature_Reactivity_Feedback(n,:) = 0.0
    do j = 1, nodes_per_elem
        !---Calculate doppler feedback for current element
        Temperature_Reactivity_Feedback(n,j) = spatial_doppler_fcn(n,j)/total_temperature_change* &
                ( temperature_soln_prev(n,j) - temperature_soln_ss(n,j) )
    end do

!if(t0 > 7.0) then
!    DEBUG = .TRUE.
!end if

if( DEBUG .eqv. .TRUE.) then

    write(outfile_unit,fmt='(a,1I6,a,1I6)'),'Change in Temperature, A^-1*RHS - node --> ',&
        n
        do j=1,nodes_per_elem
              write(outfile_unit,fmt='(f16.3)'), A_inv_times_rhs_vec(j)
        end do
        write(outfile_unit,fmt='(a)'), ' '

       write(outfile_unit,fmt='(a,4I6)'), 'nl iter ',nl_iter
       write(outfile_unit,fmt='(a,12es14.5)'),' time', t0

       write(outfile_unit,fmt='(a,4I6)'),' rho, C_p |  element --> ',n
       write(outfile_unit,fmt='(12es14.5,12es14.5 )') &
                  density_eval, heat_capacity_eval
       write(outfile_unit,fmt='(a)'),'  '

       write(outfile_unit,fmt='(a,4I6)'),' 1/Cp*rho*vol * {q} vector  --> ',n
             write(outfile_unit,fmt='(12es14.5)') &
                  (elem_vec_q_temp(i),i=1,nodes_per_elem)

       write(outfile_unit,fmt='(a,4I6)'),' [U]*{T_e} vector  --> ',n
             write(outfile_unit,fmt='(12es14.5)') &
                  (U_times_T_vec(i),i=1,nodes_per_elem)

       write(outfile_unit,fmt='(a,4I6)'),' [W_r]*{T_e} vector  --> ',n
             write(outfile_unit,fmt='(12es14.5)') &
                  (Wr_times_T_vec(i),i=1,nodes_per_elem)

       write(outfile_unit,fmt='(a,4I6)'),' [W_l]*{T_e-1} vector  --> ',n
             write(outfile_unit,fmt='(12es14.5)') &
                  (Wl_times_T_vec(i),i=1,nodes_per_elem)

       write(outfile_unit,fmt='(a,4I6)'),'RHS vector  vector  --> ',n
             write(outfile_unit,fmt='(12es14.5)') &
                 (rhs_final_vec(i),i=1,nodes_per_elem)

       if( n > 1) then
            write(outfile_unit,fmt='(a,4I6)'),' T^k-1_e-1 vector  --> ',n
            write(outfile_unit,fmt='(12es14.5)') &
                  (temperature_soln_prev(n-1,i),i=1,nodes_per_elem)
       else
            write(outfile_unit,fmt='(a,4I6)'),' T^k-1_e-1 vector  --> ',n
            write(outfile_unit,fmt='(12es14.5)') &
                  (temperature_soln_prev(n,i),i=1,nodes_per_elem)
       end if

       write(outfile_unit,fmt='(a)'), ' '
       write(outfile_unit,fmt='(a,4I6)'),' T^k-1_e vector  --> ',n
       write(outfile_unit,fmt='(12es14.5)') &
                  (temperature_soln_prev(n,i),i=1,nodes_per_elem)

       write(outfile_unit,fmt='(a)'), ' '
       write(outfile_unit,fmt='(a,4I6)'),' T^k_e vector  --> ',n
       write(outfile_unit,fmt='(12es14.5)') &
                  (temperature_soln_new(n,i),i=1,nodes_per_elem)

       write(outfile_unit,fmt='(a)'), ' '
       write(outfile_unit,fmt='(a,4I6)'),' T_e starting vector  --> ',n
       write(outfile_unit,fmt='(12es14.5)') &
                  (temperature_soln_starting(n,i),i=1,nodes_per_elem)
       write(outfile_unit,fmt='(a)'), ' '

       write(outfile_unit,fmt='(a)'),'*****************************************'
    end if
DEBUG = .FALSE.
end subroutine solve_temperature_euler


*###[ ffx2ir:
	subroutine ffx2ir(cs1,cs2,xpip,dpipjp,ier)
***#[*comment:***********************************************************
*									*
*	Get the terms to correct for the second IR pole which is	*
*	treated incorrectly if the first one is regulated with a small	*
*	mass lam and they are adjacent.  It is assumed that xpi(3)=	*
*	xpi(4)=xpi(7)=0, xpi(1)=xpi(8), xpi(2)=xpi(6).  The correction	*
*	terms are							*
*									*
*	cs1 = -C0(m2^2,0,lam^2;m2^2,0,p10^2)/(s-m1^2)			*
*	cs2 = +C0(m2^2,lam^2,0;m2^2,0,p10^2)/(s-m1^2)			*
*									*
*	when xpi(4) = lambda2 is taken in the D0,			*
*									*
*	cs1 = -C0(lam^2,0,m1^2;0,m1^2,p9^2)/(t-m2^2)			*
*	cs2 = +C0(0,lam^2,m1^2;0,m1^2,p9^2)/(t-m2^2)			*
*									*
*	when xpi(3) = lambda2.  Not yet tested.				*
*									*
*				10-oct-1991 Geert Jan van Oldenborgh	*
*									*
*	Input:	xpip(13)	(real)	usual 4point pi.pi		*
*		dpipjp(10,13)	(real)	xpip(i) - xpip(j)		*
*	output:	xpip(13)	(real)	usual 4point pi.pi modified	*
*		dpipjp(10,13)	(real)	xpip(i) - xpip(j)  modified	*
*		cs1,cs2		(complex)				*
*		ier		(integer)				*
*	calls:	ffxc0							*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ier
	DOUBLE COMPLEX cs1,cs2
	DOUBLE PRECISION xpip(13),dpipjp(10,13)
*
*	local vars
*
	integer itest,ier0,ier1,i,j,iinx(6,4)
	DOUBLE COMPLEX cc0
	DOUBLE PRECISION xpi3(6),dpipj3(6,6)
	save itest,iinx
*
*	common
*
	include 'ff.h'
*
*	data
*
*	3=put mass on xpi(3)
*	4=put mass on xpi(4)
	data itest /4/
	data iinx /2,3,4,6,7,10,
     +		   1,3,4,9,7,8,
     +		   1,2,4,5,10,8,
     +		   1,2,3,5,6,9/
*
*  #] declarations:
*  #[ work 3:
	if ( itest .eq. 3 ) then
*
*	modify xpip,dpipjp
*
	xpip(3) = lambda2
	do 10 i=1,10
	    dpipjp(i,3) = dpipjp(i,3) - lambda2
   10	continue
	do 20 i=1,13
	    dpipjp(3,i) = dpipjp(3,i) + lambda2
   20	continue
*
*	call first C0
*
	do 120 i=1,6
	    xpi3(i) = xpip(iinx(i,2))
	    do 110 j=1,6
		dpipj3(j,i) = dpipjp(iinx(j,2),iinx(i,2))
  110	    continue
  120	continue
	idsub = idsub + 1
	ier1 = 0
	call ffxc0a(cc0,xpi3,dpipj3,ier1)
	cs1 = -cc0/DBLE(dpipjp(9,2))
*
*	call second C0
*
	xpi3(2) = 0
	xpi3(3) = lambda2
	do 130 i=1,6
	    dpipj3(i,2) = dpipj3(i,2) + lambda2
	    dpipj3(i,3) = dpipj3(i,3) - lambda2
  130	continue
	do 140 i=1,6
	    dpipj3(2,i) = dpipj3(2,i) - lambda2
	    dpipj3(3,i) = dpipj3(3,i) + lambda2
  140	continue
	idsub = idsub + 1
	ier0 = 0
	call ffxc0a(cc0,xpi3,dpipj3,ier0)
	cs2 = +cc0/DBLE(dpipjp(9,2))
	ier1 = max(ier1,ier0)
	ier = ier + ier1
*  #] work 3:
*  #[ work 4:
	elseif ( itest .eq. 4 ) then
*
*	modify xpip,dpipjp
*
	xpip(4) = lambda2
	do 210 i=1,10
	    dpipjp(i,4) = dpipjp(i,4) - lambda2
  210	continue
	do 220 i=1,13
	    dpipjp(4,i) = dpipjp(4,i) + lambda2
  220	continue
*
*	call first C0
*
	do 320 i=1,6
	    xpi3(i) = xpip(iinx(i,1))
	    do 310 j=1,6
		dpipj3(j,i) = dpipjp(iinx(j,1),iinx(i,1))
  310	    continue
  320	continue
	idsub = idsub + 1
	ier1 = 0
	call ffxc0a(cc0,xpi3,dpipj3,ier1)
	cs1 = -cc0/DBLE(dpipjp(10,1))
*
*	call second C0
*
	xpi3(3) = 0
	xpi3(2) = lambda2
	do 330 i=1,6
	    dpipj3(i,3) = dpipj3(i,3) + lambda2
	    dpipj3(i,2) = dpipj3(i,2) - lambda2
  330	continue
	do 340 i=1,6
	    dpipj3(3,i) = dpipj3(3,i) - lambda2
	    dpipj3(2,i) = dpipj3(2,i) + lambda2
  340	continue
	idsub = idsub + 1
	ier0 = 0
	call ffxc0a(cc0,xpi3,dpipj3,ier0)
	cs2 = +cc0/DBLE(dpipjp(10,1))
	ier1 = max(ier1,ier0)
	ier = ier + ier1
*  #] work 4:
*  #[ error:
	else
	print *,'ffx2ir: error: itest should be either 3 or 4!',itest
	endif
*  #] error:
*###] ffx2ir:
	end


module FVW_BiotSavart

   use NWTC_Library, only: ReKi, IntKi
   use OMP_LIB ! wrap with #ifdef _OPENMP if this causes an issue

   implicit none

   real(ReKi),parameter :: PRECISION_UI  = epsilon(1.0_ReKi)/100 !< NOTE assuming problem of size 1
   real(ReKi),parameter :: MIN_EXP_VALUE=-10.0_ReKi
   real(ReKi),parameter :: MINDENOM=0.0_ReKi
!    real(ReKi),parameter :: MINDENOM=1e-15_ReKi
   real(ReKi),parameter :: MINNORM=1e-4

   integer(IntKi), parameter :: idRegNone       = 0
   integer(IntKi), parameter :: idRegRankine    = 1
   integer(IntKi), parameter :: idRegLambOseen  = 2
   integer(IntKi), parameter :: idRegVatistas   = 3
   integer(IntKi), parameter :: idRegOffset     = 4
   integer(IntKi), parameter :: idRegExp        = 1
   integer(IntKi), parameter :: idRegCompact    = 2
   integer(IntKi), parameter, dimension(5) :: idRegVALID      = (/idRegNone,idRegRankine,idRegLambOseen,idRegVatistas,idRegOffset/)
   integer(IntKi), parameter, dimension(3) :: idRegPartVALID  = (/idRegNone,idRegExp,idRegCompact/)

   real(ReKi),parameter    :: fourpi_inv =  0.25_ReKi / ACOS(-1.0_Reki )

contains

!> Induced velocity from one segment at one control points
subroutine ui_seg_11(DeltaPa, DeltaPb, SegGamma, RegFunction, RegParam1, Uind)
   ! Input/output arguments
   real(ReKi), dimension(3), intent(in) :: DeltaPa    !< 3 x 1   Pcp-P1  [m]
   real(ReKi), dimension(3), intent(in) :: DeltaPb    !< 3 x 1   Pcp-P2  [m]
   real(ReKi), intent(in)               :: SegGamma   !< Circulation  [m^2/s]
   integer, intent(in)                  :: RegFunction!< Regularization model
   real(ReKi), intent(in)               :: RegParam1  !< Regularization parameter (core radius) [m]
   real(ReKi), dimension(3),intent(out) :: Uind       !< Induced velocity (no side effects) [m/s]
   ! Variables declaration
   real(ReKi),dimension(3) :: crossprod      !<
   real(ReKi)              :: denominator    !<
   real(ReKi)              :: r_bar2         !< (r/rc)^2
   real(ReKi)              :: Kv             !<
   real(ReKi)              :: norm_a, norm_b !<
   real(ReKi)              :: norm2_r0       !< Squared length of the segment
   real(ReKi)              :: norm2_orth     !< Squared distance orthogonal to the segment
   real(ReKi)              :: xa, ya, za, xb, yb, zb !< Coordinates of X-Xa and X-Xb
   real(ReKi)              :: exp_value      !<
   !
   Uind(1:3)=0.0_ReKi
   xa=DeltaPa(1); ya=DeltaPa(2); za=DeltaPa(3)
   xb=DeltaPb(1); yb=DeltaPb(2); zb=DeltaPb(3)
   norm_a      = sqrt(xa*xa + ya*ya + za*za)
   norm_b      = sqrt(xb*xb + yb*yb + zb*zb)
   denominator  = norm_a*norm_b*(norm_a*norm_b + xa*xb+ya*yb+za*zb) ! |r1|*|r2|*(|r1|*|r2| + r1.r2)
   if (denominator>PRECISION_UI) then
      crossprod(1) = ya*zb-za*yb; crossprod(2) = za*xb-xa*zb; crossprod(3) = xa*yb-ya*xb
      norm2_orth   = crossprod(1)**2 + crossprod(2)**2 + crossprod(3)**2
      if (norm2_orth>PRECISION_UI) then ! On the singularity, Uind(1:3)=0.0_ReKi
         norm2_r0     = (xa-xb)*(xa-xb) + (ya-yb)*(ya-yb) +(za-zb)*(za-zb)
         if (norm2_r0>PRECISION_UI) then ! segment of zero length
            ! --- Far field TODO
            ! --- Regularization (close field)
            norm2_orth   = norm2_orth/norm2_r0 ! d = (r1xr2)/r0
            select case (RegFunction) !
            case ( idRegNone )         ! No vortex core model
               Kv=1.0_ReKi
            case ( idRegRankine )      ! Rankine
               r_bar2    = norm2_orth/ RegParam1**2
               if (r_bar2<1) then
                  Kv=r_bar2
               else
                  Kv=1.0_ReKi
               end if
            case ( idRegLambOseen )    ! Lamb-Oseen
               r_bar2    = norm2_orth/ RegParam1**2
               exp_value = -1.25643_ReKi*r_bar2
               if(exp_value<MIN_EXP_VALUE) then ! Remove me when Far distance implemented
                  Kv = 1.0_ReKi
               else
                  Kv = 1.0_ReKi-exp(exp_value)
               endif
            case ( idRegVatistas )    ! Vatistas n=2
               r_bar2 = norm2_orth/ RegParam1**2
               Kv     = r_bar2/sqrt(1.0_ReKi+r_bar2**2)
            case ( idRegOffset )      ! Cut-off radius
               Kv        = 1.0_ReKi
               denominator=denominator+RegParam1**2*norm2_r0
            case default
               Kv=1.0_ReKi !< Should be an error
            end select
            Kv=SegGamma*fourpi_inv*Kv*(norm_a+norm_b)/denominator
            Uind(1:3) = Kv*crossprod(1:3)
         endif
      endif
   endif
end subroutine ui_seg_11

!> Induced velocity from a list of segments defined by Connectivity (SegConnct) and Points (SegPoints)
!! NOTE: this function has side effects and expects Uind_out to be initialized!
!! The function can compute the velocity on part of the segments and part of the control points.
!! This feature is useful if some parallelization is used, while common storage vectors are used.
subroutine ui_seg(iCPStart, iCPEnd, CPs, &
      iSegStart, iSegEnd, nSegTot, nSegPTot, SegPoints, SegConnct, SegGamma,  &
      RegFunction, RegParam, Uind_out)
   real(ReKi), dimension(:,:),     intent(in)    :: CPs         !< Control points (3 x nCPs++)
   integer(IntKi),                 intent(in)    :: iCPStart    !< Index where we start in Control points array
   integer(IntKi),                 intent(in)    :: iCPEnd      !< Index where we end in Control points array
   real(ReKi), dimension(:,:),     intent(in)    :: SegPoints   !< Segment points (3 x nSegPTot)
   integer(IntKi), dimension(:,:), intent(in)    :: SegConnct   !< Connectivity, indices of segments points iSeg1, iSeg2, iDepth, iSpan
   real(ReKi), dimension(:),       intent(in)    :: SegGamma    !< Segment circulation (nSegTot)
   integer(IntKi),                 intent(in)    :: iSegStart   !< Index in SegConnct, and SegGamma where we start
   integer(IntKi),                 intent(in)    :: iSegEnd     !< Index in SegConnct, and SegGamma where we end
   integer(IntKi),                 intent(in)    :: nSegTot     !< Total number of segments
   integer(IntKi),                 intent(in)    :: nSegPTot    !< Total number of segment points
   integer(IntKi),                 intent(in)    :: RegFunction !< Regularization model
   real(ReKi), dimension(:),       intent(in)    :: RegParam    !< Regularization parameter (nSegTot)
   real(ReKi), dimension(:,:)    , intent(inout) :: Uind_out    !< Induced velocity vector - Side effects!!! (3 x nCPs++)
   ! Variables
   integer(IntKi) :: icp, is
   real(ReKi), dimension(3) :: Uind           !<
   real(ReKi), dimension(3) :: P1, P2         !< Extremities of a given segment
   ! Variables declaration
   real(ReKi),dimension(3) :: crossprod       !<
   real(ReKi)              :: denominator     !<
   real(ReKi)              :: r_bar2          !< (r/rc)^2
   real(ReKi)              :: Kv              !<
   real(ReKi)              :: norm_a, norm_b  !<
   real(ReKi)              :: norm2_orth      !<
   real(ReKi)              :: norm2_r0        !< Squared length of the segment d = (r1xr2)/r0
   real(ReKi)              :: xa, ya, za, xb, yb, zb !< Coordinates of X-Xa and X-Xb
   real(ReKi)              :: exp_value       !<

   ! Branching based on regularization model
   ! NOTE: copy paste of code is done for optimization!
   !       The only thing changing is the part labelled "regularization"
   select case (RegFunction)
   case ( idRegNone ) ! No vortex core
      !$OMP PARALLEL default(shared)
      !$OMP do private(icp,is,Uind,P1,P2,crossprod,denominator,Kv,norm_a,norm_b,norm2_r0,norm2_orth,xa,ya,za,xb,yb,zb) schedule(runtime)
      do icp=iCPStart,iCPEnd ! loop on CPs
         do is=iSegStart,iSegEnd ! loop on selected segments
            Uind = 0.0_ReKi
            P1   = SegPoints(1:3, SegConnct(1,is)) ! Segment extremity points
            P2   = SegPoints(1:3, SegConnct(2,is))
            xa=CPs(1,icp)-P1(1); ya=CPs(2,icp)-P1(2); za=CPs(3,icp)-P1(3);
            xb=CPs(1,icp)-P2(1); yb=CPs(2,icp)-P2(2); zb=CPs(3,icp)-P2(3);
            norm_a      = sqrt(xa*xa + ya*ya + za*za)
            norm_b      = sqrt(xb*xb + yb*yb + zb*zb)
            denominator = norm_a*norm_b*(norm_a*norm_b + xa*xb+ya*yb+za*zb)
            ! --- Far field TODO
            if (denominator>PRECISION_UI) then
               crossprod(1) = ya*zb-za*yb; crossprod(2) = za*xb-xa*zb; crossprod(3) = xa*yb-ya*xb
               norm2_orth   = crossprod(1)**2 + crossprod(2)**2 + crossprod(3)**2
               if (norm2_orth>PRECISION_UI) then ! On the singularity, Uind(1:3)=0.0_ReKi
                  norm2_r0     = (xa-xb)*(xa-xb) + (ya-yb)*(ya-yb) +(za-zb)*(za-zb)
                  if (norm2_r0>PRECISION_UI) then
                     ! --- Far field TODO
                     ! --- NO Regularization (close field)
                     Kv        = SegGamma(is)*fourpi_inv*(norm_a+norm_b)/(denominator + MINDENOM)
                     Uind(1:3) = Kv*crossprod(1:3)
                  end if
               end if
            end if
            Uind_out(1:3,icp) = Uind_out(1:3,icp)+Uind(1:3)
         end do ! Loop on segments
      enddo ! Loop on control points
      !$OMP END DO
      !$OMP END PARALLEL

   case ( idRegRankine )      ! Rankine
      !$OMP PARALLEL default(shared)
      !$OMP do private(icp,is,Uind,P1,P2,crossprod,denominator,r_bar2,Kv,norm_a,norm_b,norm2_r0,norm2_orth,xa,ya,za,xb,yb,zb) schedule(runtime)
      do icp=iCPStart,iCPEnd ! loop on CPs
         do is=iSegStart,iSegEnd ! loop on selected segments
            Uind = 0.0_ReKi
            P1   = SegPoints(1:3, SegConnct(1,is)) ! Segment extremity points
            P2   = SegPoints(1:3, SegConnct(2,is))
            xa=CPs(1,icp)-P1(1); ya=CPs(2,icp)-P1(2); za=CPs(3,icp)-P1(3);
            xb=CPs(1,icp)-P2(1); yb=CPs(2,icp)-P2(2); zb=CPs(3,icp)-P2(3);
            norm_a      = sqrt(xa*xa + ya*ya + za*za)
            norm_b      = sqrt(xb*xb + yb*yb + zb*zb)
            denominator = norm_a*norm_b*(norm_a*norm_b + xa*xb+ya*yb+za*zb)
            if (denominator>PRECISION_UI) then
               crossprod(1) = ya*zb-za*yb; crossprod(2) = za*xb-xa*zb; crossprod(3) = xa*yb-ya*xb
               norm2_orth   = crossprod(1)**2 + crossprod(2)**2 + crossprod(3)**2
               if (norm2_orth>PRECISION_UI) then ! On the singularity, Uind(1:3)=0.0_ReKi
                  norm2_r0     = (xa-xb)*(xa-xb) + (ya-yb)*(ya-yb) +(za-zb)*(za-zb)
                  if (norm2_r0>PRECISION_UI) then
                     ! --- Far field TODO
                     ! --- Regularization (close field) --- Rankine
                     norm2_orth = norm2_orth/norm2_r0 ! d = (r1xr2)/r0
                     r_bar2     = norm2_orth/ RegParam(is)**2
                     if (r_bar2<1) then
                        Kv=r_bar2
                     else
                        Kv=1.0_ReKi
                     end if
                     Kv        = SegGamma(is)*fourpi_inv*Kv*(norm_a+norm_b)/(denominator + MINDENOM)
                     Uind(1:3) = Kv*crossprod(1:3)
                  end if
               end if ! denominator size or distances too small
            end if !
            Uind_out(1:3,icp) = Uind_out(1:3,icp)+Uind(1:3)
         end do ! Loop on segments
      enddo ! Loop on control points
      !$OMP END DO
      !$OMP END PARALLEL

   case ( idRegLambOseen )      ! LambOseen
      !$OMP PARALLEL default(shared)
      !$OMP do private(icp,is,Uind,P1,P2,crossprod,denominator,r_bar2,Kv,norm_a,norm_b,norm2_r0,norm2_orth,xa,ya,za,xb,yb,zb,exp_value) schedule(runtime)
      do icp=iCPStart,iCPEnd ! loop on CPs
         do is=iSegStart,iSegEnd ! loop on selected segments
            Uind = 0.0_ReKi
            P1   = SegPoints(1:3, SegConnct(1,is)) ! Segment extremity points
            P2   = SegPoints(1:3, SegConnct(2,is))
            xa=CPs(1,icp)-P1(1); ya=CPs(2,icp)-P1(2); za=CPs(3,icp)-P1(3);
            xb=CPs(1,icp)-P2(1); yb=CPs(2,icp)-P2(2); zb=CPs(3,icp)-P2(3);
            norm_a      = sqrt(xa*xa + ya*ya + za*za)
            norm_b      = sqrt(xb*xb + yb*yb + zb*zb)
            denominator = norm_a*norm_b*(norm_a*norm_b + xa*xb+ya*yb+za*zb)
            if (denominator>PRECISION_UI) then
               crossprod(1) = ya*zb-za*yb; crossprod(2) = za*xb-xa*zb; crossprod(3) = xa*yb-ya*xb
               norm2_orth   = crossprod(1)**2 + crossprod(2)**2 + crossprod(3)**2
               if (norm2_orth>PRECISION_UI) then ! On the singularity, Uind(1:3)=0.0_ReKi
                  norm2_r0     = (xa-xb)*(xa-xb) + (ya-yb)*(ya-yb) +(za-zb)*(za-zb)
                  if (norm2_r0>PRECISION_UI) then
                     ! --- Far field TODO
                     ! --- Regularization (close field) --- Lamb Oseen
                     norm2_orth = norm2_orth/norm2_r0 ! d = (r1xr2)/r0
                     r_bar2     = norm2_orth/ RegParam(is)**2
                     exp_value  = -1.25643_ReKi*r_bar2
                     if(exp_value<MIN_EXP_VALUE) then ! Remove me when Far distance implemented
                        Kv = 1.0_ReKi
                     else
                        Kv = 1.0_ReKi-exp(exp_value)
                     endif
                     Kv        = SegGamma(is)*fourpi_inv*Kv*(norm_a+norm_b)/(denominator + MINDENOM)
                     Uind(1:3) = Kv*crossprod(1:3)
                  endif
               end if ! denominator size or distances too small
            end if !
            Uind_out(1:3,icp) = Uind_out(1:3,icp)+Uind(1:3)
         end do ! Loop on segments
      enddo ! Loop on control points
      !$OMP END DO
      !$OMP END PARALLEL

   case ( idRegVatistas )      ! Vatistas n=2
      !$OMP PARALLEL default(shared)
      !$OMP do private(icp,is,Uind,P1,P2,crossprod,denominator,r_bar2,Kv,norm_a,norm_b,norm2_r0,norm2_orth,xa,ya,za,xb,yb,zb) schedule(runtime)
      do icp=iCPStart,iCPEnd ! loop on CPs
         do is=iSegStart,iSegEnd ! loop on selected segments
            Uind = 0.0_ReKi
            P1   = SegPoints(1:3, SegConnct(1,is)) ! Segment extremity points
            P2   = SegPoints(1:3, SegConnct(2,is))
            xa=CPs(1,icp)-P1(1); ya=CPs(2,icp)-P1(2); za=CPs(3,icp)-P1(3);
            xb=CPs(1,icp)-P2(1); yb=CPs(2,icp)-P2(2); zb=CPs(3,icp)-P2(3);
            norm_a      = sqrt(xa*xa + ya*ya + za*za)
            norm_b      = sqrt(xb*xb + yb*yb + zb*zb)
            denominator = norm_a*norm_b*(norm_a*norm_b + xa*xb+ya*yb+za*zb)
            if (denominator>PRECISION_UI) then
               crossprod(1) = ya*zb-za*yb; crossprod(2) = za*xb-xa*zb; crossprod(3) = xa*yb-ya*xb
               norm2_orth   = crossprod(1)**2 + crossprod(2)**2 + crossprod(3)**2
               if (norm2_orth>PRECISION_UI) then ! On the singularity, Uind(1:3)=0.0_ReKi
                  norm2_r0     = (xa-xb)*(xa-xb) + (ya-yb)*(ya-yb) +(za-zb)*(za-zb)
                  if (norm2_r0>PRECISION_UI) then
                     ! --- Far field TODO
                     ! --- Regularization (close field) --- Vatistas
                     norm2_orth = norm2_orth/norm2_r0 ! d = (r1xr2)/r0
                     r_bar2     = norm2_orth/RegParam(is)**2
                     Kv         = r_bar2/sqrt(1+r_bar2**2)
                     Kv         = SegGamma(is)*fourpi_inv*Kv*(norm_a+norm_b)/(denominator + MINDENOM)
                     Uind(1:3)  = Kv*crossprod(1:3)
                  end if
               end if ! denominator size or distances too small
            end if !
            Uind_out(1:3,icp) = Uind_out(1:3,icp)+Uind(1:3)
         end do ! Loop on segments
      enddo ! Loop on control points
      !$OMP END DO
      !$OMP END PARALLEL

   case ( idRegOffset )      ! Denominator offset
      !$OMP PARALLEL default(shared)
      !$OMP do private(icp,is,Uind,P1,P2,crossprod,denominator,r_bar2,Kv,norm_a,norm_b,norm2_r0,norm2_orth,xa,ya,za,xb,yb,zb) schedule(runtime)
      do icp=iCPStart,iCPEnd ! loop on CPs
         do is=iSegStart,iSegEnd ! loop on selected segments
            Uind      = 0.0_ReKi
            P1        = SegPoints(1:3, SegConnct(1,is)) ! Segment extremity points
            P2        = SegPoints(1:3, SegConnct(2,is))
            xa=CPs(1,icp)-P1(1); ya=CPs(2,icp)-P1(2); za=CPs(3,icp)-P1(3);
            xb=CPs(1,icp)-P2(1); yb=CPs(2,icp)-P2(2); zb=CPs(3,icp)-P2(3);
            norm_a      = sqrt(xa*xa + ya*ya + za*za)
            norm_b      = sqrt(xb*xb + yb*yb + zb*zb)
            denominator = norm_a*norm_b*(norm_a*norm_b + xa*xb+ya*yb+za*zb)
            if (denominator>PRECISION_UI) then
               crossprod(1) = ya*zb-za*yb; crossprod(2) = za*xb-xa*zb; crossprod(3) = xa*yb-ya*xb
               norm2_orth   = crossprod(1)**2 + crossprod(2)**2 + crossprod(3)**2
               if (norm2_orth>PRECISION_UI) then ! On the singularity, Uind(1:3)=0.0_ReKi
                  norm2_r0     = (xa-xb)*(xa-xb) + (ya-yb)*(ya-yb) +(za-zb)*(za-zb)
                  if (norm2_r0>PRECISION_UI) then
                     ! --- Far field TODO
                     ! --- Regularization (close field) -- Offset
                     denominator = denominator+RegParam(is)**2*norm2_r0
                     Kv          = SegGamma(is)*fourpi_inv*(norm_a+norm_b)/(denominator + MINDENOM)
                     Uind(1:3)   = Kv*crossprod(1:3)
                  end if
               end if ! denominator size or distances too small
            end if !
            Uind_out(1:3,icp) = Uind_out(1:3,icp)+Uind(1:3)
         end do ! Loop on segments
      enddo ! Loop on control points
      !$OMP END DO
      !$OMP END PARALLEL
   case default
      print*,'[ERROR] Unknown RegFunction for segment',RegFunction
      STOP
   end select
end subroutine ui_seg

!> Induced velocity from `nPart` particles at `nCPs` control points. The velocity gradient is not computed
subroutine ui_part_nograd(CPs, Part, Alpha, RegFunction, RegParam, UIout, nCPs, nPart)
   integer(IntKi),               intent(in)    :: nCPs
   integer(IntKi),               intent(in)    :: nPart
   real(ReKi), dimension(:,:),   intent(in)    :: CPs         !< Control points (3 x nCPs)
   real(ReKi), dimension(:,:),   intent(inout) :: UIout       !< Induced velocity, with side effects! (3 x nCPs)
   real(ReKi), dimension(:,:),   intent(in)    :: Part        !< Particle positions (3 x nPart)
   real(ReKi), dimension(:,:),   intent(in)    :: Alpha       !< Particle intensity [m^3/s] (3 x nPart) omega dV= alpha
   integer(IntKi),               intent(in)    :: RegFunction !< Regularization function
   real(ReKi), dimension(:),     intent(in)    :: RegParam    !< Regularization parameter (nPart)
   real(ReKi), dimension(3) :: UItmp   !<
   real(ReKi), dimension(3) :: DP      !<
   integer :: icp,ip
   ! TODO: inlining of regularization
   !$OMP PARALLEL DEFAULT(SHARED)
   !$OMP DO PRIVATE(icp,ip, DP, UItmp) schedule(runtime)
   do icp=1,nCPs ! loop on CPs
      do ip=1,nPart ! loop on particles
         UItmp(1:3) = 0.0_ReKi
         DP(1:3)    = CPs(1:3,icp)-Part(1:3,ip)
         call ui_part_nograd_11(DP, Alpha(1:3,ip), RegFunction , RegParam(ip), UItmp)
         UIout(1:3,icp)=UIout(1:3,icp)+UItmp(1:3)
      enddo! loop on particles
   enddo ! loop CPs
   !$OMP END DO
   !$OMP END PARALLEL
end subroutine ui_part_nograd

!> Induced velocity from 1 particle at 1 control point. The velocity gradient is not computed
subroutine ui_part_nograd_11(DeltaP, Alpha, RegFunction, RegParam, Ui)
   real(ReKi), dimension(3), intent(out) :: Ui          !< no side effects
   real(ReKi), dimension(3), intent(in)  :: DeltaP      !< CP-PP "control point - particle point"
   real(ReKi), dimension(3), intent(in)  :: Alpha       !< Particle intensity [m^2/s] alpha=om.dV
   integer(IntKi),           intent(in)  :: RegFunction !<
   real(ReKi),               intent(in)  :: RegParam    !<
   real(ReKi),dimension(3) :: C          !< Cross product of Alpha and r
   real(ReKi)              :: E          !< Exponential poart for the mollifider
   real(ReKi)              :: r3_inv     !<
   real(ReKi)              :: rDeltaP    !< norm , distance between point and particle
   real(ReKi)              :: ScalarPart !< the part containing the inverse of the distance, but not 4pi, Mollifier
   rDeltaP=sqrt(DeltaP(1)**2+ DeltaP(2)**2+ DeltaP(3)**2)! norm
   if (rDeltaP<MINNORM) then !--- Exactly on the Singularity
      Ui(1:3)  = 0.0_ReKi
      return
   else !--- Normal Procedure
      C(1) = Alpha(2) * DeltaP(3) - Alpha(3) * DeltaP(2)
      C(2) = Alpha(3) * DeltaP(1) - Alpha(1) * DeltaP(3)
      C(3) = Alpha(1) * DeltaP(2) - Alpha(2) * DeltaP(1)
      select case (RegFunction) !
      case (idRegNone) ! No mollification
         r3_inv     = 1._ReKi/(rDeltaP**3)
         ScalarPart = r3_inv*fourpi_inv
      case (idRegExp) ! Exponential mollifier
         r3_inv     = 1._ReKi/(rDeltaP**3)
         E          = exp(-rDeltaP**3/RegParam**3)
         ScalarPart = (1._ReKi-E)*r3_inv*fourpi_inv
      case (idRegCompact) ! Compact support
         r3_inv     = 1._ReKi/sqrt(RegParam**6+rDeltaP**6)
         ScalarPart = r3_inv*fourpi_inv
      case default
         print*,'[ERROR] Wrong regularization function for particles',RegFunction
         STOP
      end select
      Ui(1:3)=C*ScalarPart
   end if ! not on singularity
end subroutine ui_part_nograd_11

!> Velocity induced by one vortex quad on nCPs Control Points
subroutine ui_quad_n1(CPs, nCPs, P1, P2, P3, P4, Gamm, RegFunction, RegParam, Uind)
   integer,                    intent(in)    :: nCPs        !<
   real(ReKi), dimension(:,:), intent(in)    :: CPs         !< 3 x "nCPs"++
   real(ReKi), dimension(3),   intent(in)    :: P1,P2,P3,P4 !< Coordinates of vortex quadrilateral
   real(ReKi),                 intent(in)    :: Gamm
   integer(IntKi) ,            intent(in)    :: RegFunction !< Regularization model (e.g. LambOseen)
   real(ReKi),                 intent(in)    :: RegParam    !< Regularization parameter [m]
   real(ReKi), dimension(:,:), intent(inout) :: Uind        !< side effects!!! 3 x "nCPs++"
   real(ReKi), dimension(3) :: CP      !<
   real(ReKi), dimension(3) :: Uindtmp !<
   real(ReKi), dimension(3) :: DP1     !<
   real(ReKi), dimension(3) :: DP2     !<
   integer                :: icp
   !
   !OMP PARALLEL DEFAULT(SHARED)
   !OMP DO PRIVATE(icp,CP,Uindtmp,DP1,DP2) schedule(runtime)
   do icp=1,nCPs
      CP(1:3)=CPs(1:3,icp)
      ! 1-2 segment
      DP1=CP-P1; DP2=CP-P2;
      call ui_seg_11 ( DP1, DP2, Gamm, RegFunction, RegParam, Uindtmp)
      Uind(1:3,icp) = Uind(1:3,icp)+Uindtmp(1:3)
      ! 3-4 segment
      DP1=CP-P3; DP2=CP-P4;
      call ui_seg_11 ( DP1, DP2, Gamm, RegFunction, RegParam, Uindtmp)
      Uind(1:3,icp) = Uind(1:3,icp)+Uindtmp(1:3)
      ! 2-3 segment
      DP1=CP-P2; DP2=CP-P3;
      call ui_seg_11 ( DP1, DP2, Gamm, RegFunction, RegParam, Uindtmp)
      Uind(1:3,icp) = Uind(1:3,icp)+Uindtmp(1:3)
      ! 4-1 segment
      DP1=CP-P4; DP2=CP-P1;
      call ui_seg_11 ( DP1, DP2, Gamm, RegFunction, RegParam, Uindtmp)
      Uind(1:3,icp) = Uind(1:3,icp)+Uindtmp(1:3)
   end do  ! loop on CPs
   !OMP END DO
   !OMP END PARALLEL
end subroutine  ui_quad_n1

end module FVW_BiotSavart