program main
implicit none
character(len=20)::file1="data1.dat"
character(len=20)::file2="data2.dat"
real*8 c1,c2,w,n
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib
real*8 q1,q2,q3,q4,q5,p1,p2,p3,p4,p5
real*8 e,pe
real*8 h,endt,ht,tout1,tout2,tout3
real*8::t1=0d0,init=0d0,overt=0d0,t2=0d0,t3=0d0
real*8 inih,inil,temph,templ,r,fh,fl,psr,inis,temps,fs
real*8 inid,tempd,fli,el,num,tempdv,reorbit,inir,r0
integer i,j,k,point
integer::count=0d0
open(10,file=file1)
open(20,file=file2)
num=0d0
fli=0d0
reorbit=0d0
el=0d0
pe=dacos(-1d0)
e=0d0
r0=70d0
inir=r0
sx=inir
call initiala(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,e,inih,inil,ht,endt,j,k,inid)
pause
tout1=0d0
tout2=0d0
call cpu_time(init)
do 3 j=1d0,1d0,1d0
do 1 i=1d0,41d0,1d0
2  tout1=tout1+ht
   !tout2=tout2+ht
  !call rks(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,ht)
  !call iss(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,ht)
  !call isf(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,ht)
  !call ems(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,ht)
  call ecf(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,ht)
  !call ecf(q1,q2,q3,q4,q5,p1,p2,p3,p4,p5,n,c1,c2,w,ht)
if(tout1.lt.endt)goto 2
call hamiltonian(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,temph)
call angularmomentum(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,templ)
r=dsqrt(sx**2d0+sy**2d0+sz**2d0)
fh=dlog10(dabs(temph-inih)+1d-16)
fl=dlog10(dabs(templ-inil)+1d-16)
!write(10,*)inir,e,fli
write(20,*)e,fh,fl
count=count+1d0
write(*,*)count
!inir=inir+1d0
!sx=inir
sx=r0
e=e+0.02d0
call inivar(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,e)
tout1=0d0
tout2=0d0
t1=0d0
t2=0d0
fli=0d0
reorbit=0d0
call hamiltonian(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,inih)
call angularmomentum(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,inil)
1 continue
inir=r0
!inir=inir+1d0
e=e+0.02d0
!e=0d0
sx=inir
call inivar(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,e)
tout1=0d0
tout2=0d0
t1=0d0
t2=0d0
fli=0d0
reorbit=0d0
call hamiltonian(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,inih)
call angularmomentum(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,inil)
3 continue
call cpu_time(overt)
write(*,*)dabs(overt-init)
pause
close(10)
close(20)
stop
end

subroutine initiala(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,e,hami,mome,h,endt,j,k,inid)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,e,hami,mome,h,endt,inid
integer j,k
j=1d0
k=1d0
h=0.1d0
endt=1d5
c1=1d0
c2=1d0
w=1d0
n=1d0/(w+1d0/w+2d0)
inid=1d-8
call inivar(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,e)
call hamiltonian(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,hami)
call angularmomentum(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,mome)
write(*,*)hami
write(*,*)mome
!pause
return
end subroutine

subroutine inivar(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,e)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,e
real*8 pe
pe=dacos(-1d0)
sy=0d0
sz=0d0
cta=0d0
ctb=0d0
px=0d0
py=dsqrt((1d0-e)/sx)
!py=6.64731237968498d0/40d0
!py=12.4117721412935d0/150d0
!py=9.59624571814721d0/88d0
pz=0d0
xia=0d0
xib=0d0
return
end subroutine

