istp/gray
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity

some cleaning in eccd routines

Browse Source
This commit is contained in:
Lorenzo Figini 2015-06-17 09:50:00 +00:00
parent cc9a10a525
commit 2333f83914
1 changed files with 52 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
src/gray.f
View File

@ -5939,13 +5939,11 @@ c
apar(15) = ygn apar(15) = ygn
c c
npar=nfpp+necp npar=nfpp+necp
do i=1,necp apar(nfpp+1:npar) = eccdpar(1:necp)
apar(nfpp+i) = eccdpar(i)
end do
c c
if(duu.gt.1.0e-6_wp_) then if(duu.gt.1.0e-6_wp_) then
call dqagsmv(fpp,uu1,uu2,apar,npar,epsa,epsr,resp,epp,neval, call dqagsmv(fpp,uu1,uu2,apar(1:nfpp),nfpp,epsa,epsr,resp,
. ier,liw,lw,last,iw,w) . epp,neval,ier,liw,lw,last,iw,w)
if (ier.gt.0) ierr=90 if (ier.gt.0) ierr=90
end if end if
c c
@ -6058,9 +6056,9 @@ c
anpl=extrapar(2) anpl=extrapar(2)
amu=extrapar(3) amu=extrapar(3)
anprre=extrapar(4) anprre=extrapar(4)
ex=dcmplx(extrapar(5),extrapar(6)) ex=cmplx(extrapar(5),extrapar(6),wp_)
ey=dcmplx(extrapar(7),extrapar(8)) ey=cmplx(extrapar(7),extrapar(8),wp_)
ez=dcmplx(extrapar(9),extrapar(10)) ez=cmplx(extrapar(9),extrapar(10),wp_)
ithn=int(extrapar(11)) ithn=int(extrapar(11))
nhn=int(extrapar(12)) nhn=int(extrapar(12))
uplp=extrapar(13) uplp=extrapar(13)
@ -6154,10 +6152,6 @@ c local variables
c c
anpl=extrapar(2) anpl=extrapar(2)
anprre=extrapar(4) anprre=extrapar(4)
ex=dcmplx(extrapar(5),extrapar(6))
ey=dcmplx(extrapar(7),extrapar(8))
ez=dcmplx(extrapar(9),extrapar(10))
nhn=int(extrapar(12))
uplp=extrapar(13) uplp=extrapar(13)
uplm=extrapar(14) uplm=extrapar(14)
ygn=extrapar(15) ygn=extrapar(15)
@ -6238,11 +6232,6 @@ c local variables
complex(wp_) :: ex,ey,ez complex(wp_) :: ex,ey,ez
c c
anpl=extrapar(2) anpl=extrapar(2)
anprre=extrapar(4)
ex=dcmplx(extrapar(5),extrapar(6))
ey=dcmplx(extrapar(7),extrapar(8))
ez=dcmplx(extrapar(9),extrapar(10))
nhn=int(extrapar(12))
ygn=extrapar(15) ygn=extrapar(15)
zeff=extrapar(16) zeff=extrapar(16)
@ -6291,28 +6280,35 @@ c extrapar(15) = ygn
c c
c extrapar(16) = zeff c extrapar(16) = zeff
c extrapar(17) = fc c extrapar(17) = fc
c extrapar(18) = hb c extrapar(18) = rbx
c extrapar(19:18+(npar-18)/2) = tlm c extrapar(19:18+(npar-18)/2) = tlm
c extrapar(19+(npar-18)/2:npar) = chlm c extrapar(19+(npar-18)/2:npar) = chlm
c c
use const_and_precisions, only : wp_ use const_and_precisions, only : wp_
use green_func_p, only: GenSpitzFunc use green_func_p, only: GenSpitzFunc
use dierckx, only : splev,splder
implicit none implicit none
c arguments c arguments
integer :: npar integer :: npar
real(wp_) :: upl,fjncl real(wp_) :: upl,fjncl
real(wp_), dimension(npar) :: extrapar real(wp_), dimension(npar) :: extrapar
c local constants
integer, parameter :: ksp=3
c local variables c local variables
integer :: nlm integer :: nlm
real(wp_) :: anpl,amu,ygn,zeff,fc,hb,gam,u2,u,upr2, real(wp_) :: anpl,amu,ygn,zeff,fc,rbx,gam,u2,u,upr2,
. bth,uth,fk,dfk,alam,fu,dfu,eta,fpp . bth,uth,fk,dfk,alam,fu,dfu,eta,fpp
c local variables
integer :: ier
real(wp_), dimension((npar-18)/2) :: wrk
real(wp_), dimension(1) :: xs,ys
c c
anpl=extrapar(2) anpl=extrapar(2)
amu=extrapar(3) amu=extrapar(3)
ygn=extrapar(15) ygn=extrapar(15)
zeff=extrapar(16) zeff=extrapar(16)
fc=extrapar(17) fc=extrapar(17)
hb=extrapar(18) rbx=extrapar(18)
gam=anpl*upl+ygn gam=anpl*upl+ygn
u2=gam*gam-1.0_wp_ u2=gam*gam-1.0_wp_
@ -6324,13 +6320,18 @@ c
fk=fk*(4.0_wp_/amu**2) fk=fk*(4.0_wp_/amu**2)
dfk=dfk*(2.0_wp_/amu)*bth dfk=dfk*(2.0_wp_/amu)*bth
alam=upr2/u2/hb alam=upr2/u2/rbx
nlm=(npar-18)/2 nlm=(npar-18)/2
call vlambda(alam,extrapar(19), xs(1)=alam
. extrapar(19+nlm), c
. nlm,fu,dfu) call splev(extrapar(19:18+nlm),nlm,extrapar(19+nlm:npar),3,
. xs(1),ys(1),1,ier)
fu=ys(1)
call splder(extrapar(19:18+nlm),nlm,extrapar(19+nlm:npar),3,1,
. xs(1),ys(1),1,wrk,ier)
dfu=ys(1)
eta=gam*fu*dfk/u-2.0_wp_*(anpl-gam*upl/u2)*fk*dfu*upl/u2/hb eta=gam*fu*dfk/u-2.0_wp_*(anpl-gam*upl/u2)*fk*dfu*upl/u2/rbx
if(upl.lt.0) eta=-eta if(upl.lt.0) eta=-eta
fjncl=eta*fpp(upl,extrapar,npar) fjncl=eta*fpp(upl,extrapar,npar)
return return
@ -6338,32 +6339,32 @@ c
c c
c c
c c
subroutine vlambda(alam,tlm,chlm,nlmt,fv,dfv) C subroutine vlambda(alam,tlm,chlm,nlmt,fv,dfv)
use const_and_precisions, only : wp_ C use const_and_precisions, only : wp_
use dierckx, only : splev,splder C use dierckx, only : splev,splder
implicit none C implicit none
c local constants Cc local constants
integer, parameter :: ksp=3 C integer, parameter :: ksp=3
c arguments Cc arguments
integer :: nlmt C integer :: nlmt
real(wp_) :: alam,fv,dfv C real(wp_) :: alam,fv,dfv
real(wp_), dimension(nlmt) :: tlm,chlm C real(wp_), dimension(nlmt) :: tlm,chlm
c local variables Cc local variables
integer :: nlm,ier C integer :: nlm,ier
real(wp_), dimension(nlmt) :: wrk C real(wp_), dimension(nlmt) :: wrk
real(wp_), dimension(1) :: xxs,ffs C real(wp_), dimension(1) :: xxs,ffs
c Cc
nlm=nlmt C nlm=nlmt
xxs(1)=alam C xxs(1)=alam
c Cc
call splev(tlm,nlm,chlm,ksp,xxs(1),ffs(1),1,ier) C call splev(tlm,nlm,chlm,ksp,xxs(1),ffs(1),1,ier)
fv=ffs(1) C fv=ffs(1)
c Cc
call splder(tlm,nlm,chlm,ksp,1,xxs(1),ffs(1),1,wrk,ier) C call splder(tlm,nlm,chlm,ksp,1,xxs(1),ffs(1),1,wrk,ier)
dfv=ffs(1) C dfv=ffs(1)
c Cc
return C return
end C end
c c
c c
c c