6778 lines
180 KiB
Fortran
6778 lines
180 KiB
Fortran
use graydata_flags, only : ipass,igrad
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
|
|
common/ierr/ierr
|
|
common/mode/sox
|
|
common/p0/p0mw
|
|
common/powrfl/powrfl
|
|
common/index_rt/index_rt
|
|
common/taumnx/taumn,taumx,pabstot,currtot
|
|
|
|
c read data plus initialization
|
|
|
|
index_rt=1
|
|
call prfile
|
|
call paraminit
|
|
call read_data
|
|
call vectinit
|
|
if(igrad.eq.0) call ic_rt
|
|
if(igrad.gt.0) call ic_gb
|
|
if(ierr.gt.0) then
|
|
print*,' IERR = ', ierr
|
|
stop
|
|
end if
|
|
|
|
c beam/ray propagation
|
|
call gray_integration
|
|
|
|
c postprocessing
|
|
|
|
call after_gray_integration
|
|
|
|
pabstott=pabstot
|
|
currtott=currtot
|
|
|
|
if (ipass.gt.1) then
|
|
c second pass into plasma
|
|
p0mw1=p0mw
|
|
igrad=0
|
|
|
|
index_rt=2
|
|
p0mw=p0mw1*powrfl
|
|
call prfile
|
|
call vectinit2
|
|
call paraminit
|
|
call ic_rt2
|
|
call gray_integration
|
|
call after_gray_integration
|
|
pabstott=pabstott+pabstot
|
|
currtott=currtott+currtot
|
|
|
|
index_rt=3
|
|
sox=-sox
|
|
p0mw=p0mw1*(1.0d0-powrfl)
|
|
call prfile
|
|
call vectinit2
|
|
call paraminit
|
|
call ic_rt2
|
|
call gray_integration
|
|
call after_gray_integration
|
|
pabstott=pabstott+pabstot
|
|
currtott=currtott+currtot
|
|
end if
|
|
print*,' '
|
|
write(6,*) 'Pabs (MW), Icd (kA) = ', pabstott,currtott*1.0d+3
|
|
|
|
end
|
|
|
|
|
|
subroutine gray_integration
|
|
use graydata_flags, only : dst
|
|
|
|
implicit none
|
|
integer istep,istop,index_rt
|
|
integer nstep
|
|
real*8 st,strfl11
|
|
integer i
|
|
real*8 st0
|
|
|
|
common/ss/st
|
|
common/istep/istep
|
|
common/nstep/nstep
|
|
common/istop/istop
|
|
common/strfl11/strfl11
|
|
common/index_rt/index_rt
|
|
|
|
c ray integration: begin
|
|
st0=0.0d0
|
|
if(index_rt.gt.1) st0=strfl11
|
|
do i=1,nstep
|
|
istep=i
|
|
st=i*dst+st0
|
|
|
|
c advance one step
|
|
|
|
call rkint4
|
|
|
|
c calculations after one step:
|
|
|
|
call after_onestep(istep,istop)
|
|
if(istop.eq.1) exit
|
|
c
|
|
end do
|
|
|
|
c ray integration: end
|
|
|
|
return
|
|
end
|
|
|
|
|
|
subroutine after_gray_integration
|
|
use const_and_precisions, only : zero
|
|
use graydata_flags, only : ibeam,iwarm,ilarm,iequil,iprof,
|
|
. filenmeqq,filenmprf,filenmbm
|
|
use graydata_anequil, only : dens0,te0
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
c
|
|
common/ss/st
|
|
common/nray/nrayr,nrayth
|
|
common/index_rt/index_rt
|
|
common/taumnx/taumn,taumx,pabstot,currtot
|
|
c
|
|
c print all ray positions in local reference system
|
|
c
|
|
if(nrayr.gt.1) then
|
|
iproj=1
|
|
nfilp=9
|
|
call projxyzt(iproj,nfilp)
|
|
end if
|
|
c
|
|
c print final results on screen
|
|
c
|
|
write(*,*)
|
|
write(*,'(a,f9.4)') 'final step (s, ct, Sr) = ',st
|
|
if(iwarm.gt.0) then
|
|
write(*,'(a,2e12.5)') 'taumn, taumx = ', taumn,taumx
|
|
else
|
|
write(*,'(a,2f9.4)') 'taumn, taumx = ', zero,zero
|
|
end if
|
|
c
|
|
write(*,'(a,f9.4)') 'Pabs_tot (MW) = ',pabstot
|
|
currtka =currtot*1.0d3
|
|
write(*,'(a,f9.4)') 'I_tot (kA) = ',currtka
|
|
c
|
|
if (index_rt.eq.1) then
|
|
if(iequil.eq.2) write(*,*) 'EQUILIBRIUM CASE : ',filenmeqq
|
|
if(iequil.eq.1) write(*,*) 'ANALTYCAL EQUILIBRIUM'
|
|
if(iprof.eq.1) write(*,*) 'PROFILE file : ',filenmprf
|
|
if(iprof.eq.0) write(*,*) 'ANALTYCAL PROFILES ne0,Te0',dens0,te0
|
|
if(ibeam.ge.1) write(*,*) 'LAUNCHER CASE : ',filenmbm
|
|
|
|
end if
|
|
c
|
|
c compute power and current density profiles for all rays
|
|
c
|
|
pabs=pabstot
|
|
currt=currtot
|
|
call pec(pabs,currt)
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine after_onestep(i,istop)
|
|
use const_and_precisions, only : pi
|
|
use reflections, only : inside
|
|
use graydata_flags, only : iwarm,istpr0,istpl0,dst,ipass,igrad
|
|
use graydata_par, only : psipol0,chipol0
|
|
use interp_eqprof, only : zbmin,zbmax,rlim,zlim,nlim
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
complex*16 ext,eyt,extr,eytr,exin2,eyin2
|
|
parameter(jmx=31,kmx=36,nmx=8000)
|
|
parameter(taucr=12.0d0)
|
|
dimension psjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx),ccci(jmx,kmx,nmx)
|
|
dimension iiv(jmx,kmx),tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx)
|
|
dimension iop(jmx,kmx),iow(jmx,kmx),ihcd(jmx,kmx),istore(jmx,kmx)
|
|
dimension tau1v(jmx,kmx),yyrfl(jmx,kmx,6),y(6),dery(6)
|
|
dimension ext(jmx,kmx,0:4),eyt(jmx,kmx,0:4)
|
|
dimension xv(3),anv(3),xvrfl(3),anvrfl(3),xvvac(3),anw(3),anwcl(3)
|
|
dimension xwcl(3),xvjk(3,jmx,kmx),anvjk(3,jmx,kmx)
|
|
dimension ywrk(6,jmx,kmx),ypwrk(6,jmx,kmx)
|
|
logical ins_pl,inside_plasma
|
|
external inside_plasma
|
|
c
|
|
common/pcjki/ppabs,ccci
|
|
common/atjki/tauv,alphav
|
|
common/tau1v/tau1v
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
common/istgr/istpr,istpl
|
|
c
|
|
common/iiv/iiv
|
|
common/iov/iop,iow,ihcd,istore
|
|
common/refln/anwcl,xwcl,jclosest
|
|
common/psjki/psjki
|
|
common/psival/psinv
|
|
common/psinv11/psinv11
|
|
common/ierr/ierr
|
|
common/taumnx/taumn,taumx,pabstot,currtot
|
|
common/xv/xv
|
|
common/anv/anv
|
|
c
|
|
common/polcof/psipol,chipol
|
|
common/evt/ext,eyt
|
|
common/yyrfl/yyrfl
|
|
common/powrfl/powrfl
|
|
common/strfl11/strfl11
|
|
common/index_rt/index_rt
|
|
c
|
|
common/wrk/ywrk,ypwrk
|
|
c
|
|
pabstot=0.0d0
|
|
currtot=0.0d0
|
|
taumn=1d+30
|
|
taumx=-1d+30
|
|
psinv11=1.0d0
|
|
iopmin=100
|
|
iowmin=100
|
|
iowmax=0
|
|
|
|
if(i.eq.1) then
|
|
psipol=psipol0
|
|
chipol=chipol0
|
|
end if
|
|
c
|
|
do j=1,nrayr
|
|
kkk=nrayth
|
|
if(j.eq.1) kkk=1
|
|
do k=1,kkk
|
|
call gwork(j,k)
|
|
c
|
|
if(ierr.gt.0) then
|
|
write(*,*) ' IERR = ', ierr
|
|
if(ierr.eq.97) then
|
|
c igrad=0
|
|
c ierr=0
|
|
else
|
|
istop=1
|
|
c exit
|
|
end if
|
|
end if
|
|
|
|
psjki(j,k,i)=psinv
|
|
rrm=sqrt(xv(1)**2+xv(2)**2)/100.d0
|
|
zzm=xv(3)/100.d0
|
|
|
|
if (iwarm.gt.0.and.i.gt.1.and.ihcd(j,k).gt.0) then
|
|
if(psinv.ge.0.and.psinv.le.1.0d0.and.
|
|
. zzm.ge.zbmin.and.zzm.le.zbmax) then
|
|
call pabs_curr(i,j,k)
|
|
iiv(j,k)=i
|
|
else
|
|
if(iiv(j,k).gt.1) tauv(j,k,i)=tauv(j,k,i-1)
|
|
end if
|
|
if(tauv(j,k,i).le.taumn) taumn=tauv(j,k,i)
|
|
if(tauv(j,k,i).ge.taumx) taumx=tauv(j,k,i)
|
|
pabstot=pabstot+ppabs(j,k,iiv(j,k))
|
|
currtot=currtot+ccci(j,k,iiv(j,k))
|
|
end if
|
|
call print_output(i,j,k)
|
|
|
|
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
ins_pl=inside_plasma(rrm,zzm)
|
|
if (mod(iop(j,k),2).eq.0 .and. ins_pl) then
|
|
iop(j,k)=iop(j,k)+1
|
|
call pol_limit(ext(j,k,iop(j,k)),eyt(j,k,iop(j,k)))
|
|
|
|
if (ipass.gt.1 .and. index_rt.eq.1 .and.
|
|
. iowmax.gt.1 .and. istore(j,k).eq.0) then
|
|
istore(j,k)=istore(j,k)+1
|
|
yyrfl(j,k,1:3)=xv
|
|
yyrfl(j,k,4:6)=anv
|
|
ihcd(j,k)=0
|
|
end if
|
|
else if (mod(iop(j,k),2).eq.1.and.
|
|
. .not.ins_pl) then
|
|
iop(j,k)=iop(j,k)+1
|
|
call pol_limit(ext(j,k,iop(j,k)),eyt(j,k,iop(j,k)))
|
|
end if
|
|
|
|
if (ipass.gt.1) then
|
|
if (iow(j,k).eq.0 .and. inside(rlim,zlim,nlim,rrm,zzm)) then
|
|
iow(j,k)=1
|
|
else if (iow(j,k).eq.1 .and.
|
|
. .not.inside(rlim,zlim,nlim,rrm,zzm)) then
|
|
iow(j,k)=2
|
|
if (ins_pl) then
|
|
iop(j,k)=iop(j,k)+1
|
|
call pol_limit(ext(j,k,iop(j,k)),eyt(j,k,iop(j,k)))
|
|
end if
|
|
call wall_refl(xv-dst*anv,anv,ext(j,k,iop(j,k)),
|
|
. eyt(j,k,iop(j,k)),xvrfl,anvrfl,extr,eytr,anw,irfl)
|
|
istore(j,k)=istore(j,k)+1
|
|
yyrfl(j,k,1:3)=xvrfl
|
|
yyrfl(j,k,4:6)=anvrfl
|
|
tau1v(j,k)=tauv(j,k,iiv(j,k))
|
|
ext(j,k,iop(j,k))=extr
|
|
eyt(j,k,iop(j,k))=eytr
|
|
if (j.lt.jclosest) then
|
|
jclosest=j
|
|
anwcl=anw
|
|
xwcl=xvrfl
|
|
end if
|
|
xv=xvrfl
|
|
anv=anvrfl
|
|
rrm=1.d-2*sqrt(xv(1)**2+xv(2)**2)
|
|
zzm=1.d-2*xv(3)
|
|
ywrk(1:3,j,k)=xv
|
|
ywrk(4:6,j,k)=anv
|
|
igrad=0
|
|
call gwork(j,k)
|
|
if (ins_pl) then
|
|
iop(j,k)=iop(j,k)+1
|
|
call pol_limit(ext(j,k,iop(j,k)),eyt(j,k,iop(j,k)))
|
|
if (index_rt.eq.1) ihcd(j,k)=0
|
|
end if
|
|
end if
|
|
end if
|
|
|
|
if(index_rt.eq.1 .and. j.eq.1) psinv11=psinv
|
|
if(iop(j,k).lt.iopmin) iopmin=iop(j,k)
|
|
if(iow(j,k).lt.iowmin) iowmin=iow(j,k)
|
|
if(iow(j,k).gt.iowmax) iowmax=iow(j,k)
|
|
|
|
xvjk(:,j,k)=xv
|
|
anvjk(:,j,k)=anv
|
|
|
|
end do
|
|
end do
|
|
|
|
if(jclosest.le.nrayr) then
|
|
aknmin=1.0d0
|
|
do j=1,nrayr
|
|
kkk=nrayth
|
|
if(j.eq.1) kkk=1
|
|
do k=1,kkk
|
|
anwclr=(anwcl(1)*xwcl(1)+anwcl(2)*xwcl(2))
|
|
. /sqrt(xwcl(1)**2+xwcl(2)**2)
|
|
anvjkr=(anvjk(1,j,k)*xvjk(1,j,k)+anvjk(2,j,k)*xvjk(2,j,k))
|
|
. /sqrt(xvjk(1,j,k)**2+xvjk(2,j,k)**2)
|
|
akdotn=anwclr*anvjkr+anwcl(3)*anvjk(3,j,k)
|
|
if(akdotn.lt.aknmin) aknmin=akdotn
|
|
end do
|
|
end do
|
|
else
|
|
aknmin=-1.0d0
|
|
end if
|
|
|
|
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
|
|
c print ray positions for j=nrayr in local reference system
|
|
|
|
istpr=istpr+1
|
|
if (istpr.eq.istpr0) then
|
|
c print*,'istep = ',i
|
|
if(nrayr.gt.1) then
|
|
iproj=0
|
|
nfilp=8
|
|
call projxyzt(iproj,nfilp)
|
|
end if
|
|
istpr=0
|
|
end if
|
|
c
|
|
if (istpl.eq.istpl0) istpl=0
|
|
istpl=istpl+1
|
|
|
|
|
|
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
|
|
c single pass is stopped when all the rays have crossed the plasma
|
|
c or complete absorption has occurred
|
|
c same for successive passes of multi-pass simulations (here exit
|
|
c from vessel is detected too
|
|
c first pass in multi-pass simulation is stopped when at least one
|
|
c ray has reflected and all rays are directed away from
|
|
c reflection point, or when no reflection has occurred and
|
|
c central ray re-enters the plasma
|
|
|
|
if((ipass.eq.1 .and. ((iopmin.gt.1) .or.
|
|
. (taumn.lt.1d+30.and.taumn.gt.taucr)))
|
|
. .or.(index_rt.gt.1 .and. (iopmin.gt.1 .or. iowmin.gt.1 .or.
|
|
. (taumn.lt.1d+30.and.taumn.gt.taucr)))) then
|
|
istop=1
|
|
else if(ipass.gt.1 .and. index_rt.eq.1 .and.
|
|
. ((iowmin.gt.1 .and. aknmin.gt.0) .or.
|
|
. (iowmax.le.1 .and. iop(1,1).gt.2))) then
|
|
c flag second pass mode coupling as unset
|
|
powrfl=-1.0d0
|
|
qqout=0.0d0
|
|
uuout=0.0d0
|
|
vvout=0.0d0
|
|
do j=1,nrayr
|
|
kkk=nrayth
|
|
if(j.eq.1) kkk=1
|
|
do k=1,kkk
|
|
c store missing initial conditions for the second pass
|
|
if (istore(j,k).eq.0) then
|
|
istore(j,k)=istore(j,k)+1
|
|
yyrfl(j,k,1:3)=xvjk(:,j,k)
|
|
yyrfl(j,k,4:6)=anvjk(:,j,k)
|
|
tau1v(j,k)=tauv(j,k,iiv(j,k))
|
|
end if
|
|
c determine mode coupling at the plasma boundary
|
|
if (powrfl.lt.0.0d0) then
|
|
call vacuum_rt(xvjk(:,j,k),anvjk(:,j,k),xvvac,ivac)
|
|
c look for first ray hitting the plasma, starting from the central
|
|
c and evaluate polarization
|
|
if (ivac.eq.1) then
|
|
y(1:3)=xvjk(:,j,k)
|
|
y(4:6)=anvjk(:,j,k)
|
|
call fwork(y,dery)
|
|
call pol_limit(exin2,eyin2)
|
|
call stokes(exin2,eyin2,qqin2,uuin2,vvin2)
|
|
powloop: do j1=1,nrayr
|
|
kkkk=nrayth
|
|
if(j1.eq.1) kkkk=1
|
|
do k1=1,kkkk
|
|
c look for first ray which completed the first pass in the plasma
|
|
if (iop(j1,k1).gt.1) then
|
|
c if found, use its polarization state to compute mode coupling
|
|
call stokes(ext(j1,k1,2),eyt(j1,k1,2),
|
|
. qqout,uuout,vvout)
|
|
exit powloop
|
|
end if
|
|
end do
|
|
end do powloop
|
|
c if no ray completed a first pass in the plasma, use central ray
|
|
c initial polarization (possibly reflected)
|
|
if (qqout.le.0.0d0) then
|
|
call stokes(ext(1,1,0),eyt(1,1,0),qqout,uuout,vvout)
|
|
end if
|
|
powrfl=0.5d0*(1.0d0+vvout*vvin2+
|
|
. uuout*uuin2+qqout*qqin2)
|
|
end if
|
|
end if
|
|
end do
|
|
end do
|
|
strfl11=i*dst
|
|
write(6,*) ' '
|
|
write(6,*) 'Reflected power fraction =',powrfl
|
|
write(66,*) psipol0,chipol0,powrfl
|
|
istop=1
|
|
end if
|
|
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine print_output(i,j,k)
|
|
use const_and_precisions, only : pi
|
|
use graydata_flags, only : iequil,istpl0
|
|
use graydata_par, only : psdbnd
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(ndim=6,jmx=31,kmx=36,nmx=8000)
|
|
parameter(taucr=12.0d0)
|
|
dimension ywrk(ndim,jmx,kmx),ypwrk(ndim,jmx,kmx)
|
|
dimension psjki(jmx,kmx,nmx)
|
|
dimension tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx)
|
|
dimension pdjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx)
|
|
dimension currj(jmx,kmx,nmx),didst(jmx,kmx,nmx),ccci(jmx,kmx,nmx)
|
|
dimension q(jmx),tau1v(jmx,kmx)
|
|
complex*16 ex,ey,ez
|
|
|
|
c
|
|
common/psjki/psjki
|
|
common/atjki/tauv,alphav
|
|
common/dpjjki/pdjki,currj
|
|
common/pcjki/ppabs,ccci
|
|
common/dcjki/didst
|
|
common/nharm/nharm,nhf
|
|
common/iokh/iohkawa
|
|
common/p0/p0mw
|
|
common/tau1v/tau1v
|
|
common/qw/q
|
|
common/index_rt/index_rt
|
|
|
|
common/ss/st
|
|
common/nray/nrayr,nrayth
|
|
common/istgr/istpr,istpl
|
|
c
|
|
common/parpl/brr,bphi,bzz,ajphi
|
|
common/btot/btot
|
|
common/xgxg/xg
|
|
common/ygyg/yg
|
|
common/dens/dens,ddens
|
|
common/tete/tekev
|
|
common/absor/alpha,effjcd,akim,tau0
|
|
common/epolar/ex,ey,ez
|
|
c
|
|
common/nplr/anpl,anpr
|
|
common/ddd/ddr,an2s,an2,fdia,bdotgr,ddi,ddr11
|
|
common/nprw/anprr,anpri
|
|
c
|
|
common/wrk/ywrk,ypwrk
|
|
c
|
|
x=ywrk(1,j,k)
|
|
y=ywrk(2,j,k)
|
|
z=ywrk(3,j,k)
|
|
rr=sqrt(x*x+y*y)
|
|
c
|
|
anx=ywrk(4,j,k)
|
|
any=ywrk(5,j,k)
|
|
anz=ywrk(6,j,k)
|
|
anr=(anx*x+any*y)/rr
|
|
anphi=(any*x-anx*y)/rr
|
|
c cnphi=(any*x-anx*y)
|
|
c
|
|
rrm=rr*1.0d-2
|
|
zzm=z*1.0d-2
|
|
stm=st*1.0d-2
|
|
xxm=x*1.0d-2
|
|
yym=y*1.0d-2
|
|
c
|
|
if(index_rt.gt.1) then
|
|
taujk=tauv(j,k,i)+tau1v(j,k)
|
|
else
|
|
taujk=tauv(j,k,i)
|
|
end if
|
|
|
|
c central ray only begin
|
|
if(j.eq.1) then
|
|
phi=acos(x/sqrt(y*y+x*x))
|
|
if(y.lt.0.0d0) phi=-phi
|
|
phideg=phi*180.0d0/pi
|
|
psi=psjki(j,k,i)
|
|
rhot=1.0d0
|
|
bbr=0.0d0
|
|
bbz=0.0d0
|
|
bpol=0.0d0
|
|
rhot=1.0d0
|
|
dens11=0.0d0
|
|
if(psi.ge.0.0d0) then
|
|
if (psi.le.1.0d0) rhot=frhotor(psi)
|
|
bbr=brr
|
|
bbz=bzz
|
|
bpol=sqrt(bbr**2+bbz**2)
|
|
else
|
|
tekev=0.0d0
|
|
akim=0.0d0
|
|
end if
|
|
ddr11=ddr
|
|
c cutoff=xg-(1-yg)*(1-anpl**2)
|
|
|
|
c print dIds in A/m/W, Jphi and Jt in MA/m2, ki in m^-1
|
|
|
|
if(psi.le.psdbnd.and.psi.ge.0.0d0) dens11=dens
|
|
dids11=didst(j,k,i)*1.0d2/(p0mw*q(j))
|
|
dpdv11=pdjki(j,k,i)/(p0mw*q(j))
|
|
ajcd11=currj(j,k,i)/(p0mw*q(j))
|
|
alpha11=alphav(j,k,i)
|
|
tau11=taujk
|
|
pt11=exp(-taujk)
|
|
|
|
write(4,99) stm,rrm,zzm,phideg,
|
|
. psi,rhot,dens11,tekev,
|
|
. bbr,bphi,bbz,ajphi*1.0d-6,sqrt(an2),anpl,akim*100,
|
|
. alpha11,tau11,pt11,ajcd11,dids11,
|
|
. dble(nhf),dble(iohkawa),dble(index_rt)
|
|
|
|
c call polarcold(exf,eyif,ezf,elf,etf)
|
|
end if
|
|
c central ray only end
|
|
|
|
if(k.eq.1.and.j.eq.nrayr) write(17,99) st,ddr11,ddr,ddi
|
|
|
|
c print dIds in MA/m, Jcd in MA/m^2, ppabs and pdjki in MW/m^3
|
|
if(istpl.eq.istpl0) then
|
|
if(j.eq.nrayr) then
|
|
c if(j.eq.nrayr.and.tauv(j,k,i).le.taucr) then
|
|
write(33,111) i,j,k,stm,xxm,yym,rrm,zzm,
|
|
. psjki(j,k,i),taujk,anpl,alphav(j,k,i),dble(index_rt)
|
|
end if
|
|
c if(k.eq.nrayth) write(33,*) ' '
|
|
end if
|
|
c
|
|
return
|
|
99 format(30(1x,e16.8e3))
|
|
111 format(3i5,16(1x,e16.8e3))
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine prfile
|
|
implicit none
|
|
integer*4 index_rt
|
|
common/index_rt/index_rt
|
|
|
|
If(index_rt.eq.1) then
|
|
|
|
write(4,*)' #sst R z phi psi rhot ne Te BR Bphi Bz Jphi '//
|
|
.'N Npl ki alpha tau Pt Jcd dIds nh iohkw index_rt'
|
|
write(8,*) ' #istep j k xt yt zt rt psin'
|
|
write(9,*) ' #istep j k xt yt zt rt psin'
|
|
write(17,*) ' #sst Dr_11 Dr_Nr1 Di_Nr1'
|
|
write(33,*) ' #i j k sst x y R z psi tauv Npl alpha index_rt'
|
|
write(12,*) ' #i sst psi w1 w2'
|
|
write(7,*)'#Icd Pa Jphip dPdVp '//
|
|
.'rhotj rhotjava rhotp rhotpav drhotjava drhotpav ratjamx '//
|
|
.'ratjbmx stmx psipol chipol index_rt Jphimx dPdVmx drhotj drhotp'
|
|
write(48,*) '#psi rhot Jphi Jcdb dPdV Icdins Pins P% index_rt'
|
|
write(66,*) "# psipol0 chipol0 powrfl"
|
|
|
|
else
|
|
|
|
|
|
c If(index_rt.eq.3) then
|
|
write(4,*) ' '
|
|
write(8,*) ' '
|
|
write(9,*) ' '
|
|
write(17,*) ' '
|
|
write(12,*) ' '
|
|
write(48,*) ' '
|
|
|
|
c end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine read_data
|
|
use const_and_precisions, only : qe=>ecgs_,me=>mecgs_,vc=>ccgs_,
|
|
* cvdr=>degree,pi
|
|
use green_func_p, only:Setup_SpitzFunc
|
|
use graydata_flags
|
|
use graydata_par
|
|
use graydata_anequil
|
|
use interp_eqprof, only : rmxm,rlim,zlim,nlim,zbmin,zbmax,
|
|
. btrcen,rcen,alloc_lim
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
character*8 wdat
|
|
character*10 wtim
|
|
parameter(nmx=8000)
|
|
c
|
|
common/xgcn/xgcn
|
|
|
|
common/nstep/nstep
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
c
|
|
common/parwv/ak0,akinv,fhz
|
|
common/parbeam/wcsi,weta,rcicsi,rcieta,phiw,phir
|
|
common/anic/anx0c,any0c,anz0c
|
|
common/mirr/x00,y00,z00
|
|
c
|
|
common/parbres/bres
|
|
common/p0/p0mw
|
|
c
|
|
common/mode/sox
|
|
common/angles/alpha0,beta0
|
|
c
|
|
open(2,file='gray.data',status= 'unknown')
|
|
c
|
|
c alpha0, beta0 (cartesian) launching angles
|
|
c fghz wave frequency (GHz)
|
|
c p0mw injected power (MW)
|
|
c
|
|
read(2,*) alpha0,beta0
|
|
read(2,*) fghz
|
|
read(2,*) p0mw
|
|
c
|
|
c nrayr number of rays in radial direction
|
|
c nrayth number of rays in angular direction
|
|
c rwmax normalized maximum radius of beam power
|
|
c rwmax=1 -> last ray at radius = waist
|
|
c
|
|
read(2,*) nrayr,nrayth,rwmax
|
|
if(nrayr.eq.1) nrayth=1
|
|
c
|
|
c x00,y00,z00 coordinates of launching point
|
|
c
|
|
read(2,*) x00,y00,z00
|
|
c
|
|
c beams parameters in local reference system
|
|
c w0 -> waist, d0 -> waist distance from launching point
|
|
c phiw angle of beam ellipse
|
|
c
|
|
read(2,*) w0csi,w0eta,d0csi,d0eta,phiw
|
|
c
|
|
c ibeam=0 :read data for beam as above
|
|
c ibeam=1 :read data from file simple astigmatic beam
|
|
c ibeam=2 :read data from file general astigmatic beam
|
|
read(2,*) ibeam
|
|
read(2,*) filenmbm
|
|
c
|
|
c iequil=0 :vacuum
|
|
c iequil=1 :analytical equilibrium
|
|
c iequil=2 :read eqdsk
|
|
c ixp=0,-1,+1 : no X point , bottom/up X point
|
|
c
|
|
read(2,*) iequil,ixp
|
|
c
|
|
c iprof=0 :analytical density and temp. profiles
|
|
c iprof>0 :numerical density and temp. profiles
|
|
c
|
|
read(2,*) iprof
|
|
c
|
|
c iwarm=0 :no absorption and cd
|
|
c iwarm=1 :weakly relativistic absorption
|
|
c iwarm=2 :relativistic absorption, n<1 asymptotic expansion
|
|
c iwarm=3 :relativistic absorption, numerical integration
|
|
c ilarm :order of larmor expansion
|
|
c imx :max n of iterations in dispersion, imx<0 uses 1st
|
|
c iteration in case of failure after |imx| iterations
|
|
|
|
read(2,*) iwarm,ilarm,imx
|
|
c if(iwarm.gt.2) iwarm=2
|
|
c
|
|
c ieccd 0/1 NO/YES ECCD calculation ieccd>0 different CD models
|
|
c
|
|
read(2,*) ieccd
|
|
if (ieccd.ge.10) call Setup_SpitzFunc
|
|
c
|
|
c ipec=0/1 :pec profiles grid in psi/rhop
|
|
c nnd :number of grid steps for pec profiles +1
|
|
c
|
|
read(2,*) ipec,nnd
|
|
c
|
|
c dst integration step
|
|
c nstep maximum number of integration steps
|
|
c istpr0 projection step = dsdt*istprj
|
|
c istpl0 plot step = dsdt*istpl
|
|
c igrad=0 optical ray-tracing, initial conditions as for beam
|
|
c igrad=1 quasi-optical ray-tracing
|
|
c igrad=-1 ray-tracing, init. condit.
|
|
c from center of mirror and with angular spread
|
|
c ipass=1/2 1 or 2 passes into plasma
|
|
c iox=1/2 OM/XM
|
|
c idst=0/1/2 0 integration in s, 1 integr. in ct, 2 integr. in Sr
|
|
c psipol0,chipol0 polarization angles
|
|
c ipol=0 compute mode polarization at antenna, ipol=1 use polariz angles
|
|
c
|
|
read(2,*) dst,nstep,istpr0,istpl0,idst
|
|
read(2,*) igrad,ipass,rwallm
|
|
read(2,*) iox, psipol0,chipol0,ipol
|
|
c
|
|
c ipsinorm 0 standard EQDSK format, 1 format Portone summer 2004
|
|
c sspl spline parameter for psi interpolation
|
|
c
|
|
read(2,*) filenmeqq
|
|
read(2,*) ipsinorm,sspl
|
|
c
|
|
c factb factor for magnetic field (only for numerical equil)
|
|
c scaling adopted: beta=const, qpsi=const, nustar=const
|
|
c iscal ne Te scaling 0: nustar=const, 1: n_greenw=const; 2 no rescaling
|
|
c factT factn factor for Te&ne scaling
|
|
c
|
|
read(2,*) factb, iscal,factt,factn
|
|
if (factb.eq.0.0d0) factb=1.0d0
|
|
c
|
|
c psbnd value of psi ( > 1 ) of density boundary
|
|
c
|
|
read(2,*) filenmprf
|
|
read(2,*) psdbnd
|
|
if(iprof.eq.0) psdbnd=1.0d0
|
|
c
|
|
c signum of toroidal B and I
|
|
c icocos index for equilibrium from COCOS - O. Sauter Feb 2012
|
|
read(2,*) sgnbphi,sgniphi,icocos
|
|
c
|
|
c read parameters for analytical density and temperature
|
|
c profiles if iprof=0
|
|
c
|
|
if(iprof.eq.0) then
|
|
read(2,*) dens0,aln1,aln2
|
|
read(2,*) te0,dte0,alt1,alt2
|
|
else
|
|
read(2,*) dummy,dummy,dummy
|
|
read(2,*) dummy,dummy,dummy,dummy
|
|
end if
|
|
read(2,*) zeff
|
|
c
|
|
c read parameters for analytical simple cylindical equilibrium
|
|
c if iequil=0,1
|
|
|
|
if(iequil.lt.2) then
|
|
read(2,*) rr0,zr0,rpa
|
|
read(2,*) b0
|
|
read(2,*) q0,qa,alq
|
|
rr0m=rr0/1.0d2
|
|
zr0m=zr0/1.0d2
|
|
rpam=rpa/1.0d2
|
|
rcen=rr0m
|
|
btrcen=b0
|
|
zbmin=(zr0-rpa)/100.d0
|
|
zbmax=(zr0+rpa)/100.d0
|
|
b0=b0*factb
|
|
call flux_average_an
|
|
c call print_prof_an
|
|
else
|
|
read(2,*) dummy,dummy,dummy
|
|
read(2,*) dummy
|
|
read(2,*) dummy,dummy,dummy
|
|
end if
|
|
c
|
|
close(unit=2)
|
|
c
|
|
if(nrayr.eq.1) igrad=0
|
|
if (nrayr.lt.5) then
|
|
igrad=0
|
|
print*,' nrayr < 5 ! => OPTICAL CASE ONLY'
|
|
print*,' '
|
|
end if
|
|
c
|
|
fhz=fghz*1.0d9
|
|
ak0=2.0d9*pi*fghz/vc
|
|
akinv=1.0d0/ak0
|
|
c
|
|
bresg=2.0d0*pi*fhz*me*vc/qe
|
|
bres=bresg*1.0d-4
|
|
c
|
|
c xg=xgcn*dens19
|
|
c
|
|
xgcn=1.0d-5*qe**2/(pi*me*fghz**2)
|
|
c
|
|
sox=-1.0d0
|
|
if(iox.eq.2) sox=1.0d0
|
|
c
|
|
c read data for beam from file if ibeam>0
|
|
c
|
|
if(ibeam.gt.0) then
|
|
call read_beams
|
|
else
|
|
zrcsi=0.5d0*ak0*w0csi**2
|
|
zreta=0.5d0*ak0*w0eta**2
|
|
if(igrad.gt.0) then
|
|
wcsi=w0csi*sqrt(1.0d0+(d0csi/zrcsi)**2)
|
|
weta=w0eta*sqrt(1.0d0+(d0eta/zreta)**2)
|
|
rcicsi=-d0csi/(d0csi**2+zrcsi**2)
|
|
rcieta=-d0eta/(d0eta**2+zreta**2)
|
|
phir=phiw
|
|
else
|
|
d0eta=d0csi
|
|
wcsi=w0csi*abs(d0csi/zrcsi)
|
|
weta=w0eta*abs(d0eta/zreta)
|
|
rcicsi=w0csi/zrcsi
|
|
rcieta=w0eta/zreta
|
|
if(d0csi.gt.0) then
|
|
rcicsi=-rcicsi
|
|
rcieta=-rcieta
|
|
end if
|
|
phir=phiw
|
|
end if
|
|
end if
|
|
c
|
|
print'(a,2f8.3)','alpha0, beta0 = ',alpha0,beta0
|
|
c
|
|
r00=sqrt(x00**2+y00**2)
|
|
phi0=acos(x00/r00)
|
|
if(y00.lt.0) phi0=-phi0
|
|
print'(a,4f8.3)','x00, y00, R00, z00 = ',x00,y00,r00,z00
|
|
print*,' '
|
|
c
|
|
c anx0c=(anr0c*x00-anphi0c*y00)/r00
|
|
c any0c=(anr0c*y00+anphi0c*x00)/r00
|
|
c
|
|
c anr0c=(anx0c*x00+any0c*y00)/r00
|
|
c anphi0c=(any0c*x00-anx0c*y00)/r00
|
|
c
|
|
c angles alpha0, beta0 in a local reference system as proposed by Gribov et al
|
|
c
|
|
c anr0c=-cos(cvdr*beta0)*cos(cvdr*alpha0)
|
|
c anphi0c=sin(cvdr*beta0)
|
|
c anz0c=-cos(cvdr*beta0)*sin(cvdr*alpha0)
|
|
|
|
anr0c=-cos(cvdr*beta0)*cos(cvdr*alpha0)
|
|
anphi0c=sin(cvdr*beta0)
|
|
anz0c=-cos(cvdr*beta0)*sin(cvdr*alpha0)
|
|
|
|
anx0c=(anr0c*x00-anphi0c*y00)/r00
|
|
any0c=(anr0c*y00+anphi0c*x00)/r00
|
|
c
|
|
c read data for Te , ne , Zeff from file if iprof>0
|
|
c
|
|
|
|
if (iprof.eq.1) then
|
|
nprof=98
|
|
lprf=length(filenmprf)
|
|
open(file=filenmprf(1:lprf)//'.prf',
|
|
. status= 'unknown',unit=nprof)
|
|
call profdata
|
|
close(nprof)
|
|
end if
|
|
c
|
|
c read equilibrium data from file if iequil=2
|
|
c
|
|
if (iequil.eq.2) then
|
|
neqdsk=99
|
|
leqq=length(filenmeqq)
|
|
open(file=filenmeqq(1:leqq)//'.eqdsk',
|
|
. status= 'unknown', unit=neqdsk)
|
|
call equidata
|
|
close(neqdsk)
|
|
|
|
c print density, temperature, safecty factor, toroidal current dens
|
|
c versus psi, rhop, rhot
|
|
call print_prof
|
|
end if
|
|
|
|
if (iequil.eq.1) call bres_anal
|
|
|
|
if (iequil.ne.2.or.ipass.lt.0) then
|
|
c set simple limiter as two cylindrical walls at rwallm and r00
|
|
nlim=5
|
|
call alloc_lim(ierr)
|
|
if (ierr.ne.0) stop
|
|
rlim(1)=rwallm
|
|
rlim(2)=max(r00*1.d-2,rmxm)
|
|
rlim(3)=rlim(2)
|
|
rlim(4)=rlim(1)
|
|
rlim(5)=rlim(1)
|
|
zlim(1)=(z00-dst*nmx)*1.d-2
|
|
zlim(2)=zlim(1)
|
|
zlim(3)=(z00+dst*nmx)*1.d-2
|
|
zlim(4)=zlim(3)
|
|
zlim(5)=zlim(1)
|
|
ipass=abs(ipass)
|
|
end if
|
|
|
|
nfil=78
|
|
|
|
open(nfil,file='headers.txt',status= 'unknown')
|
|
call date_and_time(wdat,wtim)
|
|
write(nfil,916) wdat(1:4),wdat(5:6),wdat(7:8),
|
|
. wtim(1:2),wtim(3:4),wtim(5:6)
|
|
write(nfil,904) REVISION
|
|
if (iequil.eq.2) then
|
|
write(nfil,905) trim(filenmeqq)
|
|
else
|
|
if (iequil.eq.1) write(nfil,912) rr0,zr0,rpa,B0,q0,qa,alq
|
|
if (iequil.eq.0) write(nfil,'("# VACUUM CASE")')
|
|
end if
|
|
if (iprof.eq.1) then
|
|
write(nfil,907) trim(filenmprf)
|
|
else
|
|
write(nfil,913) dens0,aln1,aln2,te0,dte0,alt1,alt2,zeff
|
|
end if
|
|
write(nfil,911) fghz,p0mw,iox
|
|
write(nfil,902) x00,y00,z00
|
|
write(nfil,908) alpha0,beta0
|
|
if(ibeam.ge.1) write(nfil,909) trim(filenmbm)
|
|
if(ibeam.eq.0) write(nfil,903) w0csi,w0eta,d0csi,d0eta,phiw
|
|
write(nfil,900) nrayr, nrayth, rwmax
|
|
write(nfil,901) igrad,iwarm,ilarm,ieccd,idst
|
|
write(nfil,915) dst,nstep
|
|
write(nfil,914) sgnbphi,sgniphi,icocos
|
|
write(nfil,906) factb,factt,factn,iscal
|
|
write(nfil,910) sspl,psdbnd,nnd,ipec,ipsinorm
|
|
write(nfil,*) ' '
|
|
close(nfil)
|
|
|
|
return
|
|
|
|
900 format('# Nray_r Nray_th rwmax : ',2i5,1x,es12.5)
|
|
901 format('# igrad iwarm ilarm ieccd idst ipol: ',7i5)
|
|
902 format('# X0 Y0 Z0 launching point (cm) : ',3(1x,es12.5))
|
|
903 format('# w0xi w0eta d0xi d0eta (cm) phiw (deg) : ',5(1x,es12.5))
|
|
904 format('# GRAY revision : ',a)
|
|
905 format('# EQUILIBRIUM file : ',a)
|
|
906 format('# fact_B fact_T fact_n iscal : ',(3(1x,es12.5),i5))
|
|
907 format('# PROFILES file : ',a)
|
|
908 format('# alpha0 beta0 launch angles (deg) CYL : ',2(1x,es12.5))
|
|
909 format('# LAUNCHER file : ',a24)
|
|
910 format('# sspl psdbnd nd ipec ipsinorm : ',2(1x,es12.5),3i5)
|
|
911 format('# fghz P0 IOX : ',2(1x,es12.5),i5)
|
|
912 format('# AN. EQUILIBRIUM R0 z0 a B0 q0 qa alq : ',7(1x,es12.5))
|
|
913 format('# AN. PROFILES ne0 aln1 aln2 Te0 Tea alt1 alt2 Zeff : '
|
|
. ,8(1x,es12.5))
|
|
914 format('# sgnB_phi sgnI_phi icocos : ',2(1x,es12.5),i5)
|
|
915 format('# dst nstep : ',1x,es12.5,i5)
|
|
916 format('# Date : ',a4,2('/',a2),1x,a2,2(':',a2))
|
|
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine surf_anal
|
|
use const_and_precisions, only : pi
|
|
use graydata_anequil, only : b0,rr0m,zr0m,rpam
|
|
use magsurf_data, only : npsi,npoints,psicon,rcon,zcon,
|
|
. alloc_surf_anal
|
|
|
|
implicit real*8(a-h,o-z)
|
|
common/parbres/bres
|
|
|
|
npsi=10
|
|
npoints=101
|
|
call alloc_surf_anal(ierr)
|
|
if (ierr.ne.0) stop
|
|
c
|
|
c print circular magnetic surfaces iequil=1
|
|
c
|
|
write(71,*) '#i psin R z'
|
|
dal=2.0d-2*pi
|
|
drn=0.1d0
|
|
do i=1,npsi
|
|
rni=i*drn
|
|
psicon(i)=rni
|
|
do k=1,npoints
|
|
drrm=rpam*rni*cos((k-1)*dal)
|
|
dzzm=rpam*rni*sin((k-1)*dal)
|
|
rrm=rr0m+drrm
|
|
zzm=zr0m+dzzm
|
|
rcon(i,k)=rrm
|
|
zcon(i,k)=zrm
|
|
write(71,111) i,rni,rrm,zzm
|
|
end do
|
|
write(71,*) ' '
|
|
write(71,*) ' '
|
|
end do
|
|
c
|
|
c print resonant B iequil=1
|
|
c
|
|
write(70,*)'#i Btot R z'
|
|
rres=b0*rr0m/bres
|
|
zmx=zr0m+rpam
|
|
zmn=zr0m-rpam
|
|
do i=1,21
|
|
zzres=zmn+(i-1)*(zmx-zmn)/2.0d1
|
|
write(70,111) i,bres,rres,zzres
|
|
end do
|
|
|
|
return
|
|
111 format(i4,20(1x,e16.8e3))
|
|
end
|
|
|
|
subroutine bres_anal
|
|
implicit real*8(a-h,o-z)
|
|
parameter(pi=3.14159265358979d0)
|
|
common/parban/b0,rr0m,zr0m,rpam
|
|
common/parbres/bres
|
|
c
|
|
c print resonant B iequil=1
|
|
c
|
|
write(70,*)'#i Btot R z'
|
|
rres=b0*rr0m/bres
|
|
zmx=zr0m+rpam
|
|
zmn=zr0m-rpam
|
|
do i=1,21
|
|
zzres=zmn+(i-1)*(zmx-zmn)/2.0d1
|
|
write(70,111) i,bres,rres,zzres
|
|
end do
|
|
|
|
return
|
|
111 format(i4,20(1x,e16.8e3))
|
|
end
|
|
c
|
|
c
|
|
subroutine read_beams
|
|
use graydata_flags, only : filenmbm, ibeam
|
|
|
|
implicit real*8(a-h,o-z)
|
|
parameter(nstrmx=50)
|
|
c
|
|
dimension alphastv(nstrmx),betastv(nstrmx),cbeta(nstrmx,4)
|
|
dimension x00v(nstrmx),y00v(nstrmx),z00v(nstrmx)
|
|
dimension cx0(nstrmx,4),cy0(nstrmx,4),cz0(nstrmx,4)
|
|
dimension waist1v(nstrmx),waist2v(nstrmx)
|
|
dimension rci1v(nstrmx),rci2v(nstrmx)
|
|
dimension cwaist1(nstrmx,4),cwaist2(nstrmx,4)
|
|
dimension crci1(nstrmx,4),crci2(nstrmx,4)
|
|
dimension phi1v(nstrmx),phi2v(nstrmx)
|
|
dimension cphi1(nstrmx,4),cphi2(nstrmx,4)
|
|
c
|
|
common/parbeam/wcsi,weta,rcicsi,rcieta,phiw,phir
|
|
common/mirr/x00,y00,z00
|
|
common/angles/alpha0,beta0
|
|
common/parwv/ak0,akinv,fhz
|
|
c
|
|
c for given alpha0 -> beta0 + beam parameters
|
|
c
|
|
c ibeam=1 simple astigmatic beam
|
|
c ibeam=2 general astigmatic beam
|
|
c
|
|
c initial beam data are measured in mm -> transformed to cm
|
|
c
|
|
nfbeam=97
|
|
lbm=length(filenmbm)
|
|
open(file=filenmbm(1:lbm)//'.txt',status= 'unknown',unit=nfbeam)
|
|
c
|
|
read(nfbeam,*) nisteer
|
|
do i=1,nisteer
|
|
if(ibeam.eq.1) then
|
|
read(nfbeam,*) steer,alphast,betast,x00mm,y00mm,z00mm,
|
|
. waist1,dvir1,waist2,dvir2,delta
|
|
phi1=delta
|
|
phi2=delta
|
|
zr1=0.5d-1*ak0*waist1**2
|
|
zr2=0.5d-1*ak0*waist2**2
|
|
w1=waist1*sqrt(1.0d0+(dvir1/zr1)**2)
|
|
w2=waist2*sqrt(1.0d0+(dvir2/zr2)**2)
|
|
rci1=-dvir1/(dvir1**2+zr1**2)
|
|
rci2=-dvir2/(dvir2**2+zr2**2)
|
|
else
|
|
read(nfbeam,*) steer,alphast,betast,x00mm,y00mm,z00mm,
|
|
. w1,w2,rci1,rci2,phi1,phi2
|
|
end if
|
|
x00v(i)=0.1d0*x00mm
|
|
y00v(i)=0.1d0*y00mm
|
|
z00v(i)=0.1d0*z00mm
|
|
alphastv(i)=alphast
|
|
betastv(i)=betast
|
|
waist1v(i)=0.1d0*w1
|
|
rci1v(i)=1.0d1*rci1
|
|
waist2v(i)=0.1d0*w2
|
|
rci2v(i)=1.0d1*rci2
|
|
phi1v(i)=phi1
|
|
phi2v(i)=phi2
|
|
end do
|
|
c
|
|
iopt=0
|
|
call difcs(alphastv,betastv,nisteer,iopt,cbeta,ier)
|
|
call difcs(alphastv,waist1v,nisteer,iopt,cwaist1,ier)
|
|
call difcs(alphastv,rci1v,nisteer,iopt,crci1,ier)
|
|
call difcs(alphastv,waist2v,nisteer,iopt,cwaist2,ier)
|
|
call difcs(alphastv,rci2v,nisteer,iopt,crci2,ier)
|
|
call difcs(alphastv,phi1v,nisteer,iopt,cphi1,ier)
|
|
call difcs(alphastv,phi2v,nisteer,iopt,cphi2,ier)
|
|
call difcs(alphastv,x00v,nisteer,iopt,cx0,ier)
|
|
call difcs(alphastv,y00v,nisteer,iopt,cy0,ier)
|
|
call difcs(alphastv,z00v,nisteer,iopt,cz0,ier)
|
|
c
|
|
if(alpha0.gt.alphastv(1).and.alpha0.lt.alphastv(nisteer)) then
|
|
call locate(alphastv,nisteer,alpha0,k)
|
|
dal=alpha0-alphastv(k)
|
|
betst=spli(cbeta,nisteer,k,dal)
|
|
x00=spli(cx0,nisteer,k,dal)
|
|
y00=spli(cy0,nisteer,k,dal)
|
|
z00=spli(cz0,nisteer,k,dal)
|
|
wcsi=spli(cwaist1,nisteer,k,dal)
|
|
weta=spli(cwaist2,nisteer,k,dal)
|
|
rcicsi=spli(crci1,nisteer,k,dal)
|
|
rcieta=spli(crci2,nisteer,k,dal)
|
|
phiw=spli(cphi1,nisteer,k,dal)
|
|
phir=spli(cphi2,nisteer,k,dal)
|
|
else
|
|
print*,' alpha0 outside table range !!!'
|
|
if(alpha0.ge.alphastv(nisteer)) ii=nisteer
|
|
if(alpha0.le.alphastv(1)) ii=1
|
|
betst=betastv(ii)
|
|
x00=x00v(ii)
|
|
y00=y00v(ii)
|
|
z00=z00v(ii)
|
|
wcsi=waist1v(ii)
|
|
weta=waist2v(ii)
|
|
rcicsi=rci1v(ii)
|
|
rcieta=rci2v(ii)
|
|
phiw=phi1v(ii)
|
|
phir=phi2v(ii)
|
|
end if
|
|
beta0=betst
|
|
c
|
|
close(nfbeam)
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine equidata
|
|
use const_and_precisions, only : pi
|
|
use graydata_flags, only : ipsinorm,sspl,ixp,icocos,neqdsk
|
|
use graydata_par, only : sgnbphi,sgniphi,factb
|
|
use interp_eqprof, only : nsrt,nszt,nsft,rlim,zlim,nlim,nr,nz,
|
|
. psia,psiant,psinop,btrcen,rcen,btaxis,rmaxis,zmaxis,rmnm,
|
|
. rmxm,zmnm,zmxm,dr,dz,zbmin,zbmax,fpolas,phitedge,rrtor,rup,zup,
|
|
. rlw,zlw,tr,tz,tfp,cc=>cceq,cfp,cc01=>cceq01,cc10=>cceq10,
|
|
. cc20=>cceq20,cc02=>cceq02,cc11=>cceq11,psinr,qpsi,rv,zv,psin,
|
|
. psi,rbbbs,zbbbs,nbbbs,alloc_equilvec,alloc_bnd
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
c parameter(np=100)
|
|
parameter(kspl=3)
|
|
character*48 stringa
|
|
c dimension rcon(2*np+1),zcon(2*np+1)
|
|
integer, dimension(:), allocatable :: iwrk,iwrkf,iwrkbsp
|
|
real*8, dimension(:), allocatable :: fpoli,fvpsi,ffvpsi,fpol,
|
|
. wrkf,wf,wrk,wrkbsp,pres,ffprim,pprim
|
|
c
|
|
common/rhotsx/rhotsx
|
|
c
|
|
c read from file eqdsk
|
|
c (see http://fusion.gat.com/efit/g_eqdsk.html)
|
|
c
|
|
c spline interpolation of psi and derivatives
|
|
c
|
|
if(icocos.gt.0) then
|
|
read (neqdsk,'(a48,3i4)') stringa,idum,nr,nz
|
|
else
|
|
read (neqdsk,*) nr,nz
|
|
end if
|
|
c
|
|
call alloc_equilvec(ierr)
|
|
if (ierr.ne.0) stop
|
|
|
|
nrest=nr+4
|
|
nzest=nz+4
|
|
lwrk=4*(nr+nz)+11*(nrest+nzest)+nrest*nz+nzest+54
|
|
liwrk=nz+nr+nrest+nzest+3
|
|
lw10=nr*3+nz*4+nr*nz
|
|
lw01=nr*4+nz*3+nr*nz
|
|
lw20=nr*2+nz*4+nr*nz
|
|
lw02=nr*4+nz*2+nr*nz
|
|
lw11=nr*3+nz*3+nr*nz
|
|
lwrkf=nr*4+nrest*16
|
|
lwrkbsp=4*(nr+nz)
|
|
liwrkbsp=nr+nz
|
|
|
|
if(allocated(fvpsi)) deallocate(fvpsi)
|
|
if(allocated(pres)) deallocate(pres)
|
|
if(allocated(ffprim)) deallocate(ffprim)
|
|
if(allocated(pprim)) deallocate(pprim)
|
|
if(allocated(ffvpsi)) deallocate(ffvpsi)
|
|
if(allocated(fpol)) deallocate(fpol)
|
|
if(allocated(fpoli)) deallocate(fpoli)
|
|
if(allocated(wrkf)) deallocate(wrkf)
|
|
if(allocated(iwrkf)) deallocate(iwrkf)
|
|
if(allocated(wf)) deallocate(wf)
|
|
if(allocated(wrk)) deallocate(wrk)
|
|
if(allocated(iwrk)) deallocate(iwrk)
|
|
if(allocated(wrkbsp)) deallocate(wrkbsp)
|
|
if(allocated(iwrkbsp)) deallocate(iwrkbsp)
|
|
|
|
allocate(fvpsi(nr*nz),pres(nr),ffprim(nr),pprim(nr),
|
|
. ffvpsi(nr*nz),fpol(nr),fpoli(nr),wrkf(lwrkf),iwrkf(nrest),
|
|
. wf(nr),wrk(lwrk),iwrk(liwrk),wrkbsp(lwrkbsp),iwrkbsp(liwrkbsp))
|
|
c
|
|
if(ipsinorm.eq.0) then
|
|
read (neqdsk,2020) drnr1,dznz1,rcen,rleft,zmid
|
|
read (neqdsk,2020) rmaxis,zmaxis,psiaxis,psiedge,btrcen
|
|
read (neqdsk,2020) current,xdum,xdum,xdum,xdum
|
|
read (neqdsk,2020) xdum,xdum,xdum,xdum,xdum
|
|
read (neqdsk,2020) (fpol(i),i=1,nr)
|
|
read (neqdsk,2020) (pres(i),i=1,nr)
|
|
read (neqdsk,2020) (ffprim(i),i=1,nr)
|
|
read (neqdsk,2020) (pprim(i),i=1,nr)
|
|
read (neqdsk,2020) ((psi(i,j),i=1,nr),j=1,nz)
|
|
read (neqdsk,2020) (qpsi(i),i=1,nr)
|
|
else
|
|
read (neqdsk,*) drnr1,dznz1,rcen,rleft,zmid
|
|
read (neqdsk,*) rmaxis,zmaxis,psiaxis,psiedge,btrcen
|
|
read (neqdsk,*) current,xdum,xdum,xdum,xdum
|
|
read (neqdsk,*) xdum,xdum,xdum,xdum,xdum
|
|
read (neqdsk,*) (fpol(i),i=1,nr)
|
|
read (neqdsk,*) (pres(i),i=1,nr)
|
|
read (neqdsk,*) (ffprim(i),i=1,nr)
|
|
read (neqdsk,*) (pprim(i),i=1,nr)
|
|
read (neqdsk,*) ((psin(i,j),i=1,nr),j=1,nz)
|
|
read (neqdsk,*) (qpsi(i),i=1,nr)
|
|
end if
|
|
2020 format (5e16.9)
|
|
|
|
c
|
|
c compensate for different reference systems
|
|
c
|
|
icocosmod=mod(icocos,10)
|
|
|
|
if (mod(icocos,2).eq.0.and.icocosmod.gt.0) then
|
|
c icocos mod 2 = 0: toroidal angle phi CW (opposite to gray convention)
|
|
btrcen=-btrcen
|
|
current=-current
|
|
do i=1,nr
|
|
fpol(i)=-fpol(i)
|
|
end do
|
|
end if
|
|
c
|
|
if (icocosmod.eq.1 .or. icocosmod.eq.4 .or.
|
|
& icocosmod.eq.5 .or. icocosmod.eq.8) then
|
|
c icocos mod 10 = 1,4,5,8: psi increasing with CCW Ip
|
|
c icocos mod 10 = 2,3,6,7: psi decreasing with CCW Ip
|
|
psiedge=-psiedge
|
|
psiaxis=-psiaxis
|
|
if (ipsinorm.eq.0) then
|
|
do j=1,nz
|
|
do i=1,nr
|
|
psi(i,j)=-psi(i,j)
|
|
end do
|
|
end do
|
|
end if
|
|
end if
|
|
|
|
c
|
|
c add check for Ip/psi and B0/Fpol sign consistency?
|
|
c
|
|
current=sign(current,psiaxis-psiedge)
|
|
btrcen=sign(btrcen,fpol(nr))
|
|
|
|
c
|
|
c length in m !!!
|
|
c
|
|
dr=drnr1/dble(nr-1)
|
|
dz=dznz1/dble(nz-1)
|
|
rv(1)=rleft
|
|
zv(1)=zmid-dznz1/2.0d0
|
|
dpsinr=1.0d0/dble(nr-1)
|
|
c
|
|
do i=1,nr
|
|
psinr(i)=(i-1)*dpsinr
|
|
rv(i)=rv(1)+(i-1)*dr
|
|
end do
|
|
c
|
|
do j=1,nz
|
|
zv(j)=zv(1)+(j-1)*dz
|
|
end do
|
|
c
|
|
rmnm=rv(1)
|
|
rmxm=rv(nr)
|
|
zmnm=zv(1)
|
|
zmxm=zv(nz)
|
|
|
|
c psi function
|
|
|
|
psia0=psiedge-psiaxis
|
|
c icocos=0: adapt psi to force Ip sign, otherwise maintain psi
|
|
if (icocosmod.ne.0) sgniphi=sign(1.0d0,-psia0)
|
|
current=sign(current,sgniphi)
|
|
|
|
psia=-sgniphi*abs(psia0)*factb
|
|
c icocos>10: input psi is in Wb
|
|
c icocos<10: input psi is in Wb/rad (gray convention)
|
|
if (icocos.ge.10) psia=psia/(2.0d0*pi)
|
|
c
|
|
c do j=1,nz
|
|
c do i=1,nr
|
|
c write(80,2021) rv(i),zv(j),psi(i,j)
|
|
c enddo
|
|
c write(80,*) ' '
|
|
c enddo
|
|
|
|
do j=1,nz
|
|
do i=1,nr
|
|
if(ipsinorm.eq.0) then
|
|
psin(i,j)=(psi(i,j)-psiaxis)/psia0
|
|
psi(i,j)=psin(i,j)*psia
|
|
else
|
|
psi(i,j)=psin(i,j)*psia
|
|
end if
|
|
ij=nz*(i-1)+j
|
|
fvpsi(ij)=psin(i,j)
|
|
enddo
|
|
enddo
|
|
c
|
|
c spline fitting/interpolation of psin(i,j) and derivatives
|
|
c
|
|
iopt=0
|
|
call regrid(iopt,nr,rv,nz,zv,fvpsi,rmnm,rmxm,zmnm,zmxm,
|
|
. kspl,kspl,sspl,nrest,nzest,nsr,tr,nsz,tz,cc,fp,
|
|
. wrk,lwrk,iwrk,liwrk,ier)
|
|
c if ier=-1 data are fitted using sspl=0
|
|
if(ier.eq.-1) then
|
|
sspl=0.0d0
|
|
call regrid(iopt,nr,rv,nz,zv,fvpsi,rmnm,rmxm,zmnm,zmxm,
|
|
. kspl,kspl,sspl,nrest,nzest,nsr,tr,nsz,tz,cc,fp,
|
|
. wrk,lwrk,iwrk,liwrk,ier)
|
|
end if
|
|
nsrt=nsr
|
|
nszt=nsz
|
|
if (sspl.gt.0.0d0) then
|
|
call bispev(tr,nsr,tz,nsz,cc,kspl,kspl,rv,nr,zv,nz,ffvpsi,
|
|
. wrkbsp,lwrkbsp,iwrkbsp,liwrkbsp,ier)
|
|
c
|
|
do j=1,nz
|
|
do i=1,nr
|
|
ij=nz*(i-1)+j
|
|
psin(i,j)=ffvpsi(ij)
|
|
psi(i,j)=psin(i,j)*psia
|
|
c write(79,2021) rv(i),zv(j),psin(i,j)
|
|
enddo
|
|
c write(79,*) ' '
|
|
enddo
|
|
end if
|
|
c2021 format(5(1x,e16.9))
|
|
c
|
|
nur=1
|
|
nuz=0
|
|
call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,
|
|
. cc10,lw10,ier)
|
|
c
|
|
nur=0
|
|
nuz=1
|
|
call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,
|
|
. cc01,lw01,ier)
|
|
c
|
|
nur=2
|
|
nuz=0
|
|
call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,
|
|
. cc20,lw20,ier)
|
|
c
|
|
nur=0
|
|
nuz=2
|
|
call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,
|
|
. cc02,lw02,ier)
|
|
c
|
|
nur=1
|
|
nuz=1
|
|
call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,
|
|
. cc11,lw11,ier)
|
|
c
|
|
c scaling of f_poloidal
|
|
c
|
|
c icocos=0: adapt fpol to force Ip sign, otherwise maintain fpol
|
|
if (icocosmod.ne.0) sgnbphi=sign(1.0d0,fpol(nr))
|
|
btrcen=sign(btrcen,sgnbphi)
|
|
|
|
do i=1,nr
|
|
fpol(i)=sgnbphi*abs(fpol(i))*factb
|
|
wf(i)=1.0d0
|
|
end do
|
|
wf(nr)=1.0d2
|
|
c
|
|
c spline interpolation of fpol(i)
|
|
c
|
|
iopt=0
|
|
xb=0.0d0
|
|
xe=1.0d0
|
|
ssfp=0.01d0
|
|
call curfit(iopt,nr,psinr,fpol,wf,xb,xe,kspl,ssfp,nrest,nsft,
|
|
. tfp,cfp,fp,wrkf,lwrkf,iwrkf,ier)
|
|
c
|
|
call splev(tfp,nsft,cfp,3,psinr,fpoli,nr,ier)
|
|
fpolas=fpoli(nr)
|
|
c
|
|
c read plasma boundaries from eqdsk file
|
|
c
|
|
read (neqdsk,*) nbbbs,nlim
|
|
|
|
call alloc_bnd(ierr)
|
|
if (ierr.ne.0) stop
|
|
|
|
if(nbbbs.gt.0) then
|
|
if(ipsinorm.eq.1)
|
|
. read (neqdsk,*) (rbbbs(i),zbbbs(i),i=1,nbbbs)
|
|
if(ipsinorm.eq.0)
|
|
. read (neqdsk,2020) (rbbbs(i),zbbbs(i),i=1,nbbbs)
|
|
c do i=1,nbbbs
|
|
c write(51,*) rbbbs(i),zbbbs(i)
|
|
c end do
|
|
end if
|
|
if(nlim.gt.0) then
|
|
if(ipsinorm.eq.1)
|
|
. read (neqdsk,*) (rlim(i),zlim(i),i=1,nlim)
|
|
if(ipsinorm.eq.0)
|
|
. read (neqdsk,2020) (rlim(i),zlim(i),i=1,nlim)
|
|
end if
|
|
c
|
|
c compute max and min z of last closed surface
|
|
c
|
|
rbmin=rmaxis
|
|
rbmax=rmaxis
|
|
if (nbbbs.gt.1) then
|
|
zbmin=1.0d+30
|
|
zbmax=-1.0d+30
|
|
do i=1,nbbbs
|
|
if(zbbbs(i).le.zbmin) then
|
|
zbmin=zbbbs(i)
|
|
rbmin=rbbbs(i)
|
|
end if
|
|
if(zbbbs(i).ge.zbmax) then
|
|
zbmax=zbbbs(i)
|
|
rbmax=rbbbs(i)
|
|
end if
|
|
end do
|
|
else
|
|
zbmin=-1.0d+30
|
|
zbmax=1.0d+30
|
|
end if
|
|
if(zbmin.le.zmnm) zbmin=zbmin+dz
|
|
if(rbmin.le.rmnm) rbmin=rbmin+dr
|
|
if(zbmax.ge.zmxm) zbmax=zbmax-dz
|
|
if(rbmax.ge.rmxm) rbmax=rbmax-dr
|
|
c
|
|
c start with uncorrected normalized psi
|
|
c
|
|
psinop=0.0d0
|
|
psinxp=1.0d0
|
|
psiant=1.0d0
|
|
c
|
|
c search for O-point
|
|
c
|
|
call points_ox(rmaxis,zmaxis,rmop,zmop,psinoptmp,info)
|
|
rmaxis=rmop
|
|
zmaxis=zmop
|
|
print'(a,2f8.4,es12.5)','O-point',rmop,zmop,psinoptmp
|
|
c
|
|
c search for X-point if ixp not = 0
|
|
c
|
|
if(ixp.ne.0) then
|
|
if(ixp.lt.0) then
|
|
r10=rbmin
|
|
z10=zbmin
|
|
call points_ox(r10,z10,rxp,zxp,psinxptmp,info)
|
|
if(psinxp.ne.-1.0d0) then
|
|
print'(a,2f8.4,es12.5)','X-point',rxp,zxp,psinxptmp
|
|
rbmin=rxp
|
|
zbmin=zxp
|
|
psinop=psinoptmp
|
|
psinxp=psinxptmp
|
|
psiant=psinxp-psinop
|
|
psin1=1.0d0
|
|
r10=rmaxis
|
|
z10=(zbmax+zmaxis)/2.0d0
|
|
call points_tgo(r10,z10,r1,z1,psin1,info)
|
|
rbmax=r1
|
|
zbmax=z1
|
|
else
|
|
ixp=0
|
|
c print'(a)','no X-point'
|
|
end if
|
|
else
|
|
r10=rmop
|
|
z10=zbmax
|
|
call points_ox(r10,z10,rxp,zxp,psinxptmp,info)
|
|
if(psinxp.ne.-1.0d0) then
|
|
print'(a,2f8.4,e16.8)','X-point',rxp,zxp,psinxptmp
|
|
zbmax=zxp
|
|
psinop=psinoptmp
|
|
psinxp=psinxptmp
|
|
psiant=psinxp-psinop
|
|
psin1=1.0d0
|
|
z10=(zbmin+zmaxis)/2.0d0
|
|
call points_tgo(r10,z10,r1,z1,psin1,info)
|
|
zbmin=z1
|
|
else
|
|
ixp=0
|
|
c print'(a)','no X-point'
|
|
end if
|
|
end if
|
|
end if
|
|
c
|
|
if (ixp.eq.0) then
|
|
psin1=1.0d0
|
|
psinop=psinoptmp
|
|
psiant=psin1-psinop
|
|
r10=rmaxis
|
|
z10=(zbmax+zmaxis)/2.0d0
|
|
call points_tgo(r10,z10,r1,z1,psin1,info)
|
|
zbmax=z1
|
|
rbmax=r1
|
|
z10=(zbmin+zmaxis)/2.0d0
|
|
call points_tgo(r10,z10,r1,z1,psin1,info)
|
|
zbmin=z1
|
|
rbmin=r1
|
|
print'(a,4f8.4)','no X-point ',rbmin,zbmin,rbmax,zbmax
|
|
end if
|
|
print*,' '
|
|
|
|
c compute B_toroidal on axis
|
|
|
|
btaxis=fpol(1)/rmaxis
|
|
btrcen=abs(btrcen)*factb
|
|
print'(a,f8.4)','factb = ',factb
|
|
print'(a,f8.4)','BT_centr= ',btrcen
|
|
print'(a,f8.4)','BT_axis = ',btaxis
|
|
|
|
c compute normalized rho_tor from eqdsk q profile
|
|
call rhotor(nr)
|
|
phitedge=abs(psia)*rhotsx*2*pi
|
|
c rrtor=sqrt(phitedge/abs(btrcen)/pi)
|
|
call rhopol
|
|
c print*,rhotsx,phitedge,rrtor,abs(psia)
|
|
|
|
c compute flux surface averaged quantities
|
|
|
|
rup=rmaxis
|
|
rlw=rmaxis
|
|
zup=zmaxis+(zbmax-zmaxis)/10.0d0
|
|
zlw=zmaxis-(zmaxis-zbmin)/10.0d0
|
|
call flux_average
|
|
c ipr=1
|
|
c call contours_psi(1.0d0,rcon,zcon,ipr)
|
|
c do ii=1,2*np+1
|
|
c write(52,*) rcon(ii), zcon(ii)
|
|
c end do
|
|
c
|
|
|
|
c locate psi surface for q=1.5 and q=2
|
|
|
|
rup=rmaxis
|
|
rlw=rmaxis
|
|
zup=(zbmax+zmaxis)/2.0d0
|
|
zlw=(zmaxis+zbmin)/2.0d0
|
|
q2=2.0d0
|
|
q15=1.5d0
|
|
call vmaxmini(qpsi,nr,qmin,qmax,iqmn,iqmx)
|
|
if (q15.gt.qmin.and.q15.lt.qmax) then
|
|
call surfq(q15,psi15)
|
|
rhot15=frhotor(psi15)
|
|
print'(3(a,f8.5))','psi_1.5 = ',psi15,' rhop_1.5 = '
|
|
. ,sqrt(psi15),' rhot_1.5 = ',rhot15
|
|
end if
|
|
if (q2.gt.qmin.and.q2.lt.qmax) then
|
|
call surfq(q2,psi2)
|
|
rhot2=frhotor(psi2)
|
|
print'(3(a,f8.5))','psi_2 = ',psi2,' rhop_2 = '
|
|
. ,sqrt(psi2),' rhot_2 = ',rhot2
|
|
end if
|
|
c
|
|
c locate btot=bres
|
|
c
|
|
call bfield_res
|
|
c
|
|
deallocate(iwrk,iwrkf,iwrkbsp,fpoli,fvpsi,ffvpsi,fpol,
|
|
. wrkf,wf,wrk,wrkbsp,pres,ffprim,pprim)
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine points_ox(rz,zz,rf,zf,psinvf,info)
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(n=2,ldfjac=n,lwa=(n*(n+13))/2)
|
|
dimension xvec(n),fvec(n),fjac(ldfjac,n),wa(lwa)
|
|
external fcnox
|
|
common/psival/psinv
|
|
xvec(1)=rz
|
|
xvec(2)=zz
|
|
tol = sqrt(dpmpar(1))
|
|
call hybrj1(fcnox,n,xvec,fvec,fjac,ldfjac,tol,info,wa,lwa)
|
|
if(info.gt.1) then
|
|
print'(a,i2,a,2f8.4)',' info subr points_ox =',info,
|
|
. ' O/X coord.',xvec
|
|
end if
|
|
rf=xvec(1)
|
|
zf=xvec(2)
|
|
call equinum_psi(rf,zf)
|
|
psinvf=psinv
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine fcnox(n,x,fvec,fjac,ldfjac,iflag)
|
|
use interp_eqprof, only: psia
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
dimension x(n),fvec(n),fjac(ldfjac,n)
|
|
common/derip1/dpsidr,dpsidz
|
|
common/derip2/ddpsidrr,ddpsidzz,ddpsidrz
|
|
|
|
select case(iflag)
|
|
case(1)
|
|
call equinum_derpsi(x(1),x(2),iflag)
|
|
fvec(1) = dpsidr/psia
|
|
fvec(2) = dpsidz/psia
|
|
case(2)
|
|
call equinum_derpsi(x(1),x(2),iflag)
|
|
fjac(1,1) = ddpsidrr/psia
|
|
fjac(1,2) = ddpsidrz/psia
|
|
fjac(2,1) = ddpsidrz/psia
|
|
fjac(2,2) = ddpsidzz/psia
|
|
case default
|
|
print*,'iflag undefined'
|
|
end select
|
|
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine points_tgo(rz,zz,rf,zf,psin,info)
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(n=2,ldfjac=n,lwa=(n*(n+13))/2)
|
|
dimension xvec(n),fvec(n),fjac(ldfjac,n),wa(lwa)
|
|
external fcntgo
|
|
common/cnpsi/h
|
|
h=psin
|
|
xvec(1)=rz
|
|
xvec(2)=zz
|
|
tol = sqrt(dpmpar(1))
|
|
call hybrj1(fcntgo,n,xvec,fvec,fjac,ldfjac,tol,info,wa,lwa)
|
|
if(info.gt.1) then
|
|
end if
|
|
rf=xvec(1)
|
|
zf=xvec(2)
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine fcntgo(n,x,fvec,fjac,ldfjac,iflag)
|
|
use interp_eqprof, only: psia
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
dimension x(n),fvec(n),fjac(ldfjac,n)
|
|
common/derip1/dpsidr,dpsidz
|
|
common/derip2/ddpsidrr,ddpsidzz,ddpsidrz
|
|
common/psival/psinv
|
|
common/cnpsi/h
|
|
|
|
select case(iflag)
|
|
case(1)
|
|
call equinum_psi(x(1),x(2))
|
|
call equinum_derpsi(x(1),x(2),iflag)
|
|
fvec(1) = psinv-h
|
|
fvec(2) = dpsidr/psia
|
|
case(2)
|
|
ii=iflag+1
|
|
call equinum_derpsi(x(1),x(2),ii)
|
|
fjac(1,1) = dpsidr/psia
|
|
fjac(1,2) = dpsidz/psia
|
|
fjac(2,1) = ddpsidrr/psia
|
|
fjac(2,2) = ddpsidrz/psia
|
|
case default
|
|
print*,'iflag undefined'
|
|
end select
|
|
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine print_prof
|
|
use interp_eqprof, only : psinr,qpsi,nr
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(eps=1.d-4)
|
|
c
|
|
common/dens/dens,ddens
|
|
c
|
|
write(55,*) ' #psi rhot ne Te q Jphi'
|
|
psin=0.0d0
|
|
rhop=0.0d0
|
|
rhot=0.0d0
|
|
call density(psin)
|
|
call tor_curr_psi(eps,ajphi)
|
|
te=temp(psin)
|
|
qq=qpsi(1)
|
|
c
|
|
write(55,111) psin,rhot,dens,te,qq,ajphi*1.d-6
|
|
c
|
|
nst=nr
|
|
do i=2,nst
|
|
psin=dble(i-1)/dble(nst-1)
|
|
rhop=sqrt(psin)
|
|
c
|
|
call density(psin)
|
|
te=temp(psin)
|
|
c
|
|
ips=int((nr-1)*psin+1)
|
|
if(i.lt.nst) then
|
|
call intlin(psinr(ips),qpsi(ips),psinr(ips+1),qpsi(ips+1),
|
|
. psin,qq)
|
|
else
|
|
qq=qpsi(nr)
|
|
end if
|
|
rhot=frhotor(psin)
|
|
call tor_curr_psi(psin,ajphi)
|
|
write(55,111) psin,rhot,dens,te,qq,ajphi*1.d-6
|
|
end do
|
|
c
|
|
return
|
|
111 format(12(1x,e12.5))
|
|
end
|
|
|
|
subroutine print_prof_an
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(nst=51)
|
|
common/dens/dens,ddens
|
|
|
|
write(55,*) ' #psi rhot ne Te'
|
|
do i=1,nst
|
|
psin=dble(i-1)/dble(nst-1)
|
|
rhop=sqrt(psin)
|
|
rhot=frhotor(psin)
|
|
call density(psin)
|
|
te=temp(psin)
|
|
write(55,111) psin,rhot,dens,te
|
|
end do
|
|
|
|
return
|
|
111 format(12(1x,e12.5))
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine surfq(qval,psival)
|
|
use magsurf_data, only : npoints
|
|
use interp_eqprof, only : nr,psinr,qpsi
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
dimension rcn(npoints),zcn(npoints)
|
|
c
|
|
c locate psi surface for q=qval
|
|
c
|
|
ncnt=(npoints-1)/2
|
|
call locate(qpsi,nr,qval,i1)
|
|
call intlin(qpsi(i1),psinr(i1),qpsi(i1+1),psinr(i1+1),
|
|
. qval,psival)
|
|
ipr=1
|
|
call contours_psi(psival,rcn,zcn,ipr)
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine bfield_res
|
|
use interp_eqprof, only : rv,zv,nr,nz,btotal
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(nnw=501,nnh=501)
|
|
parameter(icmx=2002)
|
|
dimension rrcb(icmx),zzcb(icmx),ncpts(10)
|
|
c
|
|
common/parbres/bres
|
|
c
|
|
c Btotal on psi grid
|
|
c
|
|
btmx=-1.0d30
|
|
btmn=1.0d30
|
|
do j=1,nr
|
|
rrj=rv(j)
|
|
do k=1,nz
|
|
zzk=zv(k)
|
|
call bfield(rrj,zzk,bbphi,bbr,bbz)
|
|
btotal(j,k)=sqrt(bbr**2+bbz**2+bbphi**2)
|
|
if(btotal(j,k).ge.btmx) btmx=btotal(j,k)
|
|
if(btotal(j,k).le.btmn) btmn=btotal(j,k)
|
|
c write(90,113) j,rrj,zzk,btotal(j,k)
|
|
enddo
|
|
c write(90,*) ' '
|
|
enddo
|
|
c
|
|
c compute Btot=Bres and Btot=Bres/2
|
|
c
|
|
write(70,*)'#i Btot R z'
|
|
do n=1,5
|
|
bbb=bres/dble(n)
|
|
if (bbb.ge.btmn.and.bbb.le.btmx) then
|
|
call cniteq(bbb,nconts,ncpts,nctot,rrcb,zzcb,1)
|
|
do inc=1,nctot
|
|
write(70,113) inc,bbb,rrcb(inc),zzcb(inc)
|
|
end do
|
|
end if
|
|
write(70,*) ' '
|
|
end do
|
|
c
|
|
return
|
|
113 format(i6,12(1x,e12.5))
|
|
end
|
|
c
|
|
c
|
|
subroutine profdata
|
|
use graydata_flags, only : iprof,iscal,nprof
|
|
use graydata_par, only : psdbnd,factb,factt,factn
|
|
use interp_eqprof, only : nsfd,npp,psnpp,aa,bb,cc,
|
|
. psrad,derad,terad,zfc,tfn,cfn,ct,cz,alloc_profvec
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
integer, dimension(:), allocatable :: iwrkf
|
|
real*8, dimension(:), allocatable :: wrkf,wf,wrkfd,
|
|
. densi,ddensi,d2densi
|
|
c
|
|
c read plasma profiles from file if iprof>0
|
|
c
|
|
if (iscal.eq.0) then
|
|
aat=2.0d0/3.0d0
|
|
aan=4.0d0/3.0d0
|
|
else
|
|
aat=1.0d0
|
|
aan=1.0d0
|
|
end if
|
|
ffact=factb
|
|
if(iscal.eq.2) ffact=1.0d0
|
|
c
|
|
if (iprof.gt.0) then
|
|
read(nprof,*) npp
|
|
|
|
call alloc_profvec(ierr)
|
|
if (ierr.ne.0) stop
|
|
|
|
npest=npp+4
|
|
lwrkf=npp*4+npest*16
|
|
|
|
if(allocated(wrkf)) deallocate(wrkf)
|
|
if(allocated(iwrkf)) deallocate(iwrkf)
|
|
if(allocated(wf)) deallocate(wf)
|
|
if(allocated(wrkfd)) deallocate(wrkfd)
|
|
if(allocated(densi)) deallocate(densi)
|
|
if(allocated(ddensi)) deallocate(ddensi)
|
|
if(allocated(d2densi)) deallocate(d2densi)
|
|
|
|
allocate(wrkf(lwrkf),iwrkf(npest),wf(npp),densi(npest),
|
|
. wrkfd(npest),ddensi(npest),d2densi(npest))
|
|
|
|
read(nprof,*) psrad0,terad0,derad0,zfc0
|
|
if(psrad0.ne.0.0d0) psrad0=0.0d0
|
|
psrad(1)=psrad0
|
|
terad(1)=terad0*ffact**aat*factt
|
|
derad(1)=derad0*ffact**aan*factn
|
|
zfc(1)=zfc0
|
|
wf(1)=1.0d0
|
|
do i=2,npp
|
|
read(nprof,*) psradi,teradi,deradi,zfci
|
|
psrad(i)=psradi
|
|
terad(i)=teradi*ffact**aat*factt
|
|
derad(i)=deradi*ffact**aan*factn
|
|
zfc(i)=zfci
|
|
wf(i)=1.0d0
|
|
end do
|
|
c
|
|
c spline approximation of temperature and Zeff
|
|
c
|
|
iopt=0
|
|
call difcsn(psrad,terad,npp,npp,iopt,ct,ier)
|
|
c
|
|
iopt=0
|
|
call difcsn(psrad,zfc,npp,npp,iopt,cz,ier)
|
|
c
|
|
c spline approximation of density
|
|
c
|
|
iopt=0
|
|
xb=0.0d0
|
|
xe=psrad(npp)
|
|
kspl=3
|
|
sspl=.001d0
|
|
c
|
|
call curfit(iopt,npp,psrad,derad,wf,xb,xe,kspl,sspl,npest,nsfd,
|
|
. tfn,cfn,fp,wrkf,lwrkf,iwrkf,ier)
|
|
c
|
|
call splev(tfn,nsfd,cfn,3,psrad,densi,npp,ier)
|
|
nu=1
|
|
call splder(tfn,nsfd,cfn,3,nu,psrad,ddensi,npp,wrkfd,ier)
|
|
dnpp=densi(npp)
|
|
ddnpp=ddensi(npp)
|
|
c
|
|
nu=2
|
|
call splder(tfn,nsfd,cfn,3,nu,psrad,d2densi,npp,wrkfd,ier)
|
|
d2dnpp=d2densi(npp)
|
|
|
|
if(derad(npp).eq.0.0d0) then
|
|
psdbnd=psrad(npp)
|
|
else
|
|
psnpp=psrad(npp)
|
|
dpsb=-psnpp+psdbnd
|
|
nn=3
|
|
nn1=nn+1
|
|
nn2=nn+2
|
|
aa=(nn1*nn2*dnpp+2*nn1*ddnpp*dpsb+d2dnpp*dpsb**2)
|
|
aa=aa/(-dpsb)**nn/2.0d0
|
|
bb=-(nn*nn2*dnpp+(2*nn+1)*ddnpp*dpsb+d2dnpp*dpsb**2)
|
|
bb=bb/(-dpsb)**nn1
|
|
cc=(nn1*nn*dnpp+2*nn*ddnpp*dpsb+d2dnpp*dpsb**2)
|
|
cc=cc/(-dpsb)**nn2/2.0d0
|
|
end if
|
|
c
|
|
end if
|
|
c
|
|
deallocate(iwrkf,wrkf,wf,densi,ddensi,d2densi,wrkfd)
|
|
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine rhotor(nnr)
|
|
use interp_eqprof, only : nr,psinr,qpsi,crhot,cq
|
|
|
|
implicit real*8(a-h,o-z)
|
|
real*8, dimension(:), allocatable :: rhotnr
|
|
common/rhotsx/rhotsx
|
|
c
|
|
if(allocated(cq)) deallocate(cq)
|
|
if(allocated(crhot)) deallocate(crhot)
|
|
allocate(rhotnr(nr),cq(nr,4),crhot(nr,4))
|
|
c
|
|
c normalized toroidal rho : ~ Integral q(psi) dpsi
|
|
c
|
|
iopt=0
|
|
call difcsn(psinr,qpsi,nr,nnr,iopt,cq,ier)
|
|
c
|
|
rhotnr(1)=0.0d0
|
|
do k=1,nnr-1
|
|
dx=psinr(k+1)-psinr(k)
|
|
drhot=dx*(cq(k,1)+dx*(cq(k,2)/2.0d0+dx*(cq(k,3)/3.0d0
|
|
. +dx*cq(k,4)/4.0d0)))
|
|
rhotnr(k+1)=rhotnr(k)+drhot
|
|
end do
|
|
rhotsx=rhotnr(nnr)
|
|
do k=1,nr
|
|
rhotnr(k)=sqrt(rhotnr(k)/rhotnr(nnr))
|
|
end do
|
|
c
|
|
c spline interpolation of rhotor
|
|
c
|
|
iopt=0
|
|
call difcsn(psinr,rhotnr,nr,nnr,iopt,crhot,ier)
|
|
|
|
deallocate(rhotnr)
|
|
|
|
return
|
|
end
|
|
|
|
function fq_eq(psi)
|
|
use interp_eqprof, only : psinr,nr,cq
|
|
|
|
implicit real*8(a-h,o-z)
|
|
|
|
irt=int((nr-1)*psi+1)
|
|
if(irt.eq.0) irt=1
|
|
if(irt.eq.nr) irt=nr-1
|
|
dps=psi-psinr(irt)
|
|
fq_eq=spli(cq,nr,irt,dps)
|
|
return
|
|
end
|
|
|
|
function frhotor_eq(psi)
|
|
use interp_eqprof, only : psinr,nr,crhot
|
|
|
|
implicit real*8(a-h,o-z)
|
|
c
|
|
irt=int((nr-1)*psi+1)
|
|
c if(irt.eq.0) irt=1
|
|
c if(irt.eq.nr) irt=nr-1
|
|
irt=min(max(1,irt),nr-1)
|
|
dps=psi-psinr(irt)
|
|
frhotor_eq=spli(crhot,nr,irt,dps)
|
|
return
|
|
end
|
|
|
|
function frhotor(psi)
|
|
use graydata_flags, only : iequil
|
|
|
|
implicit real*8(a-h,o-z)
|
|
if(iequil.eq.2) frhotor=frhotor_eq(psi)
|
|
if(iequil.eq.1) frhotor=frhotor_an(sqrt(psi))
|
|
return
|
|
end
|
|
|
|
function frhotor_av(psi)
|
|
use magsurf_data, only : rpstab, crhotq, npsi
|
|
|
|
implicit real*8(a-h,o-z)
|
|
|
|
rpsi=sqrt(psi)
|
|
ip=int((npsi-1)*rpsi+1)
|
|
c if(ip.eq.0) ip=1
|
|
c if(ip.eq.npsi) ip=npsi-1
|
|
ip=min(max(1,ip),npsi-1)
|
|
dps=rpsi-rpstab(ip)
|
|
frhotor_av=spli(crhotq,npsi,ip,dps)
|
|
return
|
|
end
|
|
|
|
subroutine rhopol
|
|
implicit real*8(a-h,o-z)
|
|
parameter(nnr=101,nrest=nnr+4)
|
|
parameter(lwrkp=nnr*4+nrest*16)
|
|
dimension rhop(nnr),rhot(nnr),rhopi(nnr)
|
|
dimension trp(nrest),crp(nrest),wp(nrest)
|
|
dimension wrkp(lwrkp),iwrkp(nrest)
|
|
common/coffrtp/trp
|
|
common/coffrn/nsrp
|
|
common/coffrp/crp
|
|
|
|
dr=1.0d0/dble(nnr-1)
|
|
do i=1,nnr
|
|
rhop(i)=(i-1)*dr
|
|
psin=rhop(i)*rhop(i)
|
|
rhot(i)=frhotor(psin)
|
|
wp(i)=1.0d0
|
|
end do
|
|
wp(1)=1.0d3
|
|
wp(nnr)=1.0d3
|
|
|
|
c spline interpolation of rhopol versus rhotor
|
|
iopt=0
|
|
xb=0.0d0
|
|
xe=1.0d0
|
|
ss=0.00001d0
|
|
kspl=3
|
|
call curfit(iopt,nnr,rhot,rhop,wp,xb,xe,kspl,ss,nrest,nsrp,
|
|
. trp,crp,rp,wrkp,lwrkp,iwrkp,ier)
|
|
c print*,ier
|
|
call splev(trp,nsrp,crp,3,rhot,rhopi,nnr,ier)
|
|
c do i=1,nnr
|
|
c write(54,*) rhop(i),rhot(i),rhopi(i)
|
|
c end do
|
|
|
|
return
|
|
end
|
|
|
|
function frhopol(rhot)
|
|
implicit real*8(a-h,o-z)
|
|
parameter(nnr=101,nrest=nnr+4)
|
|
dimension trp(nrest),crp(nrest),rrs(1),ffspl(1)
|
|
common/coffrtp/trp
|
|
common/coffrn/nsrp
|
|
common/coffrp/crp
|
|
rrs(1)=rhot
|
|
call splev(trp,nsrp,crp,3,rrs,ffspl,1,ier)
|
|
frhopol=ffspl(1)
|
|
return
|
|
end
|
|
|
|
subroutine cniteq(h, ncon, npts, icount, rcon, zcon,ichoi)
|
|
use interp_eqprof, only : dr,dz,nr,nz,rqgrid=>rv,zqgrid=>zv,psin,
|
|
. btotal
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
c
|
|
c v2.01 12/07/95 -- written by d v bartlett, jet joint undertaking.
|
|
c (based on an older code)
|
|
c
|
|
parameter(icmx=2002)
|
|
dimension ja(3,2),lx(1000),npts(10)
|
|
dimension rcon(icmx),zcon(icmx)
|
|
real*8, dimension(:), allocatable :: a
|
|
c
|
|
data px/0.5d0/
|
|
c
|
|
if(allocated(a)) deallocate(a)
|
|
allocate(a(nr*nz))
|
|
c
|
|
if(ichoi.eq.0) then
|
|
do j=1,nz
|
|
do i=1,nr
|
|
a(nr*(j-1)+i)=psin(i,j)
|
|
enddo
|
|
enddo
|
|
endif
|
|
c
|
|
if(ichoi.eq.1) then
|
|
do j=1,nz
|
|
do i=1,nr
|
|
a(nr*(j-1)+i)=btotal(i,j)
|
|
enddo
|
|
enddo
|
|
endif
|
|
c
|
|
do ico=1,icmx
|
|
rcon(ico)=0.0d0
|
|
zcon(ico)=0.0d0
|
|
enddo
|
|
c
|
|
nrqmax=nr
|
|
nreq=nr
|
|
nzeq=nz
|
|
drgrd=dr
|
|
dzgrd=dz
|
|
c
|
|
ncon = 0
|
|
do i=1,10
|
|
npts(i) = 0
|
|
end do
|
|
iclast = 0
|
|
icount = 0
|
|
mpl=0
|
|
ix=0
|
|
mxr = nrqmax * (nzeq - 1)
|
|
n1 = nreq - 1
|
|
c
|
|
do 3 jx=2,n1
|
|
do 3 jm=jx,mxr,nrqmax
|
|
j = jm + nrqmax
|
|
ah=a(j)-h
|
|
if(ah) 60,60,61
|
|
60 if(a(jm)-h) 62,62,1
|
|
61 if(a(jm)-h) 1,1,63
|
|
1 ix=ix+1
|
|
lx(ix)=-j
|
|
if(ah) 62,62,63
|
|
62 if(a(j-1)-h) 3,3,4
|
|
63 if(a(j-1)-h) 4,4,3
|
|
4 ix=ix+1
|
|
lx(ix)=j
|
|
3 continue
|
|
c
|
|
do 79 jm=nreq,mxr,nrqmax
|
|
j = jm + nrqmax
|
|
ah=a(j)-h
|
|
if(ah) 64,64,65
|
|
64 if(a(j-1)-h) 66,66,76
|
|
65 if(a(j-1)-h) 76,76,67
|
|
76 ix=ix+1
|
|
lx(ix)=j
|
|
if(ah) 66,66,67
|
|
66 if(a(jm)-h) 79,79,78
|
|
67 if(a(jm)-h) 78,78,79
|
|
78 ix=ix+1
|
|
lx(ix)=-j
|
|
79 continue
|
|
c
|
|
do 75 jm=1,mxr,nrqmax
|
|
j = jm + nrqmax
|
|
if(a(j)-h) 68,68,69
|
|
68 if(a(jm)-h)75,75,71
|
|
69 if(a(jm)-h)71,71,75
|
|
71 ix=ix+1
|
|
lx(ix) =-j
|
|
75 continue
|
|
c
|
|
do 73 j=2,nreq
|
|
if(a(j)-h) 58,58,59
|
|
58 if(a(j-1)-h) 73,73,72
|
|
59 if(a(j-1)-h) 72,72,73
|
|
72 ix=ix+1
|
|
lx(ix)=j
|
|
73 continue
|
|
c
|
|
if(ix) 50,50,8
|
|
108 if(mpl.lt.4) go to 8
|
|
ncon = ncon + 1
|
|
npts(ncon) = icount - iclast
|
|
iclast = icount
|
|
8 in=ix
|
|
jx=lx(in)
|
|
jfor=0
|
|
lda=1
|
|
ldb=2
|
|
30 if(jx) 21,22,22
|
|
21 jabs=-jx
|
|
jnb = jabs - nrqmax
|
|
go to 23
|
|
22 jabs=jx
|
|
jnb=jabs-1
|
|
23 adn=a(jabs)-a(jnb)
|
|
if(adn) 24,9,24
|
|
24 px=(a(jabs)-h)/adn
|
|
9 kx = (jabs - 1) / nrqmax
|
|
ikx = jabs - nrqmax * kx - 1
|
|
if(jx) 25,26,26
|
|
25 x = drgrd * ikx
|
|
y = dzgrd * (kx - px)
|
|
go to 27
|
|
26 x = drgrd * (ikx - px)
|
|
y = dzgrd * kx
|
|
27 continue
|
|
icount = icount + 1
|
|
rcon(icount) = x + rqgrid(1)
|
|
zcon(icount) = y + zqgrid(1)
|
|
mpl= icount
|
|
itm = 1
|
|
ja(1,1) = jabs + nrqmax
|
|
j=1
|
|
if(jx) 10,10,11
|
|
10 ja(1,1) = -jabs-1
|
|
j=2
|
|
11 ja(2,1)=-ja(1,1)
|
|
ja(3,1) = -jx + 1 - nrqmax
|
|
ja(3,2) = -jx
|
|
ja(j,2) = jabs - nrqmax
|
|
k= 3-j
|
|
ja(k,2) = 1-jabs
|
|
if (kx) 14,14,39
|
|
39 if(ikx) 14,14,36
|
|
36 if(ikx + 1 - nreq) 35, 37, 37
|
|
37 if(jx) 38,38,35
|
|
35 if(jfor) 28,29,28
|
|
28 do 13 i=1,3
|
|
if(jfor-ja(i,2)) 13,14,13
|
|
13 continue
|
|
38 lda=2
|
|
go to 15
|
|
14 lda=1
|
|
15 ldb=lda
|
|
29 do 18 k=1,3
|
|
do 18 l=lda,ldb
|
|
do 16 i=1,ix
|
|
if(lx(i)-ja(k,l)) 16,17,16
|
|
16 continue
|
|
go to 18
|
|
17 itm=itm+1
|
|
inext= i
|
|
if(jfor) 19,33,19
|
|
33 if(itm .gt. 3) goto 20
|
|
18 continue
|
|
19 lx(in)=0
|
|
if(itm .eq. 1) goto 6
|
|
20 jfor=jx
|
|
jx=lx(inext)
|
|
in = inext
|
|
go to 30
|
|
6 if(lx(ix)) 108,7,108
|
|
7 ix= ix-1
|
|
if(ix) 51,51,6
|
|
51 if(mpl.lt.4) go to 50
|
|
ncon = ncon + 1
|
|
npts(ncon) = icount - iclast
|
|
iclast = icount
|
|
50 continue
|
|
c
|
|
deallocate(a)
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine contours_psi(h,rcn,zcn,ipr)
|
|
use graydata_par, only : rwallm
|
|
use magsurf_data, only : npoints
|
|
use interp_eqprof, only : psia,psiant,psinop,nsr=>nsrt,nsz=>nszt,
|
|
. cc=>cceq,tr,tz,rup,zup,rlw,zlw,nr
|
|
|
|
use const_and_precisions, only : pi
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(mest=4,kspl=3)
|
|
dimension zeroc(mest)
|
|
dimension rcn(npoints),zcn(npoints)
|
|
real*8, dimension(:), allocatable :: czc
|
|
c
|
|
np=(npoints-1)/2
|
|
if(allocated(czc)) deallocate(czc)
|
|
allocate(czc(nr+4))
|
|
c
|
|
ra=rup
|
|
rb=rlw
|
|
za=zup
|
|
zb=zlw
|
|
call points_tgo(ra,za,rup,zup,h,info)
|
|
call points_tgo(rb,zb,rlw,zlw,h,info)
|
|
|
|
th=pi/dble(np)
|
|
rcn(1)=rlw
|
|
zcn(1)=zlw
|
|
rcn(npoints)=rlw
|
|
zcn(npoints)=zlw
|
|
rcn(np+1)=rup
|
|
zcn(np+1)=zup
|
|
do ic=2,np
|
|
zc=zlw+(zup-zlw)*(1.0d0-cos(th*(ic-1)))/2.0d0
|
|
iopt=1
|
|
call profil(iopt,tr,nsr,tz,nsz,cc,kspl,kspl,zc,nsr,czc,ier)
|
|
if(ier.gt.0) print*,' profil =',ier
|
|
val=h*psiant+psinop
|
|
call sproota(val,tr,nsr,czc,zeroc,mest,m,ier)
|
|
if (zeroc(1).gt.rwallm) then
|
|
rcn(ic)=zeroc(1)
|
|
zcn(ic)=zc
|
|
rcn(npoints+1-ic)=zeroc(2)
|
|
zcn(npoints+1-ic)=zc
|
|
else
|
|
rcn(ic)=zeroc(2)
|
|
zcn(ic)=zc
|
|
rcn(npoints+1-ic)=zeroc(3)
|
|
zcn(npoints+1-ic)=zc
|
|
end if
|
|
end do
|
|
if (ipr.gt.0) then
|
|
do ii=1,npoints
|
|
write(71,111) ii,h,rcn(ii),zcn(ii)
|
|
end do
|
|
write(71,*)
|
|
write(71,*)
|
|
end if
|
|
|
|
deallocate(czc)
|
|
|
|
return
|
|
111 format(i6,12(1x,e12.5))
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine flux_average
|
|
use const_and_precisions, only : zero,one,pi,ccj=>mu0inv
|
|
use magsurf_data
|
|
use interp_eqprof, only : btrcen,btaxis,rmaxis,zmaxis,phitedge
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
real*8 lam
|
|
real*8, dimension(:), allocatable :: rctemp,zctemp
|
|
|
|
parameter(nnintp=101,ncnt=100,nlam=41)
|
|
parameter(ksp=3,njest=nnintp+ksp+1,nlest=nlam+ksp+1)
|
|
parameter(lwrk=4*(nnintp+nlam)+11*(njest+nlest)+
|
|
. njest*nnintp+nlest+54)
|
|
parameter(kwrk=nnintp+nlam+njest+nlest+3)
|
|
parameter(lw01=nnintp*4+nlam*3+nnintp*nlam)
|
|
c
|
|
dimension dadrhotv(nnintp)
|
|
dimension dvdrhotv(nnintp)
|
|
dimension dlpv(2*ncnt),bv(2*ncnt+1),bpv(2*ncnt+1)
|
|
dimension vratjpl(nnintp)
|
|
dimension alam(nlam),fhlam(nnintp,nlam)
|
|
dimension ffhlam(nnintp*nlam),dffhlam(nnintp*nlam)
|
|
dimension iwrk(kwrk),wrk(lwrk)
|
|
dimension weights(nlam)
|
|
c
|
|
common/fpol/fpolv,ffpv
|
|
c
|
|
npsi=nnintp
|
|
ninpr=(npsi-1)/10
|
|
npoints = 2*ncnt+1
|
|
c
|
|
call alloc_surfvec(ierr)
|
|
if(allocated(tjp)) deallocate(tjp)
|
|
if(allocated(tlm)) deallocate(tlm)
|
|
if(allocated(ch)) deallocate(ch)
|
|
if(allocated(ch01)) deallocate(ch01)
|
|
allocate(tjp(njest),tlm(nlest),ch((njest-4)*(nlest-4)),
|
|
. ch01(lw01),rctemp(npoints),zctemp(npoints),stat=ierr)
|
|
if (ierr.ne.0) return
|
|
|
|
c computation of flux surface averaged quantities
|
|
|
|
write(71,*)' #i psin R z'
|
|
|
|
dlam=1.0d0/dble(nlam-1)
|
|
do l=1,nlam-1
|
|
alam(l)=dble(l-1)*dlam
|
|
fhlam(1,l)=sqrt(1.0d0-alam(l))
|
|
ffhlam(l)=fhlam(1,l)
|
|
dffhlam(l)=-0.5d0/sqrt(1.0d0-alam(l))
|
|
weights(l)=1.0d0
|
|
end do
|
|
weights(1)=0.5d0
|
|
weights(nlam)=0.5d0
|
|
alam(nlam)=1.0d0
|
|
fhlam(1,nlam)=0.0d0
|
|
ffhlam(nlam)=0.0d0
|
|
dffhlam(nlam)=-99999.0d0
|
|
|
|
jp=1
|
|
anorm=2.0d0*pi*rmaxis/abs(btaxis)
|
|
b2av=btaxis**2
|
|
dvdpsi=2.0d0*pi*anorm
|
|
dadpsi=2.0d0*pi/abs(btaxis)
|
|
ratio_cdator=abs(btaxis/btrcen)
|
|
ratio_cdbtor=1.0d0
|
|
ratio_pltor=1.0d0
|
|
qq=1.0d0
|
|
fc=1.0d0
|
|
|
|
psicon(1)=0.0d0
|
|
rcon(1,:)=0.0d0
|
|
zcon(1,:)=0.0d0
|
|
pstab(1)=0.0d0
|
|
rhot_eq(1)=0.0d0
|
|
rpstab(1)=0.0d0
|
|
rhotqv(1)=0.0d0
|
|
vcurrp(1)=0.0d0
|
|
vajphiav(1)=0.0d0
|
|
bmxpsi(1)=abs(btaxis)
|
|
bmnpsi(1)=abs(btaxis)
|
|
bav(1)=abs(btaxis)
|
|
rbav(1)=1.0d0
|
|
rri(1)=rmaxis
|
|
varea(1)=0.0d0
|
|
vvol(1)=0.0d0
|
|
vratjpl(1)=ratio_pltor
|
|
vratja(1)=ratio_cdator
|
|
vratjb(1)=ratio_cdbtor
|
|
ffc(1)=fc
|
|
rhot2q=0.0d0
|
|
qqv(1)=1.0d0
|
|
|
|
dadrhotv(1)=0.0d0
|
|
dvdrhotv(1)=0.0d0
|
|
|
|
C rup=rmaxis
|
|
C rlw=rmaxis
|
|
C zup=(zbmax+zmaxis)/2.0d0
|
|
C zlw=(zmaxis+zbmin)/2.0d0
|
|
|
|
do jp=2,npsi
|
|
height=dble(jp-1)/dble(npsi-1)
|
|
psicon(jp)=height
|
|
if(jp.eq.npsi) height=0.9999d0
|
|
ipr=0
|
|
jpr=mod(jp,ninpr)
|
|
if(jpr.eq.1) ipr=1
|
|
height2=height*height
|
|
call contours_psi(height2,rctemp,zctemp,ipr)
|
|
rcon(jp,:) = rctemp
|
|
zcon(jp,:) = zctemp
|
|
c
|
|
r2iav=0.0d0
|
|
anorm=0.0d0
|
|
dadpsi=0.0d0
|
|
currp=0.0d0
|
|
b2av=0.0d0
|
|
area=0.0d0
|
|
volume=0.0d0
|
|
ajphiav=0.0d0
|
|
bbav=0.0d0
|
|
bmmx=-1.0d+30
|
|
bmmn=1.0d+30
|
|
|
|
call tor_curr(rctemp(1),zctemp(1),ajphi0)
|
|
call bpol(rctemp(1),zctemp(1),brr,bzz)
|
|
call equinum_fpol(0)
|
|
bphi=fpolv/rctemp(1)
|
|
btot0=sqrt(bphi**2+brr**2+bzz**2)
|
|
bpoloid0=sqrt(brr**2+bzz**2)
|
|
bv(1)=btot0
|
|
bpv(1)=bpoloid0
|
|
rpsim0=rctemp(1)
|
|
|
|
do inc=1,npoints-1
|
|
inc1=inc+1
|
|
dla=sqrt((rctemp(inc)-rmaxis)**2+(zctemp(inc)-zmaxis)**2)
|
|
dlb=sqrt((rctemp(inc1)-rmaxis)**2+(zctemp(inc1)-zmaxis)**2)
|
|
dlp=sqrt((rctemp(inc1)-rctemp(inc))**2+
|
|
. (zctemp(inc1)-zctemp(inc))**2)
|
|
drc=(rctemp(inc1)-rctemp(inc))
|
|
|
|
c compute length, area and volume defined by psi=height^2
|
|
|
|
ph=0.5d0*(dla+dlb+dlp)
|
|
area2=ph*(ph-dla)*(ph-dlb)*(ph-dlp)
|
|
area=area+sqrt(area2)
|
|
rzp=rctemp(inc1)*zctemp(inc1)
|
|
rz=rctemp(inc)*zctemp(inc)
|
|
volume=pi*(rzp+rz)*drc+volume
|
|
|
|
c compute line integral on the contour psi=height^2
|
|
|
|
rpsim=rctemp(inc1)
|
|
zpsim=zctemp(inc1)
|
|
call bpol(rpsim,zpsim,brr,bzz)
|
|
call tor_curr(rpsim,zpsim,ajphi)
|
|
call equinum_fpol(0)
|
|
bphi=fpolv/rpsim
|
|
btot=sqrt(bphi**2+brr**2+bzz**2)
|
|
bpoloid=sqrt(brr**2+bzz**2)
|
|
dlpv(inc)=dlp
|
|
bv(inc1)=btot
|
|
bpv(inc1)=bpoloid
|
|
|
|
dlph=0.5d0*dlp
|
|
anorm=anorm+dlph*(1.0d0/bpoloid+1.0d0/bpoloid0)
|
|
dadpsi=dadpsi+dlph*
|
|
. (1.0d0/(bpoloid*rpsim)+1.0d0/(bpoloid0*rpsim0))
|
|
currp=currp+dlph*(bpoloid+bpoloid0)
|
|
b2av=b2av+dlph*(btot0**2/bpoloid0+btot**2/bpoloid)
|
|
bbav=bbav+dlph*(btot/bpoloid+btot0/bpoloid0)
|
|
r2iav=r2iav+dlph*
|
|
. (1.0d0/(bpoloid*rpsim**2)+1.0d0/(bpoloid0*rpsim0**2))
|
|
ajphiav=ajphiav+dlph*
|
|
. (ajphi0/(bpoloid0*rpsim0)+ajphi/(bpoloid*rpsim))
|
|
|
|
ajphi0=ajphi
|
|
rpsim0=rpsim
|
|
bpoloid0=bpoloid
|
|
btot0=btot
|
|
|
|
c computation maximum/minimum B values on given flux surface
|
|
|
|
if(btot.le.bmmn) bmmn=btot
|
|
if(btot.ge.bmmx) bmmx=btot
|
|
end do
|
|
|
|
c bav=<B> [T] , b2av=<B^2> [T^2] , rbav=<B>/b_min
|
|
c anorm = int d l_p/B_p = dV/dpsi/(2pi)
|
|
c r2iav=<1/R^2> [m^-2] ,
|
|
c riav=<1/R> [m^-1] = dA/dpsi/(dV/dpsi/(2pi)),
|
|
c rri = <B>/(|R B_tor|<1/R^2>) , used to compute I_tor [m^-1]
|
|
c currp = plasma current within psi=const
|
|
|
|
bbav=bbav/anorm
|
|
r2iav=r2iav/anorm
|
|
dvdpsi=2.0d0*pi*anorm
|
|
riav=dadpsi/anorm
|
|
b2av=b2av/anorm
|
|
vcurrp(jp)=ccj*currp
|
|
vajphiav(jp)=ajphiav/dadpsi
|
|
|
|
c area == varea, volume == vvol
|
|
c flux surface minor radius == (area/pi)^1/2
|
|
c ratio_cdator = Jcd_astra/J_phi Jcd_astra = <Jcd.B>/B0
|
|
c ratio_cdbtor = Jcd_jintrac/J_phi Jcd_jintrac = <Jcd.B>/<B>
|
|
c ratio_pltor = Jcd_||/J_phi Jcd_|| = <Jcd.b>
|
|
|
|
pstab(jp)=height2
|
|
rpstab(jp)=height
|
|
vvol(jp)=abs(volume)
|
|
varea(jp)=area
|
|
bav(jp)=bbav
|
|
rbav(jp)=bbav/bmmn
|
|
bmxpsi(jp)=bmmx
|
|
bmnpsi(jp)=bmmn
|
|
rri(jp)=bav(jp)/abs(fpolv*r2iav)
|
|
ratio_cdator=abs(b2av*riav/(fpolv*r2iav*btrcen))
|
|
ratio_cdbtor=abs(b2av*riav/(fpolv*r2iav*bbav))
|
|
ratio_pltor=abs(bbav*riav/(fpolv*r2iav))
|
|
vratjpl(jp)=ratio_pltor
|
|
vratja(jp)=ratio_cdator
|
|
vratjb(jp)=ratio_cdbtor
|
|
qq=abs(dvdpsi*fpolv*r2iav/(4*pi*pi))
|
|
qqv(jp)=qq
|
|
|
|
dadrhotv(jp)=phitedge*frhotor_eq(height2)/fq_eq(height2)
|
|
. *dadpsi/pi
|
|
dvdrhotv(jp)=phitedge*frhotor_eq(height2)/fq_eq(height2)
|
|
. *dvdpsi/pi
|
|
|
|
c computation of rhot from calculated q profile
|
|
|
|
rhot2q=rhot2q+(qqv(jp)*rpstab(jp)+qqv(jp-1)*rpstab(jp-1))
|
|
. /dble(npsi-1)
|
|
rhotqv(jp)=sqrt(rhot2q)
|
|
|
|
c computation of fraction of circulating/trapped fraction fc, ft
|
|
c and of function H(lambda,rhop)
|
|
c ffhlam = Bmn/Bmx/fc integral_lambda^1 dlam/<sqrt(1-lam*B(rhop)/Bmx)>
|
|
|
|
fc=0.0d0
|
|
shlam=0.0d0
|
|
do l=nlam,1,-1
|
|
lam=alam(l)
|
|
srl=0.0d0
|
|
rl2=1.0d0-lam*bv(1)/bmmx
|
|
rl0=0.d0
|
|
if(rl2.gt.0) rl0=sqrt(rl2)
|
|
do inc=1,npoints-1
|
|
rl2=1.0d0-lam*bv(inc+1)/bmmx
|
|
rl=0.0d0
|
|
if(rl2.gt.0) rl=sqrt(rl2)
|
|
srl=srl+0.5d0*dlpv(inc)*(rl/bpv(inc+1)+rl0/bpv(inc))
|
|
rl0=rl
|
|
end do
|
|
srl=srl/anorm
|
|
dhlam=0.5d0/srl
|
|
fc=fc+lam/srl*weights(l)
|
|
if(l.eq.nlam) then
|
|
fhlam(jp,l)=0.0d0
|
|
ffhlam(nlam*(jp-1)+l)=0.0d0
|
|
dffhlam(nlam*(jp-1)+l)=-dhlam
|
|
dhlam0=dhlam
|
|
else
|
|
shlam=shlam+0.5d0*(dhlam+dhlam0)*dlam
|
|
fhlam(jp,l)=shlam
|
|
dffhlam(nlam*(jp-1)+l)=-dhlam
|
|
dhlam0=dhlam
|
|
end if
|
|
end do
|
|
fc=0.75d0*b2av/bmmx**2*fc*dlam
|
|
ffc(jp)=fc
|
|
|
|
ccfh=bmmn/bmmx/fc
|
|
do l=1,nlam
|
|
ffhlam(nlam*(jp-1)+l)=ccfh*fhlam(jp,l)
|
|
dffhlam(nlam*(jp-1)+l)=ccfh*dffhlam(nlam*(jp-1)+l)
|
|
end do
|
|
end do
|
|
|
|
write(56,*)' #psi rhot_eq rhot_av |<B>| |Bmx| |Bmn|'//
|
|
.' Area Vol |I_pl| <J_phi> qq fc ratioJa ratioJb'
|
|
|
|
qqv(1)=qqv(2)
|
|
vajphiav(1)=vajphiav(2)
|
|
do jp=1,npsi
|
|
rhotqv(jp)=rhotqv(jp)/rhotqv(npsi)
|
|
if(jp.eq.npsi) then
|
|
rhotqv(jp)=1.0d0
|
|
rpstab(jp)=1.0d0
|
|
pstab(jp)=1.0d0
|
|
end if
|
|
rhot_eq(jp)=frhotor_eq(pstab(jp))
|
|
write(56,99) pstab(jp),rhot_eq(jp),rhotqv(jp),
|
|
. bav(jp),bmxpsi(jp),bmnpsi(jp),varea(jp),vvol(jp),
|
|
. vcurrp(jp),vajphiav(jp),qqv(jp),ffc(jp),
|
|
. vratja(jp),vratjb(jp)
|
|
end do
|
|
|
|
c rarea=sqrt(varea(npsi)/pi)
|
|
|
|
c spline coefficients of vvol,rbav,rri,bmxpsi,bmnpsi
|
|
c used for computations of dP/dV and J_cd
|
|
c spline coefficients of rhot
|
|
|
|
iopt=0
|
|
call difcs(rpstab,vvol,npsi,iopt,cvol,ier)
|
|
iopt=0
|
|
call difcs(rpstab,rbav,npsi,iopt,crbav,ier)
|
|
iopt=0
|
|
call difcs(rpstab,rri,npsi,iopt,crri,ier)
|
|
iopt=0
|
|
call difcs(rpstab,bmxpsi,npsi,iopt,cbmx,ier)
|
|
iopt=0
|
|
call difcs(rpstab,bmnpsi,npsi,iopt,cbmn,ier)
|
|
iopt=0
|
|
call difcs(rpstab,vratja,npsi,iopt,cratja,ier)
|
|
iopt=0
|
|
call difcs(rpstab,vratjb,npsi,iopt,cratjb,ier)
|
|
iopt=0
|
|
call difcs(rpstab,vratjpl,npsi,iopt,cratjpl,ier)
|
|
iopt=0
|
|
call difcs(rpstab,varea,npsi,iopt,carea,ier)
|
|
iopt=0
|
|
call difcs(rpstab,ffc,npsi,iopt,cfc,ier)
|
|
iopt=0
|
|
call difcs(rpstab,rhotqv,npsi,iopt,crhotq,ier)
|
|
iopt=0
|
|
call difcs(rpstab,dadrhotv,npsi,iopt,cdadrhot,ier)
|
|
iopt=0
|
|
call difcs(rpstab,dvdrhotv,npsi,iopt,cdvdrhot,ier)
|
|
|
|
c spline interpolation of H(lambda,rhop) and dH/dlambda
|
|
|
|
iopt=0
|
|
s=0.0d0
|
|
call regrid(iopt,npsi,rpstab,nlam,alam,ffhlam,
|
|
. zero,one,zero,one,ksp,ksp,s,
|
|
. njest,nlest,njp,tjp,nlm,tlm,ch,fp,wrk,lwrk,iwrk,kwrk,ier)
|
|
njpt=njp
|
|
nlmt=nlm
|
|
|
|
call coeff_parder(tjp,njp,tlm,nlm,ch,ksp,ksp,0,1,
|
|
. ch01,lw01,ier)
|
|
|
|
|
|
return
|
|
99 format(20(1x,e12.5))
|
|
end
|
|
|
|
function fdadrhot(rpsi)
|
|
use magsurf_data, only : rpstab,cdadrhot,npsi
|
|
|
|
implicit real*8(a-h,o-z)
|
|
|
|
ip=int((npsi-1)*rpsi+1)
|
|
c if(ip.eq.0) ip=1
|
|
c if(ip.eq.npsi) ip=npsi-1
|
|
ip=min(max(1,ip),npsi-1)
|
|
dps=rpsi-rpstab(ip)
|
|
fdadrhot=spli(cdadrhot,npsi,ip,dps)
|
|
return
|
|
end
|
|
|
|
function fdvdrhot(rpsi)
|
|
use magsurf_data, only : rpstab,cdvdrhot,npsi
|
|
|
|
implicit real*8(a-h,o-z)
|
|
|
|
ip=int((npsi-1)*rpsi+1)
|
|
ip=min(max(1,ip),npsi-1)
|
|
dps=rpsi-rpstab(ip)
|
|
fdvdrhot=spli(cdvdrhot,npsi,ip,dps)
|
|
return
|
|
end
|
|
|
|
subroutine flux_average_an
|
|
use graydata_anequil, only : q0,qa,alq,b0,rr0m,zr0m,rpam
|
|
use magsurf_data
|
|
use interp_eqprof, only : btrcen
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
real*8 lam
|
|
real*8, dimension(:), allocatable :: rctemp,zctemp
|
|
|
|
parameter(nnintp=101,ncnt=100,nlam=41)
|
|
parameter(zero=0.0d0,one=1.0d0)
|
|
parameter(pi=3.14159265358979d0,ccj=1.0d+7/(4.0d0*pi))
|
|
parameter(ksp=3,njest=nnintp+ksp+1,nlest=nlam+ksp+1)
|
|
parameter(lwrk=4*(nnintp+nlam)+11*(njest+nlest)+
|
|
. njest*nnintp+nlest+54)
|
|
parameter(kwrk=nnintp+nlam+njest+nlest+3)
|
|
parameter(lw01=nnintp*4+nlam*3+nnintp*nlam)
|
|
|
|
dimension dadrhotv(nnintp)
|
|
dimension dvdrhotv(nnintp)
|
|
dimension dlpv(2*ncnt),bv(2*ncnt+1),bpv(2*ncnt+1)
|
|
dimension vratjpl(nnintp)
|
|
dimension alam(nlam),fhlam(nnintp,nlam)
|
|
dimension ffhlam(nnintp*nlam),dffhlam(nnintp*nlam)
|
|
dimension iwrk(kwrk),wrk(lwrk)
|
|
dimension weights(nlam)
|
|
c
|
|
common/fpol/fpolv,ffpv
|
|
c common/psival/psin
|
|
|
|
common/derip1/dpsidr,dpsidz
|
|
common/derip2/ddpsidrr,ddpsidzz,ddpsidrz
|
|
c
|
|
npsi=nnintp
|
|
ninpr=(npsi-1)/10
|
|
npoints = 2*ncnt+1
|
|
c
|
|
call alloc_surfvec(ierr)
|
|
if(allocated(tjp)) deallocate(tjp)
|
|
if(allocated(tlm)) deallocate(tlm)
|
|
if(allocated(ch)) deallocate(ch)
|
|
if(allocated(ch01)) deallocate(ch01)
|
|
allocate(tjp(njest),tlm(nlest),ch((njest-4)*(nlest-4)),
|
|
. ch01(lw01),rctemp(npoints),zctemp(npoints),stat=ierr)
|
|
if (ierr.ne.0) return
|
|
c
|
|
c computation of flux surface averaged quantities
|
|
|
|
rmaxis=rr0m
|
|
zmaxis=zr0m
|
|
btaxis=b0
|
|
|
|
call rhopol_an
|
|
phitedge=pi*rpam*rpam*btaxis
|
|
|
|
write(71,*)' #i psin R z'
|
|
|
|
dlam=1.0d0/dble(nlam-1)
|
|
do l=1,nlam-1
|
|
alam(l)=dble(l-1)*dlam
|
|
fhlam(1,l)=sqrt(1.0d0-alam(l))
|
|
ffhlam(l)=fhlam(1,l)
|
|
dffhlam(l)=-0.5d0/sqrt(1.0d0-alam(l))
|
|
weights(l)=1.0d0
|
|
end do
|
|
weights(1)=0.5d0
|
|
weights(nlam)=0.5d0
|
|
alam(nlam)=1.0d0
|
|
fhlam(1,nlam)=0.0d0
|
|
ffhlam(nlam)=0.0d0
|
|
dffhlam(nlam)=-99999.0d0
|
|
|
|
jp=1
|
|
anorm=2.0d0*pi*rmaxis/abs(btaxis)
|
|
b2av=btaxis**2
|
|
dvdpsi=2.0d0*pi*anorm
|
|
dadpsi=2.0d0*pi/abs(btaxis)
|
|
ratio_cdator=abs(btaxis/btrcen)
|
|
ratio_cdbtor=1.0d0
|
|
ratio_pltor=1.0d0
|
|
qq=1.0d0
|
|
fc=1.0d0
|
|
|
|
psicon(1)=0.0d0
|
|
rcon(1,:)=0.0d0
|
|
zcon(1,:)=0.0d0
|
|
pstab(1)=0.0d0
|
|
rhot_eq(1)=0.0d0
|
|
rpstab(1)=0.0d0
|
|
rhotqv(1)=0.0d0
|
|
vcurrp(1)=0.0d0
|
|
vajphiav(1)=0.0d0
|
|
bmxpsi(1)=abs(btaxis)
|
|
bmnpsi(1)=abs(btaxis)
|
|
bav(1)=abs(btaxis)
|
|
rbav(1)=1.0d0
|
|
rri(1)=rmaxis
|
|
varea(1)=0.0d0
|
|
vvol(1)=0.0d0
|
|
vratjpl(1)=ratio_pltor
|
|
vratja(1)=ratio_cdator
|
|
vratjb(1)=ratio_cdbtor
|
|
ffc(1)=fc
|
|
rhot2q=0.0d0
|
|
dadrhotv(1)=0.0d0
|
|
dvdrhotv(1)=0.0d0
|
|
qqv(1)=1.0d0
|
|
|
|
C rup=rmaxis
|
|
C rlw=rmaxis
|
|
C zup=(zbmax+zmaxis)/2.0d0
|
|
C zlw=(zmaxis+zbmin)/2.0d0
|
|
|
|
do jp=2,npsi
|
|
height=dble(jp-1)/dble(npsi-1)
|
|
psicon(jp)=height
|
|
if(jp.eq.npsi) height=0.9999d0
|
|
height2=height*height
|
|
ipr=0
|
|
jpr=mod(jp,ninpr)
|
|
if(jpr.eq.1) ipr=1
|
|
call contours_psi_an(height2,rctemp,zctemp,ipr)
|
|
rcon(jp,:) = rctemp
|
|
zcon(jp,:) = zctemp
|
|
c
|
|
r2iav=0.0d0
|
|
anorm=0.0d0
|
|
dadpsi=0.0d0
|
|
currp=0.0d0
|
|
b2av=0.0d0
|
|
area=0.0d0
|
|
volume=0.0d0
|
|
ajphiav=0.0d0
|
|
bbav=0.0d0
|
|
bmmx=-1.0d+30
|
|
bmmn=1.0d+30
|
|
|
|
call equian(rctemp(1),zctemp(1))
|
|
dbvcdc13=-ddpsidzz/rctemp(1)
|
|
dbvcdc31= ddpsidrr/rctemp(1)-bzz/rctemp(1)
|
|
ajphi=ccj*(dbvcdc13-dbvcdc31)
|
|
brr=-dpsidz/rctemp(1)
|
|
bzz= dpsidr/rctemp(1)
|
|
bphi=fpolv/rctemp(1)
|
|
btot0=sqrt(bphi**2+brr**2+bzz**2)
|
|
bpoloid0=sqrt(brr**2+bzz**2)
|
|
bv(1)=btot0
|
|
bpv(1)=bpoloid0
|
|
rpsim0=rctemp(1)
|
|
|
|
do inc=1,npoints-1
|
|
inc1=inc+1
|
|
dla=sqrt((rctemp(inc)-rmaxis)**2+(zctemp(inc)-zmaxis)**2)
|
|
dlb=sqrt((rctemp(inc1)-rmaxis)**2+(zctemp(inc1)-zmaxis)**2)
|
|
dlp=sqrt((rctemp(inc1)-rctemp(inc))**2+
|
|
. (zctemp(inc1)-zctemp(inc))**2)
|
|
drc=(rctemp(inc1)-rctemp(inc))
|
|
|
|
c compute length, area and volume defined by psi=height^2
|
|
|
|
ph=0.5d0*(dla+dlb+dlp)
|
|
area2=ph*(ph-dla)*(ph-dlb)*(ph-dlp)
|
|
area=area+sqrt(area2)
|
|
rzp=rctemp(inc1)*zctemp(inc1)
|
|
rz=rctemp(inc)*zctemp(inc)
|
|
volume=pi*(rzp+rz)*drc+volume
|
|
|
|
c compute line integral on the contour psi=height^2
|
|
|
|
rpsim=rctemp(inc1)
|
|
zpsim=zctemp(inc1)
|
|
call equian(rpsim,zpsim)
|
|
brr=-dpsidz/rpsim
|
|
bzz= dpsidr/rpsim
|
|
dbvcdc13=-ddpsidzz/rpsim
|
|
dbvcdc31= ddpsidrr/rpsim-bzz/rpsim
|
|
ajphi=ccj*(dbvcdc13-dbvcdc31)
|
|
bphi=fpolv/rpsim
|
|
btot=sqrt(bphi**2+brr**2+bzz**2)
|
|
bpoloid=sqrt(brr**2+bzz**2)
|
|
dlpv(inc)=dlp
|
|
bv(inc1)=btot
|
|
bpv(inc1)=bpoloid
|
|
|
|
dlph=0.5d0*dlp
|
|
anorm=anorm+dlph*(1.0d0/bpoloid+1.0d0/bpoloid0)
|
|
dadpsi=dadpsi+dlph*
|
|
. (1.0d0/(bpoloid*rpsim)+1.0d0/(bpoloid0*rpsim0))
|
|
currp=currp+dlph*(bpoloid+bpoloid0)
|
|
b2av=b2av+dlph*(btot0**2/bpoloid0+btot**2/bpoloid)
|
|
bbav=bbav+dlph*(btot/bpoloid+btot0/bpoloid0)
|
|
r2iav=r2iav+dlph*
|
|
. (1.0d0/(bpoloid*rpsim**2)+1.0d0/(bpoloid0*rpsim0**2))
|
|
ajphiav=ajphiav+dlph*
|
|
. (ajphi0/(bpoloid0*rpsim0)+ajphi/(bpoloid*rpsim))
|
|
|
|
ajphi0=ajphi
|
|
rpsim0=rpsim
|
|
bpoloid0=bpoloid
|
|
btot0=btot
|
|
c computation maximum/minimum B values on given flux surface
|
|
|
|
if(btot.le.bmmn) bmmn=btot
|
|
if(btot.ge.bmmx) bmmx=btot
|
|
end do
|
|
|
|
c bav=<B> [T] , b2av=<B^2> [T^2] , rbav=<B>/b_min
|
|
c anorm = int d l_p/B_p = dV/dpsi/(2pi)
|
|
c r2iav=<1/R^2> [m^-2] ,
|
|
c riav=<1/R> [m^-1] = dA/dpsi/(dV/dpsi/(2pi)),
|
|
c rri = <B>/(|R B_tor|<1/R^2>) , used to compute I_tor [m^-1]
|
|
c currp = plasma current within psi=const
|
|
|
|
bbav=bbav/anorm
|
|
r2iav=r2iav/anorm
|
|
dvdpsi=2.0d0*pi*anorm
|
|
riav=dadpsi/anorm
|
|
b2av=b2av/anorm
|
|
vcurrp(jp)=ccj*currp
|
|
vajphiav(jp)=ajphiav/dadpsi
|
|
|
|
c area == varea, volume == vvol
|
|
c flux surface minor radius == (area/pi)^1/2
|
|
c ratio_cdator = Jcd_astra/J_phi Jcd_astra = <Jcd.B>/B0
|
|
c ratio_cdbtor = Jcd_jintrac/J_phi Jcd_jintrac = <Jcd.B>/<B>
|
|
c ratio_pltor = Jcd_||/J_phi Jcd_|| = <Jcd.b>
|
|
|
|
pstab(jp)=height2
|
|
rpstab(jp)=height
|
|
vvol(jp)=abs(volume)
|
|
varea(jp)=area
|
|
bav(jp)=bbav
|
|
rbav(jp)=bbav/bmmn
|
|
bmxpsi(jp)=bmmx
|
|
bmnpsi(jp)=bmmn
|
|
rri(jp)=bav(jp)/abs(fpolv*r2iav)
|
|
ratio_cdator=abs(b2av*riav/(fpolv*r2iav*btrcen))
|
|
ratio_cdbtor=abs(b2av*riav/(fpolv*r2iav*bbav))
|
|
ratio_pltor=abs(bbav*riav/(fpolv*r2iav))
|
|
vratjpl(jp)=ratio_pltor
|
|
vratja(jp)=ratio_cdator
|
|
vratjb(jp)=ratio_cdbtor
|
|
qq=abs(dvdpsi*fpolv*r2iav/(4.0d0*pi*pi))
|
|
qqv(jp)=qq
|
|
|
|
rn=frhotor_an(sqrt(pstab(jp)))
|
|
qqan=q0+(qa-q0)*rn**alq
|
|
|
|
dadr=2.0d0*pi*rn*rpam*rpam
|
|
dvdr=4.0d0*pi*pi*rn*rmaxis*rpam*rpam
|
|
|
|
c dadrhotv(jp)=rpam*rpam*btaxis*rn/qqan*dadpsi
|
|
c dvdrhotv(jp)=rpam*rpam*btaxis*rn/qqan*dvdpsi
|
|
dadrhotv(jp)=phitedge*rn*dadpsi/pi/qqan
|
|
dvdrhotv(jp)=phitedge*rn*dvdpsi/pi/qqan
|
|
|
|
c computation of rhot from calculated q profile
|
|
rhot2q=rhot2q+(qqv(jp)*rpstab(jp)+qqv(jp-1)*rpstab(jp-1))
|
|
. /dble(npsi-1)
|
|
c print*,jp,rhot2q,qqv(jp),rpstab(jp),qqv(jp-1),rpstab(jp-1)
|
|
rhotqv(jp)=sqrt(rhot2q)
|
|
c rhotqv(jp)=rn
|
|
c
|
|
write(57,99) rpstab(jp),rn,rhotqv(jp),qqv(jp),qqan,r2iav,
|
|
. dadr,dadrhotv(jp),dadpsi,dvdpsi,fpolv
|
|
|
|
c computation of fraction of circulating/trapped fraction fc, ft
|
|
c and of function H(lambda,rhop)
|
|
c ffhlam = Bmn/Bmx/fc integral_lambda^1 dlam/<sqrt(1-lam*B(rhop)/Bmx)>
|
|
|
|
fc=0.0d0
|
|
shlam=0.0d0
|
|
do l=nlam,1,-1
|
|
lam=alam(l)
|
|
srl=0.0d0
|
|
rl2=1.0d0-lam*bv(1)/bmmx
|
|
rl0=0.d0
|
|
if(rl2.gt.0) rl0=sqrt(rl2)
|
|
do inc=1,npoints-1
|
|
rl2=1.0d0-lam*bv(inc+1)/bmmx
|
|
rl=0.0d0
|
|
if(rl2.gt.0) rl=sqrt(rl2)
|
|
srl=srl+0.5d0*dlpv(inc)*(rl/bpv(inc+1)+rl0/bpv(inc))
|
|
rl0=rl
|
|
end do
|
|
srl=srl/anorm
|
|
dhlam=0.5d0/srl
|
|
fc=fc+lam/srl*weights(l)
|
|
if(l.eq.nlam) then
|
|
fhlam(jp,l)=0.0d0
|
|
ffhlam(nlam*(jp-1)+l)=0.0d0
|
|
dffhlam(nlam*(jp-1)+l)=-dhlam
|
|
dhlam0=dhlam
|
|
else
|
|
shlam=shlam+0.5d0*(dhlam+dhlam0)*dlam
|
|
fhlam(jp,l)=shlam
|
|
dffhlam(nlam*(jp-1)+l)=-dhlam
|
|
dhlam0=dhlam
|
|
end if
|
|
end do
|
|
fc=0.75d0*b2av/bmmx**2*fc*dlam
|
|
ffc(jp)=fc
|
|
|
|
ccfh=bmmn/bmmx/fc
|
|
do l=1,nlam
|
|
ffhlam(nlam*(jp-1)+l)=ccfh*fhlam(jp,l)
|
|
dffhlam(nlam*(jp-1)+l)=ccfh*dffhlam(nlam*(jp-1)+l)
|
|
end do
|
|
end do
|
|
|
|
write(56,*)' #psi rhot_eq rhot_av |<B>| |Bmx| |Bmn|'//
|
|
.' Area Vol |I_pl| <J_phi> qq fc ratioJa ratioJb dadr dvdr'
|
|
|
|
qqv(1)=qqv(2)
|
|
vajphiav(1)=vajphiav(2)
|
|
do jp=1,npsi
|
|
rhotqv(jp)=rhotqv(jp)/rhotqv(npsi)
|
|
if(jp.eq.npsi) then
|
|
rhotqv(jp)=1.0d0
|
|
rpstab(jp)=1.0d0
|
|
pstab(jp)=1.0d0
|
|
end if
|
|
rhot_eq(jp)=frhotor_an(sqrt(pstab(jp)))
|
|
write(56,99) pstab(jp),rhot_eq(jp),rhotqv(jp),
|
|
. bav(jp),bmxpsi(jp),bmnpsi(jp),varea(jp),vvol(jp),
|
|
. vcurrp(jp),vajphiav(jp),qqv(jp),ffc(jp),
|
|
. vratja(jp),vratjb(jp),dadrhotv(jp),dvdrhotv(jp)
|
|
end do
|
|
|
|
c rarea=sqrt(varea(npsi)/pi)
|
|
|
|
c spline coefficients of vvol,rbav,rri,bmxpsi,bmnpsi
|
|
c used for computations of dP/dV and J_cd
|
|
c spline coefficients of rhot
|
|
|
|
iopt=0
|
|
call difcs(rpstab,vvol,npsi,iopt,cvol,ier)
|
|
iopt=0
|
|
call difcs(rpstab,rbav,npsi,iopt,crbav,ier)
|
|
iopt=0
|
|
call difcs(rpstab,rri,npsi,iopt,crri,ier)
|
|
iopt=0
|
|
call difcs(rpstab,bmxpsi,npsi,iopt,cbmx,ier)
|
|
iopt=0
|
|
call difcs(rpstab,bmnpsi,npsi,iopt,cbmn,ier)
|
|
iopt=0
|
|
call difcs(rpstab,vratja,npsi,iopt,cratja,ier)
|
|
iopt=0
|
|
call difcs(rpstab,vratjb,npsi,iopt,cratjb,ier)
|
|
iopt=0
|
|
call difcs(rpstab,vratjpl,npsi,iopt,cratjpl,ier)
|
|
iopt=0
|
|
call difcs(rpstab,varea,npsi,iopt,carea,ier)
|
|
iopt=0
|
|
call difcs(rpstab,ffc,npsi,iopt,cfc,ier)
|
|
iopt=0
|
|
call difcs(rpstab,rhotqv,npsi,iopt,crhotq,ier)
|
|
iopt=0
|
|
call difcs(rpstab,dadrhotv,npsi,iopt,cdadrhot,ier)
|
|
iopt=0
|
|
call difcs(rpstab,dvdrhotv,npsi,iopt,cdvdrhot,ier)
|
|
|
|
c spline interpolation of H(lambda,rhop) and dH/dlambda
|
|
|
|
iopt=0
|
|
s=0.0d0
|
|
call regrid(iopt,npsi,rpstab,nlam,alam,ffhlam,
|
|
. zero,one,zero,one,ksp,ksp,s,
|
|
. njest,nlest,njp,tjp,nlm,tlm,ch,fp,wrk,lwrk,iwrk,kwrk,ier)
|
|
njpt=njp
|
|
nlmt=nlm
|
|
|
|
call coeff_parder(tjp,njp,tlm,nlm,ch,ksp,ksp,0,1,
|
|
. ch01,lw01,ier)
|
|
|
|
|
|
return
|
|
99 format(20(1x,e12.5))
|
|
end
|
|
|
|
|
|
subroutine rhopol_an
|
|
use graydata_par, only : sgniphi
|
|
use graydata_anequil, only : q0,qa,alq,b0,rr0m,rpam
|
|
use interp_eqprof, only : psia
|
|
|
|
implicit real*8(a-h,o-z)
|
|
parameter(nnr=101,nrest=nnr+4)
|
|
parameter(lwrk=nnr*4+nrest*16)
|
|
dimension rhop(nnr),rhot(nnr),rhopi(nnr),rhoti(nnr)
|
|
dimension psin(nnr)
|
|
dimension trp(nrest),crp(nrest)
|
|
dimension trot(nrest),crot(nrest)
|
|
dimension wrk(lwrk),iwrk(nrest),wp(nrest)
|
|
common/coffrtp/trp
|
|
common/coffrn/nsrp
|
|
common/coffrp/crp
|
|
common/coffrptt/trot
|
|
common/coffrnt/nsrot
|
|
common/coffrpt/crot
|
|
|
|
|
|
dr=1.0d0/dble(nnr-1)
|
|
rhot(1)=0.0d0
|
|
psin(1)=0.0d0
|
|
res=0.0d0
|
|
fq0=0.0d0
|
|
do i=2,nnr
|
|
rhot(i)=(i-1)*dr
|
|
rn=rhot(i)
|
|
qq=q0+(qa-q0)*rn**alq
|
|
fq1=rn/qq
|
|
res=res+0.5d0*(fq1+fq0)*dr
|
|
fq0=fq1
|
|
psin(i)=res
|
|
end do
|
|
|
|
wp=1.0d0
|
|
psin=psin/res
|
|
rhop=sqrt(psin)
|
|
psia=-sgniphi*abs(res*rpam*rpam*b0)
|
|
print*,psia,log(8.0d0*rr0m/rpam)-2.0d0
|
|
wp(1)=1.0d3
|
|
wp(nnr)=1.0d3
|
|
|
|
c spline interpolation of rhopol versus rhotor
|
|
iopt=0
|
|
xb=0.0d0
|
|
xe=1.0d0
|
|
ss=0.00001d0
|
|
kspl=3
|
|
call curfit(iopt,nnr,rhot,rhop,wp,xb,xe,kspl,ss,nrest,nsrp,
|
|
. trp,crp,rp,wrk,lwrk,iwrk,ier)
|
|
call splev(trp,nsrp,crp,3,rhot,rhopi,nnr,ier)
|
|
|
|
c spline interpolation of rhotor versus rhopol
|
|
iopt=0
|
|
xb=0.0d0
|
|
xe=1.0d0
|
|
ss=0.00001d0
|
|
kspl=3
|
|
call curfit(iopt,nnr,rhop,rhot,wp,xb,xe,kspl,ss,nrest,nsrot,
|
|
. trot,crot,rp,wrk,lwrk,iwrk,ier)
|
|
call splev(trot,nsrot,crot,3,rhop,rhoti,nnr,ier)
|
|
|
|
do i=1,nnr
|
|
write(54,*) rhop(i),rhot(i),rhopi(i),rhoti(i)
|
|
end do
|
|
|
|
return
|
|
end
|
|
|
|
|
|
function frhotor_an(rhop)
|
|
implicit real*8(a-h,o-z)
|
|
parameter(nnr=101,nrest=nnr+4)
|
|
dimension trot(nrest),crot(nrest),rrs(1),ffspl(1)
|
|
common/coffrptt/trot
|
|
common/coffrnt/nsrot
|
|
common/coffrpt/crot
|
|
rrs(1)=rhop
|
|
call splev(trot,nsrot,crot,3,rrs,ffspl,1,ier)
|
|
frhotor_an=ffspl(1)
|
|
return
|
|
end
|
|
|
|
|
|
subroutine contours_psi_an(h,rcn,zcn,ipr)
|
|
use graydata_anequil, only : rr0m,zr0m,rpam
|
|
use magsurf_data, only : npoints
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(pi=3.14159265358979d0)
|
|
parameter(mest=4,kspl=3)
|
|
dimension rcn(npoints),zcn(npoints)
|
|
|
|
np=(npoints-1)/2
|
|
|
|
th=pi/dble(np)
|
|
rn=frhotor_an(sqrt(h))
|
|
do ic=1,npoints
|
|
zcn(ic)=zr0m+rpam*rn*sin(th*(ic-1))
|
|
rcn(ic)=rr0m+rpam*rn*cos(th*(ic-1))
|
|
|
|
if (ipr.gt.0) then
|
|
write(71,111) ic,h,rcn(ic),zcn(ic)
|
|
end if
|
|
end do
|
|
write(71,*)
|
|
|
|
111 format(i6,12(1x,e12.5))
|
|
return
|
|
end
|
|
|
|
|
|
|
|
|
|
subroutine vectinit
|
|
use dispersion, only: expinit
|
|
use graydata_flags, only : iwarm
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(jmx=31,kmx=36,nmx=8000)
|
|
dimension psjki(jmx,kmx,nmx)
|
|
dimension tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx)
|
|
dimension pdjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx),tau1v(jmx,kmx)
|
|
dimension currj(jmx,kmx,nmx),didst(jmx,kmx,nmx),ccci(jmx,kmx,nmx)
|
|
dimension iiv(jmx,kmx),iop(jmx,kmx),iow(jmx,kmx),ihcd(jmx,kmx)
|
|
dimension istore(jmx,kmx),anwcl(3),xwcl(3)
|
|
c
|
|
common/iiv/iiv
|
|
common/iov/iop,iow,ihcd,istore
|
|
common/psjki/psjki
|
|
common/atjki/tauv,alphav
|
|
common/dpjjki/pdjki,currj
|
|
common/pcjki/ppabs,ccci
|
|
common/dcjki/didst
|
|
common/nray/nrayr,nrayth
|
|
common/nstep/nstep
|
|
common/tau1v/tau1v
|
|
common/refln/anwcl,xwcl,jclosest
|
|
c
|
|
if(nstep.gt.nmx) nstep=nmx
|
|
if(nrayr.gt.jmx) nrayr=jmx
|
|
if(nrayth.gt.kmx) nrayth=kmx
|
|
jclosest=nrayr+1
|
|
anwcl(1:3)=0.0d0
|
|
xwcl(1:3)=0.0d0
|
|
c
|
|
do i=1,nstep
|
|
do k=1,nrayth
|
|
do j=1,nrayr
|
|
psjki(j,k,i)=0.0d0
|
|
tauv(j,k,i)=0.0d0
|
|
alphav(j,k,i)=0.0d0
|
|
pdjki(j,k,i)=0.0d0
|
|
ppabs(j,k,i)=0.0d0
|
|
didst(j,k,i)=0.0d0
|
|
ccci(j,k,i)=0.0d0
|
|
currj(j,k,i)=0.0d0
|
|
iiv(j,k)=1
|
|
iop(j,k)=0
|
|
iow(j,k)=0
|
|
ihcd(j,k)=1
|
|
istore(j,k)=0
|
|
tau1v(j,k)=0.0d0
|
|
end do
|
|
end do
|
|
end do
|
|
c
|
|
if(iwarm.gt.1) call expinit
|
|
c
|
|
return
|
|
end
|
|
|
|
|
|
|
|
subroutine vectinit2
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(jmx=31,kmx=36,nmx=8000)
|
|
dimension psjki(jmx,kmx,nmx)
|
|
dimension tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx)
|
|
dimension pdjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx)
|
|
dimension currj(jmx,kmx,nmx),didst(jmx,kmx,nmx),ccci(jmx,kmx,nmx)
|
|
dimension iiv(jmx,kmx),iop(jmx,kmx),iow(jmx,kmx),ihcd(jmx,kmx)
|
|
dimension istore(jmx,kmx)
|
|
|
|
common/iiv/iiv
|
|
common/iov/iop,iow,ihcd,istore
|
|
common/psjki/psjki
|
|
common/atjki/tauv,alphav
|
|
common/dpjjki/pdjki,currj
|
|
common/pcjki/ppabs,ccci
|
|
common/dcjki/didst
|
|
common/nray/nrayr,nrayth
|
|
common/nstep/nstep
|
|
|
|
do i=1,nstep
|
|
do k=1,nrayth
|
|
do j=1,nrayr
|
|
psjki(j,k,i)=0.0d0
|
|
tauv(j,k,i)=0.0d0
|
|
alphav(j,k,i)=0.0d0
|
|
pdjki(j,k,i)=0.0d0
|
|
ppabs(j,k,i)=0.0d0
|
|
didst(j,k,i)=0.0d0
|
|
ccci(j,k,i)=0.0d0
|
|
currj(j,k,i)=0.0d0
|
|
iiv(j,k)=1
|
|
iop(j,k)=0
|
|
iow(j,k)=0
|
|
ihcd(j,k)=1
|
|
end do
|
|
end do
|
|
end do
|
|
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine paraminit
|
|
implicit real*8(a-h,o-z)
|
|
c
|
|
common/istep/istep
|
|
common/istgr/istpr,istpl
|
|
common/ierr/ierr
|
|
common/istop/istop
|
|
|
|
istpr=0
|
|
istpl=1
|
|
ierr=0
|
|
istep=0
|
|
istop=0
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
subroutine updatepos
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(jmx=31,kmx=36)
|
|
dimension xc(3,jmx,kmx),xco(3,jmx,kmx)
|
|
dimension du1(3,jmx,kmx),du1o(3,jmx,kmx)
|
|
dimension ywrk(6,jmx,kmx),ypwrk(6,jmx,kmx)
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
common/grco/xco,du1o
|
|
common/grc/xc,du1
|
|
common/wrk/ywrk,ypwrk
|
|
c
|
|
do j=1,nrayr
|
|
do k=1,nrayth
|
|
if(j.eq.1.and.k.gt.1) then
|
|
xco(1,j,k)=xco(1,j,1)
|
|
xco(2,j,k)=xco(2,j,1)
|
|
xco(3,j,k)=xco(3,j,1)
|
|
xc(1,j,k)=xc(1,j,1)
|
|
xc(2,j,k)=xc(2,j,1)
|
|
xc(3,j,k)=xc(3,j,1)
|
|
else
|
|
xco(1,j,k)=xc(1,j,k)
|
|
xco(2,j,k)=xc(2,j,k)
|
|
xco(3,j,k)=xc(3,j,k)
|
|
xc(1,j,k)=ywrk(1,j,k)
|
|
xc(2,j,k)=ywrk(2,j,k)
|
|
xc(3,j,k)=ywrk(3,j,k)
|
|
end if
|
|
du1o(1,j,k)=du1(1,j,k)
|
|
du1o(2,j,k)=du1(2,j,k)
|
|
du1o(3,j,k)=du1(3,j,k)
|
|
end do
|
|
end do
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine gradi
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(jmx=31,kmx=36)
|
|
dimension dffiu(jmx),ddffiu(jmx)
|
|
dimension xc(3,jmx,kmx),xco(3,jmx,kmx)
|
|
dimension du1(3,jmx,kmx),du1o(3,jmx,kmx)
|
|
dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx)
|
|
dimension dgrad2v(3,jmx,kmx)
|
|
dimension grad2(jmx,kmx)
|
|
dimension dxv1(3),dxv2(3),dxv3(3),dgu(3)
|
|
dimension dgg1(3),dgg2(3),dgg3(3)
|
|
dimension df1(3),df2(3),df3(3)
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
common/fi/dffiu,ddffiu
|
|
common/grco/xco,du1o
|
|
common/grc/xc,du1
|
|
common/grad2jk/grad2
|
|
common/dgrad2jk/dgrad2v
|
|
common/gradjk/gri
|
|
common/ggradjk/ggri
|
|
c
|
|
c compute grad u and grad(S_I)
|
|
c
|
|
do k=1,nrayth
|
|
do j=1,nrayr
|
|
if(j.eq.1) then
|
|
gri(1,j,k)=0.0d0
|
|
gri(2,j,k)=0.0d0
|
|
gri(3,j,k)=0.0d0
|
|
jp=j+1
|
|
km=k-1
|
|
if(k.eq.1) km=nrayth
|
|
kp=k+1
|
|
if(k.eq.nrayth) kp=1
|
|
do iv=1,3
|
|
dxv1(iv)=xc(iv,jp,k)-xc(iv,j,k)
|
|
dxv2(iv)=xc(iv,jp,kp)-xc(iv,jp,km)
|
|
dxv3(iv)=xc(iv,j,k)-xco(iv,j,k)
|
|
end do
|
|
call solg0(dxv1,dxv2,dxv3,dgu)
|
|
else
|
|
jm=j-1
|
|
km=k-1
|
|
if(k.eq.1) km=nrayth
|
|
kp=k+1
|
|
if(k.eq.nrayth) kp=1
|
|
do iv=1,3
|
|
dxv1(iv)=xc(iv,j,k)-xc(iv,jm,k)
|
|
dxv2(iv)=xc(iv,j,kp)-xc(iv,j,km)
|
|
dxv3(iv)=xc(iv,j,k)-xco(iv,j,k)
|
|
end do
|
|
call solg0(dxv1,dxv2,dxv3,dgu)
|
|
end if
|
|
du1(1,j,k)=dgu(1)
|
|
du1(2,j,k)=dgu(2)
|
|
du1(3,j,k)=dgu(3)
|
|
gri(1,j,k)=dgu(1)*dffiu(j)
|
|
gri(2,j,k)=dgu(2)*dffiu(j)
|
|
gri(3,j,k)=dgu(3)*dffiu(j)
|
|
grad2(j,k)=gri(1,j,k)**2+gri(2,j,k)**2+gri(3,j,k)**2
|
|
end do
|
|
end do
|
|
c
|
|
c compute derivatives of grad u and grad(S_I)
|
|
c
|
|
do k=1,nrayth
|
|
do j=1,nrayr
|
|
if(j.eq.1) then
|
|
jp=j+1
|
|
km=k-1
|
|
if(k.eq.1) km=nrayth
|
|
kp=k+1
|
|
if(k.eq.nrayth) kp=1
|
|
do iv=1,3
|
|
dxv1(iv)=xc(iv,jp,kp)-xc(iv,jp,km)
|
|
dxv2(iv)=xc(iv,jp,k)-xc(iv,j,k)
|
|
dxv3(iv)=xc(iv,j,k)-xco(iv,j,k)
|
|
end do
|
|
df1(1)=du1(1,jp,kp)-du1(1,jp,km)
|
|
df1(2)=du1(1,jp,k)-du1(1,j,k)
|
|
df1(3)=du1(1,j,k)-du1o(1,j,k)
|
|
df2(1)=du1(2,jp,kp)-du1(2,jp,km)
|
|
df2(2)=du1(2,jp,k)-du1(2,j,k)
|
|
df2(3)=du1(2,j,k)-du1o(2,j,k)
|
|
df3(1)=du1(3,jp,kp)-du1(3,jp,km)
|
|
df3(2)=du1(3,jp,k)-du1(3,j,k)
|
|
df3(3)=du1(3,j,k)-du1o(3,j,k)
|
|
call solg3(dxv1,dxv2,dxv3,df1,df2,df3,dgg1,dgg2,dgg3)
|
|
else
|
|
jm=j-1
|
|
km=k-1
|
|
if(k.eq.1) km=nrayth
|
|
kp=k+1
|
|
if(k.eq.nrayth) kp=1
|
|
do iv=1,3
|
|
dxv1(iv)=xc(iv,j,k)-xc(iv,jm,k)
|
|
dxv2(iv)=xc(iv,j,kp)-xc(iv,j,km)
|
|
dxv3(iv)=xc(iv,j,k)-xco(iv,j,k)
|
|
end do
|
|
df1(1)=du1(1,j,k)-du1(1,jm,k)
|
|
df1(2)=du1(1,j,kp)-du1(1,j,km)
|
|
df1(3)=du1(1,j,k)-du1o(1,j,k)
|
|
df2(1)=du1(2,j,k)-du1(2,jm,k)
|
|
df2(2)=du1(2,j,kp)-du1(2,j,km)
|
|
df2(3)=du1(2,j,k)-du1o(2,j,k)
|
|
df3(1)=du1(3,j,k)-du1(3,jm,k)
|
|
df3(2)=du1(3,j,kp)-du1(3,j,km)
|
|
df3(3)=du1(3,j,k)-du1o(3,j,k)
|
|
call solg3(dxv1,dxv2,dxv3,df1,df2,df3,dgg1,dgg2,dgg3)
|
|
end if
|
|
c
|
|
c derivatives of u
|
|
c
|
|
ux=du1(1,j,k)
|
|
uy=du1(2,j,k)
|
|
uz=du1(3,j,k)
|
|
uxx=dgg1(1)
|
|
uyy=dgg2(2)
|
|
uzz=dgg3(3)
|
|
uxy=(dgg1(2)+dgg2(1))/2.0d0
|
|
uxz=(dgg1(3)+dgg3(1))/2.0d0
|
|
uyz=(dgg2(3)+dgg3(2))/2.0d0
|
|
c
|
|
c derivatives of S_I and Grad(S_I)
|
|
c
|
|
dfu=dffiu(j)
|
|
dfuu=ddffiu(j)
|
|
gx=ux*dfu
|
|
gy=uy*dfu
|
|
gz=uz*dfu
|
|
gxx=dfuu*ux*ux+dfu*uxx
|
|
gyy=dfuu*uy*uy+dfu*uyy
|
|
gzz=dfuu*uz*uz+dfu*uzz
|
|
gxy=dfuu*ux*uy+dfu*uxy
|
|
gxz=dfuu*ux*uz+dfu*uxz
|
|
gyz=dfuu*uy*uz+dfu*uyz
|
|
c
|
|
ggri(1,1,j,k)=gxx
|
|
ggri(2,2,j,k)=gyy
|
|
ggri(3,3,j,k)=gzz
|
|
ggri(1,2,j,k)=gxy
|
|
ggri(2,1,j,k)=gxy
|
|
ggri(1,3,j,k)=gxz
|
|
ggri(3,1,j,k)=gxz
|
|
ggri(2,3,j,k)=gyz
|
|
ggri(3,2,j,k)=gyz
|
|
c
|
|
c derivatives of |Grad(S_I)|^2
|
|
c
|
|
dgrad2v(1,j,k)=2.0d0*(gx*gxx+gy*gxy+gz*gxz)
|
|
dgrad2v(2,j,k)=2.0d0*(gx*gxy+gy*gyy+gz*gyz)
|
|
dgrad2v(3,j,k)=2.0d0*(gx*gxz+gy*gyz+gz*gzz)
|
|
end do
|
|
end do
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c solution of the linear system of 3 eqs : dgg . dxv = dff
|
|
c input vectors : dxv1, dxv2, dxv3, dff
|
|
c output vector : dgg
|
|
c
|
|
c dff=(1,0,0)
|
|
c
|
|
subroutine solg0(dxv1,dxv2,dxv3,dgg)
|
|
double precision denom,aa1,aa2,aa3
|
|
double precision dxv1(3),dxv2(3),dxv3(3),dgg(3)
|
|
aa1=(dxv2(2)*dxv3(3)-dxv3(2)*dxv2(3))
|
|
aa2=(dxv1(2)*dxv3(3)-dxv1(3)*dxv3(2))
|
|
aa3=(dxv1(2)*dxv2(3)-dxv1(3)*dxv2(2))
|
|
denom = dxv1(1)*aa1-dxv2(1)*aa2+dxv3(1)*aa3
|
|
dgg(1) = aa1/denom
|
|
dgg(2) = -(dxv2(1)*dxv3(3)-dxv3(1)*dxv2(3))/denom
|
|
dgg(3) = (dxv2(1)*dxv3(2)-dxv3(1)*dxv2(2))/denom
|
|
return
|
|
end
|
|
c
|
|
c three rhs vectors df1, df2, df3
|
|
c
|
|
subroutine solg3(dxv1,dxv2,dxv3,df1,df2,df3,dg1,dg2,dg3)
|
|
double precision denom,a11,a21,a31,a12,a22,a32,a13,a23,a33
|
|
double precision dxv1(3),dxv2(3),dxv3(3)
|
|
double precision df1(3),df2(3),df3(3)
|
|
double precision dg1(3),dg2(3),dg3(3)
|
|
a11=(dxv2(2)*dxv3(3)-dxv3(2)*dxv2(3))
|
|
a21=(dxv1(2)*dxv3(3)-dxv1(3)*dxv3(2))
|
|
a31=(dxv1(2)*dxv2(3)-dxv1(3)*dxv2(2))
|
|
a12=(dxv2(1)*dxv3(3)-dxv3(1)*dxv2(3))
|
|
a22=(dxv1(1)*dxv3(3)-dxv1(3)*dxv3(1))
|
|
a32=(dxv1(1)*dxv2(3)-dxv1(3)*dxv2(1))
|
|
a13=(dxv2(1)*dxv3(2)-dxv3(1)*dxv2(2))
|
|
a23=(dxv1(1)*dxv3(2)-dxv1(2)*dxv3(1))
|
|
a33=(dxv1(1)*dxv2(2)-dxv1(2)*dxv2(1))
|
|
denom = dxv1(1)*a11-dxv2(1)*a21+dxv3(1)*a31
|
|
dg1(1) = (df1(1)*a11-df1(2)*a21+df1(3)*a31)/denom
|
|
dg1(2) = -(df1(1)*a12-df1(2)*a22+df1(3)*a32)/denom
|
|
dg1(3) = (df1(1)*a13-df1(2)*a23+df1(3)*a33)/denom
|
|
dg2(1) = (df2(1)*a11-df2(2)*a21+df2(3)*a31)/denom
|
|
dg2(2) = -(df2(1)*a12-df2(2)*a22+df2(3)*a32)/denom
|
|
dg2(3) = (df2(1)*a13-df2(2)*a23+df2(3)*a33)/denom
|
|
dg3(1) = (df3(1)*a11-df3(2)*a21+df3(3)*a31)/denom
|
|
dg3(2) = -(df3(1)*a12-df3(2)*a22+df3(3)*a32)/denom
|
|
dg3(3) = (df3(1)*a13-df3(2)*a23+df3(3)*a33)/denom
|
|
return
|
|
end
|
|
c
|
|
c Runge-Kutta integrator
|
|
c
|
|
subroutine rkint4
|
|
use graydata_flags, only : dst,igrad
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(ndim=6,jmx=31,kmx=36)
|
|
dimension y(ndim),yy(ndim)
|
|
dimension fk1(ndim),fk2(ndim),fk3(ndim),fk4(ndim)
|
|
dimension dgr2(3),dgr(3),ddgr(3,3)
|
|
dimension ywrk(ndim,jmx,kmx),ypwrk(ndim,jmx,kmx)
|
|
dimension grad2(jmx,kmx),dgrad2v(3,jmx,kmx)
|
|
dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx)
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
c
|
|
common/wrk/ywrk,ypwrk
|
|
common/grad2jk/grad2
|
|
common/dgrad2jk/dgrad2v
|
|
common/gradjk/gri
|
|
common/ggradjk/ggri
|
|
common/gr/gr2
|
|
common/dgr/dgr2,dgr,ddgr
|
|
c
|
|
h=dst
|
|
hh=h*0.5d0
|
|
h6=h/6.0d0
|
|
c
|
|
do j=1,nrayr
|
|
kkk=nrayth
|
|
if(j.eq.1) kkk=1
|
|
do k=1,kkk
|
|
do ieq=1,ndim
|
|
y(ieq)=ywrk(ieq,j,k)
|
|
fk1(ieq)=ypwrk(ieq,j,k)
|
|
yy(ieq)=y(ieq)+fk1(ieq)*hh
|
|
end do
|
|
gr2=grad2(j,k)
|
|
do iv=1,3
|
|
dgr2(iv)=dgrad2v(iv,j,k)
|
|
dgr(iv)=gri(iv,j,k)
|
|
do jv=1,3
|
|
ddgr(iv,jv)=ggri(iv,jv,j,k)
|
|
end do
|
|
end do
|
|
call fwork(yy,fk2)
|
|
c
|
|
do ieq=1,ndim
|
|
yy(ieq)=y(ieq)+fk2(ieq)*hh
|
|
end do
|
|
call fwork(yy,fk3)
|
|
c
|
|
do ieq=1,ndim
|
|
yy(ieq)=y(ieq)+fk3(ieq)*h
|
|
end do
|
|
call fwork(yy,fk4)
|
|
c
|
|
do ieq=1,ndim
|
|
ywrk(ieq,j,k)=y(ieq)
|
|
. +h6*(fk1(ieq)+2.0d0*fk2(ieq)+2.0d0*fk3(ieq)+fk4(ieq))
|
|
end do
|
|
end do
|
|
end do
|
|
c
|
|
call updatepos
|
|
c
|
|
if(igrad.eq.1) call gradi
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine gwork(j,k)
|
|
use graydata_flags, only : igrad
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(ndim=6,jmx=31,kmx=36)
|
|
dimension yy(ndim),yyp(ndim)
|
|
dimension dgr2(3),dgr(3),ddgr(3,3)
|
|
dimension ywrk(ndim,jmx,kmx),ypwrk(ndim,jmx,kmx)
|
|
dimension grad2(jmx,kmx),dgrad2v(3,jmx,kmx)
|
|
dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx)
|
|
c
|
|
common/wrk/ywrk,ypwrk
|
|
common/grad2jk/grad2
|
|
common/dgrad2jk/dgrad2v
|
|
common/gradjk/gri
|
|
common/ggradjk/ggri
|
|
common/gr/gr2
|
|
common/dgr/dgr2,dgr,ddgr
|
|
c
|
|
c begin --- update vector yy
|
|
c
|
|
do ieq=1,ndim
|
|
yy(ieq)=ywrk(ieq,j,k)
|
|
end do
|
|
c
|
|
if(igrad.eq.1) then
|
|
gr2=grad2(j,k)
|
|
do iv=1,3
|
|
dgr2(iv)=dgrad2v(iv,j,k)
|
|
dgr(iv)=gri(iv,j,k)
|
|
do jv=1,3
|
|
ddgr(iv,jv)=ggri(iv,jv,j,k)
|
|
end do
|
|
end do
|
|
end if
|
|
c
|
|
call fwork(yy,yyp)
|
|
c
|
|
do ieq=1,ndim
|
|
ypwrk(ieq,j,k)=yyp(ieq)
|
|
end do
|
|
c
|
|
c end --- update vector yy
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine fwork(y,dery)
|
|
use graydata_flags, only : idst,igrad
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(ndim=6)
|
|
dimension y(ndim),dery(ndim)
|
|
dimension xv(3),anv(3),vgv(3),bv(3),derbv(3,3),derxg(3),deryg(3)
|
|
dimension derdxv(3),danpldxv(3),derdnv(3)
|
|
dimension dgr2(3),dgr(3),ddgr(3,3),dbgr(3)
|
|
c
|
|
common/gr/gr2
|
|
common/dgr/dgr2,dgr,ddgr
|
|
common/ddd/dd,an2s,an2,fdia,bdotgr,ddi,ddr11
|
|
common/mode/sox
|
|
common/nplr/anpl,anpr
|
|
common/bb/bv
|
|
common/dbb/derbv
|
|
common/xgxg/xg
|
|
common/ygyg/yg
|
|
common/dxgyg/derxg,deryg
|
|
common/vgv/vgm,derdnm
|
|
common/dersdst/dersdst
|
|
common/ierr/ierr
|
|
common/anv/anv
|
|
common/xv/xv
|
|
c
|
|
xx=y(1)
|
|
yy=y(2)
|
|
zz=y(3)
|
|
|
|
xv(1)=y(1)
|
|
xv(2)=y(2)
|
|
xv(3)=y(3)
|
|
c
|
|
anv(1) = y(4)
|
|
anv(2) = y(5)
|
|
anv(3) = y(6)
|
|
c
|
|
C rr=sqrt(xx**2+yy**2)
|
|
C phi=acos(xx/rr)
|
|
C if (yy.lt.0.0d0) then
|
|
C phi=-phi
|
|
C end if
|
|
c
|
|
call plas_deriv(xx,yy,zz)
|
|
c
|
|
an2=anv(1)*anv(1)+anv(2)*anv(2)+anv(3)*anv(3)
|
|
anpl=anv(1)*bv(1)+anv(2)*bv(2)+anv(3)*bv(3)
|
|
c
|
|
if(abs(anpl).gt.0.99d0) then
|
|
if(abs(anpl).le.1.05d0) then
|
|
ierr=97
|
|
else
|
|
ierr=98
|
|
end if
|
|
end if
|
|
c
|
|
anpl2=anpl*anpl
|
|
dnl=1.0d0-anpl2
|
|
anpr2=an2-anpl2
|
|
anpr=0.0d0
|
|
if(anpr2.gt.0.0d0) anpr=sqrt(anpr2)
|
|
yg2=yg**2
|
|
c
|
|
an2s=1.0d0
|
|
dan2sdxg=0.0d0
|
|
dan2sdyg=0.0d0
|
|
dan2sdnpl=0.0d0
|
|
del=0.0d0
|
|
fdia=0.0d0
|
|
dfdiadnpl=0.0d0
|
|
dfdiadxg=0.0d0
|
|
dfdiadyg=0.0d0
|
|
c
|
|
duh=1.0d0-xg-yg2
|
|
if(xg.gt.0.0d0) then
|
|
del=sqrt(dnl*dnl+4.0d0*anpl*anpl*(1.0d0-xg)/yg2)
|
|
an2s=1.0d0-xg -xg*yg2*(1.0d0+anpl2+sox*del)/duh/2.0d0
|
|
c
|
|
dan2sdxg=-yg2*(1.0d0-yg2)*(1.0d0+anpl2+sox*del)/duh**2/2.0d0
|
|
. +sox*xg*anpl2/(del*duh)-1.0d0
|
|
dan2sdyg=-xg*yg*(1.0d0-xg)*(1.0d0+anpl2+sox*del)/duh**2
|
|
. +2.0d0*sox*xg*(1.0d0-xg)*anpl2/(yg*del*duh)
|
|
dan2sdnpl=-xg*yg2*anpl/duh
|
|
. -sox*xg*anpl*(2.0d0*(1.0d0-xg)-yg2*dnl)/(del*duh)
|
|
c
|
|
if(igrad.gt.0) then
|
|
ddelnpl2=2.0d0*(2.0d0*(1.0d0-xg)*(1.0d0+3.0d0*anpl2**2)
|
|
. -yg2*dnl**3)/yg2/del**3
|
|
fdia=-xg*yg2*(1.0d0+sox*ddelnpl2/2.0d0)/duh
|
|
derdel=2.0d0*(1.0d0-xg)*anpl2*(1.0d0+3.0d0*anpl2**2)
|
|
. -dnl**2*(1.0d0+3.0d0*anpl2)*yg2
|
|
derdel=4.0d0*derdel/(yg**5*del**5)
|
|
ddelnpl2y=2.0d0*(1.0d0-xg)*derdel
|
|
ddelnpl2x=yg*derdel
|
|
dfdiadnpl=24.0d0*sox*xg*(1.0d0-xg)*anpl*(1.0d0-anpl**4)
|
|
. /(yg2*del**5)
|
|
dfdiadxg=-yg2*(1.0d0-yg2)/duh**2-sox*yg2*((1.0d0-yg2)*ddelnpl2
|
|
. +xg*duh*ddelnpl2x)/(2.0d0*duh**2)
|
|
dfdiadyg=-2.0d0*yg*xg*(1.0d0-xg)/duh**2
|
|
. -sox*xg*yg*(2.0d0*(1.0d0-xg)*ddelnpl2
|
|
. +yg*duh*ddelnpl2y)/(2.0d0*duh**2)
|
|
c
|
|
end if
|
|
end if
|
|
c
|
|
bdotgr=0.0d0
|
|
do iv=1,3
|
|
bdotgr=bdotgr+bv(iv)*dgr(iv)
|
|
dbgr(iv)=0.0d0
|
|
do jv=1,3
|
|
dbgr(iv)=dgr(jv)*derbv(jv,iv)+bv(jv)*ddgr(jv,iv)
|
|
end do
|
|
end do
|
|
c
|
|
derdnm=0.0d0
|
|
c
|
|
do iv=1,3
|
|
danpldxv(iv)=anv(1)*derbv(1,iv)+anv(2)*derbv(2,iv)
|
|
. +anv(3)*derbv(3,iv)
|
|
derdxv(iv)=-(derxg(iv)*dan2sdxg
|
|
. +deryg(iv)*dan2sdyg+danpldxv(iv)*dan2sdnpl)
|
|
derdxv(iv)=derdxv(iv)-igrad*dgr2(iv)
|
|
c
|
|
derdxv(iv)=derdxv(iv)+fdia*bdotgr*dbgr(iv)+0.5d0*bdotgr**2*
|
|
. (derxg(iv)*dfdiadxg+deryg(iv)*dfdiadyg+danpldxv(iv)*dfdiadnpl)
|
|
c
|
|
derdnv(iv)=2.0d0*anv(iv)-bv(iv)*dan2sdnpl
|
|
. +0.5d0*bdotgr**2*bv(iv)*dfdiadnpl
|
|
c
|
|
derdnm=derdnm+derdnv(iv)**2
|
|
end do
|
|
c
|
|
derdnm=sqrt(derdnm)
|
|
c
|
|
derdom=-2.0d0*an2+2.0d0*xg*dan2sdxg+yg*dan2sdyg+anpl*dan2sdnpl
|
|
. +2.0d0*igrad*gr2
|
|
. -bdotgr**2*(fdia+xg*dfdiadxg+yg*dfdiadyg/2.0d0
|
|
. +anpl*dfdiadnpl/2.0d0)
|
|
c
|
|
if (idst.eq.0) then
|
|
c integration variable: s
|
|
denom=-derdnm
|
|
else if (idst.eq.1) then
|
|
c integration variable: c*t
|
|
denom=derdom
|
|
else
|
|
c integration variable: Sr
|
|
denom=-(anv(1)*derdnv(1)+anv(2)*derdnv(2)+anv(3)*derdnv(3))
|
|
end if
|
|
c
|
|
c coefficient for integration in s
|
|
c ds/dst, where st is the integration variable
|
|
dersdst=-derdnm/denom
|
|
c
|
|
dery(1) = -derdnv(1)/denom
|
|
dery(2) = -derdnv(2)/denom
|
|
dery(3) = -derdnv(3)/denom
|
|
dery(4) = derdxv(1)/denom
|
|
dery(5) = derdxv(2)/denom
|
|
dery(6) = derdxv(3)/denom
|
|
c
|
|
c vgv : ~ group velocity
|
|
c
|
|
vgm=0
|
|
do iv=1,3
|
|
vgv(iv)=-derdnv(iv)/derdom
|
|
vgm=vgm+vgv(iv)**2
|
|
end do
|
|
vgm=sqrt(vgm)
|
|
c
|
|
c dd : dispersion relation (real part)
|
|
c ddi : dispersion relation (imaginary part)
|
|
c
|
|
dd=an2-an2s-igrad*(gr2-0.5d0*bdotgr**2*fdia)
|
|
ddi=derdnv(1)*dgr(1)+derdnv(2)*dgr(2)+derdnv(3)*dgr(3)
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine plas_deriv(xx,yy,zz)
|
|
use const_and_precisions, only : pi
|
|
use graydata_flags, only : iequil
|
|
use graydata_par, only : sgnbphi
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
dimension bv(3),derxg(3),deryg(3),derbv(3,3),dbtot(3)
|
|
dimension bvc(3),dbvcdc(3,3),dbvdc(3,3),dbv(3,3)
|
|
c
|
|
common/parbres/bres
|
|
common/parpl/brr,bphi,bzz,ajphi
|
|
common/btot/btot
|
|
common/bb/bv
|
|
common/dbb/derbv
|
|
common/xgxg/xg
|
|
common/dxgdps/dxgdpsi
|
|
common/ygyg/yg
|
|
common/dxgyg/derxg,deryg
|
|
common/derip1/dpsidr,dpsidz
|
|
common/derip2/ddpsidrr,ddpsidzz,ddpsidrz
|
|
common/fpol/fpolv,ffpv
|
|
common/psival/psinv
|
|
|
|
xg=0.0d0
|
|
yg=9.9d1
|
|
c
|
|
do iv=1,3
|
|
derxg(iv)=0.0d0
|
|
deryg(iv)=0.0d0
|
|
bv(iv)=0.0d0
|
|
dbtot(iv)=0.0d0
|
|
do jv=1,3
|
|
dbv(iv,jv)=0.0d0
|
|
derbv(iv,jv)=0.0d0
|
|
dbvcdc(iv,jv)=0.0d0
|
|
dbvcdc(iv,jv)=0.0d0
|
|
dbvdc(iv,jv)=0.0d0
|
|
end do
|
|
end do
|
|
c
|
|
if(iequil.eq.0) return
|
|
c
|
|
c cylindrical coordinates
|
|
c
|
|
rr2=xx**2+yy**2
|
|
rr=sqrt(rr2)
|
|
csphi=xx/rr
|
|
snphi=yy/rr
|
|
c
|
|
bv(1)=-snphi*sgnbphi
|
|
bv(2)=csphi*sgnbphi
|
|
c
|
|
c convert from cm to meters
|
|
c
|
|
zzm=1.0d-2*zz
|
|
rrm=1.0d-2*rr
|
|
c
|
|
if(iequil.eq.1) then
|
|
call equian(rrm,zzm)
|
|
end if
|
|
c
|
|
if(iequil.eq.2) then
|
|
call equinum_psi(rrm,zzm)
|
|
call equinum_derpsi(rrm,zzm,3)
|
|
call equinum_fpol(1)
|
|
end if
|
|
|
|
call sub_xg_derxg
|
|
yg=fpolv/(rrm*bres)
|
|
bphi=fpolv/rrm
|
|
btot=abs(bphi)
|
|
if(psinv.lt.0.0d0) return
|
|
c
|
|
c B = f(psi)/R e_phi+ grad psi x e_phi/R
|
|
c
|
|
c bvc(i) = B_i in cylindrical coordinates
|
|
c bv(i) = B_i in cartesian coordinates
|
|
c
|
|
bphi=fpolv/rrm
|
|
brr=-dpsidz/rrm
|
|
bzz= dpsidr/rrm
|
|
c
|
|
dfpolv=ffpv/fpolv
|
|
c
|
|
bvc(1)=brr
|
|
bvc(2)=bphi
|
|
bvc(3)=bzz
|
|
c
|
|
bv(1)=bvc(1)*csphi-bvc(2)*snphi
|
|
bv(2)=bvc(1)*snphi+bvc(2)*csphi
|
|
bv(3)=bvc(3)
|
|
c
|
|
b2tot=bv(1)**2+bv(2)**2+bv(3)**2
|
|
btot=sqrt(b2tot)
|
|
c
|
|
c dbvcdc(iv,jv) = d Bcil(iv) / dxvcil(jv)
|
|
c
|
|
dbvcdc(1,1)=-ddpsidrz/rrm-brr/rrm
|
|
dbvcdc(1,3)=-ddpsidzz/rrm
|
|
dbvcdc(2,1)= dfpolv*dpsidr/rrm-bphi/rrm
|
|
dbvcdc(2,3)= dfpolv*dpsidz/rrm
|
|
dbvcdc(3,1)= ddpsidrr/rrm-bzz/rrm
|
|
dbvcdc(3,3)= ddpsidrz/rrm
|
|
c
|
|
c dbvdc(iv,jv) = d Bcart(iv) / dxvcil(jv)
|
|
c
|
|
dbvdc(1,1) = dbvcdc(1,1)*csphi-dbvcdc(2,1)*snphi
|
|
dbvdc(1,2) = -bv(2)
|
|
dbvdc(1,3) = dbvcdc(1,3)*csphi-dbvcdc(2,3)*snphi
|
|
dbvdc(2,1) = dbvcdc(1,1)*snphi+dbvcdc(2,1)*csphi
|
|
dbvdc(2,2) = bv(1)
|
|
dbvdc(2,3) = dbvcdc(1,3)*snphi+dbvcdc(2,3)*csphi
|
|
dbvdc(3,1) = dbvcdc(3,1)
|
|
dbvdc(3,2) = dbvcdc(3,2)
|
|
dbvdc(3,3) = dbvcdc(3,3)
|
|
c
|
|
drrdx=csphi
|
|
drrdy=snphi
|
|
dphidx=-snphi/rrm
|
|
dphidy=csphi/rrm
|
|
c
|
|
c dbv(iv,jv) = d Bcart(iv) / dxvcart(jv)
|
|
c
|
|
dbv(1,1)=drrdx*dbvdc(1,1)+dphidx*dbvdc(1,2)
|
|
dbv(1,2)=drrdy*dbvdc(1,1)+dphidy*dbvdc(1,2)
|
|
dbv(1,3)=dbvdc(1,3)
|
|
dbv(2,1)=drrdx*dbvdc(2,1)+dphidx*dbvdc(2,2)
|
|
dbv(2,2)=drrdy*dbvdc(2,1)+dphidy*dbvdc(2,2)
|
|
dbv(2,3)=dbvdc(2,3)
|
|
dbv(3,1)=drrdx*dbvdc(3,1)+dphidx*dbvdc(3,2)
|
|
dbv(3,2)=drrdy*dbvdc(3,1)+dphidy*dbvdc(3,2)
|
|
dbv(3,3)=dbvdc(3,3)
|
|
c
|
|
dbtot(1)=(bv(1)*dbv(1,1)+bv(2)*dbv(2,1)+bv(3)*dbv(3,1))/btot
|
|
dbtot(2)=(bv(1)*dbv(1,2)+bv(2)*dbv(2,2)+bv(3)*dbv(3,2))/btot
|
|
dbtot(3)=(bv(1)*dbv(1,3)+bv(2)*dbv(2,3)+bv(3)*dbv(3,3))/btot
|
|
c
|
|
yg=btot/Bres
|
|
c
|
|
c convert spatial derivatives from dummy/m -> dummy/cm
|
|
c to be used in fwork
|
|
c
|
|
c bv(i) = B_i / B ; derbv(i,j) = d (B_i / B) /d x,y,z
|
|
c
|
|
do iv=1,3
|
|
deryg(iv)=1.0d-2*dbtot(iv)/Bres
|
|
bv(iv)=bv(iv)/btot
|
|
do jv=1,3
|
|
derbv(iv,jv)=1.0d-2*(dbv(iv,jv)-bv(iv)*dbtot(jv))/btot
|
|
end do
|
|
end do
|
|
c
|
|
derxg(1)=1.0d-2*drrdx*dpsidr*dxgdpsi
|
|
derxg(2)=1.0d-2*drrdy*dpsidr*dxgdpsi
|
|
derxg(3)=1.0d-2*dpsidz*dxgdpsi
|
|
c
|
|
c current density computation in Ampere/m^2
|
|
c ccj==1/mu_0
|
|
c
|
|
ccj=1.0d+7/(4.0d0*pi)
|
|
ajphi=ccj*(dbvcdc(1,3)-dbvcdc(3,1))
|
|
c ajr=ccj*(dbvcdc(3,2)/rrm-dbvcdc(2,3))
|
|
c ajz=ccj*(bvc(2)/rrm+dbvcdc(2,1)-dbvcdc(1,2))
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine equian(rrm,zzm)
|
|
use graydata_par, only : sgnbphi,sgniphi
|
|
use graydata_anequil, only : b0,rr0m,zr0m,rpam,q0,qa,alq
|
|
use interp_eqprof, only : psia
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
c
|
|
common/psival/psinv
|
|
common/derip1/dpsidr,dpsidz
|
|
common/derip2/ddpsidrr,ddpsidzz,ddpsidrz
|
|
common/fpol/fpolv,ffpv
|
|
common/xgxg/xg
|
|
common/dxgdps/dxgdpsi
|
|
common/xgcn/xgcn
|
|
common/dens/dens,ddens
|
|
|
|
dpsidrp=0.0d0
|
|
d2psidrp=0.0d0
|
|
c
|
|
c simple model for equilibrium: large aspect ratio
|
|
c outside plasma: analytical continuation, not solution Maxwell eqs
|
|
c
|
|
rpm=sqrt((rrm-rr0m)**2+(zzm-zr0m)**2)
|
|
rn=rpm/rpam
|
|
c
|
|
snt=0.0d0
|
|
cst=1.0d0
|
|
if (rpm.gt.0.0d0) then
|
|
snt=(zzm-zr0m)/rpm
|
|
cst=(rrm-rr0m)/rpm
|
|
end if
|
|
c
|
|
rhot=rn
|
|
if(rn.le.1) then
|
|
rhop=frhopol(rhot)
|
|
psinv=rhop*rhop
|
|
else
|
|
psinv=1.0d0+B0*rpam**2/2.0d0/abs(psia)/qa*(rn*rn-1.0d0)
|
|
rhop=sqrt(psinv)
|
|
end if
|
|
c
|
|
sgn=sgniphi*sgnbphi
|
|
if(rn.le.1.0d0) then
|
|
qq=q0+(qa-q0)*rn**alq
|
|
dpsidrp=B0*rpam*rn/qq*sgn
|
|
dqq=alq*(qa-q0)*rn**(alq-1.0d0)
|
|
d2psidrp=B0*(1.0d0-rn*dqq/qq)/qq*sgn
|
|
else
|
|
dpsidrp=B0*rpam/qa*rn*sgn
|
|
d2psidrp=B0/qa*sgn
|
|
end if
|
|
c
|
|
fpolv=sgnbphi*b0*rr0m
|
|
dfpolv=0.0d0
|
|
ffpv=0.0d0
|
|
c
|
|
dpsidr=dpsidrp*cst
|
|
dpsidz=dpsidrp*snt
|
|
ddpsidrr=dpsidrp*snt**2/rpm+cst**2*d2psidrp
|
|
ddpsidrz=cst*snt*(d2psidrp-dpsidrp/rpm)
|
|
ddpsidzz=dpsidrp*cst**2/rpm+snt**2*d2psidrp
|
|
|
|
return
|
|
end
|
|
|
|
|
|
subroutine equinum_psi(rpsim,zpsim)
|
|
use interp_eqprof, only : rmnm,rmxm,zmnm,zmxm,psiant,psinop,
|
|
. tr,tz,ccspl=>cceq,nsrt,nszt
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(lwrk=8,liwrk=2)
|
|
dimension wrk(lwrk),iwrk(liwrk)
|
|
dimension rrs(1),zzs(1),ffspl(1)
|
|
parameter(nrs=1,nzs=1)
|
|
c
|
|
common/psival/psinv
|
|
c
|
|
psinv=-1.0d0
|
|
c
|
|
c here lengths are measured in meters
|
|
c
|
|
if (rpsim.gt.rmxm.or.rpsim.lt.rmnm) return
|
|
if (zpsim.gt.zmxm.or.zpsim.lt.zmnm) return
|
|
c
|
|
rrs(1)=rpsim
|
|
zzs(1)=zpsim
|
|
nsr=nsrt
|
|
nsz=nszt
|
|
call fpbisp(tr,nsr,tz,nsz,ccspl,3,3,
|
|
. rrs,nrs,zzs,nzs,ffspl,wrk(1),wrk(5),iwrk(1),iwrk(2))
|
|
psinv=(ffspl(1)-psinop)/psiant
|
|
c
|
|
return
|
|
end
|
|
|
|
subroutine equinum_derpsi(rpsim,zpsim,iderpsi)
|
|
use interp_eqprof, only : nr,nz,rmnm,rmxm,zmnm,zmxm,cc01=>cceq01,
|
|
. cc10=>cceq10,cc20=>cceq20,cc02=>cceq02,cc11=>cceq11
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
integer*4 iderpsi
|
|
c
|
|
common/derip1/dpsidr,dpsidz
|
|
common/derip2/ddpsidrr,ddpsidzz,ddpsidrz
|
|
c
|
|
lw10=nr*3+nz*4+nr*nz
|
|
lw01=nr*4+nz*3+nr*nz
|
|
lw20=nr*2+nz*4+nr*nz
|
|
lw02=nr*4+nz*2+nr*nz
|
|
lw11=nr*3+nz*3+nr*nz
|
|
c
|
|
dpsidr=0.0d0
|
|
dpsidz=0.0d0
|
|
ddpsidrr=0.0d0
|
|
ddpsidzz=0.0d0
|
|
ddpsidrz=0.0d0
|
|
|
|
c here lengths are measured in meters
|
|
if (rpsim.gt.rmxm.or.rpsim.lt.rmnm) return
|
|
if (zpsim.gt.zmxm.or.zpsim.lt.zmnm) return
|
|
|
|
select case(iderpsi)
|
|
|
|
case(1)
|
|
nur=1
|
|
nuz=0
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc10,lw10)
|
|
dpsidr=derpsi
|
|
nur=0
|
|
nuz=1
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc01,lw01)
|
|
dpsidz=derpsi
|
|
|
|
case(2)
|
|
nur=2
|
|
nuz=0
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc20,lw20)
|
|
ddpsidrr=derpsi
|
|
nur=0
|
|
nuz=2
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc02,lw02)
|
|
ddpsidzz=derpsi
|
|
nur=1
|
|
nuz=1
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc11,lw11)
|
|
ddpsidrz=derpsi
|
|
|
|
case(3)
|
|
nur=1
|
|
nuz=0
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc10,lw10)
|
|
dpsidr=derpsi
|
|
nur=0
|
|
nuz=1
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc01,lw01)
|
|
dpsidz=derpsi
|
|
nur=2
|
|
nuz=0
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc20,lw20)
|
|
ddpsidrr=derpsi
|
|
nur=0
|
|
nuz=2
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc02,lw02)
|
|
ddpsidzz=derpsi
|
|
nur=1
|
|
nuz=1
|
|
call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc11,lw11)
|
|
ddpsidrz=derpsi
|
|
|
|
case default
|
|
print*,'iderpsi undefined'
|
|
|
|
end select
|
|
|
|
return
|
|
end
|
|
|
|
subroutine sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc,lw)
|
|
use interp_eqprof, only : nr,nz,psia,tr,tz,nsrt,nszt
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(liwrk=2)
|
|
parameter(nrs=1,nzs=1)
|
|
dimension iwrk(liwrk)
|
|
dimension rrs(1),zzs(1),ffspl(1)
|
|
dimension cc(lw)
|
|
|
|
rrs(1)=rpsim
|
|
zzs(1)=zpsim
|
|
nsr=nsrt
|
|
nsz=nszt
|
|
kkr=3-nur
|
|
kkz=3-nuz
|
|
iwr=1+(nr-nur-4)*(nz-nuz-4)
|
|
iwz=iwr+4-nur
|
|
call fpbisp(tr(nur+1),nsr-2*nur,tz(nuz+1),nsz-2*nuz,cc,kkr,kkz
|
|
. ,rrs,nrs,zzs,nzs,ffspl,cc(iwr),cc(iwz),iwrk(1),iwrk(2))
|
|
derpsi=ffspl(1)*psia
|
|
|
|
return
|
|
end
|
|
|
|
subroutine equinum_fpol(iderfpol)
|
|
use interp_eqprof, only : nr,psia,tfp,nsft,cfp,fpolas
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
dimension rrs(1),ffspl(1)
|
|
dimension wrkfd(nr+4)
|
|
integer*4 iderfpol
|
|
c
|
|
common/psival/psinv
|
|
common/fpol/fpolv,ffpv
|
|
|
|
fpolv=fpolas
|
|
dfpolv=0.0d0
|
|
ffpv=0.0d0
|
|
if(iderfpol.lt.0.or.iderfpol.gt.1) return
|
|
|
|
if(psinv.le.1.0d0.and.psinv.gt.0.0d0) then
|
|
rrs(1)=psinv
|
|
call splev(tfp,nsft,cfp,3,rrs,ffspl,1,ier)
|
|
fpolv=ffspl(1)
|
|
if(iderfpol.eq.1) then
|
|
call splder(tfp,nsft,cfp,3,1,rrs,ffspl,1,wrkfd,ier)
|
|
dfpolv=ffspl(1)
|
|
ffpv=fpolv*dfpolv/psia
|
|
end if
|
|
end if
|
|
|
|
return
|
|
end
|
|
|
|
subroutine bfield(rpsim,zpsim,bphi,brr,bzz)
|
|
implicit real*8 (a-h,o-z)
|
|
call btor(rpsim,zpsim,bphi)
|
|
call bpol(rpsim,zpsim,brr,bzz)
|
|
return
|
|
end
|
|
|
|
subroutine btor(rpsim,zpsim,bphi)
|
|
implicit real*8 (a-h,o-z)
|
|
common/psival/psinv
|
|
common/fpol/fpolv,ffpv
|
|
call equinum_psi(rpsim,zpsim)
|
|
call equinum_fpol(0)
|
|
bphi=fpolv/rpsim
|
|
return
|
|
end
|
|
|
|
subroutine bpol(rpsim,zpsim,brr,bzz)
|
|
implicit real*8 (a-h,o-z)
|
|
common/derip1/dpsidr,dpsidz
|
|
call equinum_derpsi(rpsim,zpsim,1)
|
|
brr=-dpsidz/rpsim
|
|
bzz= dpsidr/rpsim
|
|
return
|
|
end
|
|
|
|
subroutine tor_curr_psi(h,ajphi)
|
|
use interp_eqprof, only : zmaxis
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
|
|
call psi_raxis(h,r1,r2)
|
|
call tor_curr(r2,zmaxis,ajphi)
|
|
return
|
|
end
|
|
c
|
|
subroutine tor_curr(rpsim,zpsim,ajphi)
|
|
use const_and_precisions, only : pi,ccj=>mu0inv
|
|
implicit real*8 (a-h,o-z)
|
|
common/derip1/dpsidr,dpsidz
|
|
common/derip2/ddpsidrr,ddpsidzz,ddpsidrz
|
|
call equinum_derpsi(rpsim,zpsim,3)
|
|
bzz= dpsidr/rpsim
|
|
dbvcdc13=-ddpsidzz/rpsim
|
|
dbvcdc31= ddpsidrr/rpsim-bzz/rpsim
|
|
ajphi=ccj*(dbvcdc13-dbvcdc31)
|
|
return
|
|
end
|
|
c
|
|
subroutine psi_raxis(h,r1,r2)
|
|
use interp_eqprof, only : psiant,psinop,zmaxis,nsr=>nsrt,
|
|
. nsz=>nszt,cc=>cceq,tr,tz,nr
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(mest=4,kspl=3)
|
|
dimension zeroc(mest)
|
|
real*8, dimension(:), allocatable :: czc
|
|
c
|
|
if(allocated(czc)) deallocate(czc)
|
|
allocate(czc(nr+4))
|
|
c
|
|
iopt=1
|
|
zc=zmaxis
|
|
call profil(iopt,tr,nsr,tz,nsz,cc,kspl,kspl,zc,nsr,czc,ier)
|
|
if(ier.gt.0) print*,' profil =',ier
|
|
val=h*psiant+psinop
|
|
call sproota(val,tr,nsr,czc,zeroc,mest,m,ier)
|
|
r1=zeroc(1)
|
|
r2=zeroc(2)
|
|
|
|
deallocate(czc)
|
|
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine sub_xg_derxg
|
|
use interp_eqprof, only : psia
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
common/psival/psinv
|
|
common/xgxg/xg
|
|
common/dxgdps/dxgdpsi
|
|
common/xgcn/xgcn
|
|
common/dens/dens,ddenspsin
|
|
xg=0.0d0
|
|
dxgdpsi=0.0d0
|
|
c if(psinv.le.psdbnd.and.psinv.ge.0) then
|
|
call density(psinv)
|
|
xg=xgcn*dens
|
|
dxgdpsi=xgcn*ddenspsin/psia
|
|
c end if
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine density(arg)
|
|
use graydata_flags, only : iprof
|
|
use graydata_par, only : psdbnd
|
|
use graydata_anequil, only : dens0,aln1,aln2
|
|
use interp_eqprof, only : psnpp,aad=>aa,bbd=>bb,ccd=>cc,tfn,nsfd,
|
|
. cfn,npp
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
dimension xxs(1),ffs(1)
|
|
dimension wrkfd(npp+4)
|
|
c
|
|
common/dens/dens,ddens
|
|
c
|
|
c computation of density [10^19 m^-3] and derivative wrt psi
|
|
c
|
|
dens=0.0d0
|
|
ddens=0.0d0
|
|
if(arg.gt.psdbnd.or.arg.lt.0.0d0) return
|
|
c
|
|
if(iprof.eq.0) then
|
|
if(arg.gt.1.0d0) return
|
|
profd=(1.0d0-arg**aln1)**aln2
|
|
dens=dens0*profd
|
|
dprofd=-aln1*aln2*arg**(aln1-1.0d0)
|
|
. *(1.0d0-arg**aln1)**(aln2-1.0d0)
|
|
ddens=dens0*dprofd
|
|
else
|
|
if(arg.le.psdbnd.and.arg.gt.psnpp) then
|
|
c
|
|
c cubic interpolation for 1 < psi < psdbnd
|
|
c
|
|
nn=3
|
|
nn1=nn+1
|
|
nn2=nn+2
|
|
dpsib=arg-psdbnd
|
|
dens=aad*dpsib**nn+bbd*dpsib**nn1+ccd*dpsib**nn2
|
|
ddens=nn*aad*dpsib**(nn-1)+nn1*bbd*dpsib**nn
|
|
. +nn2*ccd*dpsib**nn1
|
|
else
|
|
xxs(1)=arg
|
|
ier=0
|
|
call splev(tfn,nsfd,cfn,3,xxs,ffs,1,ier)
|
|
dens=ffs(1)
|
|
nu=1
|
|
ier=0
|
|
call splder(tfn,nsfd,cfn,3,nu,xxs,ffs,1,wrkfd,ier)
|
|
ddens=ffs(1)
|
|
if(ier.gt.0) print*,ier
|
|
if(abs(dens).lt.1.0d-10) dens=0.0d0
|
|
end if
|
|
if(dens.lt.0.0d0) print*,' DENSITY NEGATIVE',dens
|
|
c
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
function temp(arg)
|
|
use graydata_flags, only : iprof
|
|
use graydata_anequil, only : te0,dte0,alt1,alt2
|
|
use interp_eqprof, only : psrad,ct,npp
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
c
|
|
temp=0.0d0
|
|
if(arg.ge.1.0d0.or.arg.lt.0.0d0) return
|
|
if(iprof.eq.0) then
|
|
proft=(1.0d0-arg**alt1)**alt2
|
|
temp=(te0-dte0)*proft+dte0
|
|
else
|
|
call locate(psrad,npp,arg,k)
|
|
if(k.eq.0) k=1
|
|
if(k.eq.npp) k=npp-1
|
|
dps=arg-psrad(k)
|
|
temp=spli(ct,npp,k,dps)
|
|
endif
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
function fzeff(arg)
|
|
use graydata_flags, only : iprof
|
|
use graydata_anequil, only : zeffan
|
|
use interp_eqprof, only : psrad,cz,npp
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
c
|
|
fzeff=1
|
|
ps=arg
|
|
if(ps.gt.1.0d0.and.ps.lt.0.0d0) return
|
|
if(iprof.eq.0) then
|
|
fzeff=zeffan
|
|
else
|
|
call locate(psrad,npp,ps,k)
|
|
k=max(1,min(k,npp-1))
|
|
dps=ps-psrad(k)
|
|
fzeff=spli(cz,npp,k,dps)
|
|
endif
|
|
return
|
|
end
|
|
c
|
|
c beam tracing initial conditions igrad=1
|
|
c
|
|
subroutine ic_gb
|
|
use const_and_precisions, only : izero,zero,one,pi,cvdr=>degree
|
|
use graydata_flags, only : ipol
|
|
use graydata_par, only : rwmax,psipol0,chipol0
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(ndim=6,ndimm=3)
|
|
parameter(jmx=31,kmx=36)
|
|
dimension ywrk0(ndim,jmx,kmx),ypwrk0(ndim,jmx,kmx)
|
|
dimension ytmp(ndim),yptmp(ndim)
|
|
dimension xc0(ndimm,jmx,kmx),du10(ndimm,jmx,kmx)
|
|
dimension dffiu(jmx),ddffiu(jmx)
|
|
dimension grad2(jmx,kmx),dgrad2v(ndimm,jmx,kmx)
|
|
dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx)
|
|
complex*16 ext(jmx,kmx,0:4),eyt(jmx,kmx,0:4)
|
|
complex*16 ui,sss,ddd,phic,qi1,qi2,tc,ts,qqxx,qqxy,qqyy
|
|
complex*16 dqi1,dqi2,dqqxx,dqqyy,dqqxy
|
|
complex*16 d2qi1,d2qi2,d2qqxx,d2qqyy,d2qqxy
|
|
complex*16 catand
|
|
external catand
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
common/parwv/ak0,akinv,fhz
|
|
common/parbeam/wcsi,weta,rcicsi,rcieta,phiw,phir
|
|
common/anic/anx0c,any0c,anz0c
|
|
common/wrk/ywrk0,ypwrk0
|
|
common/grc/xc0,du10
|
|
common/fi/dffiu,ddffiu
|
|
common/mirr/x00,y00,z00
|
|
common/grad2jk/grad2
|
|
common/dgrad2jk/dgrad2v
|
|
common/gradjk/gri
|
|
common/ggradjk/ggri
|
|
common/ddd/dd,an2s,an2,fdia,bdotgr,ddi,ddr11
|
|
common/evt/ext,eyt
|
|
common/nplr/anpl,anpr
|
|
common/psival/psinv
|
|
common/parpl/brr,bphi,bzz,ajphi
|
|
common/dens/dens,ddens
|
|
common/tete/tekev
|
|
|
|
c
|
|
ui=(0.0d0,1.0d0)
|
|
csth=anz0c
|
|
snth=sqrt(1.0d0-csth**2)
|
|
csps=1.0d0
|
|
snps=0.0d0
|
|
if(snth.gt.0.0d0) then
|
|
csps=any0c/snth
|
|
snps=anx0c/snth
|
|
end if
|
|
c
|
|
phiwrad=phiw*cvdr
|
|
phirrad=phir*cvdr
|
|
csphiw=cos(phiwrad)
|
|
snphiw=sin(phiwrad)
|
|
c csphir=cos(phirrad)
|
|
c snphir=sin(phirrad)
|
|
c
|
|
wwcsi=2.0d0*akinv/wcsi**2
|
|
wweta=2.0d0*akinv/weta**2
|
|
c
|
|
if(phir.ne.phiw) then
|
|
sk=(rcicsi+rcieta)
|
|
sw=(wwcsi+wweta)
|
|
dk=(rcicsi-rcieta)
|
|
dw=(wwcsi-wweta)
|
|
ts=-(dk*sin(2.0d0*phirrad)-ui*dw*sin(2.0d0*phiwrad))
|
|
tc=(dk*cos(2.0d0*phirrad)-ui*dw*cos(2.0d0*phiwrad))
|
|
phic=0.5d0*catand(ts/tc)
|
|
ddd=dk*cos(2*(phirrad+phic))-ui*dw*cos(2*(phiwrad+phic))
|
|
sss=sk-ui*sw
|
|
qi1=0.5d0*(sss+ddd)
|
|
qi2=0.5d0*(sss-ddd)
|
|
rci1=dble(qi1)
|
|
ww1=-dimag(qi1)
|
|
rci2=dble(qi2)
|
|
ww2=-dimag(qi2)
|
|
else
|
|
rci1=rcicsi
|
|
rci2=rcieta
|
|
ww1=wwcsi
|
|
ww2=wweta
|
|
phic=-phiwrad
|
|
qi1=rci1-ui*ww1
|
|
qi2=rci2-ui*ww2
|
|
end if
|
|
|
|
c w01=sqrt(2.0d0*akinv/ww1)
|
|
c z01=-rci1/(rci1**2+ww1**2)
|
|
c w02=sqrt(2.0d0*akinv/ww2)
|
|
c z02=-rci2/(rci2**2+ww2**2)
|
|
|
|
qqxx=qi1*cos(phic)**2+qi2*sin(phic)**2
|
|
qqyy=qi1*sin(phic)**2+qi2*cos(phic)**2
|
|
qqxy=-(qi1-qi2)*sin(2.0d0*phic)
|
|
wwxx=-dimag(qqxx)
|
|
wwyy=-dimag(qqyy)
|
|
wwxy=-dimag(qqxy)/2.0d0
|
|
rcixx=dble(qqxx)
|
|
rciyy=dble(qqyy)
|
|
rcixy=dble(qqxy)/2.0d0
|
|
|
|
dqi1=-qi1**2
|
|
dqi2=-qi2**2
|
|
d2qi1=2*qi1**3
|
|
d2qi2=2*qi2**3
|
|
dqqxx=dqi1*cos(phic)**2+dqi2*sin(phic)**2
|
|
dqqyy=dqi1*sin(phic)**2+dqi2*cos(phic)**2
|
|
dqqxy=-(dqi1-dqi2)*sin(2.0d0*phic)
|
|
d2qqxx=d2qi1*cos(phic)**2+d2qi2*sin(phic)**2
|
|
d2qqyy=d2qi1*sin(phic)**2+d2qi2*cos(phic)**2
|
|
d2qqxy=-(d2qi1-d2qi2)*sin(2.0d0*phic)
|
|
dwwxx=-dimag(dqqxx)
|
|
dwwyy=-dimag(dqqyy)
|
|
dwwxy=-dimag(dqqxy)/2.0d0
|
|
d2wwxx=-dimag(d2qqxx)
|
|
d2wwyy=-dimag(d2qqyy)
|
|
d2wwxy=-dimag(d2qqxy)/2.0d0
|
|
drcixx=dble(dqqxx)
|
|
drciyy=dble(dqqyy)
|
|
drcixy=dble(dqqxy)/2.0d0
|
|
|
|
dr=1.0d0
|
|
if(nrayr.gt.1) dr=rwmax/dble(nrayr-1)
|
|
da=2.0d0*pi/dble(nrayth)
|
|
c
|
|
ddfu=2.0d0*dr**2*akinv
|
|
do j=1,nrayr
|
|
u=dble(j-1)
|
|
c ffi=u**2*ddfu/2.0d0
|
|
dffiu(j)=u*ddfu
|
|
ddffiu(j)=ddfu
|
|
do k=1,nrayth
|
|
alfak=(k-1)*da
|
|
dcsiw=dr*cos(alfak)*wcsi
|
|
detaw=dr*sin(alfak)*weta
|
|
dx0t=dcsiw*csphiw-detaw*snphiw
|
|
dy0t=dcsiw*snphiw+detaw*csphiw
|
|
x0t=u*dx0t
|
|
y0t=u*dy0t
|
|
z0t=-0.5d0*(rcixx*x0t**2+rciyy*y0t**2+2*rcixy*x0t*y0t)
|
|
c
|
|
c csiw=u*dcsiw
|
|
c etaw=u*detaw
|
|
c csir=x0t*csphir+y0t*snphir
|
|
c etar=-x0t*snphir+y0t*csphir
|
|
c
|
|
dx0= x0t*csps+snps*(y0t*csth+z0t*snth)
|
|
dy0=-x0t*snps+csps*(y0t*csth+z0t*snth)
|
|
dz0= z0t*csth-y0t*snth
|
|
x0=x00+dx0
|
|
y0=y00+dy0
|
|
z0=z00+dz0
|
|
|
|
gxt=x0t*wwxx+y0t*wwxy
|
|
gyt=x0t*wwxy+y0t*wwyy
|
|
gzt=0.5d0*(x0t**2*dwwxx+y0t**2*dwwyy)+x0t*y0t*dwwxy
|
|
gr2=gxt*gxt+gyt*gyt+gzt*gzt
|
|
gxxt=wwxx
|
|
gyyt=wwyy
|
|
gzzt=0.5d0*(x0t**2*d2wwxx+y0t**2*d2wwyy)+x0t*y0t*d2wwxy
|
|
gxyt=wwxy
|
|
gxzt=x0t*dwwxx+y0t*dwwxy
|
|
gyzt=x0t*dwwxy+y0t*dwwyy
|
|
dgr2xt=2.0d0*(gxt*gxxt+gyt*gxyt+gzt*gxzt)
|
|
dgr2yt=2.0d0*(gxt*gxyt+gyt*gyyt+gzt*gyzt)
|
|
dgr2zt=2.0d0*(gxt*gxzt+gyt*gyzt+gzt*gzzt)
|
|
dgr2x= dgr2xt*csps+snps*(dgr2yt*csth+dgr2zt*snth)
|
|
dgr2y=-dgr2xt*snps+csps*(dgr2yt*csth+dgr2zt*snth)
|
|
dgr2z= dgr2zt*csth-dgr2yt*snth
|
|
gri(1,j,k)=gxt*csps+snps*(gyt*csth+gzt*snth)
|
|
gri(2,j,k)=-gxt*snps+csps*(gyt*csth+gzt*snth)
|
|
gri(3,j,k)=gzt*csth-gyt*snth
|
|
ggri(1,1,j,k)=gxxt*csps**2+
|
|
. snps**2*(gyyt*csth**2+gzzt*snth**2+2.0d0*snth*csth*gyzt)+
|
|
. 2.0d0*snps*csps*(gxyt*csth+gxzt*snth)
|
|
ggri(2,2,j,k)=gxxt*snps**2+
|
|
. csps**2*(gyyt*csth**2+gzzt*snth**2+2.0d0*snth*csth*gyzt)-
|
|
. 2.0d0*snps*csps*(gxyt*csth+gxzt*snth)
|
|
ggri(3,3,j,k)=gzzt*csth**2+gyyt*snth**2-2.0d0*csth*snth*gyzt
|
|
ggri(1,2,j,k)=csps*snps*(-gxxt+csth**2*gyyt+snth**2*gzzt
|
|
. +2.0d0*csth*snth*gyzt)
|
|
. +(csps**2-snps**2)*(snth*gxzt+csth*gxyt)
|
|
ggri(1,3,j,k)=csth*snth*snps*(gzzt-gyyt)
|
|
. +(csth**2-snth**2)*snps*gyzt+csps*(csth*gxzt-snth*gxyt)
|
|
ggri(2,3,j,k)=csth*snth*csps*(gzzt-gyyt)
|
|
. +(csth**2-snth**2)*csps*gyzt+snps*(snth*gxyt-csth*gxzt)
|
|
ggri(2,1,j,k)=ggri(1,2,j,k)
|
|
ggri(3,1,j,k)=ggri(1,3,j,k)
|
|
ggri(3,2,j,k)=ggri(2,3,j,k)
|
|
c
|
|
du1tx=(dx0t*wwxx+dy0t*wwxy)/ddfu
|
|
du1ty=(dx0t*wwxy+dy0t*wwyy)/ddfu
|
|
du1tz=0.5d0*u*(dx0t**2*dwwxx+dy0t**2*dwwyy+
|
|
. 2.0d0*dx0t*dy0t*dwwxy)/ddfu
|
|
c
|
|
pppx=x0t*rcixx+y0t*rcixy
|
|
pppy=x0t*rcixy+y0t*rciyy
|
|
denpp=pppx*gxt+pppy*gyt
|
|
if (denpp.ne.0.0d0) then
|
|
ppx=-pppx*gzt/denpp
|
|
ppy=-pppy*gzt/denpp
|
|
else
|
|
ppx=0.0d0
|
|
ppy=0.0d0
|
|
end if
|
|
c
|
|
anzt=sqrt((1.0d0+gr2)/(1.0d0+ppx**2+ppy**2))
|
|
anxt=ppx*anzt
|
|
anyt=ppy*anzt
|
|
c
|
|
anx= anxt*csps+snps*(anyt*csth+anzt*snth)
|
|
any=-anxt*snps+csps*(anyt*csth+anzt*snth)
|
|
anz= anzt*csth-anyt*snth
|
|
c
|
|
an20=1.0d0+gr2
|
|
an0=sqrt(an20)
|
|
anx0=anx
|
|
any0=any
|
|
anz0=anz
|
|
c
|
|
xc0(1,j,k)=x0
|
|
xc0(2,j,k)=y0
|
|
xc0(3,j,k)=z0
|
|
c
|
|
ywrk0(1,j,k)=x0
|
|
ywrk0(2,j,k)=y0
|
|
ywrk0(3,j,k)=z0
|
|
ywrk0(4,j,k)=anx0
|
|
ywrk0(5,j,k)=any0
|
|
ywrk0(6,j,k)=anz0
|
|
c
|
|
ypwrk0(1,j,k) = anx0/an0
|
|
ypwrk0(2,j,k) = any0/an0
|
|
ypwrk0(3,j,k) = anz0/an0
|
|
ypwrk0(4,j,k) = dgr2x/an0/2.0d0
|
|
ypwrk0(5,j,k) = dgr2y/an0/2.0d0
|
|
ypwrk0(6,j,k) = dgr2z/an0/2.0d0
|
|
c
|
|
ytmp=ywrk0(:,j,k)
|
|
yptmp=ypwrk0(:,j,k)
|
|
call fwork(ytmp,yptmp)
|
|
|
|
if(ipol.eq.0) then
|
|
call pol_limit(ext(j,k,0),eyt(j,k,0))
|
|
qq=abs(ext(j,k,0))**2-abs(eyt(j,k,0))**2
|
|
uu=2.0d0*dble(ext(j,k,0)*dconjg(eyt(j,k,0)))
|
|
vv=2.0d0*dimag(ext(j,k,0)*dconjg(eyt(j,k,0)))
|
|
call polellipse(qq,uu,vv,psipol0,chipol0)
|
|
else
|
|
qq=cos(2.0d0*chipol0*cvdr)*cos(2.0d0*psipol0*cvdr)
|
|
uu=cos(2.0d0*chipol0*cvdr)*sin(2.0d0*psipol0*cvdr)
|
|
vv=sin(2.0d0*chipol0*cvdr)
|
|
if(qq**2.lt.1) then
|
|
deltapol=asin(vv/sqrt(1.0d0-qq**2))
|
|
ext(j,k,0)= sqrt((1.0d0+qq)/2)
|
|
eyt(j,k,0)= sqrt((1.0d0-qq)/2)*exp(-ui*deltapol)
|
|
else
|
|
ext(j,k,0)= 1.0d0
|
|
eyt(j,k,0)= 0.0d0
|
|
end if
|
|
endif
|
|
c
|
|
grad2(j,k)=gr2
|
|
dgrad2v(1,j,k)=dgr2x
|
|
dgrad2v(2,j,k)=dgr2y
|
|
dgrad2v(3,j,k)=dgr2z
|
|
c
|
|
du10(1,j,k)= du1tx*csps+snps*(du1ty*csth+du1tz*snth)
|
|
du10(2,j,k)=-du1tx*snps+csps*(du1ty*csth+du1tz*snth)
|
|
du10(3,j,k)= du1tz*csth-du1ty*snth
|
|
c
|
|
dd=anx0**2+any0**2+anz0**2-an20
|
|
vgradi=anxt*gxt+anyt*gyt+anzt*gzt
|
|
ddi=2.0d0*vgradi
|
|
c
|
|
r0=sqrt(x0**2+y0**2)
|
|
x0m=x0/1.0d2
|
|
y0m=y0/1.0d2
|
|
r0m=r0/1.0d2
|
|
z0m=z0/1.0d2
|
|
if(j.eq.nrayr) then
|
|
write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m,
|
|
. psinv,zero,anpl,zero,one
|
|
end if
|
|
if(j.eq.1.and.k.eq.1) then
|
|
write(4,99) zero,r0m,z0m,atan2(y0m,x0m)*180.0d0/pi,
|
|
. psinv,one,dens,tekev,brr,bphi,bzz,
|
|
. ajphi*1.0d-6,sqrt(anpl**2+anpr**2),anpl,zero,
|
|
. zero,zero,zero,zero,zero,zero,zero,one
|
|
|
|
ddr110=dd
|
|
end if
|
|
if(j.eq.nrayr.and.k.eq.1) then
|
|
write(17,99) zero,ddr110,dd,ddi
|
|
end if
|
|
end do
|
|
end do
|
|
|
|
call pweigth
|
|
c
|
|
if(nrayr.gt.1) then
|
|
iproj=0
|
|
nfilp=8
|
|
call projxyzt(iproj,nfilp)
|
|
end if
|
|
c
|
|
return
|
|
99 format(24(1x,e16.8e3))
|
|
111 format(3i5,20(1x,e16.8e3))
|
|
end
|
|
c
|
|
c ray tracing initial conditions igrad=0
|
|
c
|
|
subroutine ic_rt
|
|
use const_and_precisions, only : izero,zero,one,pi,cvdr=>degree,
|
|
* ui=>im
|
|
use graydata_flags, only : ipol
|
|
use graydata_par, only : rwmax,psipol0,chipol0
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(ndim=6,ndimm=3)
|
|
parameter(jmx=31,kmx=36)
|
|
dimension ywrk0(ndim,jmx,kmx),ypwrk0(ndim,jmx,kmx)
|
|
dimension ytmp(ndim),yptmp(ndim)
|
|
dimension xc0(ndimm,jmx,kmx),du10(ndimm,jmx,kmx)
|
|
dimension dffiu(jmx),ddffiu(jmx)
|
|
dimension grad2(jmx,kmx),dgrad2v(ndimm,jmx,kmx)
|
|
dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx)
|
|
complex*16 ext(jmx,kmx,0:4),eyt(jmx,kmx,0:4)
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
common/parbeam/wcsi,weta,rcicsi,rcieta,phiw,phir
|
|
common/anic/anx0c,any0c,anz0c
|
|
common/wrk/ywrk0,ypwrk0
|
|
common/grc/xc0,du10
|
|
common/fi/dffiu,ddffiu
|
|
common/mirr/x00,y00,z00
|
|
common/grad2jk/grad2
|
|
common/dgrad2jk/dgrad2v
|
|
common/gradjk/gri
|
|
common/ggradjk/ggri
|
|
common/ddd/dd,an2s,an2,fdia,bdotgr,ddi,ddr11
|
|
common/evt/ext,eyt
|
|
common/nplr/anpl,anpr
|
|
common/psival/psinv
|
|
common/parpl/brr,bphi,bzz,ajphi
|
|
common/dens/dens,ddens
|
|
common/tete/tekev
|
|
c
|
|
csth=anz0c
|
|
snth=sqrt(1.0d0-csth**2)
|
|
csps=1.0d0
|
|
snps=0.0d0
|
|
if(snth.gt.0.0d0) then
|
|
csps=any0c/snth
|
|
snps=anx0c/snth
|
|
end if
|
|
c
|
|
phiwrad=phiw*cvdr
|
|
csphiw=cos(phiwrad)
|
|
snphiw=sin(phiwrad)
|
|
c
|
|
dr=1.0d0
|
|
if(nrayr.gt.1) dr=rwmax/dble(nrayr-1)
|
|
da=2.0d0*pi/dble(nrayth)
|
|
z0t=0.0d0
|
|
c
|
|
do j=1,nrayr
|
|
u=dble(j-1)
|
|
dffiu(j)=0.0d0
|
|
ddffiu(j)=0.0d0
|
|
do k=1,nrayth
|
|
alfak=(k-1)*da
|
|
dcsiw=dr*cos(alfak)*wcsi
|
|
detaw=dr*sin(alfak)*weta
|
|
dx0t=dcsiw*csphiw-detaw*snphiw
|
|
dy0t=dcsiw*snphiw+detaw*csphiw
|
|
x0t=u*dx0t
|
|
y0t=u*dy0t
|
|
c
|
|
c csiw=u*dcsiw
|
|
c etaw=u*detaw
|
|
c csir=csiw
|
|
c etar=etaw
|
|
c
|
|
dx0= x0t*csps+snps*(y0t*csth+z0t*snth)
|
|
dy0=-x0t*snps+csps*(y0t*csth+z0t*snth)
|
|
dz0= z0t*csth-y0t*snth
|
|
c
|
|
x0=x00+dx0
|
|
y0=y00+dy0
|
|
z0=z00+dz0
|
|
c
|
|
ppcsi=u*dr*cos(alfak)*rcicsi
|
|
ppeta=u*dr*sin(alfak)*rcieta
|
|
c
|
|
anzt=1.0d0/sqrt(1.0d0+ppcsi**2+ppeta**2)
|
|
ancsi=ppcsi*anzt
|
|
aneta=ppeta*anzt
|
|
c
|
|
anxt=ancsi*csphiw-aneta*snphiw
|
|
anyt=ancsi*snphiw+aneta*csphiw
|
|
c
|
|
anx= anxt*csps+snps*(anyt*csth+anzt*snth)
|
|
any=-anxt*snps+csps*(anyt*csth+anzt*snth)
|
|
anz= anzt*csth-anyt*snth
|
|
c
|
|
an20=1.0d0
|
|
an0=sqrt(an20)
|
|
anx0=anx
|
|
any0=any
|
|
anz0=anz
|
|
c
|
|
xc0(1,j,k)=x0
|
|
xc0(2,j,k)=y0
|
|
xc0(3,j,k)=z0
|
|
c
|
|
ywrk0(1,j,k)=x0
|
|
ywrk0(2,j,k)=y0
|
|
ywrk0(3,j,k)=z0
|
|
ywrk0(4,j,k)=anx0
|
|
ywrk0(5,j,k)=any0
|
|
ywrk0(6,j,k)=anz0
|
|
c
|
|
ypwrk0(1,j,k) = anx0/an0
|
|
ypwrk0(2,j,k) = any0/an0
|
|
ypwrk0(3,j,k) = anz0/an0
|
|
ypwrk0(4,j,k) = 0.0d0
|
|
ypwrk0(5,j,k) = 0.0d0
|
|
ypwrk0(6,j,k) = 0.0d0
|
|
c
|
|
ytmp=ywrk0(:,j,k)
|
|
yptmp=ypwrk0(:,j,k)
|
|
call fwork(ytmp,yptmp)
|
|
|
|
if(ipol.eq.0) then
|
|
call pol_limit(ext(j,k,0),eyt(j,k,0))
|
|
qq=abs(ext(j,k,0))**2-abs(eyt(j,k,0))**2
|
|
uu=2.0d0*dble(ext(j,k,0)*dconjg(eyt(j,k,0)))
|
|
vv=2.0d0*dimag(ext(j,k,0)*dconjg(eyt(j,k,0)))
|
|
call polellipse(qq,uu,vv,psipol0,chipol0)
|
|
else
|
|
qq=cos(2.0d0*chipol0*cvdr)*cos(2.0d0*psipol0*cvdr)
|
|
uu=cos(2.0d0*chipol0*cvdr)*sin(2.0d0*psipol0*cvdr)
|
|
vv=sin(2.0d0*chipol0*cvdr)
|
|
if(qq**2.lt.1.0d0) then
|
|
c deltapol=phix-phiy, phix =0
|
|
deltapol=atan2(vv,uu)
|
|
ext(j,k,0)= sqrt((1.0d0+qq)/2)
|
|
eyt(j,k,0)= sqrt((1.0d0-qq)/2)*exp(-ui*deltapol)
|
|
else
|
|
if(qq.gt.0.0d0) then
|
|
ext(j,k,0)= 1.0d0
|
|
eyt(j,k,0)= 0.0d0
|
|
else
|
|
eyt(j,k,0)= 1.0d0
|
|
ext(j,k,0)= 0.0d0
|
|
end if
|
|
end if
|
|
endif
|
|
c
|
|
do iv=1,3
|
|
gri(iv,j,k)=0.0d0
|
|
dgrad2v(iv,j,k)=0.0d0
|
|
du10(iv,j,k)=0.0d0
|
|
do jv=1,3
|
|
ggri(iv,jv,j,k)=0.0d0
|
|
end do
|
|
end do
|
|
grad2(j,k)=0.0d0
|
|
c
|
|
dd=anx0**2+any0**2+anz0**2-an20
|
|
vgradi=0.0d0
|
|
ddi=2.0d0*vgradi
|
|
c
|
|
r0=sqrt(x0**2+y0**2)
|
|
x0m=x0/1.0d2
|
|
y0m=y0/1.0d2
|
|
r0m=r0/1.0d2
|
|
z0m=z0/1.0d2
|
|
if(j.eq.nrayr) then
|
|
write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m,
|
|
. psinv,zero,anpl,zero,one
|
|
end if
|
|
if(j.eq.1.and.k.eq.1) then
|
|
write(17,99) zero,zero,zero,zero
|
|
write(4,99) zero,r0m,z0m,atan2(y0m,x0m)*180.0d0/pi,
|
|
. psinv,one,dens,tekev,brr,bphi,bzz,
|
|
. ajphi*1.0d-6,sqrt(anpl**2+anpr**2),anpl,zero,
|
|
. zero,zero,zero,zero,zero,zero,zero,one
|
|
end if
|
|
end do
|
|
end do
|
|
|
|
call pweigth
|
|
c
|
|
if(nrayr.gt.1) then
|
|
iproj=0
|
|
nfilp=8
|
|
call projxyzt(iproj,nfilp)
|
|
end if
|
|
c
|
|
return
|
|
99 format(24(1x,e16.8e3))
|
|
111 format(3i5,20(1x,e16.8e3))
|
|
end
|
|
|
|
|
|
|
|
subroutine ic_rt2
|
|
use const_and_precisions, only : izero,zero,one,pi,cvdr=>degree
|
|
use graydata_par, only : psipol0,chipol0
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(ndim=6,ndimm=3)
|
|
parameter(jmx=31,kmx=36)
|
|
dimension ywrk0(ndim,jmx,kmx),ypwrk0(ndim,jmx,kmx)
|
|
dimension ytmp(ndim),yptmp(ndim)
|
|
dimension yyrfl(jmx,kmx,ndim)
|
|
dimension xc0(ndimm,jmx,kmx),du10(ndimm,jmx,kmx)
|
|
dimension grad2(jmx,kmx),dgrad2v(ndimm,jmx,kmx)
|
|
dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx)
|
|
complex*16 ext(jmx,kmx,0:4),eyt(jmx,kmx,0:4)
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
common/wrk/ywrk0,ypwrk0
|
|
common/grc/xc0,du10
|
|
common/grad2jk/grad2
|
|
common/dgrad2jk/dgrad2v
|
|
common/gradjk/gri
|
|
common/ggradjk/ggri
|
|
common/ddd/dd,an2s,an2,fdia,bdotgr,ddi,ddr11
|
|
common/yyrfl/yyrfl
|
|
common/evt/ext,eyt
|
|
common/nplr/anpl,anpr
|
|
common/psival/psinv
|
|
common/parpl/brr,bphi,bzz,ajphi
|
|
common/dens/dens,ddens
|
|
common/tete/tekev
|
|
|
|
do j=1,nrayr
|
|
do k=1,nrayth
|
|
x0=yyrfl(j,k,1)
|
|
y0=yyrfl(j,k,2)
|
|
z0=yyrfl(j,k,3)
|
|
anx0=yyrfl(j,k,4)
|
|
any0=yyrfl(j,k,5)
|
|
anz0=yyrfl(j,k,6)
|
|
an20=anx0*anx0+any0*any0+anz0*anz0
|
|
an0=sqrt(an20)
|
|
c
|
|
xc0(1,j,k)=x0
|
|
xc0(2,j,k)=y0
|
|
xc0(3,j,k)=z0
|
|
c
|
|
ywrk0(1,j,k)=x0
|
|
ywrk0(2,j,k)=y0
|
|
ywrk0(3,j,k)=z0
|
|
ywrk0(4,j,k)=anx0/an0
|
|
ywrk0(5,j,k)=any0/an0
|
|
ywrk0(6,j,k)=anz0/an0
|
|
c
|
|
ypwrk0(1,j,k) = anx0/an0
|
|
ypwrk0(2,j,k) = any0/an0
|
|
ypwrk0(3,j,k) = anz0/an0
|
|
ypwrk0(4,j,k) = 0.0d0
|
|
ypwrk0(5,j,k) = 0.0d0
|
|
ypwrk0(6,j,k) = 0.0d0
|
|
c
|
|
ytmp=ywrk0(:,j,k)
|
|
yptmp=ypwrk0(:,j,k)
|
|
call fwork(ytmp,yptmp)
|
|
|
|
call pol_limit(ext(j,k,0),eyt(j,k,0))
|
|
qq=abs(ext(j,k,0))**2-abs(eyt(j,k,0))**2
|
|
uu=2.0d0*dble(ext(j,k,0)*dconjg(eyt(j,k,0)))
|
|
vv=2.0d0*dimag(ext(j,k,0)*dconjg(eyt(j,k,0)))
|
|
call polellipse(qq,uu,vv,psipol0,chipol0)
|
|
c
|
|
do iv=1,3
|
|
gri(iv,j,k)=0.0d0
|
|
dgrad2v(iv,j,k)=0.0d0
|
|
du10(iv,j,k)=0.0d0
|
|
do jv=1,3
|
|
ggri(iv,jv,j,k)=0.0d0
|
|
end do
|
|
end do
|
|
grad2(j,k)=0.0d0
|
|
c
|
|
dd=anx0**2+any0**2+anz0**2-an20
|
|
vgradi=0.0d0
|
|
ddi=2.0d0*vgradi
|
|
c
|
|
r0=sqrt(x0**2+y0**2)
|
|
x0m=x0/1.0d2
|
|
y0m=y0/1.0d2
|
|
r0m=r0/1.0d2
|
|
z0m=z0/1.0d2
|
|
if(j.eq.nrayr) then
|
|
write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m,
|
|
. psinv,zero,anpl,zero,one
|
|
end if
|
|
if(j.eq.1.and.k.eq.1) then
|
|
write(17,99) zero,zero,zero,zero
|
|
write(4,99) strfl11,r0m,z0m,atan2(y0m,x0m)*180.0d0/pi,
|
|
. psinv,one,dens,tekev,brr,bphi,bzz,
|
|
. ajphi*1.0d-6,sqrt(anpl**2+anpr**2),anpl,zero,
|
|
. zero,zero,zero,zero,zero,zero,zero,one
|
|
end if
|
|
end do
|
|
end do
|
|
c
|
|
call pweigth
|
|
c
|
|
if(nrayr.gt.1) then
|
|
iproj=0
|
|
nfilp=8
|
|
call projxyzt(iproj,nfilp)
|
|
end if
|
|
c
|
|
return
|
|
99 format(24(1x,e16.8e3))
|
|
111 format(3i5,20(1x,e16.8e3))
|
|
end
|
|
c
|
|
c ray power weigth coefficient q(j)
|
|
c
|
|
subroutine pweigth
|
|
use graydata_par, only : rwmax
|
|
|
|
implicit real*8(a-h,o-z)
|
|
parameter(jmx=31)
|
|
dimension q(jmx)
|
|
common/qw/q
|
|
common/nray/nrayr,nrayth
|
|
c
|
|
dr=1.0d0
|
|
if(nrayr.gt.1) dr=rwmax/dble(nrayr-1)
|
|
r1=0.0d0
|
|
summ=0.0d0
|
|
q(1)=1.0d0
|
|
if(nrayr.gt.1) then
|
|
do j=1,nrayr
|
|
r2=(dble(j)-0.5d0)*dr
|
|
q(j)=(exp(-2.0d0*r1**2)-exp(-2.0d0*r2**2))
|
|
r1=r2
|
|
summ=summ+q(j)
|
|
end do
|
|
c
|
|
q(1)=q(1)/summ
|
|
sm=q(1)
|
|
j=1
|
|
k=1
|
|
do j=2,nrayr
|
|
q(j)=q(j)/nrayth/summ
|
|
do k=1,nrayth
|
|
sm=sm+q(j)
|
|
end do
|
|
end do
|
|
end if
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine valpsispl(rpsi,voli,dervoli,areai,rrii,rbavi,
|
|
. bmxi,bmni,fci,intp)
|
|
use magsurf_data, only : rpstab,cvol,crri,crbav,cbmx,cbmn,
|
|
. carea,cfc,npsi
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
c
|
|
ip=int((npsi-1)*rpsi+1)
|
|
c if(ip.eq.0) ip=1
|
|
c if(ip.eq.npsi) ip=npsi-1
|
|
ip=min(max(1,ip),npsi-1)
|
|
c
|
|
dps=rpsi-rpstab(ip)
|
|
c
|
|
areai=spli(carea,npsi,ip,dps)
|
|
voli=spli(cvol,npsi,ip,dps)
|
|
dervoli=splid(cvol,npsi,ip,dps)
|
|
rrii=spli(crri,npsi,ip,dps)
|
|
c
|
|
if(intp.eq.0) return
|
|
c
|
|
rbavi=spli(crbav,npsi,ip,dps)
|
|
bmxi=spli(cbmx,npsi,ip,dps)
|
|
bmni=spli(cbmn,npsi,ip,dps)
|
|
fci=spli(cfc,npsi,ip,dps)
|
|
c
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine ratioj(rpsi,ratjai,ratjbi,ratjpli)
|
|
use magsurf_data, only : rpstab,cratja,cratjb,cratjpl,npsi
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
|
|
ip=int((npsi-1)*rpsi+1)
|
|
c if(ip.eq.0) ip=1
|
|
c if(ip.eq.npsi) ip=npsi-1
|
|
ip=min(max(1,ip),npsi-1)
|
|
dps=rpsi-rpstab(ip)
|
|
ratjai=spli(cratja,npsi,ip,dps)
|
|
ratjbi=spli(cratjb,npsi,ip,dps)
|
|
ratjpli=spli(cratjpl,npsi,ip,dps)
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine pabs_curr(i,j,k)
|
|
use const_and_precisions, only : pi
|
|
use graydata_flags, only : iequil,dst
|
|
use graydata_par, only : sgnbphi
|
|
use graydata_anequil, only : b0,rr0m,rpam
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(jmx=31,kmx=36,nmx=8000)
|
|
dimension psjki(jmx,kmx,nmx)
|
|
dimension tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx)
|
|
dimension pdjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx)
|
|
dimension currj(jmx,kmx,nmx),didst(jmx,kmx,nmx),ccci(jmx,kmx,nmx)
|
|
dimension q(jmx),tau1v(jmx,kmx)
|
|
c
|
|
common/psjki/psjki
|
|
common/atjki/tauv,alphav
|
|
common/dpjjki/pdjki,currj
|
|
common/pcjki/ppabs,ccci
|
|
common/dcjki/didst
|
|
common/tau1v/tau1v
|
|
c
|
|
common/qw/q
|
|
common/p0/p0mw
|
|
c
|
|
common/dersdst/dersdst
|
|
c
|
|
common/absor/alpha,effjcd,akim,tau0
|
|
c
|
|
common/psival/psinv
|
|
common/bmxmn/bmxi,bmni
|
|
common/fc/fci
|
|
c
|
|
dvvl=1.0d0
|
|
rbavi=1.0d0
|
|
rrii=rr0m
|
|
rhop0=sqrt(psjki(j,k,i-1))
|
|
intp=1
|
|
psinv=psjki(j,k,i)
|
|
rhop=sqrt(psinv)
|
|
call valpsispl(rhop,voli,dervoli,area,rrii,
|
|
. rbavi,bmxi,bmni,fci,intp)
|
|
dvvl=dervoli*abs(rhop-rhop0)
|
|
if(dvvl.le.0.0d0) dvvl=1.0d0
|
|
c
|
|
adnm=2.0d0*pi*rrii
|
|
c
|
|
c calcolo della corrente cohen: currtot [MA]
|
|
c calcolo della densita' corrente cohen: currj [MA/m^2]
|
|
c calcolo della densita' potenza: pdjki [MW/m^3]
|
|
c calcolo della efficienza <j/p>: effjcdav [A m/W ]
|
|
c
|
|
tau0=tauv(j,k,i-1)
|
|
c
|
|
call ecrh_cd
|
|
c
|
|
alphav(j,k,i)=alpha
|
|
dtau=(alphav(j,k,i)+alphav(j,k,i-1))*dersdst*dst/2.0d0
|
|
tauv(j,k,i)=tauv(j,k,i-1)+dtau
|
|
dpdst=p0mw*q(j)*exp(-tauv(j,k,i)-tau1v(j,k))*
|
|
. alphav(j,k,i)*dersdst
|
|
pdjki(j,k,i)=dpdst*dst/dvvl
|
|
ppabs(j,k,i)=p0mw*q(j)*exp(-tau1v(j,k))*
|
|
. (1.0d0-exp(-tauv(j,k,i)))
|
|
effjcdav=rbavi*effjcd
|
|
currj(j,k,i)=sgnbphi*effjcdav*pdjki(j,k,i)
|
|
didst(j,k,i)=sgnbphi*effjcdav*dpdst/adnm
|
|
dcidst=(didst(j,k,i)+didst(j,k,i-1))/2.0d0
|
|
ccci(j,k,i)=ccci(j,k,i-1)+dcidst*dst
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine ecrh_cd
|
|
use const_and_precisions, only : mc2=>mc2_
|
|
use dispersion, only : harmnumber, warmdisp
|
|
use graydata_flags, only : iwarm,ilarm,ieccd,imx
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(taucr=12.0d0,xxcr=16.0d0,eps=1.d-8)
|
|
complex*16 ex,ey,ez
|
|
c
|
|
common/nharm/nhmin,nhmax
|
|
c
|
|
common/xgxg/xg
|
|
common/ygyg/yg
|
|
common/nplr/anpl,anpr
|
|
common/vgv/vgm,derdnm
|
|
common/parwv/ak0,akinv,fhz
|
|
common/mode/sox
|
|
c
|
|
common/nprw/anprre,anprim
|
|
common/epolar/ex,ey,ez
|
|
c
|
|
common/absor/alpha,effjcd,akim,tau
|
|
c
|
|
common/ierr/ierr
|
|
common/iokh/iokhawa
|
|
c
|
|
common/psival/psinv
|
|
common/tete/tekev
|
|
common/dens/dens,ddens
|
|
common/btot/btot
|
|
common/bmxmn/bmax,bmin
|
|
common/fc/fc
|
|
c
|
|
c absorption computation
|
|
c
|
|
alpha=0.0d0
|
|
akim=0.0d0
|
|
effjcd=0.0d0
|
|
c
|
|
tekev=temp(psinv)
|
|
c
|
|
if(tekev.le.0.0d0.or.tau.gt.taucr) return
|
|
c
|
|
amu=mc2/tekev
|
|
call harmnumber(yg,amu,anpl,nhmin,nhmax,iwarm)
|
|
if(nhmin.eq.0) return
|
|
c
|
|
lrm=max(ilarm,nhmax)
|
|
call warmdisp(xg,yg,amu,anpl,anpr,sox,lrm,ierr,anprre,anprim,
|
|
* iwarm,imx,ex,ey,ez)
|
|
c
|
|
akim=ak0*anprim
|
|
ratiovgr=2.0d0*anpr/derdnm
|
|
c ratiovgr=2.0d0*anpr/derdnm*vgm
|
|
alpha=2.0d0*akim*ratiovgr
|
|
if(alpha.lt.0.0d0) then
|
|
ierr=94
|
|
print*,' IERR = ', ierr,' alpha negative'
|
|
end if
|
|
c
|
|
if(ieccd.gt.0) then
|
|
ithn=1
|
|
if(lrm.gt.nhmin) ithn=2
|
|
zeff=fzeff(psinv)
|
|
rbn=btot/bmin
|
|
rbx=btot/bmax
|
|
call eccd(yg,anpl,anprre,amu,zeff,rbn,rbx,fc,ex,ey,ez,
|
|
* dens,psinv,ieccd,nhmin,nhmax,ithn,effjcd,iokhawa,ierr)
|
|
end if
|
|
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine eccd(yg,anpl,anprre,amu,zeff,rbn,rbx,fc,ex,ey,ez,
|
|
* dens,psinv,ieccd,nhmn,nhmx,ithn,effjcd,iokhawa,ierr)
|
|
use green_func_p, only: SpitzFuncCoeff
|
|
use const_and_precisions, only : pi,qesi=>e_,mesi=>me_,vcsi=>c_,
|
|
* qe=>ecgs_,me=>mecgs_,vc=>ccgs_,mc2=>mc2_
|
|
|
|
implicit none
|
|
real*8 anum,denom,resp,resj,effjcd,coullog,dens
|
|
real*8 yg,anpl,anpr,amu,anprre,anprim
|
|
real*8 mc2m2,anucc,canucc,ddens
|
|
real*8 ceff,Zeff,psinv
|
|
real*8 rbn,rbx,alams,fp0s,pa,fc
|
|
real*8 fjch,fjncl,fjch0,fconic
|
|
real*8 cst2,eccdpar(5)
|
|
complex*16 ex,ey,ez
|
|
integer ieccd,nhmn,nhmx,nhn,ithn,ierr,iokhawa
|
|
external fjch,fjncl,fjch0
|
|
|
|
parameter(mc2m2=1.0d0/mc2**2)
|
|
parameter(canucc=2.0d13*pi*qe**4/(me**2*vc**3))
|
|
parameter(ceff=qesi/(mesi*vcsi))
|
|
|
|
anum=0.0d0
|
|
denom=0.0d0
|
|
effjcd=0.0d0
|
|
|
|
coullog=48.0d0-log(1.0d7*dens*mc2m2*amu**2)
|
|
anucc=canucc*dens*coullog
|
|
|
|
c nhmx=nhmn
|
|
|
|
eccdpar(1)=zeff
|
|
|
|
select case(ieccd)
|
|
|
|
case(1)
|
|
c cohen model
|
|
c rbn=B/B_min
|
|
c rbx=B/B_max
|
|
c cst2=1.0d0-B/B_max
|
|
c alams=sqrt(1-B_min/B_max)
|
|
c Zeff < 31 !!!
|
|
c fp0s= P_a (alams)
|
|
cst2=1.0d0-rbx
|
|
if(cst2.lt.1d-6) cst2=0.0d0
|
|
alams=sqrt(1.0d0-rbx/rbn)
|
|
pa=sqrt(32.0d0/(Zeff+1.0d0)-1.0d0)/2.0d0
|
|
fp0s=fconic(alams,pa,0)
|
|
eccdpar(2)=rbn
|
|
eccdpar(3)=alams
|
|
eccdpar(4)=pa
|
|
eccdpar(5)=fp0s
|
|
do nhn=nhmn,nhmx
|
|
call curr_int(yg,anpl,anprre,amu,ex,ey,ez,nhn,ithn,cst2,
|
|
* fjch,eccdpar,5,resj,resp,iokhawa,ierr)
|
|
anum=anum+resj
|
|
denom=denom+resp
|
|
end do
|
|
|
|
case(2:9)
|
|
cst2=0.0d0
|
|
do nhn=nhmn,nhmx
|
|
call curr_int(yg,anpl,anprre,amu,ex,ey,ez,nhn,ithn,cst2,
|
|
* fjch0,eccdpar,1,resj,resp,iokhawa,ierr)
|
|
anum=anum+resj
|
|
denom=denom+resp
|
|
end do
|
|
|
|
case(10:11)
|
|
c neoclassical model:
|
|
c ft=1-fc trapped particle fraction
|
|
c rzfc=(1+Zeff)/fc
|
|
cst2=1.0d0-rbx
|
|
if(cst2.lt.1d-6) cst2=0.0d0
|
|
call SpitzFuncCoeff(amu,Zeff,fc)
|
|
eccdpar(2) = fc
|
|
eccdpar(3) = rbx
|
|
eccdpar(4) = psinv
|
|
do nhn=nhmn,nhmx
|
|
call curr_int(yg,anpl,anprre,amu,ex,ey,ez,nhn,ithn,cst2,
|
|
* fjncl,eccdpar,4,resj,resp,iokhawa,ierr)
|
|
anum=anum+resj
|
|
denom=denom+resp
|
|
end do
|
|
|
|
CASE DEFAULT
|
|
print*,'ieccd undefined'
|
|
|
|
end select
|
|
c
|
|
c effjpl = <J_parallel>/<p_d> /(B_min/<B>) [A m /W]
|
|
c
|
|
if(denom.gt.0.0d0) effjcd=-ceff*anum/(anucc*denom)
|
|
return
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine curr_int(yg,anpl,anprre,amu,ex,ey,ez,nhn,ithn,cst2,
|
|
* fcur,eccdpar,necp,resj,resp,iokhawa,ierr)
|
|
implicit real*8(a-h,o-z)
|
|
parameter(epsa=0.0d0,epsr=1.0d-2)
|
|
parameter(xxcr=16.0d0)
|
|
parameter (lw=5000,liw=lw/4)
|
|
parameter (nfpp=15)
|
|
complex*16 ex,ey,ez
|
|
dimension w(lw),iw(liw),eccdpar(necp),apar(nfpp+necp)
|
|
external fcur,fpp
|
|
|
|
c EC power and current densities
|
|
|
|
anpl2=anpl*anpl
|
|
dnl=1.0d0-anpl2
|
|
ygn=nhn*yg
|
|
ygn2=ygn*ygn
|
|
|
|
resj=0.0d0
|
|
resj1=0.0d0
|
|
resj2=0.0d0
|
|
resp=0.0d0
|
|
c
|
|
rdu2=anpl2+ygn2-1.0d0
|
|
uplp=0.0d0
|
|
uplm=0.0d0
|
|
upltp=0.0d0
|
|
upltm=0.0d0
|
|
c
|
|
if (rdu2.ge.0.0d0) then
|
|
rdu=sqrt(rdu2)
|
|
uplp=(anpl*ygn+rdu)/dnl
|
|
uplm=(anpl*ygn-rdu)/dnl
|
|
c
|
|
uu1=uplm
|
|
uu2=uplp
|
|
xx1=amu*(anpl*uu1+ygn-1.0d0)
|
|
xx2=amu*(anpl*uu2+ygn-1.0d0)
|
|
c
|
|
if(xx2.gt.xxcr) uu2=(xxcr/amu-ygn+1.0d0)/anpl
|
|
if(xx1.gt.xxcr) uu1=(xxcr/amu-ygn+1.0d0)/anpl
|
|
duu=abs(uu1-uu2)
|
|
c
|
|
apar(1) = yg
|
|
apar(2) = anpl
|
|
apar(3) = amu
|
|
apar(4) = anprre
|
|
apar(5) = dble(ex)
|
|
apar(6) = dimag(ex)
|
|
apar(7) = dble(ey)
|
|
apar(8) = dimag(ey)
|
|
apar(9) = dble(ez)
|
|
apar(10) = dimag(ez)
|
|
apar(11) = dble(ithn)
|
|
apar(12) = dble(nhn)
|
|
apar(13) = uplp
|
|
apar(14) = uplm
|
|
apar(15) = ygn
|
|
c
|
|
npar=nfpp+necp
|
|
do i=1,necp
|
|
apar(nfpp+i) = eccdpar(i)
|
|
end do
|
|
c
|
|
if(duu.gt.1.d-6) then
|
|
call dqagsmv(fpp,uu1,uu2,apar,npar,epsa,epsr,resp,epp,neval,
|
|
. ier,liw,lw,last,iw,w)
|
|
if (ier.gt.0) ierr=90
|
|
end if
|
|
c
|
|
rdu2t=cst2*anpl2+ygn2-1.0d0
|
|
c
|
|
if (rdu2t.lt.0.0d0.or.cst2.eq.0.0d0) then
|
|
c
|
|
c resonance curve does not cross the trapping region
|
|
c
|
|
iokhawa=0
|
|
if(duu.gt.1.d-4) then
|
|
call dqagsmv(fcur,uu1,uu2,apar,npar,epsa,epsr,
|
|
. resj,ej,neval,ier,liw,lw,last,iw,w)
|
|
if (ier.gt.0) ierr=91
|
|
end if
|
|
else
|
|
c
|
|
c resonance curve crosses the trapping region
|
|
c
|
|
iokhawa=1
|
|
rdut=sqrt(rdu2t)
|
|
cst=sqrt(cst2)
|
|
upltm=(cst2*anpl*ygn-cst*rdut)/(1.0d0-cst2*anpl2)
|
|
upltp=(cst2*anpl*ygn+cst*rdut)/(1.0d0-cst2*anpl2)
|
|
c
|
|
uu1=uplm
|
|
uu2=upltm
|
|
xx1=amu*(anpl*uu1+ygn-1.0d0)
|
|
xx2=amu*(anpl*uu2+ygn-1.0d0)
|
|
if(xx1.lt.xxcr.or.xx2.lt.xxcr) then
|
|
if(xx2.gt.xxcr) uu2=(xxcr/amu-ygn+1.0d0)/anpl
|
|
if(xx1.gt.xxcr) uu1=(xxcr/amu-ygn+1.0d0)/anpl
|
|
duu=abs(uu1-uu2)
|
|
if(duu.gt.1.d-6) then
|
|
call dqagsmv(fcur,uu1,uu2,apar,npar,epsa,epsr,
|
|
. resj1,ej1,neval,ier,liw,lw,last,iw,w)
|
|
if (ier.gt.0) then
|
|
if (abs(resj1).lt.1.0d-10) then
|
|
resj1=0.0d0
|
|
else
|
|
ierr=92
|
|
end if
|
|
end if
|
|
end if
|
|
end if
|
|
c
|
|
uu1=upltp
|
|
uu2=uplp
|
|
xx1=amu*(anpl*uu1+ygn-1.0d0)
|
|
xx2=amu*(anpl*uu2+ygn-1.0d0)
|
|
if(xx1.lt.xxcr.or.xx2.lt.xxcr) then
|
|
if(xx2.gt.xxcr) uu2=(xxcr/amu-ygn+1.0d0)/anpl
|
|
if(xx1.gt.xxcr) uu1=(xxcr/amu-ygn+1.0d0)/anpl
|
|
duu=abs(uu1-uu2)
|
|
if(duu.gt.1.d-6) then
|
|
call dqagsmv(fcur,uu1,uu2,apar,npar,epsa,epsr,
|
|
. resj2,ej2,neval,ier,liw,lw,last,iw,w)
|
|
if (ier.gt.0) then
|
|
if(ier.ne.2) ierr=93
|
|
end if
|
|
end if
|
|
end if
|
|
resj=resj1+resj2
|
|
end if
|
|
end if
|
|
|
|
return
|
|
end
|
|
c
|
|
c computation of integral for power density, integrand function fpp
|
|
c
|
|
c ith=0 : polarization term = const
|
|
c ith=1 : polarization term Larmor radius expansion to lowest order
|
|
c ith=2 : full polarization term (J Bessel)
|
|
c
|
|
function fpp(upl,extrapar,npar)
|
|
c
|
|
c integration variable upl passed explicitly. other variables passed
|
|
c as array of extra parameters of length npar=size(extrapar)
|
|
c
|
|
c extrapar(1) = yg
|
|
c extrapar(2) = anpl
|
|
c extrapar(3) = amu
|
|
c extrapar(4) = Re(anprw)
|
|
c extrapar(5) = Re(ex)
|
|
c extrapar(6) = Im(ex)
|
|
c extrapar(7) = Re(ey)
|
|
c extrapar(8) = Im(ey)
|
|
c extrapar(9) = Re(ez)
|
|
c extrapar(10) = Im(ez)
|
|
c extrapar(11) = double(ithn)
|
|
c extrapar(12) = double(nhn)
|
|
c extrapar(13) = uplp
|
|
c extrapar(14) = uplm
|
|
c extrapar(15) = ygn
|
|
c
|
|
use const_and_precisions, only : ui=>im
|
|
implicit real*8 (a-h,o-z)
|
|
complex*16 ex,ey,ez,emxy,epxy
|
|
dimension extrapar(npar)
|
|
|
|
yg=extrapar(1)
|
|
anpl=extrapar(2)
|
|
amu=extrapar(3)
|
|
anprre=extrapar(4)
|
|
ex=dcmplx(extrapar(5),extrapar(6))
|
|
ey=dcmplx(extrapar(7),extrapar(8))
|
|
ez=dcmplx(extrapar(9),extrapar(10))
|
|
ithn=int(extrapar(11))
|
|
nhn=int(extrapar(12))
|
|
uplp=extrapar(13)
|
|
uplm=extrapar(14)
|
|
ygn=extrapar(15)
|
|
|
|
upr2=(1.0d0-anpl**2)*(uplp-upl)*(upl-uplm)
|
|
gam=anpl*upl+ygn
|
|
ee=exp(-amu*(gam-1))
|
|
|
|
thn2=1.0d0
|
|
thn2u=upr2*thn2
|
|
if(ithn.gt.0) then
|
|
emxy=ex-ui*ey
|
|
epxy=ex+ui*ey
|
|
if(upr2.gt.0.0d0) then
|
|
upr=sqrt(upr2)
|
|
bb=anprre*upr/yg
|
|
if(ithn.eq.1) then
|
|
c Larmor radius expansion polarization term at lowest order
|
|
cth=1.0d0
|
|
if(nhn.gt.1) cth=(0.5d0*bb)**(nhn-1)*nhn/fact(nhn)
|
|
thn2=(0.5d0*cth*abs(emxy+ez*anprre*upl/ygn))**2
|
|
thn2u=upr2*thn2
|
|
else
|
|
c Full polarization term
|
|
nm=nhn-1
|
|
np=nhn+1
|
|
ajbnm=dbesjn(nm, bb)
|
|
ajbnp=dbesjn(np, bb)
|
|
ajbn=dbesjn(nhn, bb)
|
|
thn2u=(abs(ez*ajbn*upl+upr*(ajbnp*epxy+ajbnm*emxy)/2.0d0))**2
|
|
end if
|
|
end if
|
|
end if
|
|
|
|
fpp=ee*thn2u
|
|
return
|
|
end
|
|
|
|
c computation of integral for current density
|
|
c fjch integrand for Cohen model with trapping
|
|
c fjch0 integrand for Cohen model without trapping
|
|
c fjncl integrand for momentum conserv. model K(u) from Maruschenko
|
|
c gg=F(u)/u with F(u) as in Cohen paper
|
|
c
|
|
function fjch(upl,extrapar,npar)
|
|
c
|
|
c integration variable upl passed explicitly. Other variables passed
|
|
c as array of extra parameters of length npar=size(extrapar).
|
|
c variables with index 1..15 must be passed to fpp
|
|
c variable with index 16 is zeff
|
|
c variables with index gt 16 are specific of the cd model
|
|
c
|
|
c extrapar(1) = yg
|
|
c extrapar(2) = anpl
|
|
c extrapar(3) = amu
|
|
c extrapar(4) = Re(anprw)
|
|
c extrapar(5) = Re(ex)
|
|
c extrapar(6) = Im(ex)
|
|
c extrapar(7) = Re(ey)
|
|
c extrapar(8) = Im(ey)
|
|
c extrapar(9) = Re(ez)
|
|
c extrapar(10) = Im(ez)
|
|
c extrapar(11) = double(ithn)
|
|
c extrapar(12) = double(nhn)
|
|
c extrapar(13) = uplp
|
|
c extrapar(14) = uplm
|
|
c extrapar(15) = ygn
|
|
c
|
|
c extrapar(16) = zeff
|
|
c extrapar(17) = rb
|
|
c extrapar(18) = alams
|
|
c extrapar(19) = pa
|
|
c extrapar(20) = fp0s
|
|
c
|
|
implicit real*8 (a-h,o-z)
|
|
complex*16 ex,ey,ez
|
|
dimension extrapar(npar)
|
|
|
|
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))
|
|
uplp=extrapar(13)
|
|
uplm=extrapar(14)
|
|
ygn=extrapar(15)
|
|
zeff=extrapar(16)
|
|
rb=extrapar(17)
|
|
alams=extrapar(18)
|
|
pa=extrapar(19)
|
|
fp0s=extrapar(20)
|
|
|
|
upr2=(1.0d0-anpl**2)*(uplp-upl)*(upl-uplm)
|
|
gam=anpl*upl+ygn
|
|
u2=gam*gam-1.0d0
|
|
u=sqrt(u2)
|
|
z5=Zeff+5.0d0
|
|
xi=1.0d0/z5**2
|
|
xib=1.0d0-xi
|
|
xibi=1.0d0/xib
|
|
fu2b=1.0d0+xib*u2
|
|
fu2=1.0d0+xi*u2
|
|
gu=(1.0d0-1.0d0/fu2b**xibi)/sqrt(fu2)
|
|
gg=u*gu/z5
|
|
dgg=(gu+u2*(2.0d0/fu2b**(1.0d0+xibi)/sqrt(fu2)-xi*gu/fu2))/z5
|
|
|
|
alam=sqrt(1.0d0-upr2/u2/rb)
|
|
fp0=fconic(alam,pa,0)
|
|
dfp0=-(pa*pa/2.0d0+0.125d0)
|
|
if (alam.lt.1.0d0) then
|
|
dfp0=-fconic(alam,pa,1)/sqrt(1.0d0-alam**2)
|
|
end if
|
|
fh=alam*(1.0d0-alams*fp0/(alam*fp0s))
|
|
dfhl=1.0d0-alams*dfp0/fp0s
|
|
|
|
eta=gam*fh*(gg/u+dgg)+upl*(anpl*u2-upl*gam)*gg*dfhl/(u2*u*rb*alam)
|
|
|
|
if(upl.lt.0.0d0) eta=-eta
|
|
fjch=eta*fpp(upl,extrapar,npar)
|
|
return
|
|
end
|
|
|
|
|
|
|
|
function fjch0(upl,extrapar,npar)
|
|
c
|
|
c integration variable upl passed explicitly. Other variables passed
|
|
c as array of extra parameters of length npar=size(extrapar).
|
|
c variables with index 1..15 must be passed to fpp
|
|
c variable with index 16 is zeff
|
|
c variables with index gt 16 are specific of the cd model
|
|
c
|
|
c extrapar(1) = yg
|
|
c extrapar(2) = anpl
|
|
c extrapar(3) = amu
|
|
c extrapar(4) = Re(anprw)
|
|
c extrapar(5) = Re(ex)
|
|
c extrapar(6) = Im(ex)
|
|
c extrapar(7) = Re(ey)
|
|
c extrapar(8) = Im(ey)
|
|
c extrapar(9) = Re(ez)
|
|
c extrapar(10) = Im(ez)
|
|
c extrapar(11) = double(ithn)
|
|
c extrapar(12) = double(nhn)
|
|
c extrapar(13) = uplp
|
|
c extrapar(14) = uplm
|
|
c extrapar(15) = ygn
|
|
c
|
|
c extrapar(16) = zeff
|
|
c
|
|
implicit real*8 (a-h,o-z)
|
|
complex*16 ex,ey,ez
|
|
dimension extrapar(npar)
|
|
|
|
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)
|
|
zeff=extrapar(16)
|
|
|
|
gam=anpl*upl+ygn
|
|
u2=gam*gam-1.0d0
|
|
u=sqrt(u2)
|
|
z5=Zeff+5.0d0
|
|
xi=1.0d0/z5**2
|
|
xib=1.0d0-xi
|
|
xibi=1.0d0/xib
|
|
fu2b=1.0d0+xib*u2
|
|
fu2=1.0d0+xi*u2
|
|
gu=(1.0d0-1.0d0/fu2b**xibi)/sqrt(fu2)
|
|
gg=u*gu/z5
|
|
dgg=(gu+u2*(2.0d0/fu2b**(1.0d0+xibi)/sqrt(fu2)-xi*gu/fu2))/z5
|
|
eta=anpl*gg+gam*upl*dgg/u
|
|
fjch0=eta*fpp(upl,extrapar,npar)
|
|
return
|
|
end
|
|
|
|
|
|
|
|
function fjncl(upl,extrapar,npar)
|
|
c
|
|
c integration variable upl passed explicitly. Other variables passed
|
|
c as array of extra parameters of length npar=size(extrapar).
|
|
c variables with index 1..15 must be passed to fpp
|
|
c variable with index 16 is zeff
|
|
c variables with index gt 16 are specific of the cd model
|
|
c
|
|
c extrapar(1) = yg
|
|
c extrapar(2) = anpl
|
|
c extrapar(3) = amu
|
|
c extrapar(4) = Re(anprw)
|
|
c extrapar(5) = Re(ex)
|
|
c extrapar(6) = Im(ex)
|
|
c extrapar(7) = Re(ey)
|
|
c extrapar(8) = Im(ey)
|
|
c extrapar(9) = Re(ez)
|
|
c extrapar(10) = Im(ez)
|
|
c extrapar(11) = double(ithn)
|
|
c extrapar(12) = double(nhn)
|
|
c extrapar(13) = uplp
|
|
c extrapar(14) = uplm
|
|
c extrapar(15) = ygn
|
|
c
|
|
c extrapar(16) = zeff
|
|
c extrapar(17) = fc
|
|
c extrapar(18) = hb
|
|
c extrapar(29) = psin
|
|
c
|
|
use green_func_p, only: GenSpitzFunc
|
|
implicit real*8 (a-h,o-z)
|
|
dimension extrapar(npar)
|
|
|
|
anpl=extrapar(2)
|
|
amu=extrapar(3)
|
|
ygn=extrapar(15)
|
|
zeff=extrapar(16)
|
|
fc=extrapar(17)
|
|
hb=extrapar(18)
|
|
psin=extrapar(19)
|
|
|
|
gam=anpl*upl+ygn
|
|
u2=gam*gam-1.0d0
|
|
u=sqrt(u2)
|
|
upr2=u2-upl*upl
|
|
bth=sqrt(2.0d0/amu)
|
|
uth=u/bth
|
|
call GenSpitzFunc(amu,Zeff,fc,uth,u,gam,fk,dfk)
|
|
fk=fk*(4.0d0/amu**2)
|
|
dfk=dfk*(2.0d0/amu)*bth
|
|
|
|
alam=upr2/u2/hb
|
|
call vlambda(alam,psin,fu,dfu)
|
|
|
|
eta=gam*fu*dfk/u-2.0d0*(anpl-gam*upl/u2)*fk*dfu*upl/u2/hb
|
|
if(upl.lt.0) eta=-eta
|
|
fjncl=eta*fpp(upl,extrapar,npar)
|
|
return
|
|
end
|
|
|
|
subroutine vlambda(alam,psi,fv,dfv)
|
|
use magsurf_data, only : ch,ch01,tjp,tlm,njpt,nlmt,npsi
|
|
|
|
implicit real*8 (a-h,o-z)
|
|
parameter (nlam=41)
|
|
parameter(ksp=3,nlest=nlam+ksp+1)
|
|
|
|
external fpbisp
|
|
|
|
dimension xxs(1),yys(1),ffs(1)
|
|
integer, dimension(:), allocatable :: iwrk
|
|
real*8, dimension(:), allocatable :: wrk
|
|
|
|
njest=npsi+ksp+1
|
|
kwrk=npsi+nlam+njest+nlest+3
|
|
lwrk=4*(npsi+nlam)+11*(njest+nlest)+njest*npsi+nlest+54
|
|
allocate(iwrk(kwrk),wrk(lwrk))
|
|
|
|
njp=njpt
|
|
nlm=nlmt
|
|
xxs(1)=sqrt(psi)
|
|
yys(1)=alam
|
|
|
|
call fpbisp(tjp,njp,tlm,nlm,ch,ksp,ksp,xxs,1,yys,1,ffs,
|
|
. wrk(1),wrk(5),iwrk(1),iwrk(2))
|
|
fv=ffs(1)
|
|
|
|
iwp=1+(njp-4)*(nlm-5)
|
|
iwl=iwp+4
|
|
call fpbisp(tjp(1),njp,tlm(2),nlm-2,ch01,3,2,
|
|
. xxs,1,yys,1,ffs,ch01(iwp),ch01(iwl),iwrk(1),iwrk(2))
|
|
dfv=ffs(1)
|
|
|
|
return
|
|
end
|
|
|
|
|
|
subroutine projxyzt(iproj,nfile)
|
|
implicit real*8 (a-h,o-z)
|
|
parameter(jmx=31,kmx=36)
|
|
dimension ywrk(6,jmx,kmx),ypwrk(6,jmx,kmx)
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
common/wrk/ywrk,ypwrk
|
|
common/psinv11/psinv11
|
|
common/istep/istep
|
|
common/ss/st
|
|
c
|
|
rtimn=1.d+30
|
|
rtimx=-1.d-30
|
|
c
|
|
jd=1
|
|
if(iproj.eq.0) jd=nrayr-1
|
|
do j=1,nrayr,jd
|
|
kkk=nrayth
|
|
if(j.eq.1) kkk=1
|
|
do k=1,kkk
|
|
c
|
|
dx=ywrk(1,j,k)-ywrk(1,1,1)
|
|
dy=ywrk(2,j,k)-ywrk(2,1,1)
|
|
dz=ywrk(3,j,k)-ywrk(3,1,1)
|
|
c
|
|
dirx=ywrk(4,j,k)
|
|
diry=ywrk(5,j,k)
|
|
dirz=ywrk(6,j,k)
|
|
dir=sqrt(dirx*dirx+diry*diry+dirz*dirz)
|
|
c
|
|
if(j.eq.1.and.k.eq.1) then
|
|
csth1=dirz/dir
|
|
snth1=sqrt(1.0d0-csth1**2)
|
|
csps1=1.0d0
|
|
snps1=0.0d0
|
|
if(snth1.gt.0.0d0) then
|
|
csps1=diry/(dir*snth1)
|
|
snps1=dirx/(dir*snth1)
|
|
end if
|
|
end if
|
|
xti= dx*csps1-dy*snps1
|
|
yti=(dx*snps1+dy*csps1)*csth1-dz*snth1
|
|
zti=(dx*snps1+dy*csps1)*snth1+dz*csth1
|
|
rti=sqrt(xti**2+yti**2)
|
|
Cc
|
|
C dirxt= (dirx*csps1-diry*snps1)/dir
|
|
C diryt=((dirx*snps1+diry*csps1)*csth1-dirz*snth1)/dir
|
|
C dirzt=((dirx*snps1+diry*csps1)*snth1+dirz*csth1)/dir
|
|
Cc
|
|
C if(k.eq.1) then
|
|
C xti1=xti
|
|
C yti1=yti
|
|
C zti1=zti
|
|
C rti1=rti
|
|
C end if
|
|
|
|
if(.not.(iproj.eq.0.and.j.eq.1))
|
|
. write(nfile,111) istep,j,k,xti,yti,zti,rti,psinv11
|
|
c
|
|
if(rti.ge.rtimx.and.j.eq.nrayr) rtimx=rti
|
|
if(rti.le.rtimn.and.j.eq.nrayr) rtimn=rti
|
|
c
|
|
end do
|
|
c
|
|
c if(.not.(iproj.eq.0.and.j.eq.1))
|
|
c . write(nfile,111) istep,j,k,xti,yti,zti,rti,psinv11
|
|
if(iproj.eq.1) write(nfile,*) ' '
|
|
end do
|
|
c
|
|
write(nfile,*) ' '
|
|
c
|
|
write(12,99) istep,st,psinv11,rtimn,rtimx
|
|
return
|
|
99 format(i5,12(1x,e16.8e3))
|
|
111 format(3i5,12(1x,e16.8e3))
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine pec(pabs,currt)
|
|
use const_and_precisions, only : pi,one
|
|
use graydata_flags, only : ipec,ieccd,iequil,nnd,dst
|
|
use graydata_anequil, only : rr0m,rpam
|
|
|
|
implicit real*8(a-h,o-z)
|
|
parameter(nndmx=5001,jmx=31,kmx=36,nmx=8000)
|
|
parameter(rtbc=one)
|
|
dimension psjki(jmx,kmx,nmx),iiv(jmx,kmx)
|
|
dimension ppabs(jmx,kmx,nmx),ccci(jmx,kmx,nmx)
|
|
dimension pdjki(jmx,kmx,nmx),currj(jmx,kmx,nmx)
|
|
dimension xxi(nmx),ypt(nmx),yamp(nmx)
|
|
dimension rtab(nndmx),rhotv(nndmx)
|
|
dimension rtab1(0:nndmx)
|
|
dimension ajphiv(nndmx),dpdv(nndmx)
|
|
dimension dvolt(nndmx),darea(nndmx)
|
|
dimension ratjav(nndmx),ratjbv(nndmx),ratjplv(nndmx)
|
|
dimension ajplv(nndmx),ajcdav(nndmx),ajcdbv(nndmx)
|
|
dimension pins(nndmx),currins(nndmx),fi(nndmx)
|
|
parameter(llmx=21)
|
|
dimension isev(llmx)
|
|
c
|
|
common/nray/nrayr,nrayth
|
|
common/istep/istep
|
|
common/index_rt/index_rt
|
|
c
|
|
common/iiv/iiv
|
|
common/psjki/psjki
|
|
common/pcjki/ppabs,ccci
|
|
common/dpjjki/pdjki,currj
|
|
c
|
|
common/angles/alpha0,beta0
|
|
common/taumnx/taumn,taumx,pabstot,currtot
|
|
c
|
|
common/polcof/psipol,chipol
|
|
c
|
|
stf=istep*dst
|
|
nd=nnd
|
|
|
|
if(pabstot.gt.0.0d0) then
|
|
do ll=1,llmx
|
|
isev(ll)=0
|
|
end do
|
|
|
|
intp=0
|
|
voli0=0.0d0
|
|
areai0=0.0d0
|
|
rtab1(0)=0.0d0
|
|
do it=1,nd
|
|
drt=1.0d0/dble(nd-1)
|
|
rt=dble(it-1)*drt
|
|
if(it.lt.nd) then
|
|
rt1=rt+drt/2.0d0
|
|
else
|
|
rt1=rt
|
|
end if
|
|
rtab(it)=rt
|
|
rtab1(it)=rt1
|
|
dpdv(it)=0.0d0
|
|
ajphiv(it)=0.0d0
|
|
if (ipec.eq.0) then
|
|
psit=rt
|
|
psit1=rt1
|
|
else
|
|
psit=rt**2
|
|
psit1=rt1**2
|
|
end if
|
|
rhotv(it)=frhotor(psit)
|
|
call valpsispl(sqrt(psit1),voli1,dervoli,areai1,rrii,
|
|
. rbavi,bmxi,bmni,fci,intp)
|
|
dvolt(it)=abs(voli1-voli0)
|
|
darea(it)=abs(areai1-areai0)
|
|
voli0=voli1
|
|
areai0=areai1
|
|
call ratioj(sqrt(psit),ratjai,ratjbi,ratjpli)
|
|
ratjav(it)=ratjai
|
|
ratjbv(it)=ratjbi
|
|
ratjplv(it)=ratjpli
|
|
end do
|
|
|
|
kkk=1
|
|
do j=1,nrayr
|
|
if(j.gt.1) kkk=nrayth
|
|
do k=1,kkk
|
|
ise0=0
|
|
ii=iiv(j,k)
|
|
if (ii.lt.nmx) then
|
|
if(psjki(j,k,ii+1).ne.0.0d0) ii=ii+1
|
|
end if
|
|
idecr=-1
|
|
is=1
|
|
do i=1,ii
|
|
if(ipec.eq.0) xxi(i)=abs(psjki(j,k,i))
|
|
if(ipec.eq.1) xxi(i)=sqrt(abs(psjki(j,k,i)))
|
|
if(psjki(j,k,i).ge.0.and.psjki(j,k,i).le.rtbc) then
|
|
ypt(i)=ppabs(j,k,i)
|
|
yamp(i)=ccci(j,k,i)
|
|
else
|
|
ypt(i)=0.0d0
|
|
yamp(i)=0.0d0
|
|
end if
|
|
if(ise0.eq.0) then
|
|
if(xxi(i).lt.rtbc) then
|
|
ise0=i
|
|
isev(is)=i-1
|
|
is=is+1
|
|
end if
|
|
else
|
|
if (idecr.eq.-1) then
|
|
if(xxi(i).gt.xxi(i-1)) then
|
|
isev(is)=i-1
|
|
is=is+1
|
|
idecr=1
|
|
end if
|
|
else
|
|
if(xxi(i).gt.rtbc) exit
|
|
if(xxi(i).lt.xxi(i-1)) then
|
|
! isev(is)=i !!!!!!!!!! it should be isev(is)=i-1
|
|
isev(is)=i-1
|
|
is=is+1
|
|
idecr=-1
|
|
end if
|
|
end if
|
|
end if
|
|
end do
|
|
c
|
|
isev(is)=i-1
|
|
ppa1=0.0d0
|
|
cci1=0.0d0
|
|
do iis=1,is-1
|
|
iis1=iis+1
|
|
iise0=isev(iis)
|
|
iise=isev(iis1)
|
|
if (mod(iis,2).ne.0) then
|
|
idecr=-1
|
|
ind1=nd
|
|
ind2=2
|
|
iind=-1
|
|
else
|
|
idecr=1
|
|
ind1=1
|
|
ind2=nd
|
|
iind=1
|
|
end if
|
|
do ind=ind1,ind2,iind !!!!!!!!!! is it safe?
|
|
! iind=ind !!!!!!!!!! iind reused in the loop!
|
|
indi=ind !!!!!!!!!! iind reused in the loop!
|
|
if (idecr.eq.-1) indi=ind-1
|
|
rt1=rtab1(indi)
|
|
call locatex(xxi,iise,iise0,iise,rt1,itb1)
|
|
if(itb1.ge.iise0.and.itb1.lt.iise) then
|
|
call intlin(xxi(itb1),ypt(itb1),xxi(itb1+1),
|
|
. ypt(itb1+1),rt1,ppa2)
|
|
call intlin(xxi(itb1),yamp(itb1),xxi(itb1+1),
|
|
. yamp(itb1+1),rt1,cci2)
|
|
dppa=ppa2-ppa1
|
|
dpdv(ind)=dpdv(ind)+dppa
|
|
didst=(cci2-cci1)
|
|
ajphiv(ind)=ajphiv(ind)+didst
|
|
ppa1=ppa2
|
|
cci1=cci2
|
|
end if
|
|
end do
|
|
end do
|
|
end do
|
|
end do
|
|
|
|
h=1.0d0/dble(nd-1)
|
|
rhotpav=0.0d0
|
|
drhotpav=0.0d0
|
|
rhotjav=0.0d0
|
|
rhotjava=0.0d0
|
|
rhot2java=0.0d0
|
|
|
|
fi=dpdv/h
|
|
call simpson (nd,h,fi,spds)
|
|
fi=rhotv*dpdv/h
|
|
call simpson (nd,h,fi,rhotpav)
|
|
fi=rhotv*rhotv*dpdv/h
|
|
call simpson (nd,h,fi,rhot2pav)
|
|
rhotpav=rhotpav/spds
|
|
rhot2pav=rhot2pav/spds
|
|
|
|
if (ieccd.ne.0) then
|
|
fi=ajphiv/h
|
|
call simpson (nd,h,fi,sccs)
|
|
fi=rhotv*ajphiv/h
|
|
call simpson (nd,h,fi,rhotjav)
|
|
fi=abs(ajphiv)/h
|
|
call simpson (nd,h,fi,sccsa)
|
|
fi=rhotv*abs(ajphiv)/h
|
|
call simpson (nd,h,fi,rhotjava)
|
|
fi=rhotv*rhotv*abs(ajphiv)/h
|
|
call simpson (nd,h,fi,rhot2java)
|
|
rhotjav=rhotjav/sccs
|
|
rhotjava=rhotjava/sccsa
|
|
rhot2java=rhot2java/sccsa
|
|
end if
|
|
|
|
c factor sqrt(8)=2 sqrt(2) to match with full width
|
|
c of gaussian profile
|
|
drhot2pav=rhot2pav-rhotpav**2
|
|
drhotpav=sqrt(8.d0*drhot2pav)
|
|
drhot2java=rhot2java-rhotjava**2
|
|
drhotjava=sqrt(8.d0*drhot2java)
|
|
|
|
spds=0.0d0
|
|
sccs=0.0d0
|
|
do i=1,nd
|
|
spds=spds+dpdv(i)
|
|
sccs=sccs+ajphiv(i)
|
|
pins(i)=spds
|
|
currins(i)=sccs
|
|
dpdv(i)=dpdv(i)/dvolt(i)
|
|
ajphiv(i)=ajphiv(i)/darea(i)
|
|
end do
|
|
|
|
facpds=1.0d0
|
|
facjs=1.0d0
|
|
if(spds.gt.0.0d0) facpds=pabs/spds
|
|
if(sccs.ne.0.0d0) facjs=currt/sccs
|
|
|
|
do i=1,nd
|
|
dpdv(i)=facpds*dpdv(i)
|
|
ajphiv(i)=facjs*ajphiv(i)
|
|
ajcdav(i)=ajphiv(i)*ratjav(i)
|
|
ajcdbv(i)=ajphiv(i)*ratjbv(i)
|
|
ajplv(i)=ajphiv(i)*ratjplv(i)
|
|
end do
|
|
|
|
rhpp=frhopol(rhotpav)
|
|
rhpj=frhopol(rhotjava)
|
|
dpdvp=pabs*2.0d0/(sqrt(pi)*drhotpav*fdvdrhot(rhpp))
|
|
ajphip=currt*2.0d0/(sqrt(pi)*drhotjava*fdadrhot(rhpj))
|
|
call ratioj(rhpj,ratjamx,ratjbmx,ratjplmx)
|
|
|
|
call profwidth(nd,rtab,dpdv,rhotp,rhopp,dpdvmx,
|
|
. drhotp,drhopp)
|
|
if(ieccd.ne.0) then
|
|
call profwidth(nd,rtab,ajphiv,rhotjfi,rhopfi,ajmxfi,
|
|
. drhotjfi,drhopfi)
|
|
xps=rhopfi
|
|
else
|
|
rhotjfi=0.0d0
|
|
rhopfi=0.0d0
|
|
ajmxfi=0.0d0
|
|
ajphip=0.0d0
|
|
drhotjfi=0.0d0
|
|
drhopfi=0.0d0
|
|
xps=rhopp
|
|
ratjamx=1.0d0
|
|
ratjbmx=1.0d0
|
|
ratjplmx=1.0d0
|
|
end if
|
|
|
|
iif1=iiv(1,1)
|
|
istmx=1
|
|
do i=2,iif1
|
|
if(psjki(1,1,i).ge.0.0d0) then
|
|
if(pdjki(1,1,i).gt.pdjki(1,1,i-1)) istmx=i
|
|
end if
|
|
end do
|
|
stmx=istmx*dst
|
|
|
|
pins_02=0.0d0
|
|
pins_05=0.0d0
|
|
pins_085=0.0d0
|
|
|
|
xrhot=0.2d0
|
|
call locate(rhotv,nd,xrhot,i1)
|
|
call intlin(rhotv(i1),pins(i1),rhotv(i1+1),pins(i1+1),
|
|
. xrhot,pins_02)
|
|
xrhot=0.5d0
|
|
call locate(rhotv,nd,xrhot,i1)
|
|
call intlin(rhotv(i1),pins(i1),rhotv(i1+1),pins(i1+1),
|
|
. xrhot,pins_05)
|
|
xrhot=0.85d0
|
|
call locate(rhotv,nd,xrhot,i1)
|
|
call intlin(rhotv(i1),pins(i1),rhotv(i1+1),pins(i1+1),
|
|
. xrhot,pins_085)
|
|
|
|
else
|
|
ajmxfi=0.0d0
|
|
ajphip=0.0d0
|
|
dpdvp=0.0d0
|
|
dpdvmx=0.0d0
|
|
rhotjfi=1.0d0
|
|
rhotjav=1.0d0
|
|
rhotjava=1.0d0
|
|
rhotp=1.0d0
|
|
rhotpav=1.0d0
|
|
drhotjfi=0.0d0
|
|
drhotjava=0.0d0
|
|
drhotp=0.0d0
|
|
drhotpav=0.0d0
|
|
ratjamx=1.0d0
|
|
ratjbmx=1.0d0
|
|
taumn=0
|
|
taumx=0
|
|
stmx=stf
|
|
pins_02=0.0d0
|
|
pins_05=0.0d0
|
|
pins_085=0.0d0
|
|
c end of pabstot > 0
|
|
end if
|
|
|
|
c dPdV [MW/m^3], Jcd [MA/m^2]
|
|
|
|
if(ieccd.eq.0) currt=0.0d0
|
|
currtka=currt*1.0d3
|
|
|
|
write(6,*)' '
|
|
write(6,*)'#beta0 alpha0 Icd Pa Jphip dPdVp '//
|
|
.'rhotj rhotjava rhotp rhotpav drhotjava drhotpav ratjamx '//
|
|
.'ratjbmx stmx psipol chipol index_rt Jphimx dPdVmx drhotj drhotp'
|
|
write(6,99) beta0,alpha0,currtka,pabstot,ajphip,dpdvp,
|
|
. rhotjfi,rhotjava,rhotp,rhotpav,
|
|
. drhotjava,drhotpav,ratjamx,ratjbmx,stmx,psipol,chipol,
|
|
. real(index_rt),ajmxfi,dpdvmx,drhotjfi,drhotp
|
|
|
|
write(7,99) currtka,pabstot,ajphip,dpdvp,
|
|
. rhotjfi,rhotjava,rhotp,rhotpav,
|
|
. drhotjava,drhotpav,ratjamx,ratjbmx,stmx,psipol,chipol,
|
|
. real(index_rt),ajmxfi,dpdvmx,drhotjfi,drhotp
|
|
|
|
do i=1,nd
|
|
if (ipec.eq.0) then
|
|
psin=rtab(i)
|
|
rhop=sqrt(rtab(i))
|
|
else
|
|
psin=rtab(i)**2
|
|
rhop=rtab(i)
|
|
end if
|
|
pinsr=0.0d0
|
|
if(pabstot.gt.0) pinsr=pins(i)/pabstot
|
|
write(48,99) psin,rhotv(i),ajphiv(i),ajcdbv(i),dpdv(i),
|
|
. currins(i),pins(i),pinsr,real(index_rt)
|
|
end do
|
|
|
|
return
|
|
99 format(30(1x,e12.5))
|
|
end
|
|
c
|
|
c
|
|
c
|
|
subroutine profwidth(nd,xx,yy,rhotmx,rhopmx,ypk,drhot,drhop)
|
|
use const_and_precisions, only : emn1
|
|
use graydata_flags, only : ipec,iequil
|
|
|
|
implicit real*8(a-h,o-z)
|
|
dimension xx(nd),yy(nd)
|
|
common/jmxmn/rhotp,rhotm,ypkp,ypkm
|
|
c
|
|
call vmaxmini(yy,nd,ymn,ymx,imn,imx)
|
|
ypk=0.0d0
|
|
xmx=xx(imx)
|
|
xmn=xx(imn)
|
|
if (abs(ymx).gt.abs(ymn)) then
|
|
ipk=imx
|
|
ypkp=ymx
|
|
xpkp=xmx
|
|
if(abs(ymn/ymx).lt.1d-2) ymn=0.0d0
|
|
ypkm=ymn
|
|
xpkm=xmn
|
|
else
|
|
ipk=imn
|
|
ypkp=ymn
|
|
xpkp=xmn
|
|
if(abs(ymx/ymn).lt.1d-2) ymx=0.0d0
|
|
ypkm=ymx
|
|
xpkm=xmx
|
|
end if
|
|
if(xpkp.gt.0.0d0) then
|
|
xpk=xpkp
|
|
ypk=ypkp
|
|
yye=ypk*emn1
|
|
call locatex(yy,nd,1,ipk,yye,ie1)
|
|
if(ie1.gt.0.and.ie1.lt.nd) then
|
|
call intlin(yy(ie1),xx(ie1),yy(ie1+1),xx(ie1+1),yye,rte1)
|
|
else
|
|
rte1=0.0d0
|
|
end if
|
|
call locatex(yy,nd,ipk,nd,yye,ie2)
|
|
if(ie2.gt.0.and.ie2.lt.nd) then
|
|
call intlin(yy(ie2),xx(ie2),yy(ie2+1),xx(ie2+1),yye,rte2)
|
|
else
|
|
rte2=0.0d0
|
|
end if
|
|
else
|
|
ipk=2
|
|
xpk=xx(2)
|
|
ypk=yy(2)
|
|
rte1=0.0d0
|
|
yye=ypk*emn1
|
|
call locate(yy,nd,yye,ie2)
|
|
call intlin(yy(ie2),xx(ie2),yy(ie1+2),xx(ie1+2),yye,rte2)
|
|
end if
|
|
c
|
|
ipk=1
|
|
if(ymx.ne.0.and.ymn.ne.0) ipk=2
|
|
c
|
|
drhop=0.0d0
|
|
drhot=0.0d0
|
|
psie1=0.0d0
|
|
psie2=1.0d0
|
|
rhopmx=1.0d0
|
|
rhopmn=0.0d0
|
|
if (ie1.gt.0.or.ie2.gt.0) then
|
|
if(ipec.eq.0) then
|
|
rhopmx=sqrt(xpkp)
|
|
rhopmn=sqrt(xpkm)
|
|
psie2=rte2
|
|
psie1=rte1
|
|
drhop=sqrt(rte2)-sqrt(rte1)
|
|
else
|
|
rhopmx=xpkp
|
|
rhopmn=xpkm
|
|
drhop=rte2-rte1
|
|
psie2=rte2**2
|
|
psie1=rte1**2
|
|
end if
|
|
end if
|
|
c
|
|
rhotmx=frhotor(rhopmx**2)
|
|
rhotmn=frhotor(rhopmn**2)
|
|
rhote2=frhotor(psie2)
|
|
rhote1=frhotor(psie1)
|
|
drhot=rhote2-rhote1
|
|
c
|
|
if(ipk.eq.2) then
|
|
drhop=-drhop
|
|
drhot=-drhot
|
|
end if
|
|
|
|
ypk=ypkp
|
|
rhotp=rhotmx
|
|
rhotm=rhotmn
|
|
c
|
|
return
|
|
end
|
|
c
|
|
subroutine polarcold(exf,eyif,ezf,elf,etf)
|
|
implicit real*8(a-h,o-z)
|
|
common/nplr/anpl,anpr
|
|
common/xgxg/xg
|
|
common/ygyg/yg
|
|
common/mode/sox
|
|
c
|
|
c dcold dispersion
|
|
c dielectric tensor (transposed)
|
|
c
|
|
c exf=0.0d0
|
|
c eyif=0.0d0
|
|
c ezf=0.0d0
|
|
c if(xg.le.0) return
|
|
c
|
|
anpl2=anpl*anpl
|
|
anpr2=anpr*anpr
|
|
an2=anpl2+anpr2
|
|
yg2=yg**2
|
|
dy2=1.0d0-yg2
|
|
aa=1.0d0-xg-yg2
|
|
e3=1.0d0-xg
|
|
c
|
|
if(xg.gt.0.0d0) then
|
|
if (anpl.ne.0.0d0) then
|
|
qq=xg*yg/(an2*dy2-aa)
|
|
p=(anpr2-e3)/(anpl*anpr)
|
|
ezf=1.0d0/sqrt(1.0d0+p*p*(1.0d0+qq*qq))
|
|
exf=p*ezf
|
|
eyif=qq*exf
|
|
else
|
|
if(sox.lt.0.d0) then
|
|
ezf=1
|
|
exf=0
|
|
eyif=0
|
|
else
|
|
ezf=0
|
|
qq=-aa/(xg*yg)
|
|
exf=1.0d0/sqrt(1.0d0+qq*qq)
|
|
eyif=qq*exf
|
|
end if
|
|
end if
|
|
elf=(anpl*ezf+anpr*exf)/sqrt(an2)
|
|
etf=sqrt(1.0d0-elf*elf)
|
|
else
|
|
if(sox.lt.0.0d0) then
|
|
ezf=1
|
|
exf=0
|
|
eyif=0
|
|
else
|
|
ezf=0
|
|
exf=0.0d0
|
|
eyif=1.0d0
|
|
end if
|
|
elf=0
|
|
etf=1
|
|
end if
|
|
c
|
|
return
|
|
end
|
|
|
|
subroutine pol_limit(ext,eyt)
|
|
use const_and_precisions, only : ui=>im,pi
|
|
implicit none
|
|
real*8 bv(3),anv(3)
|
|
real*8 anx,any,anz,anpl,anpr,yg,xe2om,ye2om,xe2xm,ye2xm
|
|
real*8 an2,an,anxy,sngam,csgam,csg2,sng2,ffo,ffx,ffo2,ffx2
|
|
real*8 deno,denx,anpl2,dnl,del0
|
|
real*8 gam
|
|
real*8 sox
|
|
complex*16 exom,eyom,exxm,eyxm,ext,eyt
|
|
c
|
|
common/anv/anv
|
|
common/nplr/anpl,anpr
|
|
common/ygyg/yg
|
|
common/bb/bv
|
|
common/mode/sox
|
|
c
|
|
anx=anv(1)
|
|
any=anv(2)
|
|
anz=anv(3)
|
|
anpl2=anpl*anpl
|
|
dnl=1.0d0-anpl2
|
|
del0=sqrt(dnl**2+4.0d0*anpl2/yg**2)
|
|
ffo=0.5d0*yg*(dnl+del0)
|
|
ffx=0.5d0*yg*(dnl-del0)
|
|
an2=anx*anx+any*any+anz*anz
|
|
an=sqrt(an2)
|
|
anxy=sqrt(anx*anx+any*any)
|
|
sngam=(anz*anpl-an2*bv(3))/(an*anxy*anpr)
|
|
csgam=-(any*bv(1)-anx*bv(2))/anxy/anpr
|
|
csg2=csgam**2
|
|
sng2=sngam**2
|
|
ffo2=ffo*ffo
|
|
ffx2=ffx*ffx
|
|
deno=ffo2+anpl2
|
|
denx=ffx2+anpl2
|
|
xe2om=(ffo2*csg2+anpl2*sng2)/deno
|
|
ye2om=(ffo2*sng2+anpl2*csg2)/deno
|
|
xe2xm=(ffx2*csg2+anpl2*sng2)/denx
|
|
ye2xm=(ffx2*sng2+anpl2*csg2)/denx
|
|
c
|
|
exom=(ffo*csgam-ui*anpl*sngam)/sqrt(deno)
|
|
eyom=(-ffo*sngam-ui*anpl*csgam)/sqrt(deno)
|
|
c
|
|
exxm=(ffx*csgam-ui*anpl*sngam)/sqrt(denx)
|
|
eyxm=(-ffx*sngam-ui*anpl*csgam)/sqrt(denx)
|
|
c
|
|
if (sox.lt.0.0d0) then
|
|
ext=exom
|
|
eyt=eyom
|
|
else
|
|
ext=exxm
|
|
eyt=eyxm
|
|
endif
|
|
|
|
gam=atan(sngam/csgam)*180.d0/pi
|
|
|
|
return
|
|
end
|
|
|
|
subroutine stokes(ext,eyt,qq,uu,vv)
|
|
implicit none
|
|
complex*16 ext,eyt
|
|
real*8 qq,uu,vv
|
|
qq=abs(ext)**2-abs(eyt)**2
|
|
uu=2.0d0*dble(ext*dconjg(eyt))
|
|
vv=2.0d0*dimag(ext*dconjg(eyt))
|
|
end subroutine stokes
|
|
|
|
subroutine polellipse(qq,uu,vv,psipol,chipol)
|
|
use const_and_precisions, only : pi
|
|
implicit none
|
|
real*8 qq,uu,vv,psipol,chipol
|
|
c real*8 llm,aa,bb,ell
|
|
c llm=sqrt(qq**2+uu**2)
|
|
c aa=sqrt((1+llm)/2.0d0)
|
|
c bb=sqrt((1-llm)/2.0d0)
|
|
c ell=bb/aa
|
|
psipol=0.5d0*atan2(uu,qq)*180.d0/pi
|
|
chipol=0.5d0*asin(vv)*180.d0/pi
|
|
end subroutine polellipse
|
|
|
|
|
|
logical function inside_plasma(rrm,zzm)
|
|
use graydata_flags, only : iequil
|
|
use graydata_par, only : psdbnd
|
|
use interp_eqprof, only : zbmin,zbmax
|
|
|
|
implicit none
|
|
real*8 rrm,zzm,psinv
|
|
|
|
common/psival/psinv
|
|
|
|
if(iequil.eq.1) then
|
|
call equian(rrm,zzm)
|
|
else
|
|
call equinum_psi(rrm,zzm)
|
|
end if
|
|
|
|
if (psinv.ge.0.0d0.and.psinv.lt.psdbnd) then
|
|
if (psinv.lt.1.0d0.and.zzm.lt.zbmin.or.zzm.gt.zbmax) then
|
|
inside_plasma=.false.
|
|
else
|
|
inside_plasma=.true.
|
|
end if
|
|
else
|
|
inside_plasma=.false.
|
|
end if
|
|
|
|
end function inside_plasma
|
|
|
|
|
|
subroutine wall_refl(xv,anv,ext,eyt,xvrfl,anvrfl,extr,eytr,walln,
|
|
. irfl)
|
|
use reflections, only : inters_linewall,inside
|
|
use const_and_precisions, only : ui=>im,pi
|
|
use interp_eqprof, only : rlim,zlim,nlim
|
|
implicit none
|
|
integer*4 irfl
|
|
real*8 anv(3),anv0(3),xv(3),xvrfl(3)
|
|
real*8 walln(3),anvrfl(3),vv1(3),vv2(3),vv3(3)
|
|
real*8 smax,rrm,zzm
|
|
complex*16 extr,eytr,eztr,ext,eyt
|
|
complex*16 evin(3),evrfl(3)
|
|
|
|
anv0=anv/sqrt(anv(1)**2+anv(2)**2+anv(3)**2)
|
|
rrm=1.d-2*sqrt(xv(1)**2+xv(2)**2)
|
|
zzm=1.d-2*xv(3)
|
|
|
|
c computation of reflection coordinates and normal to the wall
|
|
call inters_linewall(xv/1.d2,anv0,rlim(1:nlim),zlim(1:nlim),
|
|
. nlim,smax,walln)
|
|
smax=smax*1.d2
|
|
xvrfl=xv+smax*anv0
|
|
irfl=1
|
|
if (.not.inside(rlim,zlim,nlim,rrm,zzm)) then
|
|
! first wall interface is outside-inside
|
|
if (dot_product(walln,walln)<tiny(walln)) then
|
|
! wall never hit
|
|
xvrfl=xv
|
|
anvrfl=anv0
|
|
extr=ext
|
|
eytr=eyt
|
|
irfl=0
|
|
return
|
|
end if
|
|
! search second wall interface (inside-outside)
|
|
call inters_linewall(xvrfl/1.d2,anv0,rlim(1:nlim),zlim(1:nlim),
|
|
. nlim,smax,walln)
|
|
smax=smax*1.d2
|
|
xvrfl=xvrfl+smax*anv0
|
|
irfl=2
|
|
end if
|
|
|
|
c rotation matrix from local to lab frame
|
|
vv1(1)=anv0(2)
|
|
vv1(2)=-anv0(1)
|
|
vv1(3)=0.0d0
|
|
vv2(1)=anv0(1)*anv0(3)
|
|
vv2(2)=anv0(2)*anv0(3)
|
|
vv2(3)=-anv0(1)*anv0(1)-anv0(2)*anv0(2)
|
|
vv1=vv1/sqrt(vv1(1)**2+vv1(2)**2+vv1(3)**2)
|
|
vv2=vv2/sqrt(vv2(1)**2+vv2(2)**2+vv2(3)**2)
|
|
vv3=anv0
|
|
|
|
evin=ext*vv1+eyt*vv2
|
|
c wave vector and electric field after reflection in lab frame
|
|
anvrfl=anv0-2.0d0*
|
|
. (anv0(1)*walln(1)+anv0(2)*walln(2)+anv0(3)*walln(3))*walln
|
|
evrfl=-evin+2.0d0*
|
|
. (evin(1)*walln(1)+evin(2)*walln(2)+evin(3)*walln(3))*walln
|
|
|
|
vv1(1)=anvrfl(2)
|
|
vv1(2)=-anvrfl(1)
|
|
vv1(3)=0.0d0
|
|
vv2(1)=anvrfl(1)*anvrfl(3)
|
|
vv2(2)=anvrfl(2)*anvrfl(3)
|
|
vv2(3)=-anvrfl(1)*anvrfl(1)-anvrfl(2)*anvrfl(2)
|
|
vv1=vv1/sqrt(vv1(1)**2+vv1(2)**2+vv1(3)**2)
|
|
vv2=vv2/sqrt(vv2(1)**2+vv2(2)**2+vv2(3)**2)
|
|
vv3=anvrfl/sqrt(anvrfl(1)**2+anvrfl(2)**2+anvrfl(3)**2)
|
|
|
|
extr=dot_product(vv1,evrfl)
|
|
eytr=dot_product(vv2,evrfl)
|
|
eztr=dot_product(vv3,evrfl)
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vacuum_rt(xvstart,anv,xvend,ivac)
|
|
use reflections, only : inters_linewall,inside
|
|
use graydata_flags, only : dst
|
|
use interp_eqprof, only : rlim,zlim,nlim
|
|
|
|
implicit none
|
|
integer*4 ivac
|
|
integer i
|
|
real*8 st,rrm,zzm,dstvac,smax
|
|
real*8 anv(3),xvstart(3),xvend(3),walln(3)
|
|
real*8 xv0(3),anv0(3)
|
|
logical plfound,inside_plasma
|
|
external inside_plasma
|
|
|
|
common/dstvac/dstvac
|
|
|
|
c ivac=1 plasma hit before wall reflection
|
|
c ivac=2 wall hit before plasma
|
|
c ivac=-1 vessel (and thus plasma) never crossed
|
|
|
|
! the real argument associated to xvstart is in a common block
|
|
! used by fwork!!!
|
|
xv0=xvstart
|
|
anv0=anv
|
|
call inters_linewall(xv0/1.d2,anv,rlim(1:nlim),zlim(1:nlim),
|
|
. nlim,smax,walln)
|
|
smax=smax*1.d2
|
|
rrm=1.d-2*sqrt(xv0(1)**2+xv0(2)**2)
|
|
zzm=1.d-2*xv0(3)
|
|
if (.not.inside(rlim,zlim,nlim,rrm,zzm)) then
|
|
! first wall interface is outside-inside
|
|
if (dot_product(walln,walln)<tiny(walln)) then
|
|
! wall never hit
|
|
dstvac=0.0d0
|
|
xvend=xv0
|
|
ivac=-1
|
|
return
|
|
end if
|
|
! search second wall interface (inside-outside)
|
|
st=smax
|
|
xvend=xv0+st*anv
|
|
call inters_linewall(xvend/1.d2,anv,rlim(1:nlim),zlim(1:nlim),
|
|
. nlim,smax,walln)
|
|
smax=smax*1.d2+st
|
|
end if
|
|
i=0
|
|
do
|
|
st=i*dst
|
|
xvend=xv0+st*anv0
|
|
rrm=1.d-2*sqrt(xvend(1)**2+xvend(2)**2)
|
|
zzm=1.d-2*xvend(3)
|
|
plfound=inside_plasma(rrm,zzm,0)
|
|
if (st.ge.smax.or.plfound) exit
|
|
i=i+1
|
|
end do
|
|
|
|
if (plfound) then
|
|
ivac=1
|
|
dstvac=st
|
|
else
|
|
ivac=2
|
|
dstvac=smax
|
|
xvend=xv0+smax*anv0
|
|
end if
|
|
|
|
! the real argument associated to xvstart is in a common block
|
|
! used by fwork!!!
|
|
xvstart=xv0
|
|
anv=anv0
|
|
|
|
return
|
|
end
|
|
|