subroutine hamiltonian(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,hami)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,hami
hami=((px**2d0+py**2d0+pz**2d0)/2d0-1d0/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))+((1d0/8d0)*(3d0*n-1d0)*((px**2d0+py**2d0+pz**2d0)**2d0)-(1d0/2d0)*(1d0/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*((3d0+n)*(px**2d0+py**2d0+pz**2d0)+n*(((sx/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*px+(sy/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*py+(sz/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*pz)**2d0))+(1d0/2d0)*(1d0/(sx**2d0+sy**2d0+sz**2d0)))+((1d0/16d0)*(1d0-5d0*n+5d0*n*n)*((px**2d0+py**2d0+pz**2d0)**3d0)+(1d0/8d0)*(1d0/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*&
((5d0-20d0*n-3d0*n*n)*((px**2d0+py**2d0+pz**2d0)**2d0)-2d0*n*n*(((sx/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*px+(sy/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*py+(sz/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*pz)**2d0)*(px**2d0+py**2d0+pz**2d0)-3d0*n*n*(((sx/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*px+(sy/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*py+(sz/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*pz)**4d0))+(1d0/2d0)*(1d0/(sx**2d0+sy**2d0+sz**2d0))*((5d0+8d0*n)*(px**2d0+py**2d0+pz**2d0)+3d0*n*(((sx/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*px+(sy/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*py+(sz/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*pz)**2d0))-(1d0/4d0)*(1d0/((sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))*(1d0+3d0*n))+(n/((sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))*((sy*pz-sz*py)*(((2d0+(3d0/2d0)*(1d0/w)))*((((((c1*w)**2d0-xia**2d0)**(1d0/2d0))*dcos(cta))))+((2d0+(3d0/2d0)*w))*((((((c2/w)**2d0-xib**2d0)**&
(1d0/2d0))*dcos(ctb)))))+(sz*px-sx*pz)*(((2d0+(3d0/2d0)*(1d0/w)))*((((((c1*w)**2d0-xia**2d0)**(1d0/2d0))*dsin(cta))))+((2d0+(3d0/2d0)*w))*((((((c2/w)**2d0-xib**2d0)**(1d0/2d0))*dsin(ctb)))))+(sx*py-sy*px)*(((2d0+(3d0/2d0)*(1d0/w)))*((xia))+((2d0+(3d0/2d0)*w))*((xib))))+(n/2d0)*(1d0/((sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))*(3d0*(((((sx)*(1d0/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))))*((((1d0+1d0/w))*((((((c1*w)**2d0-xia**2d0)**(1d0/2d0))*dcos(cta))))+((1d0+w))*((((((c2/w)**2d0-xib**2d0)**(1d0/2d0))*dcos(ctb))))))+(((sy)*(1d0/((sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))))*((((1d0+1d0/w))*((((((c1*w)**2d0-xia**2d0)**(1d0/2d0))*dsin(cta))))+((1d0+w))*((((((c2/w)**2d0-xib**2d0)**(1d0/2d0))*dsin(ctb))))))+(((sz)*(1d0/((sx**2d0+sy**2d0+sz**2d0)**&
(1d0/2d0)))))*((((1d0+1d0/w))*((xia))+((1d0+w))*((xib))))))**2d0-((((((1d0+1d0/w))*((((((c1*w)**2d0-xia**2d0)**(1d0/2d0))*dcos(cta))))+((1d0+w))*((((((c2/w)**2d0-xib**2d0)**(1d0/2d0))*dcos(ctb))))))**2d0+((((1d0+1d0/w))*((((((c1*w)**2d0-xia**2d0)**(1d0/2d0))*dsin(cta))))+((1d0+w))*((((((c2/w)**2d0-xib**2d0)**(1d0/2d0))*dsin(ctb))))))**2d0+((((1d0+1d0/w))*((xia))+((1d0+w))*((xib))))**2d0)))
return
end subroutine

subroutine angularmomentum(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,lt)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,lt
real*8 orbitl,totall
!orbitl=((sy*pz-sz*py)**2d0+(sz*px-sx*pz)**2d0+(sx*py-sy*px)**2d0)**(1d0/2d0)
totall=dsqrt((((sy*pz-sz*py))+((((((c1*w)**2d0-xia**2d0)**(1d0/2d0))*dcos(cta))))+((((((c2/w)**2d0-xib**2d0)**(1d0/2d0))*dcos(ctb)))))**2d0+(((sz*px-sx*pz))+((((((c1*w)**2d0-xia**2d0)**(1d0/2d0))*dsin(cta))))+((((((c2/w)**2d0-xib**2d0)**(1d0/2d0))*dsin(ctb)))))**2d0+(((sx*py-sy*px))+((xia))+((xib)))**2d0)
!lt=orbitl
lt=totall
return
end subroutine

subroutine xdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxt)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxt
dxt=px-(4d0*n**2d0*px*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0+4d0*px*(3d0*n**2d0+20d0*n-5d0)*(px**2d0+py**2d0+pz**2d0)+(12d0*n**2d0*sx*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**3d0)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(4d0*n**2d0*sx*(px**2d0+py**2d0+pz**2d0)*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/&
(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))/(8d0*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))+(2d0*px*(8d0*n+5d0)+(6d0*n*sx*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0))-(2d0*px*(n+3d0)+(2d0*n*sx*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/&
(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))+6d0*px*((5d0*n**2d0)/16d0-(5d0*n)/16d0+1d0/16d0)*(px**2d0+py**2d0+pz**2d0)**2d0+(n*(sz*(dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))-sy*(xib*((3d0*w)/2d0+2d0)+xia*(3d0/(2d0*w)+2d0))))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+4d0*px*((3d0*n)/8d0-1d0/8d0)*(px**2d0+py**2d0+pz**2d0)
return
end subroutine

subroutine ydot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dyt)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dyt
dyt=py-(4d0*n**2d0*py*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0+4d0*py*(3d0*n**2d0+20d0*n-5d0)*(px**2d0+py**2d0+pz**2d0)+(12d0*n**2d0*sy*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**3d0)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(4d0*n**2d0*sy*(px**2d0+py**2d0+pz**2d0)*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/&
(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))/(8d0*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))+(2d0*py*(8d0*n+5d0)+(6d0*n*sy*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0))-(2d0*py*(n+3d0)+(2d0*n*sy*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))-(n*(sz*(dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*&
((3d0*w)/2d0+2d0)+dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))-sx*(xib*((3d0*w)/2d0+2d0)+xia*(3d0/(2d0*w)+2d0))))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+6d0*py*((5d0*n**2d0)/16d0-(5d0*n)/16d0+1d0/16d0)*(px**2d0+py**2d0+pz**2d0)**2d0+4d0*py*((3d0*n)/8d0-1d0/8d0)*(px**2d0+py**2d0+pz**2d0)
return
end subroutine

subroutine zdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dzt)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dzt
dzt=pz-(4d0*n**2d0*pz*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0+4d0*pz*(3d0*n**2d0+20d0*n-5d0)*(px**2d0+py**2d0+pz**2d0)+(12d0*n**2d0*sz*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**3d0)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(4d0*n**2d0*sz*(px**2d0+py**2d0+pz**2d0)*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/&
(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))/(8d0*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))+(2d0*pz*(8d0*n+5d0)+(6d0*n*sz*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0))-(2d0*pz*(n+3d0)+(2d0*n*sz*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))+6d0*pz*((5d0*n**2d0)/16d0-(5d0*n)/16d0+1d0/16d0)*&
(px**2d0+py**2d0+pz**2d0)**2d0+4d0*pz*((3d0*n)/8d0-1d0/8d0)*(px**2d0+py**2d0+pz**2d0)+(n*(sy*(dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))-sx*(dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)
return
end subroutine

subroutine pxdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpxt)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpxt
dpxt=sx/(sx**2d0+sy**2d0+sz**2d0)**2d0-sx/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(12d0*n**2d0*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**3d0*((px*sx**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-px/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sx*sy)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(pz*sx*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))+4d0*n**2d0*(px**2d0+py**2d0+pz**2d0)*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((px*sx**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-px/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sx*sy)/&
(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(pz*sx*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(8d0*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))-(3d0*sx*(3d0*n+1d0))/(4d0*(sx**2d0+sy**2d0+sz**2d0)**(5d0/2d0))+(n*(pz*(dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))-py*(xib*((3d0*w)/2d0+2d0)+xia*(3d0/(2d0*w)+2d0))))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(sx*((n+3d0)*(px**2d0+py**2d0+pz**2d0)+n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**&
(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))+(sx*((8d0*n+5d0)*(px**2d0+py**2d0+pz**2d0)+3d0*n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0))/(sx**2d0+sy**2d0+sz**2d0)**2d0-(sx*(3d0*n**2d0*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**4d0+(3d0*n**2d0+20d0*n-5d0)*(px**2d0+py**2d0+pz**2d0)**2d0+2d0*n**2d0*(px**2d0+py**2d0+pz**2d0)*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/&
(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0))/(8d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))-(3d0*n*sx*((dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))**2d0-3d0*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**&
(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0+(xia*(1d0/w+1d0)+xib*(w+1d0))**2d0+(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))**2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(5d0/2d0))+(3d0*n*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**&
(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((sx**2d0*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w&
+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(sx*sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(3d0*n*sx*((xib*((3d0*w)/2d0+2d0)+xia*(3d0/(2d0*w)+2d0))*(px*sy-py*sx)+(dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))*&
(py*sz-pz*sy)-(dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))*(px*sz-pz*sx)))/(sx**2d0+sy**2d0+sz**2d0)**(5d0/2d0)+(3d0*n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((px*sx**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-px/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sx*sy)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(pz*sx*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/&
(sx**2d0+sy**2d0+sz**2d0)-(n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((px*sx**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-px/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sx*sy)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(pz*sx*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)
return
end subroutine

subroutine pydot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpyt)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpyt
dpyt=sy/(sx**2d0+sy**2d0+sz**2d0)**2d0-sy/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(12d0*n**2d0*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**3d0*((py*sy**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-py/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(px*sx*sy)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(pz*sy*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))+4d0*n**2d0*(px**2d0+py**2d0+pz**2d0)*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((py*sy**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-py/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(px*sx*sy)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(pz*sy*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(8d0*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))-(n*(pz*(dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*&
((3d0*w)/2d0+2d0)+dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))-px*(xib*((3d0*w)/2d0+2d0)+xia*(3d0/(2d0*w)+2d0))))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(3d0*sy*(3d0*n+1d0))/(4d0*(sx**2d0+sy**2d0+sz**2d0)**(5d0/2d0))-(sy*((n+3d0)*(px**2d0+py**2d0+pz**2d0)+n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))+(sy*((8d0*n+5d0)*(px**2d0+py**2d0+pz**2d0)+3d0*n*((px*sx)/&
(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0))/(sx**2d0+sy**2d0+sz**2d0)**2d0-(sy*(3d0*n**2d0*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**4d0+(3d0*n**2d0+20d0*n-5d0)*(px**2d0+py**2d0+pz**2d0)**2d0+2d0*n**2d0*(px**2d0+py**2d0+pz**2d0)*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0))/(8d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))-(3d0*n*sy*((dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))**2d0-3d0*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*&
(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0+(xia*(1d0/w+1d0)+xib*(w+1d0))**2d0+(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))**2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(5d0/2d0))-(3d0*n*sy*((xib*((3d0*w)/2d0+2d0)+xia*(3d0/(2d0*w)+2d0))*(px*sy-py*sx)+(dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))*(py*sz-pz*sy)-(dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dsin(cta)*&
(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))*(px*sz-pz*sx)))/(sx**2d0+sy**2d0+sz**2d0)**(5d0/2d0)+(3d0*n*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((sy**2d0*(dsin(cta)*(c1**2d0*w**2d0-&
xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*sy*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(sy*sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(3d0*n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((py*sy**2d0)/&
(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-py/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(px*sx*sy)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(pz*sy*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)-(n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((py*sy**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-py/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(px*sx*sy)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(pz*sy*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)
return
end subroutine

subroutine pzdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpzt)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpzt
dpzt=sz/(sx**2d0+sy**2d0+sz**2d0)**2d0-sz/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(12d0*n**2d0*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**3d0*((pz*sz**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-pz/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(px*sx*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(py*sy*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))+4d0*n**2d0*(px**2d0+py**2d0+pz**2d0)*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((pz*sz**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-pz/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(px*sx*sz)/&
(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(py*sy*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(8d0*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))-(3d0*sz*(3d0*n+1d0))/(4d0*(sx**2d0+sy**2d0+sz**2d0)**(5d0/2d0))-(sz*((n+3d0)*(px**2d0+py**2d0+pz**2d0)+n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))+(sz*((8d0*n+5d0)*(px**2d0+py**2d0+pz**2d0)+3d0*n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/&
(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0))/(sx**2d0+sy**2d0+sz**2d0)**2d0+(n*(py*(dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))-px*(dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(sz*(3d0*n**2d0*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**&
(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**4d0+(3d0*n**2d0+20d0*n-5d0)*(px**2d0+py**2d0+pz**2d0)**2d0+2d0*n**2d0*(px**2d0+py**2d0+pz**2d0)*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0))/(8d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))-(3d0*n*sz*((dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))**2d0-3d0*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**&
(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))**2d0+(xia*(1d0/w+1d0)+xib*(w+1d0))**2d0+(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))**2d0))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(5d0/2d0))-(3d0*n*sz*((xib*((3d0*w)/2d0+2d0)+xia*(3d0/(2d0*w)+2d0))*(px*sy-py*sx)+(dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))*(py*sz-pz*sy)-(dsin(ctb)*&
(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)+dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0))*(px*sz-pz*sx)))/(sx**2d0+sy**2d0+sz**2d0)**(5d0/2d0)+(3d0*n*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((sz**2d0*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(xia*(1d0/w+1d0)+xib*(w+1d0))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*sz*(dcos(cta)*(c1**2d0*w**2d0&
-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(sy*sz*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(3d0*n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((pz*sz**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-pz/(sx**2d0+sy**2d0+sz**2d0)**&
(1d0/2d0)+(px*sx*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(py*sy*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)-(n*((px*sx)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(py*sy)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(pz*sz)/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((pz*sz**2d0)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-pz/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(px*sx*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)+(py*sy*sz)/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)
return
end subroutine

subroutine ctadot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dcta)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dcta
dcta=-(n*((3d0/(2d0*w)+2d0)*(px*sy-py*sx)-(xia*dcos(cta)*(3d0/(2d0*w)+2d0)*(py*sz-pz*sy))/(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)+(xia*dsin(cta)*(3d0/(2d0*w)+2d0)*(px*sz-pz*sx))/(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(n*(2d0*(xia*(1d0/w+1d0)+xib*(w+1d0))*(1d0/w+1d0)+6d0*((sx*xia*dcos(cta)*(1d0/w+1d0))/((c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))-(sz*(1d0/w+1d0))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*xia*dsin(cta)*(1d0/w+1d0))/((c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*&
(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))-(2d0*xia*dcos(cta)*(1d0/w+1d0)*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**&
(1d0/2d0)*(w+1d0)))/(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)-(2d0*xia*dsin(cta)*(1d0/w+1d0)*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))
return
end subroutine

subroutine ctbdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dctb)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dctb
dctb=-(n*(((3d0*w)/2d0+2d0)*(px*sy-py*sx)-(xib*dcos(ctb)*((3d0*w)/2d0+2d0)*(py*sz-pz*sy))/(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)+(xib*dsin(ctb)*((3d0*w)/2d0+2d0)*(px*sz-pz*sx))/(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)-(n*(2d0*(xia*(1d0/w+1d0)+xib*(w+1d0))*(w+1d0)+6d0*((sx*xib*dcos(ctb)*(w+1d0))/((c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))-(sz*(w+1d0))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*xib*dsin(ctb)*(w+1d0))/((c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*&
(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)))*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))-(2d0*xib*dsin(ctb)*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w&
+1d0))*(w+1d0))/(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)-(2d0*xib*dcos(ctb)*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))*(w+1d0))/(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))
return
end subroutine

subroutine xiadot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxia)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxia
dxia=(n*(6d0*((sx*dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)-(sy*dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**&
(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))-2d0*dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))+2d0*dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*&
(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))-(n*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0)*(px*sz-pz*sx)+dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(3d0/(2d0*w)+2d0)*(py*sz-pz*sy)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)
return
end subroutine

subroutine xibdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxib)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxib
dxib=-(n*(6d0*((sy*dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)-(sx*dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))*((sz*(xia*(1d0/w+1d0)+xib*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sx*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*&
(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0)+(sy*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0)))/(sx**2d0+sy**2d0+sz**2d0)**(1d0/2d0))+2d0*dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(dcos(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))*(w+1d0)-2d0*dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(dsin(cta)*(c1**2d0*w**2d0-xia**2d0)**(1d0/2d0)*(1d0/w+1d0)+dsin(ctb)*&
(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*(w+1d0))*(w+1d0)))/(2d0*(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0))-(n*(dcos(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)*(px*sz-pz*sx)+dsin(ctb)*(c2**2d0/w**2d0-xib**2d0)**(1d0/2d0)*((3d0*w)/2d0+2d0)*(py*sz-pz*sy)))/(sx**2d0+sy**2d0+sz**2d0)**(3d0/2d0)
return
end subroutine

subroutine step(t,h)
implicit none
real*8 t,h
t=t+h
return
end subroutine

subroutine rks(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,h)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,h
real*8 sx0,sy0,sz0,cta0,ctb0,px0,py0,pz0,xia0,xib0
real*8::a=1d0/2d0
real*8 k1sx,k1sy,k1sz,k1cta,k1ctb,k1px,k1py,k1pz,k1xia,k1xib
real*8 k2sx,k2sy,k2sz,k2cta,k2ctb,k2px,k2py,k2pz,k2xia,k2xib
real*8 dx,dy,dz,dcta,dctb,dpx,dpy,dpz,dxia,dxib
sx0=sx
sy0=sy
sz0=sz
cta0=cta
ctb0=ctb
px0=px
py0=py
pz0=pz
xia0=xia
xib0=xib
call xdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dx)
call ydot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dy)
call zdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dz)
call ctadot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dcta)
call ctbdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dctb)
call pxdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpx)
call pydot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpy)
call pzdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpz)
call xiadot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxia)
call xibdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxib)
k1sx=h*dx
k1sy=h*dy
k1sz=h*dz
k1cta=h*dcta
k1ctb=h*dctb
k1px=h*dpx
k1py=h*dpy
k1pz=h*dpz
k1xia=h*dxia
k1xib=h*dxib
sx=sx0+k1sx
sy=sy0+k1sy
sz=sz0+k1sz
cta=cta0+k1cta
ctb=ctb0+k1ctb
px=px0+k1px
py=py0+k1py
pz=pz0+k1pz
xia=xia0+k1xia
xib=xib0+k1xib
call xdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dx)
call ydot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dy)
call zdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dz)
call ctadot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dcta)
call ctbdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dctb)
call pxdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpx)
call pydot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpy)
call pzdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpz)
call xiadot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxia)
call xibdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxib)
k2sx=h*dx
k2sy=h*dy
k2sz=h*dz
k2cta=h*dcta
k2ctb=h*dctb
k2px=h*dpx
k2py=h*dpy
k2pz=h*dpz
k2xia=h*dxia
k2xib=h*dxib
sx=sx0+a*(k1sx+k2sx)
sy=sy0+a*(k1sy+k2sy)
sz=sz0+a*(k1sz+k2sz)
cta=cta0+a*(k1cta+k2cta)
ctb=ctb0+a*(k1ctb+k2ctb)
px=px0+a*(k1px+k2px)
py=py0+a*(k1py+k2py)
pz=pz0+a*(k1pz+k2pz)
xia=xia0+a*(k1xia+k2xia)
xib=xib0+a*(k1xib+k2xib)
return
end subroutine

subroutine iss(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,h)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,h
real*8 sx0,sy0,sz0,cta0,ctb0,px0,py0,pz0,xia0,xib0
real*8::error=1d-15,d=0d0
real*8 sxm,sym,szm,ctam,ctbm,pxm,pym,pzm,xiam,xibm
real*8 z1,z2,z3,z4,z5,z6,z7,z8,z9,z10
real*8 dx,dy,dz,dcta,dctb,dpx,dpy,dpz,dxia,dxib
integer::j=2000d0
integer i
i=0d0
sx0=sx
sy0=sy
sz0=sz
cta0=cta
ctb0=ctb
px0=px
py0=py
pz0=pz
xia0=xia
xib0=xib
sxm=sx
sym=sy
szm=sz
ctam=cta
ctbm=ctb
pxm=px
pym=py
pzm=pz
xiam=xia
xibm=xib
1 z1=sxm
  z2=sym
  z3=szm
  z4=ctam
  z5=ctbm
  z6=pxm
  z7=pym
  z8=pzm
  z9=xiam
  z10=xibm
  call xdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dx)
  sxm=sx0+h*dx
  sx=(sx0+sxm)/2d0
  call ydot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dy)
  sym=sy0+h*dy
  sy=(sy0+sym)/2d0
  call zdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dz)
  szm=sz0+h*dz
  sz=(sz0+szm)/2d0
  call ctadot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dcta)
  ctam=cta0+h*dcta
  cta=(cta0+ctam)/2d0
  call ctbdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dctb)
  ctbm=ctb0+h*dctb
  ctb=(ctb0+ctbm)/2d0
  call pxdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpx)
  pxm=px0+h*dpx
  px=(px0+pxm)/2d0
  call pydot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpy)
  pym=py0+h*dpy
  py=(py0+pym)/2d0
  call pzdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dpz)
  pzm=pz0+h*dpz
  pz=(pz0+pzm)/2d0
  call xiadot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxia)
  xiam=xia0+h*dxia
  xia=(xia0+xiam)/2d0
  call xibdot(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,dxib)
  xibm=xib0+h*dxib
  xib=(xib0+xibm)/2d0
  i=i+1d0
  d=dsqrt((z1-sxm)**2d0+(z2-sym)**2d0+(z3-szm)**2d0+(z4-ctam)**2d0+(z5-ctbm)**2d0+(z6-pxm)**2d0+(z7-pym)**2d0+(z8-pzm)**2d0+(z9-xiam)**2d0+(z10-xibm)**2d0+1d-32)
  !write(*,*)d
  !pause
  if(i.gt.j)then
  goto 2
  else
  end if
  if(d.gt.error)goto 1
2 sx=sxm
  sy=sym
  sz=szm
  cta=ctam
  ctb=ctbm
  px=pxm
  py=pym
  pz=pzm
  xia=xiam
  xib=xibm
return
end subroutine

subroutine ems(sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,h)
implicit none
real*8 sx,sy,sz,cta,ctb,px,py,pz,xia,xib,n,c1,c2,w,h
real*8 sx0,sy0,sz0,cta0,ctb0,px0,py0,pz0,xia0,xib0
real*8 q1,q2,q3,q4,q5,p1,p2,p3,p4,p5
real*8 q10,q20,q30,q40,q50,p10,p20,p30,p40,p50
real*8 dq1,dq2,dq3,dq4,dq5,dp1,dp2,dp3,dp4,dp5
real*8 dx,dy,dz,dcta,dctb,dpx,dpy,dpz,dxia,dxib
sx0=sx
sy0=sy
sz0=sz
cta0=cta
ctb0=ctb
px0=px
py0=py
pz0=pz
xia0=xia
xib0=xib
q1=sx
q2=sy
q3=sz
q4=cta
q5=ctb
p1=px
p2=py
p3=pz
p4=xia
p5=xib
q10=q1
q20=q2
q30=q3
q40=q4
q50=q5
p10=p1
p20=p2
p30=p3
p40=p4
p50=p5
call xdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dx)
call ydot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dy)
call zdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dz)
call ctadot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dcta)
call ctbdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dctb)
call pxdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp1)
call pydot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp2)
call pzdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp3)
call xiadot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp4)
call xibdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp5)
sx=sx0+(1d0/2d0)*h*dx
sy=sy0+(1d0/2d0)*h*dy
sz=sz0+(1d0/2d0)*h*dz
cta=cta0+(1d0/2d0)*h*dcta
ctb=ctb0+(1d0/2d0)*h*dctb
p1=p10+(1d0/2d0)*h*dp1
p2=p20+(1d0/2d0)*h*dp2
p3=p30+(1d0/2d0)*h*dp3
p4=p40+(1d0/2d0)*h*dp4
p5=p50+(1d0/2d0)*h*dp5
call xdot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dq1)
call ydot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dq2)
call zdot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dq3)
call ctadot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dq4)
call ctbdot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dq5)
call pxdot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dpx)
call pydot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dpy)
call pzdot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dpz)
call xiadot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dxia)
call xibdot(sx,sy,sz,cta,ctb,p1,p2,p3,p4,p5,n,c1,c2,w,dxib)
px=px0+h*dpx
py=py0+h*dpy
pz=pz0+h*dpz
xia=xia0+h*dxia
xib=xib0+h*dxib
q1=q10+h*dq1
q2=q20+h*dq2
q3=q30+h*dq3
q4=q40+h*dq4
q5=q50+h*dq5
call xdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dx)
call ydot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dy)
call zdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dz)
call ctadot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dcta)
call ctbdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dctb)
call pxdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp1)
call pydot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp2)
call pzdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp3)
call xiadot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp4)
call xibdot(q1,q2,q3,q4,q5,px,py,pz,xia,xib,n,c1,c2,w,dp5)
sx=sx+(1d0/2d0)*h*dx
sy=sy+(1d0/2d0)*h*dy
sz=sz+(1d0/2d0)*h*dz
cta=cta+(1d0/2d0)*h*dcta
ctb=ctb+(1d0/2d0)*h*dctb
p1=p1+(1d0/2d0)*h*dp1
p2=p2+(1d0/2d0)*h*dp2
p3=p3+(1d0/2d0)*h*dp3
p4=p4+(1d0/2d0)*h*dp4
p5=p5+(1d0/2d0)*h*dp5
sx=(sx+q1)/2d0
sy=(sy+q2)/2d0
sz=(sz+q3)/2d0
cta=(cta+q4)/2d0
ctb=(ctb+q5)/2d0
px=(px+p1)/2d0
py=(py+p2)/2d0
pz=(pz+p3)/2d0
xia=(xia+p4)/2d0
xib=(xib+p5)/2d0
return
end subroutine

subroutine ecf(q1,q2,q3,q4,q5,p1,p2,p3,p4,p5,n,c1,c2,w,h)
implicit real*8 (a-z)
real*8 q1,q2,q3,q4,q5,p1,p2,p3,p4,p5,n,c1,c2,w,h
real*8 q10,q20,q30,q40,q50,p10,p20,p30,p40,p50
real*8 q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m
real*8 z1,z2,z3,z4,z5,z6,z7,z8,z9,z10
real*8 h0000010000,h0000000000,h0000110000,h0001110000,h0011110000,h0111110000,h1111110000,h1111110001,h1111110011,h1111110111,h1111111111
real*8 h0000001000,h0000011000,h0000111000,h0001111000,h0011111000,h0111111000,h1111111000,h1111111001,h1111111011
real*8 h0000000100,h0000001100,h0000011100,h0000111100,h0001111100,h0011111100,h0111111100,h1111111100,h1111111101
real*8 h0000000010,h0000000110,h0000001110,h0000011110,h0000111110,h0001111110,h0011111110,h0111111110,h1111111110
real*8 h0000000001,h0000000011,h0000000111,h0000001111,h0000011111,h0000111111,h0001111111,h0011111111,h0111111111
real*8 h1000000000,h1000000001,h1000000011,h1000000111,h1000001111,h1000011111,h1000111111,h1001111111,h1011111111
real*8 h0100000000,h1100000000,h1100000001,h1100000011,h1100000111,h1100001111,h1100011111,h1100111111,h1101111111
real*8 h0010000000,h0110000000,h1110000000,h1110000001,h1110000011,h1110000111,h1110001111,h1110011111,h1110111111
real*8 h0001000000,h0011000000,h0111000000,h1111000000,h1111000001,h1111000011,h1111000111,h1111001111,h1111011111
real*8 h0000100000,h0001100000,h0011100000,h0111100000,h1111100000,h1111100001,h1111100011,h1111100111,h1111101111
real*8::error=1d-12
real*8::d=0d0
real*8 dist
integer::j=15d0
integer i
i=1d0
q10=q1
q20=q2
q30=q3
q40=q4
q50=q5
p10=p1
p20=p2
p30=p3
p40=p4
p50=p5
q1m=q1
q2m=q2
q3m=q3
q4m=q4
q5m=q5
p1m=p1
p2m=p2
p3m=p3
p4m=p4
p5m=p5
call rks(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h)
1 z1=q1m
  z2=q2m
  z3=q3m
  z4=q4m
  z5=q5m
  z6=p1m
  z7=p2m
  z8=p3m
  z9=p4m
  z10=p5m
call hamiltonian(q10,q20,q30,q40,q50,p1m,p20,p30,p40,p50,n,c1,c2,w,h0000010000)
call hamiltonian(q1m,q20,q30,q40,q50,p1m,p20,p30,p40,p50,n,c1,c2,w,h1000010000)
call hamiltonian(q10,q20,q30,q40,q5m,p1m,p20,p30,p40,p5m,n,c1,c2,w,h0000110001)
call hamiltonian(q1m,q2m,q30,q40,q50,p1m,p2m,p30,p40,p50,n,c1,c2,w,h1100011000)
call hamiltonian(q10,q20,q30,q4m,q5m,p1m,p20,p30,p4m,p5m,n,c1,c2,w,h0001110011)
call hamiltonian(q1m,q2m,q3m,q40,q50,p1m,p2m,p3m,p40,p50,n,c1,c2,w,h1110011100)
call hamiltonian(q10,q20,q3m,q4m,q5m,p1m,p20,p3m,p4m,p5m,n,c1,c2,w,h0011110111)
call hamiltonian(q1m,q2m,q3m,q4m,q50,p1m,p2m,p3m,p4m,p50,n,c1,c2,w,h1111011110)
call hamiltonian(q10,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h0111111111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q1m,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h1000000000)
call hamiltonian(q10,q20,q30,q40,q5m,p10,p20,p30,p40,p5m,n,c1,c2,w,h0000100001)
call hamiltonian(q1m,q2m,q30,q40,q50,p10,p2m,p30,p40,p50,n,c1,c2,w,h1100001000)
call hamiltonian(q10,q20,q30,q4m,q5m,p10,p20,p30,p4m,p5m,n,c1,c2,w,h0001100011)
call hamiltonian(q1m,q2m,q3m,q40,q50,p10,p2m,p3m,p40,p50,n,c1,c2,w,h1110001100)
call hamiltonian(q10,q20,q3m,q4m,q5m,p10,p20,p3m,p4m,p5m,n,c1,c2,w,h0011100111)
call hamiltonian(q1m,q2m,q3m,q4m,q50,p10,p2m,p3m,p4m,p50,n,c1,c2,w,h1111001110)
call hamiltonian(q10,q2m,q3m,q4m,q5m,p10,p2m,p3m,p4m,p5m,n,c1,c2,w,h0111101111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p10,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111101111)
if(dabs(p1m-p10).ne.0d0)then
q1m=h*(1d0/(p1m-p10))*(1d0/10d0)*((h0000010000-h0000000000+h1000010000-h1000000000+h0000110001-h0000100001+h1100011000-h1100001000+h0001110011-h0001100011+h1110011100-h1110001100+h0011110111-h0011100111+h1111011110-h1111001110+h0111111111-h0111101111+h1111111111-h1111101111))+q10
else
end if
call hamiltonian(q10,q20,q30,q40,q50,p10,p2m,p30,p40,p50,n,c1,c2,w,h0000001000)
call hamiltonian(q10,q2m,q30,q40,q50,p10,p2m,p30,p40,p50,n,c1,c2,w,h0100001000)
call hamiltonian(q1m,q20,q30,q40,q50,p1m,p2m,p30,p40,p50,n,c1,c2,w,h1000011000)
call hamiltonian(q10,q2m,q3m,q40,q50,p10,p2m,p3m,p40,p50,n,c1,c2,w,h0110001100)
call hamiltonian(q1m,q20,q30,q40,q5m,p1m,p2m,p30,p40,p5m,n,c1,c2,w,h1000111001)
call hamiltonian(q10,q2m,q3m,q4m,q50,p10,p2m,p3m,p4m,p50,n,c1,c2,w,h0111001110)
call hamiltonian(q1m,q20,q30,q4m,q5m,p1m,p2m,p30,p4m,p5m,n,c1,c2,w,h1001111011)
call hamiltonian(q10,q2m,q3m,q4m,q5m,p10,p2m,p3m,p4m,p5m,n,c1,c2,w,h0111101111)
call hamiltonian(q1m,q20,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1011111111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
!call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q10,q2m,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0100000000)
call hamiltonian(q1m,q20,q30,q40,q50,p1m,p20,p30,p40,p50,n,c1,c2,w,h1000010000)
call hamiltonian(q10,q2m,q3m,q40,q50,p10,p20,p3m,p40,p50,n,c1,c2,w,h0110000100)
call hamiltonian(q1m,q20,q30,q40,q5m,p1m,p20,p30,p40,p5m,n,c1,c2,w,h1000110001)
call hamiltonian(q10,q2m,q3m,q4m,q50,p10,p20,p3m,p4m,p50,n,c1,c2,w,h0111000110)
call hamiltonian(q1m,q20,q30,q4m,q5m,p1m,p20,p30,p4m,p5m,n,c1,c2,w,h1001110011)
call hamiltonian(q10,q2m,q3m,q4m,q5m,p10,p20,p3m,p4m,p5m,n,c1,c2,w,h0111100111)
call hamiltonian(q1m,q20,q3m,q4m,q5m,p1m,p20,p3m,p4m,p5m,n,c1,c2,w,h1011110111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p20,p3m,p4m,p5m,n,c1,c2,w,h1111110111)
if(dabs(p2m-p20).ne.0d0)then
q2m=h*(1d0/(p2m-p20))*(1d0/10d0)*((h0000001000-h0000000000+h0100001000-h0100000000+h1000011000-h1000010000+h0110001100-h0110000100+h1000111001-h1000110001+h0111001110-h0111000110+h1001111011-h1001110011+h0111101111-h0111100111+h1011111111-h1011110111+h1111111111-h1111110111))+q20
else
end if
call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p3m,p40,p50,n,c1,c2,w,h0000000100)
call hamiltonian(q10,q20,q3m,q40,q50,p10,p20,p3m,p40,p50,n,c1,c2,w,h0010000100)
call hamiltonian(q10,q2m,q30,q40,q50,p10,p2m,p3m,p40,p50,n,c1,c2,w,h0100001100)
call hamiltonian(q10,q20,q3m,q4m,q50,p10,p20,p3m,p4m,p50,n,c1,c2,w,h0011000110)
call hamiltonian(q1m,q2m,q30,q40,q50,p1m,p2m,p3m,p40,p50,n,c1,c2,w,h1100011100)
call hamiltonian(q10,q20,q3m,q4m,q5m,p10,p20,p3m,p4m,p5m,n,c1,c2,w,h0011100111)
call hamiltonian(q1m,q2m,q30,q40,q5m,p1m,p2m,p3m,p40,p5m,n,c1,c2,w,h1100111101)
call hamiltonian(q1m,q20,q3m,q4m,q5m,p1m,p20,p3m,p4m,p5m,n,c1,c2,w,h1011110111)
call hamiltonian(q1m,q2m,q30,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1101111111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
!call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q10,q20,q3m,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0010000000)
call hamiltonian(q10,q2m,q30,q40,q50,p10,p2m,p30,p40,p50,n,c1,c2,w,h0100001000)
call hamiltonian(q10,q20,q3m,q4m,q50,p10,p20,p30,p4m,p50,n,c1,c2,w,h0011000010)
call hamiltonian(q1m,q2m,q30,q40,q50,p1m,p2m,p30,p40,p50,n,c1,c2,w,h1100011000)
call hamiltonian(q10,q20,q3m,q4m,q5m,p10,p20,p30,p4m,p5m,n,c1,c2,w,h0011100011)
call hamiltonian(q1m,q2m,q30,q40,q5m,p1m,p2m,p30,p40,p5m,n,c1,c2,w,h1100111001)
call hamiltonian(q1m,q20,q3m,q4m,q5m,p1m,p20,p30,p4m,p5m,n,c1,c2,w,h1011110011)
call hamiltonian(q1m,q2m,q30,q4m,q5m,p1m,p2m,p30,p4m,p5m,n,c1,c2,w,h1101111011)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p30,p4m,p5m,n,c1,c2,w,h1111111011)
if(dabs(p3m-p30).ne.0d0)then
q3m=h*(1d0/(p3m-p30))*(1d0/10d0)*((h0000000100-h0000000000+h0010000100-h0010000000+h0100001100-h0100001000+h0011000110-h0011000010+h1100011100-h1100011000+h0011100111-h0011100011+h1100111101-h1100111001+h1011110111-h1011110011+h1101111111-h1101111011+h1111111111-h1111111011))+q30
else
end if
call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p4m,p50,n,c1,c2,w,h0000000010)
call hamiltonian(q10,q20,q30,q4m,q50,p10,p20,p30,p4m,p50,n,c1,c2,w,h0001000010)
call hamiltonian(q10,q20,q3m,q40,q50,p10,p20,p3m,p4m,p50,n,c1,c2,w,h0010000110)
call hamiltonian(q10,q20,q30,q4m,q5m,p10,p20,p30,p4m,p5m,n,c1,c2,w,h0001100011)
call hamiltonian(q10,q2m,q3m,q40,q50,p10,p2m,p3m,p4m,p50,n,c1,c2,w,h0110001110)
call hamiltonian(q1m,q20,q30,q4m,q5m,p1m,p20,p30,p4m,p5m,n,c1,c2,w,h1001110011)
call hamiltonian(q1m,q2m,q3m,q40,q50,p1m,p2m,p3m,p4m,p50,n,c1,c2,w,h1110011110)
call hamiltonian(q1m,q2m,q30,q4m,q5m,p1m,p2m,p30,p4m,p5m,n,c1,c2,w,h1101111011)
call hamiltonian(q1m,q2m,q3m,q40,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1110111111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
!call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q10,q20,q30,q4m,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0001000000)
call hamiltonian(q10,q20,q3m,q40,q50,p10,p20,p3m,p40,p50,n,c1,c2,w,h0010000100)
call hamiltonian(q10,q20,q30,q4m,q5m,p10,p20,p30,p40,p5m,n,c1,c2,w,h0001100001)
call hamiltonian(q10,q2m,q3m,q40,q50,p10,p2m,p3m,p40,p50,n,c1,c2,w,h0110001100)
call hamiltonian(q1m,q20,q30,q4m,q5m,p1m,p20,p30,p40,p5m,n,c1,c2,w,h1001110001)
call hamiltonian(q1m,q2m,q3m,q40,q50,p1m,p2m,p3m,p40,p50,n,c1,c2,w,h1110011100)
call hamiltonian(q1m,q2m,q30,q4m,q5m,p1m,p2m,p30,p40,p5m,n,c1,c2,w,h1101111001)
call hamiltonian(q1m,q2m,q3m,q40,q5m,p1m,p2m,p3m,p40,p5m,n,c1,c2,w,h1110111101)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p40,p5m,n,c1,c2,w,h1111111101)
if(dabs(p4m-p40).ne.0d0)then
q4m=h*(1d0/(p4m-p40))*(1d0/10d0)*((h0000000010-h0000000000+h0001000010-h0001000000+h0010000110-h0010000100+h0001100011-h0001100001+h0110001110-h0110001100+h1001110011-h1001110001+h1110011110-h1110011100+h1101111011-h1101111001+h1110111111-h1110111101+h1111111111-h1111111101))+q40
else
end if
call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p5m,n,c1,c2,w,h0000000001)
call hamiltonian(q10,q20,q30,q40,q5m,p10,p20,p30,p40,p5m,n,c1,c2,w,h0000100001)
call hamiltonian(q10,q20,q30,q4m,q50,p10,p20,p30,p4m,p5m,n,c1,c2,w,h0001000011)
call hamiltonian(q1m,q20,q30,q40,q5m,p1m,p20,p30,p40,p5m,n,c1,c2,w,h1000110001)
call hamiltonian(q10,q20,q3m,q4m,q50,p10,p20,p3m,p4m,p5m,n,c1,c2,w,h0011000111)
call hamiltonian(q1m,q2m,q30,q40,q5m,p1m,p2m,p30,p40,p5m,n,c1,c2,w,h1100111001)
call hamiltonian(q10,q2m,q3m,q4m,q50,p10,p2m,p3m,p4m,p5m,n,c1,c2,w,h0111001111)
call hamiltonian(q1m,q2m,q3m,q40,q5m,p1m,p2m,p3m,p40,p5m,n,c1,c2,w,h1110111101)
call hamiltonian(q1m,q2m,q3m,q4m,q50,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111011111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
!call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q10,q20,q30,q40,q5m,p10,p20,p30,p40,p50,n,c1,c2,w,h0000100000)
call hamiltonian(q10,q20,q30,q4m,q50,p10,p20,p30,p4m,p50,n,c1,c2,w,h0001000010)
call hamiltonian(q1m,q20,q30,q40,q5m,p1m,p20,p30,p40,p50,n,c1,c2,w,h1000110000)
call hamiltonian(q10,q20,q3m,q4m,q50,p10,p20,p3m,p4m,p50,n,c1,c2,w,h0011000110)
call hamiltonian(q1m,q2m,q30,q40,q5m,p1m,p2m,p30,p40,p50,n,c1,c2,w,h1100111000)
call hamiltonian(q10,q2m,q3m,q4m,q50,p10,p2m,p3m,p4m,p50,n,c1,c2,w,h0111001110)
call hamiltonian(q1m,q2m,q3m,q40,q5m,p1m,p2m,p3m,p40,p50,n,c1,c2,w,h1110111100)
call hamiltonian(q1m,q2m,q3m,q4m,q50,p1m,p2m,p3m,p4m,p50,n,c1,c2,w,h1111011110)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p50,n,c1,c2,w,h1111111110)
if(dabs(p5m-p50).ne.0d0)then
q5m=h*(1d0/(p5m-p50))*(1d0/10d0)*((h0000000001-h0000000000+h0000100001-h0000100000+h0001000011-h0001000010+h1000110001-h1000110000+h0011000111-h0011000110+h1100111001-h1100111000+h0111001111-h0111001110+h1110111101-h1110111100+h1111011111-h1111011110+h1111111111-h1111111110))+q50
else
end if
call hamiltonian(q1m,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h1000000000)
call hamiltonian(q1m,q20,q30,q40,q50,p1m,p20,p30,p40,p50,n,c1,c2,w,h1000010000)
call hamiltonian(q1m,q2m,q30,q40,q50,p10,p2m,p30,p40,p50,n,c1,c2,w,h1100001000)
call hamiltonian(q1m,q20,q30,q40,q5m,p1m,p20,p30,p40,p5m,n,c1,c2,w,h1000110001)
call hamiltonian(q1m,q2m,q3m,q40,q50,p10,p2m,p3m,p40,p50,n,c1,c2,w,h1110001100)
call hamiltonian(q1m,q20,q30,q4m,q5m,p1m,p20,p30,p4m,p5m,n,c1,c2,w,h1001110011)
call hamiltonian(q1m,q2m,q3m,q4m,q50,p10,p2m,p3m,p4m,p50,n,c1,c2,w,h1111001110)
call hamiltonian(q1m,q20,q3m,q4m,q5m,p1m,p20,p3m,p4m,p5m,n,c1,c2,w,h1011110111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p10,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111101111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
!call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q10,q20,q30,q40,q50,p1m,p20,p30,p40,p50,n,c1,c2,w,h0000010000)
call hamiltonian(q10,q2m,q30,q40,q50,p10,p2m,p30,p40,p50,n,c1,c2,w,h0100001000)
call hamiltonian(q10,q20,q30,q40,q5m,p1m,p20,p30,p40,p5m,n,c1,c2,w,h0000110001)
call hamiltonian(q10,q2m,q3m,q40,q50,p10,p2m,p3m,p40,p50,n,c1,c2,w,h0110001100)
call hamiltonian(q10,q20,q30,q4m,q5m,p1m,p20,p30,p4m,p5m,n,c1,c2,w,h0001110011)
call hamiltonian(q10,q2m,q3m,q4m,q50,p10,p2m,p3m,p4m,p50,n,c1,c2,w,h0111001110)
call hamiltonian(q10,q20,q3m,q4m,q5m,p1m,p20,p3m,p4m,p5m,n,c1,c2,w,h0011110111)
call hamiltonian(q10,q2m,q3m,q4m,q5m,p10,p2m,p3m,p4m,p5m,n,c1,c2,w,h0111101111)
call hamiltonian(q10,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h0111111111)
if(dabs(q1m-q10).ne.0d0)then
p1m=(-h)*(1d0/(q1m-q10))*(1d0/10d0)*((h1000000000-h0000000000+h1000010000-h0000010000+h1100001000-h0100001000+h1000110001-h0000110001+h1110001100-h0110001100+h1001110011-h0001110011+h1111001110-h0111001110+h1011110111-h0011110111+h1111101111-h0111101111+h1111111111-h0111111111))+p10
else
end if
call hamiltonian(q10,q2m,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0100000000)
call hamiltonian(q10,q2m,q30,q40,q50,p10,p2m,p30,p40,p50,n,c1,c2,w,h0100001000)
call hamiltonian(q10,q2m,q3m,q40,q50,p10,p20,p3m,p40,p50,n,c1,c2,w,h0110000100)
call hamiltonian(q1m,q2m,q30,q40,q50,p1m,p2m,p30,p40,p50,n,c1,c2,w,h1100011000)
call hamiltonian(q10,q2m,q3m,q4m,q50,p10,p20,p3m,p4m,p50,n,c1,c2,w,h0111000110)
call hamiltonian(q1m,q2m,q30,q40,q5m,p1m,p2m,p30,p40,p5m,n,c1,c2,w,h1100111001)
call hamiltonian(q10,q2m,q3m,q4m,q5m,p10,p20,p3m,p4m,p5m,n,c1,c2,w,h0111100111)
call hamiltonian(q1m,q2m,q30,q4m,q5m,p1m,p2m,p30,p4m,p5m,n,c1,c2,w,h1101111011)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p20,p3m,p4m,p5m,n,c1,c2,w,h1111110111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
!call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q10,q20,q30,q40,q50,p10,p2m,p30,p40,p50,n,c1,c2,w,h0000001000)
call hamiltonian(q10,q20,q3m,q40,q50,p10,p20,p3m,p40,p50,n,c1,c2,w,h0010000100)
call hamiltonian(q1m,q20,q30,q40,q50,p1m,p2m,p30,p40,p50,n,c1,c2,w,h1000011000)
call hamiltonian(q10,q20,q3m,q4m,q50,p10,p20,p3m,p4m,p50,n,c1,c2,w,h0011000110)
call hamiltonian(q1m,q20,q30,q40,q5m,p1m,p2m,p30,p40,p5m,n,c1,c2,w,h1000111001)
call hamiltonian(q10,q20,q3m,q4m,q5m,p10,p20,p3m,p4m,p5m,n,c1,c2,w,h0011100111)
call hamiltonian(q1m,q20,q30,q4m,q5m,p1m,p2m,p30,p4m,p5m,n,c1,c2,w,h1001111011)
call hamiltonian(q1m,q20,q3m,q4m,q5m,p1m,p20,p3m,p4m,p5m,n,c1,c2,w,h1011110111)
call hamiltonian(q1m,q20,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1011111111)
if(dabs(q2m-q20).ne.0d0)then
p2m=(-h)*(1d0/(q2m-q20))*(1d0/10d0)*((h0100000000-h0000000000+h0100001000-h0000001000+h0110000100-h0010000100+h1100011000-h1000011000+h0111000110-h0011000110+h1100111001-h1000111001+h0111100111-h0011100111+h1101111011-h1001111011+h1111110111-h1011110111+h1111111111-h1011111111))+p20
else
end if
call hamiltonian(q10,q20,q3m,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0010000000)
call hamiltonian(q10,q20,q3m,q40,q50,p10,p20,p3m,p40,p50,n,c1,c2,w,h0010000100)
call hamiltonian(q10,q20,q3m,q4m,q50,p10,p20,p30,p4m,p50,n,c1,c2,w,h0011000010)
call hamiltonian(q10,q2m,q3m,q40,q50,p10,p2m,p3m,p40,p50,n,c1,c2,w,h0110001100)
call hamiltonian(q10,q20,q3m,q4m,q5m,p10,p20,p30,p4m,p5m,n,c1,c2,w,h0011100011)
call hamiltonian(q1m,q2m,q3m,q40,q50,p1m,p2m,p3m,p40,p50,n,c1,c2,w,h1110011100)
call hamiltonian(q1m,q20,q3m,q4m,q5m,p1m,p20,p30,p4m,p5m,n,c1,c2,w,h1011110011)
call hamiltonian(q1m,q2m,q3m,q40,q5m,p1m,p2m,p3m,p40,p5m,n,c1,c2,w,h1110111101)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p30,p4m,p5m,n,c1,c2,w,h1111111011)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
!call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p3m,p40,p50,n,c1,c2,w,h0000000100)
call hamiltonian(q10,q20,q30,q4m,q50,p10,p20,p30,p4m,p50,n,c1,c2,w,h0001000010)
call hamiltonian(q10,q2m,q30,q40,q50,p10,p2m,p3m,p40,p50,n,c1,c2,w,h0100001100)
call hamiltonian(q10,q20,q30,q4m,q5m,p10,p20,p30,p4m,p5m,n,c1,c2,w,h0001100011)
call hamiltonian(q1m,q2m,q30,q40,q50,p1m,p2m,p3m,p40,p50,n,c1,c2,w,h1100011100)
call hamiltonian(q1m,q20,q30,q4m,q5m,p1m,p20,p30,p4m,p5m,n,c1,c2,w,h1001110011)
call hamiltonian(q1m,q2m,q30,q40,q5m,p1m,p2m,p3m,p40,p5m,n,c1,c2,w,h1100111101)
call hamiltonian(q1m,q2m,q30,q4m,q5m,p1m,p2m,p30,p4m,p5m,n,c1,c2,w,h1101111011)
call hamiltonian(q1m,q2m,q30,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1101111111)
if(dabs(q3m-q30).ne.0d0)then
p3m=(-h)*(1d0/(q3m-q30))*(1d0/10d0)*((h0010000000-h0000000000+h0010000100-h0000000100+h0011000010-h0001000010+h0110001100-h0100001100+h0011100011-h0001100011+h1110011100-h1100011100+h1011110011-h1001110011+h1110111101-h1100111101+h1111111011-h1101111011+h1111111111-h1101111111))+p30
else
end if
call hamiltonian(q10,q20,q30,q4m,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0001000000)
call hamiltonian(q10,q20,q30,q4m,q50,p10,p20,p30,p4m,p50,n,c1,c2,w,h0001000010)
call hamiltonian(q10,q20,q30,q4m,q5m,p10,p20,p30,p40,p5m,n,c1,c2,w,h0001100001)
call hamiltonian(q10,q20,q3m,q4m,q50,p10,p20,p3m,p4m,p50,n,c1,c2,w,h0011000110)
call hamiltonian(q1m,q20,q30,q4m,q5m,p1m,p20,p30,p40,p5m,n,c1,c2,w,h1001110001)
call hamiltonian(q10,q2m,q3m,q4m,q50,p10,p2m,p3m,p4m,p50,n,c1,c2,w,h0111001110)
call hamiltonian(q1m,q2m,q30,q4m,q5m,p1m,p2m,p30,p40,p5m,n,c1,c2,w,h1101111001)
call hamiltonian(q1m,q2m,q3m,q4m,q50,p1m,p2m,p3m,p4m,p50,n,c1,c2,w,h1111011110)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p40,p5m,n,c1,c2,w,h1111111101)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
!call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p4m,p50,n,c1,c2,w,h0000000010)
call hamiltonian(q10,q20,q30,q40,q5m,p10,p20,p30,p40,p5m,n,c1,c2,w,h0000100001)
call hamiltonian(q10,q20,q3m,q40,q50,p10,p20,p3m,p4m,p50,n,c1,c2,w,h0010000110)
call hamiltonian(q1m,q20,q30,q40,q5m,p1m,p20,p30,p40,p5m,n,c1,c2,w,h1000110001)
call hamiltonian(q10,q2m,q3m,q40,q50,p10,p2m,p3m,p4m,p50,n,c1,c2,w,h0110001110)
call hamiltonian(q1m,q2m,q30,q40,q5m,p1m,p2m,p30,p40,p5m,n,c1,c2,w,h1100111001)
call hamiltonian(q1m,q2m,q3m,q40,q50,p1m,p2m,p3m,p4m,p50,n,c1,c2,w,h1110011110)
call hamiltonian(q1m,q2m,q3m,q40,q5m,p1m,p2m,p3m,p40,p5m,n,c1,c2,w,h1110111101)
call hamiltonian(q1m,q2m,q3m,q40,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1110111111)
if(dabs(q4m-q40).ne.0d0)then
p4m=(-h)*(1d0/(q4m-q40))*(1d0/10d0)*((h0001000000-h0000000000+h0001000010-h0000000010+h0001100001-h0000100001+h0011000110-h0010000110+h1001110001-h1000110001+h0111001110-h0110001110+h1101111001-h1100111001+h1111011110-h1110011110+h1111111101-h1110111101+h1111111111-h1110111111))+p40
else
end if
call hamiltonian(q10,q20,q30,q40,q5m,p10,p20,p30,p40,p50,n,c1,c2,w,h0000100000)
call hamiltonian(q10,q20,q30,q40,q5m,p10,p20,p30,p40,p5m,n,c1,c2,w,h0000100001)
call hamiltonian(q1m,q20,q30,q40,q5m,p1m,p20,p30,p40,p50,n,c1,c2,w,h1000110000)
call hamiltonian(q10,q20,q30,q4m,q5m,p10,p20,p30,p4m,p5m,n,c1,c2,w,h0001100011)
call hamiltonian(q1m,q2m,q30,q40,q5m,p1m,p2m,p30,p40,p50,n,c1,c2,w,h1100111000)
call hamiltonian(q10,q20,q3m,q4m,q5m,p10,p20,p3m,p4m,p5m,n,c1,c2,w,h0011100111)
call hamiltonian(q1m,q2m,q3m,q40,q5m,p1m,p2m,p3m,p40,p50,n,c1,c2,w,h1110111100)
call hamiltonian(q10,q2m,q3m,q4m,q5m,p10,p2m,p3m,p4m,p5m,n,c1,c2,w,h0111101111)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p50,n,c1,c2,w,h1111111110)
call hamiltonian(q1m,q2m,q3m,q4m,q5m,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111111111)
!call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p50,n,c1,c2,w,h0000000000)
call hamiltonian(q10,q20,q30,q40,q50,p10,p20,p30,p40,p5m,n,c1,c2,w,h0000000001)
call hamiltonian(q1m,q20,q30,q40,q50,p1m,p20,p30,p40,p50,n,c1,c2,w,h1000010000)
call hamiltonian(q10,q20,q30,q4m,q50,p10,p20,p30,p4m,p5m,n,c1,c2,w,h0001000011)
call hamiltonian(q1m,q2m,q30,q40,q50,p1m,p2m,p30,p40,p50,n,c1,c2,w,h1100011000)
call hamiltonian(q10,q20,q3m,q4m,q50,p10,p20,p3m,p4m,p5m,n,c1,c2,w,h0011000111)
call hamiltonian(q1m,q2m,q3m,q40,q50,p1m,p2m,p3m,p40,p50,n,c1,c2,w,h1110011100)
call hamiltonian(q10,q2m,q3m,q4m,q50,p10,p2m,p3m,p4m,p5m,n,c1,c2,w,h0111001111)
call hamiltonian(q1m,q2m,q3m,q4m,q50,p1m,p2m,p3m,p4m,p50,n,c1,c2,w,h1111011110)
call hamiltonian(q1m,q2m,q3m,q4m,q50,p1m,p2m,p3m,p4m,p5m,n,c1,c2,w,h1111011111)
if(dabs(q5m-q50).ne.0d0)then
p5m=(-h)*(1d0/(q5m-q50))*(1d0/10d0)*((h0000100000-h0000000000+h0000100001-h0000000001+h1000110000-h1000010000+h0001100011-h0001000011+h1100111000-h1100011000+h0011100111-h0011000111+h1110111100-h1110011100+h0111101111-h0111001111+h1111111110-h1111011110+h1111111111-h1111011111))+p50
else
end if
  i=i+1d0
  d=dsqrt((z1-q1m)**2d0+(z2-q2m)**2d0+(z3-q3m)**2d0+(z4-q4m)**2d0+(z5-q5m)**2d0+(z6-p1m)**2d0+(z7-p2m)**2d0+(z8-p3m)**2d0+(z9-p4m)**2d0+(z10-p5m)**2d0+1d-32)
  !write(*,*)d
  !pause
  if(i.gt.j)then
  goto 2
  else
  end if
  if(d.gt.error)goto 1
2 q1=q1m
  q2=q2m
  q3=q3m
  q4=q4m
  q5=q5m
  p1=p1m
  p2=p2m
  p3=p3m
  p4=p4m
  p5=p5m
return
end subroutine


      SUBROUTINE MB03AF( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1,
     $                   S1, C2, S2 )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute two Givens rotations (C1,S1) and (C2,S2) such that the
C     orthogonal matrix
C
C               [ Q  0 ]        [  C1  S1  0 ]   [ 1  0   0  ]
C           Z = [      ],  Q := [ -S1  C1  0 ] * [ 0  C2  S2 ],
C               [ 0  I ]        [  0   0   1 ]   [ 0 -S2  C2 ]
C
C     makes the first column of the real Wilkinson double shift
C     polynomial of the product of matrices in periodic upper Hessenberg
C     form, stored in the array A, parallel to the first unit vector.
C     Only the rotation defined by C1 and S1 is used for the real
C     Wilkinson single shift polynomial (see SLICOT Library routines
C     MB03BE or MB03BF).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SHFT    CHARACTER*1
C             Specifies the number of shifts employed by the shift
C             polynomial, as follows:
C             = 'D':  two real shifts;
C             = 'S':  one real shift.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     N       (input)  INTEGER
C             The order of the factors in the array A.
C             N >= 2, for a single shift polynomial;
C             N >= 3, for a double shift polynomial.
C
C     AMAP    (input) INTEGER array, dimension (K)
C             The map for accessing the factors, i.e., if AMAP(I) = J,
C             then the factor A_I is stored at the J-th position in A.
C             AMAP(K) is the pointer to the Hessenberg matrix.
C             Before calling this routine, AMAP returned by SLICOT
C             Library routine MB03BA should be modified as follows:
C             J = AMAP(1), AMAP(I) = AMAP(I+1), I = 1:K-1, AMAP(K) = J.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C             S(K) is not used, but assumed to be 1.
C
C     SINV    (input) INTEGER
C             Signature multiplier. Entries of S are virtually
C             multiplied by SINV.
C
C     A       (input)  DOUBLE PRECISION array, dimension (LDA1,LDA2,K)
C             On entry, the leading N-by-N-by-K part of this array must
C             contain a n-by-n product (implicitly represented by its K
C             factors) in periodic upper Hessenberg form.
C
C     LDA1    INTEGER
C             The first leading dimension of the array A.  LDA1 >= N.
C
C     LDA2    INTEGER
C             The second leading dimension of the array A.  LDA2 >= N.
C
C     C1      (output)  DOUBLE PRECISION
C     S1      (output)  DOUBLE PRECISION
C             On exit, C1 and S1 contain the parameters for the first
C             Givens rotation.
C
C     C2      (output)  DOUBLE PRECISION
C     S2      (output)  DOUBLE PRECISION
C             On exit, if SHFT = 'D', C2 and S2 contain the parameters
C             for the second Givens rotation. Otherwise, C2 = 1, S2 = 0.
C
C     METHOD
C
C     Givens rotations are properly computed and applied.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Dec. 2018, Dec. 2020.
C
C     REVISIONS
C
C     V. Sima, Dec. 2019.
C
C     KEYWORDS
C
C     Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SHFT
      INTEGER           K, LDA1, LDA2, N, SINV
      DOUBLE PRECISION  C1, C2, S1, S2
C     .. Array Arguments ..
      INTEGER           AMAP(*), S(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*)
C     .. Local Scalars ..
      LOGICAL           SGLE
      INTEGER           AI, I, M
      DOUBLE PRECISION  ALPHA, BETA, C2R, C3, C3R, C4, C4R, C5, C5R, C6,
     $                  C6R, CS, CX, DELTA, EPSIL, ETA, GAMMA, S2R, S3,
     $                  S3R, S4, S4R, S5, S5R, S6, S6R, SS, SSS, SSSS,
     $                  SX, TEMP, THETA, VAL1, VAL2, VAL3, VAL4, VAL5,
     $                  ZETA
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARTG
C
C     .. Executable Statements ..
C
      SGLE = LSAME( SHFT, 'S' )
      M = N - 1
      AI = AMAP(K)
      CALL DLARTG( A(1,1,AI), A(2,1,AI), C1, S1, TEMP )
	CALL DLARTG( TEMP,      ONE,       C2, S2, TEMP )
C
      DO 10  I = K - 1, 1, -1
         AI = AMAP(I)
         IF ( S(AI).EQ.SINV ) THEN
            ALPHA = C2 * ( C1 * A(1,1,AI) + S1 * A(1,2,AI) )
            BETA  = S1 * C2 * A(2,2,AI)
            GAMMA = S2 * A(N,N,AI)
            CALL DLARTG( ALPHA, BETA,  C1, S1, TEMP )
            CALL DLARTG( TEMP,  GAMMA, C2, S2, VAL1 )
         ELSE
            ALPHA = C1 * S2 * A(1,1,AI)
            GAMMA = S1 * A(1,1,AI)
            BETA  = S2 * ( C1 * A(1,2,AI) + S1 * A(2,2,AI) )
            DELTA = C1 * A(2,2,AI) - S1 * A(1,2,AI)
            CALL DLARTG( DELTA, GAMMA, C1, S1, TEMP )
            ALPHA = C1 * ALPHA + S1 * BETA
            BETA  = C2 * A(N,N,AI)
            CALL DLARTG( BETA, ALPHA, C2, S2, TEMP )
         END IF
   10 CONTINUE
C
      I  = K
      AI = AMAP(I)
      ALPHA =  S2 * A(N,N,AI) - C1 * C2
      BETA  = -S1 * C2
C
      IF ( SGLE ) THEN
C
C        This is sufficient for single real shifts.
C
         CALL DLARTG( ALPHA, BETA, C1, S1, TEMP )
C
      ELSE
C
         GAMMA = -S2 * A(N,M,AI)
         CALL DLARTG( ALPHA, GAMMA, C2, S2, TEMP )
         CALL DLARTG( TEMP,  BETA,  C1, S1, TEMP )
         CX = C1 * C2
         SX = C1 * S2
         BETA  = S1 * A(N,M,AI)
         ALPHA = CX * A(N,M,AI) + SX * A(N,N,AI)
         GAMMA = S1 * A(M,M,AI)
         DELTA = CX * A(M,M,AI) + SX * A(M,N,AI)
         VAL1  = S1 * A(3,2,AI)
         VAL2  = CX * A(2,1,AI) + S1 * A(2,2,AI)
         VAL3  = CX * A(1,1,AI) + S1 * A(1,2,AI)
         CALL DLARTG( ALPHA, BETA, C1, S1, TEMP )
         CALL DLARTG( GAMMA, TEMP, C2, S2, TEMP )
         CALL DLARTG( DELTA, TEMP, C3, S3, TEMP )
         CALL DLARTG( VAL1,  TEMP, C4, S4, TEMP )
         CALL DLARTG( VAL2,  TEMP, C5, S5, TEMP )
         CALL DLARTG( VAL3,  TEMP, C6, S6, TEMP )
C
         DO 20  I = K - 1, 1, -1
            AI = AMAP(I)
C
            IF ( S(AI).EQ.SINV ) THEN
               SS    = S3 * S4
               SSS   = S2 * SS
               SSSS  = S1 * SSS
               VAL1  = C4 * A(1,3,AI)
               VAL2  = C4 * A(2,3,AI)
               VAL3  = C4 * A(3,3,AI)
               ALPHA = S4 * C3 * A(M,M,AI) + SSS  * C1 * A(M,N,AI)
               BETA  = SS * C2 * A(M,M,AI) + SSSS * A(M,N,AI)
               GAMMA = SSS  * C1 * A(N,N,AI)
               DELTA = SSSS * A(N,N,AI)
C
               SS    = S5 * S6
               CS    = C5 * S6
               VAL1  = SS * VAL1 + CS * A(1,2,AI) + C6 * A(1,1,AI)
               VAL2  = SS * VAL2 + CS * A(2,2,AI)
               VAL3  = SS * VAL3
               ALPHA = SS * ALPHA
               BETA  = SS * BETA
               GAMMA = SS * GAMMA
               DELTA = SS * DELTA
C
               CALL DLARTG( GAMMA, DELTA, C1, S1, TEMP )
               CALL DLARTG( BETA,  TEMP,  C2, S2, TEMP )
               CALL DLARTG( ALPHA, TEMP,  C3, S3, TEMP )
               CALL DLARTG( VAL3,  TEMP,  C4, S4, TEMP )
               CALL DLARTG( VAL2,  TEMP,  C5, S5, TEMP )
               CALL DLARTG( VAL1,  TEMP,  C6, S6, TEMP )
C
            ELSE
C
               DELTA =  C1 * A(N,N,AI)
               EPSIL =  S1 * A(N,N,AI)
C
               ALPHA =  C2 * A(M,M,AI)
               BETA  =  S2 * DELTA
               GAMMA = -S2 * A(M,M,AI)
               ZETA  =  C2 * A(M,N,AI) + S2 * EPSIL
               ETA   = -S2 * A(M,N,AI) + C2 * EPSIL
C
C              Update the entry (2n+1,2n+1) for G1'.
C
               DELTA = C1 * C2 * DELTA + S1*ETA
C
C              Compute the new, right rotation G2.
C
               CALL DLARTG( DELTA, -GAMMA,  C2R, S2R, TEMP )
C
C              Apply G3 to the 2-by-4 submatrix in
C              (n+1:n+2,[n+1:n+2 2n+1:2n+1]).
C
               DELTA =  C3 * A(M,M,AI)
               EPSIL =  S3 * ALPHA
               ETA   =  C3 * A(M,N,AI) + S3 * BETA
               THETA =  S3 * ZETA
               GAMMA = -S3 * A(M,M,AI)
               BETA  = -S3 * A(M,N,AI) + C3 * BETA
C
C              Update the entry (n+2,n+2) for G1' and G2R'.
C
               ALPHA = C2R * C3 * ALPHA + S2R * ( C1 * BETA +
     $                                            S1 * C3 * ZETA )
C
C              Compute the new G3.
C
               CALL DLARTG( ALPHA, -GAMMA, C3R, S3R, TEMP )
C
C              Apply G4 to the 2-by-5 submatrix in
C              ([3 n+1],[3 n+1:n+2 2n+1:2n+1]).
C
               VAL1  =  C4 * A(3,3,AI)
               VAL2  =  S4 * DELTA
               VAL3  =  S4 * EPSIL
               VAL4  =  S4 * ETA
               VAL5  =  S4 * THETA
               BETA  = -S4 * A(3,3,AI)
               DELTA =  C4 * DELTA
               EPSIL =  C4 * EPSIL
               ZETA  =  C4 * ETA
               ETA   =  C4 * THETA
C
C              Update the entry (n+1,n+1) for G1', G2R', and G3R'.
C
               ALPHA = C3R * DELTA + S3R * ( C2R * EPSIL + S2R *
     $                                      ( C1 * ZETA  + S1 * ETA ) )
C
C              Compute the new G4.
C
               CALL DLARTG( ALPHA, -BETA, C4R, S4R, TEMP )
C
C              Apply G5 to the 2-by-6 submatrix in
C              (2:3,[2:3 n+1:n+2 2n+1:2n+2]).
C
               BETA  =  C5 * A(2,2,AI)
               DELTA =  C5 * A(2,3,AI) + S5 * VAL1
               EPSIL =  S5 * VAL2
               ZETA  =  S5 * VAL3
               ETA   =  S5 * VAL4
               THETA =  S5 * VAL5
               GAMMA = -S5 * A(2,2,AI)
               VAL1  =  C5 * VAL1 - S5 * A(2,3,AI)
               VAL2  =  C5 * VAL2
               VAL3  =  C5 * VAL3
               VAL4  =  C5 * VAL4
               VAL5  =  C5 * VAL5
C
C              Update the entry (3,3) for G1', G2R', G3R', and G4R'.
C
               ALPHA = C4R * VAL1 + S4R * ( C3R * VAL2 + S3R *
     $                                    ( C2R * VAL3 + S2R *
     $                                    ( C1 * VAL4 + S1 * VAL5 ) ) )
C
C              Compute the new G5.
C
               CALL DLARTG( ALPHA, -GAMMA, C5R, S5R, TEMP )
C
C              Apply G6 to the 2-by-7 submatrix in
C              (1:2,[1:3 n+1:n+2 2n+1:2n+2]).
C
               GAMMA = -S6 * A(1,1,AI)
               BETA  =  C6 * BETA  - S6 * A(1,2,AI)
               DELTA =  C6 * DELTA - S6 * A(1,3,AI)
               EPSIL =  C6 * EPSIL
               ZETA  =  C6 * ZETA
               ETA   =  C6 * ETA
               THETA =  C6 * THETA
C
C              Update the entry (2,2) for G1', G2R', G3R', G4R', and
C              G5R'.
C
               ALPHA = C5R * BETA + S5R * ( C4R * DELTA + S4R *
     $                                    ( C3R * EPSIL + S3R *
     $                                    ( C2R * ZETA  + S2R *
     $                                    ( C1  * ETA   + S1  * THETA )
     $                                ) ) )
C
C              Compute the new G5.
C
               CALL DLARTG( ALPHA, -GAMMA, C6R, S6R, TEMP )
C
               C2 = C2R
               S2 = S2R
               C3 = C3R
               S3 = S3R
               C4 = C4R
               S4 = S4R
               C5 = C5R
               S5 = S5R
               C6 = C6R
               S6 = S6R
C
            END IF
C
   20    CONTINUE
C
C        Last step: let the rotations collap into the first factor.
C
         VAL1  =  S5 * S6
         VAL2  =  S4 * VAL1
         VAL3  =  S3 * VAL2
         ALPHA =  C3 * VAL2 - C6
         BETA  =  C2 * VAL3 - C5 * S6
         GAMMA = -C4 * VAL1
         CALL DLARTG( BETA,  GAMMA, C2, S2, TEMP )
         CALL DLARTG( ALPHA, TEMP,  C1, S1, VAL1 )
C
      END IF
C
      RETURN
C *** Last line of MB03AF ***
      END


C
C	$Id$
C
      SUBROUTINE CSINTRC1 (N,PLAT,PLON,X,Y,Z,F,LIST,LPTR,LEND,
     .                   IFLGS,SIGMA,IFLGG,GRAD, IST, FP,
     .                   IER)
      INTEGER N, LIST(*), LPTR(*), LEND(N), IFLGS, IFLGG,
     .        IST, IER
      DOUBLE PRECISION PLAT, PLON, X(N), Y(N), Z(N), F(N),
     .                 SIGMA(*), GRAD(3,N), FP
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/25/96
C
C   Given a triangulation of a set of nodes on the unit
C sphere, along with data values and gradients at the nodes,
C this routine computes a value F(P), where F interpolates
C the nodal data and is once-continuously differentiable
C over the convex hull of the nodes.  Refer to Function CSFVAL
C for further details.  If P is not contained in a triangle,
C an extrapolated value is computed by extending F beyond
C the boundary in a continuous fashion.
C
C On input:
C
C       N = Number of nodes in the triangulation.  N .GE. 3
C           and N .GE. 7 if IFLGG .LE. 0.
C
C       PLAT,PLON = Latitude and longitude in radians of the
C                   point P at which F is to be evaluated.
C
C       X,Y,Z = Arrays of length N containing Cartesian
C               coordinates of the nodes.
C
C       F = Array of length N containing values of F at the
C           nodes:  F(I) = F(X(I),Y(I),Z(I)).
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to STRIPACK
C                        Subroutine CSTRMESH.
C
C       IFLGS = Tension factor option:
C               IFLGS .LE. 0 if a single uniform tension
C                            factor is to be used.
C               IFLGS .GE. 1 if variable tension is desired.
C
C       SIGMA = Uniform tension factor (IFLGS .LE. 0), or
C               array containing tension factors associated
C               with arcs in one-to-one correspondence with
C               LIST entries (IFLGS .GE. 1).  Refer to Sub-
C               programs CSFVAL, CSGETSIG, CSSIG0, CSSIG1, and CSSIG2.
C
C       IFLGG = Gradient option:
C               IFLGG .LE. 0 if CSINTRC1 is to provide grad-
C                            ient estimates as needed (from
C                            CSGRADL).
C               IFLGG .GE. 1 if gradients are user-provided
C                            in GRAD.  This is more effici-
C                            ent if CSINTRC1 is to be called
C                            several times.
C
C       GRAD = 3 by N array whose I-th column contains
C              an estimated gradient at node I if IFLGG .GE.
C              1, or unused dummy parameter if IFLGG .LE. 0.
C              Refer to Subroutines CSGRADL and CSGRADG.
C
C       IST = Index of the starting node in the search for a
C             triangle containing P.  The output value of
C             IST from a previous call may be a good choice.
C             1 .LE. IST .LE. N.
C
C Input parameters other than IST are not altered by this
C   routine.
C
C On output:
C
C       IST = Index of one of the vertices of the triangle
C             containing P (or a boundary node if P is not
C             contained in a triangle) unless IER = 4.
C
C       FP = Value of F at P unless IER < 0, in which case
C            FP is not defined.
C
C       IER = Error indicator and information flag:
C               =  0 - no error.
C               =  1 - invalid number of input points (must be
C                      greater than 3).
C               =  4 - first three nodes are collinear.
C               =  7 - vertex of a triangle containing an interpolation
C                      point is outside its valid range.
C               =  8 - the angular distance between an interpolated
C                      point and the nearest point of the
C                      triangulation is at least 90 degrees.
C               =  9 - not enough input points to calculate a gradient.
C
C STRIPACK modules required by CSINTRC1: CSJRAND, CSLSTPTR, CSSTORE,
C                                        CSTRFIND
C                    (and optionally)  CSGETNP if IFLGG .LE. 0
C
C SSRFPACK modules required by CSINTRC1:  CSARCINT, CSARCLEN,
C                                         CSFVAL, CSHVAL, CSSNHCSH
C              (and if IFLGG .LE. 0)  CSAPLYR, CSAPLYRT, CSCONSTR,
C                                       CSGIVENS, CSGRADL,
C                                       CSROTATE, CSSETUP
C
C Intrinsic functions called by CSINTRC1:  COS, SIN, SQRT
C
C***********************************************************
C
      INTEGER CSLSTPTR
      DOUBLE PRECISION CSARCLEN, CSFVAL
      INTEGER I, IERR, I1, I2, I3, LP, N1, N2, NN
      DOUBLE PRECISION A, B1, B2, B3, DUM(3), FQ, GQ(3),
     .                 GQN, G1(3), G2(3), G3(3), P(3),
     .                 P1(3), P2(3), P3(3), PTGQ, PTN1,
     .                 PTN2, Q(3), QNORM, S1, S2, S3, S12,
     .                 SUM
C
C Local parameters:
C
C A =        Angular separation between P and Q
C B1,B2,B3 = Barycentric coordinates of the central projec-
C              tion of P onto the underlying planar triangle,
C              or (B1 and B2) projection of Q onto the
C              underlying line segment N1-N2 when P is
C              exterior.  Unnormalized coordinates are
C              computed by CSTRFIND when P is in a triangle.
C DUM =      Dummy parameter for CSARCINT
C FQ,GQ =    Interpolated value and gradient at Q
C GQN =      Negative of the component of GQ in the direction
C              Q->P
C G1,G2,G3 = Gradients at I1, I2, and I3, or (G1 and G2) at
C              N1 and N2
C I =        DO-loop index
C IERR =     Error flag for calls to CSGRADL
C I1,I2,I3 = Vertex indexes returned by CSTRFIND
C LP =       LIST pointer
C N1,N2 =    Indexes of the endpoints of a boundary arc when
C              P is exterior (not contained in a triangle)
C NN =       Local copy of N
C P =        Cartesian coordinates of P
C P1,P2,P3 = Cartesian coordinates of the vertices I1, I2,
C              and I3, or (P1 and P2) coordinates of N1 and
C              N2 if P is exterior
C PTGQ =     Scalar product (P,GQ) -- factor of the component
C              of GQ in the direction Q->P
C PTN1 =     Scalar product (P,N1) -- factor of B1 and B2
C PTN2 =     Scalar product (P,N2) -- factor of B1 and B2
C Q =        Closest boundary point to P when P is exterior
C QNORM =    Factor used to normalize Q
C S1,S2,S3 = Tension factors associated with the triangle
C              sides opposite I1, I2, and I3, or (S1) the
C              boundary arc N1-N2
C S12 =      Scalar product (N1,N2) -- factor of B1 and B2
C SUM =      Quantity used to normalize the barycentric
C              coordinates
C
      NN = N
      IF (NN .LT. 3) THEN
        GO TO 100
      ELSE IF (IFLGG .LE. 0  .AND.  NN .LT. 7) THEN
        GO TO 110
      ELSE IF (IST .LT. 1  .OR.  IST .GT. NN) THEN
        GO TO 120
      ENDIF
C
C Transform (PLAT,PLON) to Cartesian coordinates.
C
      P(1) = COS(PLAT)*COS(PLON)
      P(2) = COS(PLAT)*SIN(PLON)
      P(3) = SIN(PLAT)
C
C Locate P with respect to the triangulation.
C
      CALL CSTRFIND (IST,P,NN,X,Y,Z,LIST,LPTR,LEND, B1,B2,B3,
     .             I1,I2,I3)
      IF (I1 .EQ. 0) GO TO 130
      IST = I1
      IF (I3 .NE. 0) THEN
C
C P is contained in the triangle (I1,I2,I3).  Store the
C   vertex coordinates, gradients, and tension factors in
C   local variables.
C
        P1(1) = X(I1)
        P1(2) = Y(I1)
        P1(3) = Z(I1)
        P2(1) = X(I2)
        P2(2) = Y(I2)
        P2(3) = Z(I2)
        P3(1) = X(I3)
        P3(2) = Y(I3)
        P3(3) = Z(I3)
        IF (IFLGG .GT. 0) THEN
C
C   Gradients are user-provided.
C
          DO 1 I = 1,3
            G1(I) = GRAD(I,I1)
            G2(I) = GRAD(I,I2)
            G3(I) = GRAD(I,I3)
    1       CONTINUE
        ELSE
C
C   Compute gradient estimates at the vertices.
C
          CALL CSGRADL (NN,I1,X,Y,Z,F,LIST,LPTR,LEND, G1,IERR)
          IF (IERR .LT. 0) GO TO 130
          CALL CSGRADL (NN,I2,X,Y,Z,F,LIST,LPTR,LEND, G2,IERR)
          IF (IERR .LT. 0) GO TO 130
          CALL CSGRADL (NN,I3,X,Y,Z,F,LIST,LPTR,LEND, G3,IERR)
          IF (IERR .LT. 0) GO TO 130
        ENDIF
C
        IF (IFLGS .GT. 0) THEN
C
C   Variable tension:
C
          LP = CSLSTPTR(LEND(I2),I3,LIST,LPTR)
          S1 = SIGMA(LP)
          LP = CSLSTPTR(LEND(I3),I1,LIST,LPTR)
          S2 = SIGMA(LP)
          LP = CSLSTPTR(LEND(I1),I2,LIST,LPTR)
          S3 = SIGMA(LP)
        ELSE
C
C   Uniform tension:
C
          S1 = SIGMA(1)
          S2 = S1
          S3 = S1
        ENDIF
C
C Normalize the coordinates.
C
        SUM = B1 + B2 + B3
        B1 = B1/SUM
        B2 = B2/SUM
        B3 = B3/SUM
        FP = CSFVAL(B1,B2,B3,P1,P2,P3,F(I1),F(I2),F(I3),G1,
     .            G2,G3,S1,S2,S3)
        IER = 0
        RETURN
      ENDIF
C
C P is exterior to the triangulation, and I1 and I2 are
C   boundary nodes which are visible from P.  Extrapolate to
C   P by linear (with respect to arc-length) interpolation
C   of the value and directional derivative (gradient comp-
C   onent in the direction Q->P) of the interpolatory
C   surface at Q where Q is the closest boundary point to P.
C
C Determine Q by traversing the boundary starting from I1.
C
      N1 = I1
      PTN1 = P(1)*X(N1) + P(2)*Y(N1) + P(3)*Z(N1)
      IF (I1 .NE. I2) GO TO 3
C
C All boundary nodes are visible from P.  Find a boundary
C   arc N1->N2 such that P Left (N2 X N1)->N1.
C
C Counterclockwise boundary traversal:
C   Set N2 to the first neighbor of N1.
C
    2 LP = LEND(N1)
        LP = LPTR(LP)
        N2 = LIST(LP)
C
C Compute inner products (N1,N2) and (P,N2), and compute
C   B2 = Det(P,N1,N2 X N1).
C
        S12 = X(N1)*X(N2) + Y(N1)*Y(N2) + Z(N1)*Z(N2)
        PTN2 = P(1)*X(N2) + P(2)*Y(N2) + P(3)*Z(N2)
        B2 = PTN2 - S12*PTN1
        IF (B2 .LE. 0.) GO TO 3
C
C P Right (N2 X N1)->N1:  iterate.
C
        N1 = N2
        I1 = N1
        PTN1 = PTN2
        GO TO 2
C
C P Left (N2 X N1)->N1 where N2 is the first neighbor of N1.
C   Clockwise boundary traversal:
C
    3 N2 = N1
        PTN2 = PTN1
C
C Set N1 to the last neighbor of N2 and test for
C   termination.
C
        LP = LEND(N2)
        N1 = -LIST(LP)
        IF (N1 .EQ. I1) GO TO 140
C
C Compute inner products (N1,N2) and (P,N1).
C
        S12 = X(N1)*X(N2) + Y(N1)*Y(N2) + Z(N1)*Z(N2)
        PTN1 = P(1)*X(N1) + P(2)*Y(N1) + P(3)*Z(N1)
C
C Compute B2 = Det(P,N1,N2 X N1) = Det(Q,N1,N2 X N1)*(P,Q).
C
        B2 = PTN2 - S12*PTN1
        IF (B2 .LE. 0.) GO TO 3
C
C Compute B1 = Det(P,N2 X N1,N2) = Det(Q,N2 X N1,N2)*(P,Q).
C
      B1 = PTN1 - S12*PTN2
      IF (B1 .LE. 0.) THEN
C
C Q = N2.  Store value, coordinates, and gradient at Q.
C
        FQ = F(N2)
        Q(1) = X(N2)
        Q(2) = Y(N2)
        Q(3) = Z(N2)
        IF (IFLGG .GT. 0) THEN
          DO 4 I = 1,3
            GQ(I) = GRAD(I,N2)
    4       CONTINUE
        ELSE
          CALL CSGRADL (NN,N2,X,Y,Z,F,LIST,LPTR,LEND, GQ,IERR)
          IF (IERR .LT. 0) GO TO 130
        ENDIF
C
C Extrapolate to P:  FP = FQ + A*(GQ,Q X (PXQ)/SIN(A)),
C   where A is the angular separation between Q and P,
C   and Sin(A) is the magnitude of P X Q.
C
        A = CSARCLEN(Q,P)
        PTGQ = P(1)*GQ(1) + P(2)*GQ(2) + P(3)*GQ(3)
        FP = FQ
        IF (A .NE. 0.) FP = FP + PTGQ*A/SIN(A)
        IER = 0
        RETURN
      ENDIF
C
C P Strictly Left (N2 X N1)->N2 and P Strictly Left
C   N1->(N2 X N1).  Thus Q lies on the interior of N1->N2.
C   Store coordinates of N1 and N2 in local variables.
C
      P1(1) = X(N1)
      P1(2) = Y(N1)
      P1(3) = Z(N1)
      P2(1) = X(N2)
      P2(2) = Y(N2)
      P2(3) = Z(N2)
C
C Compute the central projection of Q onto P2-P1 and
C   normalize to obtain Q.
C
      QNORM = 0.
      DO 5 I = 1,3
        Q(I) = B1*P1(I) + B2*P2(I)
        QNORM = QNORM + Q(I)*Q(I)
    5   CONTINUE
      QNORM = SQRT(QNORM)
      DO 6 I = 1,3
        Q(I) = Q(I)/QNORM
    6   CONTINUE
C
C Store gradients at N1 and N2 and tension factor S1.
C
      IF (IFLGG .GT. 0) THEN
        DO 7 I = 1,3
          G1(I) = GRAD(I,N1)
          G2(I) = GRAD(I,N2)
    7     CONTINUE
      ELSE
        CALL CSGRADL (NN,N1,X,Y,Z,F,LIST,LPTR,LEND, G1,IERR)
        IF (IERR .LT. 0) GO TO 130
        CALL CSGRADL (NN,N2,X,Y,Z,F,LIST,LPTR,LEND, G2,IERR)
        IF (IERR .LT. 0) GO TO 130
      ENDIF
C
      IF (IFLGS .LE. 0) S1 = SIGMA(1)
      IF (IFLGS .GE. 1) S1 = SIGMA(LP)
C
C Compute an interpolated value and normal gradient
C   component at Q.
C
      CALL CSARCINT (Q,P1,P2,F(N1),F(N2),G1,G2,S1, FQ,DUM,GQN)
C
C Extrapolate to P:  the normal gradient component GQN is
C   the negative of the component in the direction Q->P.
C
      FP = FQ - GQN*CSARCLEN(Q,P)
      IER = 0
      RETURN
C
C  Invalid number of input points (must be greater than 3).
C
  100 CONTINUE
      IER = 1
      RETURN
C
C  Not enough input points to calculate a gradient.
C
  110 CONTINUE
      IER = 9
      RETURN
C
C  Vertex of a triangle containing an interpolation point is outside
C  its valid range.
C
  120 CONTINUE
      IER = 7
      RETURN
C
C  First three nodes are collinear.
C
  130 CONTINUE
      IER = 4
      RETURN
C
  140 CONTINUE
      IER = 8
      RETURN
C
      END