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

nocommon branch merged back into trunk

Browse Source
This commit is contained in:
Lorenzo Figini 2015-11-18 16:34:33 +00:00
parent 9eb901015e
commit ce10204479
30 changed files with 22515 additions and 20076 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
Makefile
View File

@ -2,8 +2,11 @@
EXE=gray EXE=gray
# Objects list # Objects list
OBJ=gray.o grayl.o reflections.o green_func_p.o \ MAINOBJ=main.o
const_and_precisions.o itm_constants.o itm_types.o OTHOBJ= beamdata.o beams.o conical.o const_and_precisions.o coreprofiles.o \
dierckx.o dispersion.o eccd.o eierf.o graycore.o gray-externals.o \
gray_params.o equilibrium.o magsurf_data.o math.o minpack.o numint.o \
pec.o polarization.o quadpack.o reflections.o simplespline.o utils.o
# Alternative search paths # Alternative search paths
vpath %.f90 src vpath %.f90 src
@ -11,32 +14,56 @@ vpath %.f src
# Fortran compiler name and flags # Fortran compiler name and flags
FC=gfortran FC=gfortran
FFLAGS=-O3 #-Wall -g -fcheck=all FFLAGS=-O3
#FFLAGS=-Wall -g -finit-real=nan -ffpe-trap=invalid -fcheck=all -fbounds-check
DIRECTIVES = -DREVISION="'$(shell svnversion src)'" DIRECTIVES = -DREVISION="'$(shell svnversion src)'"
all: $(EXE) all: $(EXE)
# Build executable from object files # Build executable from object files
$(EXE): $(OBJ) $(EXE): $(MAINOBJ) $(OTHOBJ)
$(FC) $(FFLAGS) -o $@ $^ $(FC) $(FFLAGS) -o $@ $^
# Dependencies on modules # Dependencies on modules
gray.o: green_func_p.o reflections.o main.o: const_and_precisions.o beams.o coreprofiles.o equilibrium.o \
green_func_p.o: const_and_precisions.o graycore.o gray_params.o reflections.o
const_and_precisions.o: itm_types.o itm_constants.o graycore.o: const_and_precisions.o beamdata.o beams.o coreprofiles.o \
itm_constants.o: itm_types.o dispersion.o equilibrium.o gray-externals.o gray_params.o \
pec.o polarization.o reflections.o utils.o
gray-externals.o: const_and_precisions.o beams.o coreprofiles.o dierckx.o \
dispersion.o eccd.o gray_params.o \
equilibrium.o magsurf_data.o math.o numint.o quadpack.o \
reflections.o simplespline.o utils.o beamdata.o
beams.o: const_and_precisions.o dierckx.o reflections.o simplespline.o utils.o
beamdata.o: const_and_precisions.o gray_params.o
conical.o: const_and_precisions.o
coreprofiles.o: const_and_precisions.o dierckx.o gray_params.o simplespline.o \
utils.o
dierckx.o: const_and_precisions.o
dispersion.o: const_and_precisions.o eierf.o math.o quadpack.o
eccd.o: const_and_precisions.o conical.o magsurf_data.o dierckx.o numint.o
eierf.o: const_and_precisions.o
gray_params.o: const_and_precisions.o utils.o
equilibrium.o: const_and_precisions.o dierckx.o minpack.o simplespline.o \
utils.o gray_params.o
magsurf_data.o: const_and_precisions.o gray_params.o equilibrium.o dierckx.o \
reflections.o simplespline.o utils.o
math.o: const_and_precisions.o
minpack.o: const_and_precisions.o
numint.o: const_and_precisions.o
pec.o: const_and_precisions.o beamdata.o equilibrium.o gray_params.o \
magsurf_data.o utils.o
polarization.o: const_and_precisions.o
quadpack.o: const_and_precisions.o
reflections.o: const_and_precisions.o utils.o
simplespline.o: const_and_precisions.o
utils.o: const_and_precisions.o
# General object compilation command # General object compilation command
%.o: %.f90 %.o: %.f90
$(FC) $(FFLAGS) -c $<
gray.o:gray.f green_func_p.o
$(FC) -cpp $(DIRECTIVES) $(FFLAGS) -c $< $(FC) -cpp $(DIRECTIVES) $(FFLAGS) -c $<
grayl.o:grayl.f
$(FC) $(FFLAGS) -c $^
.PHONY: clean install .PHONY: clean install
# Remove output files # Remove output files
clean: clean:

248
src/beamdata.f90 Normal file
View File

@ -0,0 +1,248 @@
module beamdata
use const_and_precisions, only : wp_
implicit none
integer, save :: nray,nrayr,nrayth,nstep,jray1
real(wp_), save :: dst,h,hh,h6,rwmax,twodr2
integer, parameter :: nfileproj0 = 8, nfilew = 12
contains
subroutine init_rtr(rtrparam,ywork,ypwork,xc,du1,gri,ggri, &
psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv)
use gray_params, only : rtrparam_type
use const_and_precisions, only : zero,half,two
implicit none
type(rtrparam_type), intent(in) :: rtrparam
real(wp_), dimension(:,:), intent(out), allocatable :: ywork,ypwork, &
gri,psjki,tauv,alphav,ppabs,dids,ccci
real(wp_), dimension(:,:,:), intent(out), allocatable :: xc,du1,ggri
real(wp_), dimension(:), intent(out), allocatable :: p0jk
complex(wp_), dimension(:), intent(out), allocatable :: ext, eyt
integer, dimension(:), intent(out), allocatable :: iiv
dst=rtrparam%dst
h=dst
hh=h*half
h6=h/6.0_wp_
nrayr=rtrparam%nrayr
nrayth=rtrparam%nrayth
if(nrayr==1) nrayth=1
nray=(nrayr-1)*nrayth+1
rwmax=rtrparam%rwmax
if(nrayr>1) then
twodr2 = two*(rwmax/(nrayr-1))**2
else
twodr2 = two
end if
nstep=rtrparam%nstep
call alloc_beam(ywork,ypwork,xc,du1,gri,ggri, &
psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv)
end subroutine init_rtr
function rayi2jk(i) result(jk)
implicit none
integer, intent(in) :: i
integer, dimension(2) :: jk
integer :: ioff
if (i>1) then
ioff = i - 2
jk(1) = ioff/nrayth ! jr-2
jk(2) = ioff - jk(1)*nrayth + 1 ! kt
! jk(2) = mod(ioff,nrayth) + 1 ! kt
jk(1) = jk(1) + 2 ! jr
else
jk = 1
end if
end function rayi2jk
function rayi2j(i) result(jr)
implicit none
integer, intent(in) :: i
integer :: jr
! jr = max(1, (i-2)/nrayth + 2)
if (i>1) then
jr = (i-2)/nrayth + 2
else
jr = 1
end if
end function rayi2j
function rayi2k(i) result(kt)
implicit none
integer, intent(in) :: i
integer :: kt
! kt = max(1, mod(i-2,nrayth) + 1)
if (i>1) then
kt = mod(i-2,nrayth) + 1
else
kt = 1
end if
end function rayi2k
function rayjk2i(jr,kt) result(i)
implicit none
integer, intent(in) :: jr,kt
integer :: i
! i = max(1, (jr-2)*nrayth + kt + 1)
if (jr>1) then
i = (jr-2)*nrayth + kt + 1
else
i = 1
end if
end function rayjk2i
subroutine alloc_beam(ywork,ypwork,xc,du1,gri,ggri, &
psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv)
implicit none
real(wp_), dimension(:,:), intent(out), allocatable :: ywork,ypwork, &
gri,psjki,tauv,alphav,ppabs,dids,ccci
real(wp_), dimension(:,:,:), intent(out), allocatable :: xc,du1,ggri
real(wp_), dimension(:), intent(out), allocatable :: p0jk
complex(wp_), dimension(:), intent(out), allocatable :: ext, eyt
integer, dimension(:), intent(out), allocatable :: iiv
call dealloc_beam(ywork,ypwork,xc,du1,gri,ggri, &
psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv)
allocate(ywork(6,nray), ypwork(6,nray), gri(3,nray), ggri(3,3,nray), &
xc(3,nrayth,nrayr), du1(3,nrayth,nrayr), &
psjki(nray,nstep), tauv(nray,nstep), alphav(nray,nstep), &
ppabs(nray,nstep), dids(nray,nstep), ccci(nray,nstep), &
p0jk(nray), ext(nray), eyt(nray), iiv(nray))
end subroutine alloc_beam
subroutine dealloc_beam(ywork,ypwork,xc,du1,gri,ggri, &
psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv)
implicit none
real(wp_), dimension(:,:), intent(out), allocatable :: ywork,ypwork, &
gri,psjki,tauv,alphav,ppabs,dids,ccci
real(wp_), dimension(:,:,:), intent(out), allocatable :: xc,du1,ggri
real(wp_), dimension(:), intent(out), allocatable :: p0jk
complex(wp_), dimension(:), intent(out), allocatable :: ext, eyt
integer, dimension(:), intent(out), allocatable :: iiv
if (allocated(ywork)) deallocate(ywork)
if (allocated(ypwork)) deallocate(ypwork)
if (allocated(xc)) deallocate(xc)
if (allocated(du1)) deallocate(du1)
if (allocated(gri)) deallocate(gri)
if (allocated(ggri)) deallocate(ggri)
if (allocated(psjki)) deallocate(psjki)
if (allocated(tauv)) deallocate(tauv)
if (allocated(alphav)) deallocate(alphav)
if (allocated(ppabs)) deallocate(ppabs)
if (allocated(dids)) deallocate(dids)
if (allocated(ccci)) deallocate(ccci)
if (allocated(p0jk)) deallocate(p0jk)
if (allocated(ext)) deallocate(ext)
if (allocated(eyt)) deallocate(eyt)
if (allocated(iiv)) deallocate(iiv)
end subroutine dealloc_beam
subroutine pweight(p0,p0jk)
! power associated to jk-th ray p0jk(j) for total beam power p0
use const_and_precisions, only : wp_, zero, one, half, two
implicit none
! arguments
real(wp_), intent(in) :: p0
real(wp_), dimension(:), intent(out) :: p0jk
! local variables
integer :: j,jk,jkn
real(wp_) :: dr,r,w,r0,w0,summ
real(wp_), dimension(nrayr) :: q
if(nray==1) then
q(1) = one
else
dr = rwmax/dble(nrayr - 1)
summ = zero
w0 = one
do j = 1, nrayr
r = (dble(j) - half)*dr
w = exp(-two*r**2)
q(j) = w - w0
summ = summ + q(j)
r0 = r
w0 = w
end do
q = q/summ
q(2:) = q(2:)/nrayth
end if
p0jk(1)=q(1)*p0
jk=2
do j=2,nrayr
jkn=jk+nrayth
p0jk(jk:jkn-1)=q(j)*p0
jk=jkn
end do
end subroutine pweight
subroutine print_projxyzt(st,ywrk,iproj)
use const_and_precisions, only : wp_, comp_huge, zero, one
implicit none
! arguments
real(wp_), intent(in) :: st
real(wp_), dimension(:,:), intent(in) :: ywrk
integer, intent(in) :: iproj
! local variables
integer :: jk,jkz,nfile
integer, dimension(2) ::jkv
real(wp_), dimension(3) :: xv1,dir,dxv
real(wp_) :: dirm,rtimn,rtimx,csth1,snth1,csps1,snps1,xti,yti,zti,rti
! common/external functions/variables
nfile = nfileproj0 + iproj
xv1 = ywrk(1:3,1)
dir = ywrk(4:6,1)
dirm = sqrt(dir(1)**2 + dir(2)**2 + dir(3)**2)
dir = dir/dirm
csth1 = dir(3)
snth1 = sqrt(one - csth1**2)
if(snth1 > zero) then
csps1=dir(2)/snth1
snps1=dir(1)/snth1
else
csps1=one
snps1=zero
end if
if(iproj==0) then
jkz = nray - nrayth + 1
else
jkz = 1
end if
rtimn = comp_huge
rtimx = zero
do jk = jkz, nray
dxv = ywrk(1:3,jk) - xv1
xti = dxv(1)*csps1 - dxv(2)*snps1
yti =(dxv(1)*snps1 + dxv(2)*csps1)*csth1 - dxv(3)*snth1
zti =(dxv(1)*snps1 + dxv(2)*csps1)*snth1 + dxv(3)*csth1
rti = sqrt(xti**2 + yti**2)
jkv=rayi2jk(jk)
if(.not.(iproj==0 .and. jk==1)) &
write(nfile,'(1x,e16.8e3,2i5,4(1x,e16.8e3))') st,jkv,xti,yti,zti,rti
if(iproj==1 .and. jkv(2)==nrayth) write(nfile,*) ' '
if(rti>=rtimx .and. jkv(1)==nrayr) rtimx = rti
if(rti<=rtimn .and. jkv(1)==nrayr) rtimn = rti
end do
write(nfile,*) ' '
write(nfilew,'(3(1x,e16.8e3))') st,rtimn,rtimx
end subroutine print_projxyzt
end module beamdata

763
src/beams.f90 Normal file
View File

@ -0,0 +1,763 @@
module beams
use const_and_precisions, only : wp_
implicit none
contains
subroutine read_beam0(file_beam,fghz,x00,y00,z00, &
wcsi,weta,rcicsi,rcieta,phiw,phir,unit)
use const_and_precisions, only : pi,vc=>ccgs_
use utils, only : get_free_unit
implicit none
! arguments
character(len=*), intent(in) :: file_beam
real(wp_), intent(out) :: fGHz,x00,y00,z00
real(wp_), intent(out) :: wcsi,weta,rcicsi,rcieta,phir,phiw
integer, intent(in), optional :: unit
! local variables
integer :: u
real(wp_) :: ak0,zrcsi,zreta,w0csi,w0eta,d0csi,d0eta
if (present(unit)) then
u=unit
else
u = get_free_unit()
end if
open(unit=u,file=trim(file_beam),status='OLD',action='READ')
! fghz wave frequency (GHz)
read(u,*) fGHz
! x00,y00,z00 coordinates of launching point in cm
read(u,*) x00, y00, z00
! beams parameters in local reference system
! w0 -> waist, d0 -> waist distance from launching point
! phiw angle of spot ellipse
read(u,*) w0csi,w0eta,d0csi,d0eta,phiw
close(u)
ak0=2.0e9_wp_*pi*fghz/vc
zrcsi=0.5_wp_*ak0*w0csi**2
zreta=0.5_wp_*ak0*w0eta**2
wcsi=w0csi*sqrt(1.0_wp_+(d0csi/zrcsi)**2)
weta=w0eta*sqrt(1.0_wp_+(d0eta/zreta)**2)
rcicsi=-d0csi/(d0csi**2+zrcsi**2)
rcieta=-d0eta/(d0eta**2+zreta**2)
phir=phiw
end subroutine read_beam0
subroutine read_beam1(file_beam,alpha0,beta0,fghz,x00,y00,z00, &
wcsi,weta,rcicsi,rcieta,phiw,phir,unit)
use const_and_precisions, only : pi,vc=>ccgs_
use simplespline, only : spli, difcs
use utils, only : get_free_unit,locate
implicit none
! arguments
character(len=*), intent(in) :: file_beam
real(wp_), intent(in) :: alpha0
real(wp_), intent(out) :: fghz,x00,y00,z00,beta0
real(wp_), intent(out) :: wcsi,weta,rcicsi,rcieta,phir,phiw
integer, intent(in), optional :: unit
! local variables
integer :: u,ierr,iopt,ier,nisteer,i,k,ii
real(wp_) :: steer,dal
real(wp_), dimension(:), allocatable :: alphastv,betastv,x00v,y00v, &
z00v,waist1v,waist2v,rci1v,rci2v,phi1v,phi2v, &
cbeta,cx0,cy0,cz0,cwaist1,cwaist2, &
crci1,crci2,cphi1,cphi2
if (present(unit)) then
u=unit
else
u = get_free_unit()
end if
open(unit=u,file=file_beam,status='OLD',action='READ')
read(u,*) fghz
read(u,*) nisteer
allocate(alphastv(nisteer),betastv(nisteer),waist1v(nisteer), &
waist2v(nisteer),rci1v(nisteer),rci2v(nisteer), &
phi1v(nisteer),phi2v(nisteer),x00v(nisteer), &
y00v(nisteer),z00v(nisteer),cbeta(4*nisteer), &
cx0(4*nisteer),cy0(4*nisteer),cz0(4*nisteer), &
cwaist1(4*nisteer),cwaist2(4*nisteer),crci1(4*nisteer), &
crci2(4*nisteer),cphi1(4*nisteer),cphi2(4*nisteer), &
stat=ierr)
if (ierr/=0) then
close(u)
deallocate(alphastv,betastv,waist1v,waist2v,rci1v,rci2v, &
phi1v,phi2v,x00v,y00v,z00v,cbeta, &
cx0,cy0,cz0,cwaist1,cwaist2,crci1,crci2,cphi1,cphi2)
write(*,*) 'cannot allocate arrays for beam data'
stop
end if
do i=1,nisteer
read(u,*) steer,alphastv(i),betastv(i),x00v(i),y00v(i),z00v(i), &
waist1v(i),waist2v(i),rci1v(i),rci2v(i),phi1v(i),phi2v(i)
end do
close(u)
! initial beam data measured in mm -> transformed to cm
x00v = 0.1_wp_*x00v
y00v = 0.1_wp_*y00v
z00v = 0.1_wp_*z00v
waist1v = 0.1_wp_*waist1v
waist2v = 0.1_wp_*waist2v
rci1v = 10._wp_*rci1v
rci2v = 10._wp_*rci2v
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)
if((alpha0 > alphastv(1)).and.(alpha0 < alphastv(nisteer))) then
call locate(alphastv,nisteer,alpha0,k)
dal=alpha0-alphastv(k)
beta0=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
write(*,*) ' alpha0 outside table range !!!'
if(alpha0 >= alphastv(nisteer)) ii=nisteer
if(alpha0 <= alphastv(1)) ii=1
beta0=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
deallocate(alphastv,betastv,waist1v,waist2v,rci1v,rci2v, &
phi1v,phi2v,x00v,y00v,z00v,cbeta, &
cx0,cy0,cz0,cwaist1,cwaist2,crci1,crci2,cphi1,cphi2)
end subroutine read_beam1
subroutine read_beam2(file_beam,beamid,alpha0,beta0,fghz,iox,x00,y00,z00, &
wcsi,weta,rcicsi,rcieta,phiw,phir,unit)
use utils, only : get_free_unit, intlin, locate
use reflections, only : inside
use dierckx, only : curfit, splev, surfit, bispev
implicit none
character(len=*), intent(in) :: file_beam
integer, intent(in) :: beamid
real(wp_), intent(inout) :: alpha0,beta0
real(wp_), intent(out) :: fghz,x00,y00,z00, wcsi,weta,rcicsi,rcieta,phir,phiw
integer, intent(out) :: iox
integer, intent(in), optional :: unit
character(len=20) :: beamname
integer :: u
integer :: i, ier, nisteer, fdeg, jumprow, nbeam, nalpha, nbeta
integer :: iopt, incheck, nxcoord, nycoord, nxest, nyest, lwrk, kwrk
integer :: nxwaist1, nywaist1, nxwaist2, nywaist2, nxrci1, nyrci1, nxrci2
integer :: nyrci2, nxphi1, nyphi1, nxphi2, nyphi2, nxx0, nyx0, nxy0, nyy0
integer :: nxz0, nyz0, kx, ky, ii, npolyg, nmax, lwrk2, in
integer :: nxycoord
integer, DIMENSION(:), ALLOCATABLE :: iwrk
real(wp_) :: alphast,betast, waist1, waist2, rci1, rci2, phi1, phi2
real(wp_) :: fp, minx, maxx, miny, maxy, eps, xcoord0, ycoord0
real(wp_), DIMENSION(:), ALLOCATABLE :: x00v, y00v, z00v, alphastv, &
betastv, waist1v, waist2v, rci1v, rci2v, phi1v, phi2v, xcoord, &
ycoord, wrk, txwaist1, tywaist1, txwaist2, tywaist2, &
txrci1, tyrci1, txrci2, tyrci2, txphi1, typhi1, txphi2, typhi2, &
txx0, tyx0, txy0, tyy0, txz0, tyz0, txycoord, cycoord, cwaist1, &
cwaist2, crci1, crci2, cphi1,cphi2, cx0, cy0, cz0, w, wrk2, &
xpolyg, ypolyg, xpolygA, ypolygA, xpolygB, ypolygB, xpolygC, &
ypolygC, xpolygD, ypolygD
real(wp_), DIMENSION(4) :: xvert, yvert
real(wp_), dimension(1) :: fi
integer, parameter :: kspl=1
real(wp_), parameter :: sspl=0.01_wp_
if (present(unit)) then
u=unit
else
u = get_free_unit()
end if
open(unit=u,file=file_beam,status='OLD',action='READ')
!=======================================================================================
! # of beams
read(u,*) nbeam
!
! unused beams' data
jumprow=0
! c====================================================================================
do i=1,beamid-1
read(u,*) beamname, iox, fghz, nalpha, nbeta
jumprow = jumprow+nalpha*nbeta
end do
! c====================================================================================
!
! beam of interest
read(u,*) beamname, iox, fghz, nalpha, nbeta
!
! c====================================================================================
! unused beams' data grids
do i=1,(nbeam - beamid)
read(u,*) beamname
end do
do i=1,jumprow
read(u,*) alphast,betast,x00,y00,z00,waist1,waist2,rci1,rci2,phi1,phi2
end do
! c====================================================================================
!
! # of elements in beam data grid
nisteer = nalpha*nbeta
!
allocate(alphastv(nisteer),betastv(nisteer),waist1v(nisteer), &
waist2v(nisteer),rci1v(nisteer),rci2v(nisteer),phi1v(nisteer), &
phi2v(nisteer),x00v(nisteer),y00v(nisteer),z00v(nisteer), &
xcoord(nisteer),ycoord(nisteer))
!
! c====================================================================================
! beam data grid reading
do i=1,nisteer
read(u,*) alphast,betast,x00,y00,z00,waist1,waist2,rci1,rci2,phi1,phi2
!
! initial beam data (x00, y00, z00) are measured in mm -> transformed to cm
x00v(i)=0.1d0*x00
y00v(i)=0.1d0*y00
z00v(i)=0.1d0*z00
alphastv(i)=alphast
betastv(i)=betast
waist1v(i)=0.1d0*waist1
rci1v(i)=1.0d1*rci1
waist2v(i)=0.1d0*waist2
rci2v(i)=1.0d1*rci2
phi1v(i)=phi1
phi2v(i)=phi2
end do
close(u)
! c====================================================================================
!
! fdeg = 0 alpha, beta free variables
! 1 alpha free variable
! 2 beta free variable
! 3 no free variables
fdeg = 2*(1/nalpha) + 1/nbeta
!#######################################################################################
!
! no free variables
if(fdeg.eq.3) then
alpha0=alphastv(1)
beta0=betastv(1)
x00=x00v(1)
y00=y00v(1)
z00=z00v(1)
wcsi=waist1v(1)
weta=waist2v(1)
rcicsi=rci1v(1)
rcieta=rci2v(1)
phiw=phi1v(1)
phir=phi2v(1)
return
end if
!#######################################################################################
!
!
!#######################################################################################
if(fdeg.eq.2) then
! beta = independent variable
! alpha = dependent variable
xcoord = betastv
ycoord = alphastv
xcoord0 = beta0
ycoord0 = alpha0
kx=min(nbeta-1,kspl)
! c====================================================================================
else
! c====================================================================================
! alpha = independent variable
! beta = dependent/independent (fdeg = 1/0)
xcoord = alphastv
ycoord = betastv
xcoord0 = alpha0
ycoord0 = beta0
nxcoord = nalpha
nycoord = nbeta
kx=min(nalpha-1,kspl)
ky=min(nbeta-1,kspl)
end if
!#######################################################################################
!
iopt = 0
incheck = 0
!
!#######################################################################################
if(fdeg.ne.0) then
nxest = kx + nxcoord + 1
lwrk = (nxcoord*(kx+1)+nxest*(7+3*kx))
kwrk = nxest
allocate(cycoord(nxest), txycoord(nxest), cwaist1(nxest), &
txwaist1(nxest), cwaist2(nxest), txwaist2(nxest), &
crci1(nxest), txrci1(nxest), crci2(nxest), txrci2(nxest), &
cphi1(nxest), txphi1(nxest), cphi2(nxest), txphi2(nxest), &
cx0(nxest), txx0(nxest), cy0(nxest), txy0(nxest), &
cz0(nxest), txz0(nxest), w(nxcoord), wrk(lwrk), iwrk(kwrk))
!
w = 1.d0
!
! 2D interpolation
call curfit(iopt,nxcoord,xcoord,ycoord,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxycoord, &
txycoord,cycoord,fp,wrk,lwrk,iwrk,ier)
!
call curfit(iopt,nxcoord,xcoord,waist1v,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxwaist1, &
txwaist1,cwaist1,fp,wrk,lwrk,iwrk,ier)
!
call curfit(iopt,nxcoord,xcoord,waist2v,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxwaist2, &
txwaist2,cwaist2,fp,wrk,lwrk,iwrk,ier)
!
call curfit(iopt,nxcoord,xcoord,rci1v,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxrci1, &
txrci1,crci1,fp,wrk,lwrk,iwrk,ier)
!
call curfit(iopt,nxcoord,xcoord,rci2v,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxrci2, &
txrci2,crci2,fp,wrk,lwrk,iwrk,ier)
!
call curfit(iopt,nxcoord,xcoord,phi1v,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxphi1, &
txphi1,cphi1,fp,wrk,lwrk,iwrk,ier)
!
call curfit(iopt,nxcoord,xcoord,phi2v,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxphi2, &
txphi2,cphi2,fp,wrk,lwrk,iwrk,ier)
!
call curfit(iopt,nxcoord,xcoord,x00v,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxx0, &
txx0,cx0,fp,wrk,lwrk,iwrk,ier)
!
call curfit(iopt,nxcoord,xcoord,y00v,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxy0, &
txy0,cy0,fp,wrk,lwrk,iwrk,ier)
!
call curfit(iopt,nxcoord,xcoord,z00v,w, &
xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxz0, &
txz0,cz0,fp,wrk,lwrk,iwrk,ier)
!
! check if xcoord0 is out of table range
! incheck = 1 inside / 0 outside
if(xcoord0.gt.xcoord(1).and.xcoord0.lt.xcoord(nisteer)) incheck=1
! c====================================================================================
else
! c====================================================================================
npolyg = 2*(nxcoord+nycoord-2)
minx = minval(xcoord)
maxx = maxval(xcoord)
miny = minval(ycoord)
maxy = maxval(ycoord)
nxest = kx + 1 + int(sqrt(nisteer/2.))
nyest = ky + 1 + int(sqrt(nisteer/2.))
nmax = max(nxest,nyest)
eps = 10.**(-8)
lwrk = (nmax-2)**2*(7*nmax-2)+18*nmax+8*nisteer-19
lwrk2 = (nmax-2)**2*(4*nmax-1)+4*nmax-2
kwrk = nisteer+(nmax-3)*(nmax-3)
allocate(cwaist1(nxest*nyest), txwaist1(nmax), tywaist1(nmax), &
cwaist2(nxest*nyest), txwaist2(nmax), tywaist2(nmax), &
crci1(nxest*nyest), txrci1(nmax), tyrci1(nmax), &
crci2(nxest*nyest), txrci2(nmax), tyrci2(nmax), &
cphi1(nxest*nyest), txphi1(nmax), typhi1(nmax), &
cphi2(nxest*nyest), txphi2(nmax), typhi2(nmax), &
cx0(nxest*nyest), txx0(nmax), tyx0(nmax), &
cy0(nxest*nyest), txy0(nmax), tyy0(nmax), &
cz0(nxest*nyest), txz0(nmax), tyz0(nmax), &
wrk(lwrk), wrk2(lwrk2), iwrk(kwrk), &
xpolyg(npolyg), ypolyg(npolyg), w(nisteer))
!
w = 1.d0
!
! 3D interpolation
call surfit(iopt,nisteer,xcoord,ycoord,waist1v,w, &
minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, &
nxwaist1,txwaist1,nywaist1,tywaist1,cwaist1,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier)
!
call surfit(iopt,nisteer,xcoord,ycoord,waist2v,w, &
minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, &
nxwaist2,txwaist2,nywaist2,tywaist2,cwaist2,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier)
!
call surfit(iopt,nisteer,xcoord,ycoord,rci1v,w, &
minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, &
nxrci1,txrci1,nyrci1,tyrci1,crci1,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier)
!
call surfit(iopt,nisteer,xcoord,ycoord,rci2v,w, &
minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, &
nxrci2,txrci2,nyrci2,tyrci2,crci2,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier)
!
call surfit(iopt,nisteer,xcoord,ycoord,phi1v,w, &
minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, &
nxphi1,txphi1,nyphi1,typhi1,cphi1,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier)
!
call surfit(iopt,nisteer,xcoord,ycoord,phi2v,w, &
minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, &
nxphi2,txphi2,nyphi2,typhi2,cphi2,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier)
!
call surfit(iopt,nisteer,xcoord,ycoord,x00v,w, &
minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, &
nxx0,txx0,nyx0,tyx0,cx0,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier)
!
call surfit(iopt,nisteer,xcoord,ycoord,y00v,w, &
minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, &
nxy0,txy0,nyy0,tyy0,cy0,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier)
!
call surfit(iopt,nisteer,xcoord,ycoord,z00v,w, &
minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, &
nxz0,txz0,nyz0,tyz0,cz0,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier)
! data range polygon
xpolyg(1:nxcoord) = xcoord(1:nxcoord)
ypolyg(1:nxcoord) = ycoord(1:nxcoord)
!
! c====================================================================================
do i=1,nycoord-2
xpolyg(nxcoord+i) = xcoord((i+1)*nxcoord)
xpolyg(2*nxcoord+nycoord-2+i) = xcoord((nycoord-i-1)*nxcoord+1)
ypolyg(nxcoord+i) = ycoord((i+1)*nxcoord)
ypolyg(2*nxcoord+nycoord-2+i) = ycoord((nycoord-i-1)*nxcoord+1)
end do
! c====================================================================================
do i=1,nxcoord
xpolyg(nxcoord+nycoord-2+i) = xcoord(nxcoord*nycoord-i+1)
ypolyg(nxcoord+nycoord-2+i) = ycoord(nxcoord*nycoord-i+1)
end do
! c====================================================================================
!
! check if (xcoord0, ycoord0) is out of table range
! incheck = 1 inside / 0 outside
if(inside(xpolyg,ypolyg,npolyg,xcoord0,ycoord0)) incheck = 1
end if
deallocate(wrk,iwrk)
!#######################################################################################
!
!
!#######################################################################################
if(fdeg.ne.0) then
! c====================================================================================
if(incheck.eq.1) then
call splev(txycoord,nxycoord,cycoord,kx,(/xcoord0/),fi,1,ier)
ycoord0=fi(1)
call splev(txwaist1,nxwaist1,cwaist1,kx,(/xcoord0/),fi,1,ier)
wcsi=fi(1)
call splev(txwaist2,nxwaist2,cwaist2,kx,(/xcoord0/),fi,1,ier)
weta=fi(1)
call splev(txrci1,nxrci1,crci1,kx,(/xcoord0/),fi,1,ier)
rcicsi=fi(1)
call splev(txrci2,nxrci2,crci2,kx,(/xcoord0/),fi,1,ier)
rcieta=fi(1)
call splev(txphi1,nxphi1,cphi1,kx,(/xcoord0/),fi,1,ier)
phiw=fi(1)
call splev(txphi2,nxphi2,cphi2,kx,(/xcoord0/),fi,1,ier)
phir=fi(1)
call splev(txx0,nxx0,cx0,kx,(/xcoord0/),fi,1,ier)
x00=fi(1)
call splev(txy0,nxy0,cy0,kx,(/xcoord0/),fi,1,ier)
y00=fi(1)
call splev(txz0,nxz0,cz0,kx,(/xcoord0/),fi,1,ier)
z00=fi(1)
! c----------------------------------------------------------------------------------
else
! c----------------------------------------------------------------------------------
if(xcoord0.ge.xcoord(nisteer)) ii=nisteer
if(xcoord0.le.xcoord(1)) ii=1
!
xcoord0=xcoord(ii)
ycoord0=ycoord(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
! c====================================================================================
else
! c====================================================================================
if(incheck.eq.0) then
allocate(xpolygA(nxcoord), ypolygA(nxcoord), xpolygC(nxcoord), &
ypolygC(nxcoord), xpolygB(nycoord), ypolygB(nycoord), &
xpolygD(nycoord), ypolygD(nycoord))
! coordinates of vertices v1,v2,v3,v4
xvert(1) = xpolyg(1)
xvert(2) = xpolyg(nxcoord)
xvert(3) = xpolyg(nxcoord+nycoord-1)
xvert(4) = xpolyg(2*nxcoord+nycoord-2)
yvert(1) = ypolyg(1)
yvert(2) = ypolyg(nxcoord)
yvert(3) = ypolyg(nxcoord+nycoord-1)
yvert(4) = ypolyg(2*nxcoord+nycoord-2)
! coordinates of side A,B,C,D
xpolygA = xpolyg(1:nxcoord)
ypolygA = ypolyg(1:nxcoord)
xpolygB = xpolyg(nxcoord:nxcoord+nycoord-1)
ypolygB = ypolyg(nxcoord:nxcoord+nycoord-1)
xpolygC = xpolyg(nxcoord+nycoord-1:2*nxcoord+nycoord-2)
ypolygC = ypolyg(nxcoord+nycoord-1:2*nxcoord+nycoord-2)
xpolygD(1:nycoord-1) = xpolyg(2*nxcoord+nycoord-2:npolyg)
xpolygD(nycoord) = xpolyg(1)
ypolygD(1:nycoord-1) = ypolyg(2*nxcoord+nycoord-2:npolyg)
ypolygD(nycoord) = ypolyg(1)
! c----------------------------------------------------------------------------------
! search for position of xcoord0, ycoord0 with respect to (alpha,beta) data grid
!
! | |
! (6) (5) (4)
! | |
! _ _ _ v4 _________________v3_ _ _ _
! | C | (1)->(8) outside regions
! | |
! (7) D | | B (3) v1->v4 grid vertices
! | |
! _ _ _ _ |_________________| _ _ _ _ A-D grid sides
! v1 A v2
! | |
! (8) (1) (2)
! | |
!
if(xcoord0.gt.xvert(1).and.xcoord0.lt.xvert(2).and.ycoord0.le.maxval(ypolygA)) then
in=1
else if(ycoord0.gt.yvert(2).and.ycoord0.lt.yvert(3).and.xcoord0.ge.minval(xpolygB)) then
in=3
else if(xcoord0.lt.xvert(3).and.xcoord0.gt.xvert(4).and.ycoord0.ge.minval(ypolygC)) then
in=5
else if(ycoord0.lt.yvert(4).and.ycoord0.gt.yvert(1).and.xcoord0.le.maxval(xpolygD)) then
in=7
else if(xcoord0.ge.xvert(2).and.ycoord0.le.yvert(2)) then
in=2
else if(xcoord0.ge.xvert(3).and.ycoord0.ge.yvert(3)) then
in=4
else if(xcoord0.le.xvert(4).and.ycoord0.ge.yvert(4)) then
in=6
else if(xcoord0.le.xvert(1).and.ycoord0.le.yvert(1)) then
in=8
endif
! c----------------------------------------------------------------------------------
!
! c----------------------------------------------------------------------------------
! (xcoord0,ycoord0) is set to its nearest point on (alpha, beta) grid border
! depending on the region
! 1: xcoord0 unchanged, ycoord0 moved on side A
! 3: xcoord0 moved on side B, ycoord0 unchanged
! 5: xcoord0 unchanged, ycoord0 moved on side C
! 7: xcoord0 moved on side D, ycoord0 unchanged
! 2,4,6,8: (xcoord0,ycoord0) set to nearest vertex coordinates
! in 1,3,5,7 incheck is set back to 1 to evaluate x00,y00,z00,waist,rci,phi in
! new (xcoord0,ycoord0)
! in 2,4,6,8 incheck remains 0 and x00,y00,z00,waist,rci,phi values at the
! (xcoord0,ycoord0) vertex are used
alpha0 = xcoord0
beta0 = ycoord0
SELECT CASE (in)
CASE (1)
write(*,*) ' beta0 outside table range !!!'
! locate position of xcoord0 with respect to x coordinates of side A
call locate(xpolygA,nxcoord,xcoord0,ii)
! find corresponding y value on side A for xcoord position
call intlin(xpolygA(ii),ypolygA(ii),xpolygA(ii+1),ypolygA(ii+1),xcoord0,ycoord0)
incheck = 1
CASE (2)
write(*,*) ' alpha0 and beta0 outside table range !!!'
! xcoord0, ycoord0 set
xcoord0 = xvert(2)
ycoord0 = yvert(2)
ii = nxcoord !indice per assegnare valori waist, rci, phi
CASE (3)
write(*,*) ' alpha0 outside table range !!!'
call locate(ypolygB,nycoord,ycoord0,ii)
call intlin(ypolygB(ii),xpolygB(ii),ypolygB(ii+1),xpolygB(ii+1),ycoord0,xcoord0)
incheck = 1
CASE (4)
write(*,*) ' alpha0 and beta0 outside table range !!!'
xcoord0 = xvert(3)
ycoord0 = yvert(3)
ii = nxcoord+nycoord-1
CASE (5)
write(*,*) ' beta0 outside table range !!!'
call locate(xpolygC,nxcoord,xcoord0,ii)
call intlin(xpolygC(ii+1),ypolygC(ii+1),xpolygC(ii),ypolygC(ii),xcoord0,ycoord0)
incheck = 1
CASE (6)
write(*,*) ' alpha0 and beta0 outside table range !!!'
xcoord0 = xvert(4)
ycoord0 = yvert(4)
ii = 2*nxcoord+nycoord-2
CASE (7)
write(*,*) ' alpha0 outside table range !!!'
call locate(ypolygD,nycoord,ycoord0,ii)
call intlin(ypolygD(ii),xpolygD(ii),ypolygD(ii+1),xpolygD(ii+1),ycoord0,xcoord0)
incheck = 1
CASE (8)
write(*,*) ' alpha0 and beta0 outside table range !!!!'
xcoord0 = xvert(1)
ycoord0 = yvert(1)
ii = 1
END SELECT
! c----------------------------------------------------------------------------------
!
deallocate(xpolygA, ypolygA, xpolygC, ypolygC, xpolygB, ypolygB, xpolygD, ypolygD)
end if
! c====================================================================================
!
! c====================================================================================
if(incheck.eq.1) then
lwrk = 2*(kx+ky+2)
kwrk = 4
allocate(wrk(lwrk),iwrk(kwrk))
call bispev(txwaist1,nxwaist1,tywaist1,nywaist1,cwaist1, &
kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier)
wcsi=fi(1)
call bispev(txwaist2,nxwaist2,tywaist2,nywaist2,cwaist2, &
kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier)
weta=fi(1)
call bispev(txrci1,nxrci1,tyrci1,nyrci1,crci1, &
kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier)
rcicsi=fi(1)
call bispev(txrci2,nxrci2,tyrci2,nyrci2,crci2, &
kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier)
rcieta=fi(1)
call bispev(txphi1,nxphi1,typhi1,nyphi1,cphi1, &
kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier)
phiw=fi(1)
call bispev(txphi2,nxphi2,typhi2,nyphi2,cphi2, &
kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier)
phir=fi(1)
call bispev(txx0,nxx0,tyx0,nyx0,cx0, &
kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier)
x00=fi(1)
call bispev(txy0,nxy0,tyy0,nyy0,cy0, &
kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier)
y00=fi(1)
call bispev(txz0,nxz0,tyz0,nyz0,cz0, &
kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier)
z00=fi(1)
deallocate(wrk,iwrk)
! c----------------------------------------------------------------------------------
else
! c----------------------------------------------------------------------------------
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
! c====================================================================================
end if
!#######################################################################################
!
if(fdeg.ne.0) then
deallocate(cycoord, txycoord, cwaist1, txwaist1, cwaist2, &
txwaist2, crci1, txrci1, crci2, txrci2, cphi1, txphi1, &
cphi2, txphi2, cx0, txx0, cy0, txy0, cz0, txz0, w)
else
deallocate(cwaist1, txwaist1, tywaist1, cwaist2, txwaist2, tywaist2, &
crci1, txrci1, tyrci1, crci2, txrci2, tyrci2, &
cphi1, txphi1, typhi1, cphi2, txphi2, typhi2, &
cx0, txx0, tyx0, cy0, txy0, tyy0, cz0, txz0, tyz0, &
wrk2, xpolyg, ypolyg, w)
end if
!
!#######################################################################################
! set correct values for alpha, beta
if(fdeg.eq.2) then
alpha0 = ycoord0
beta0 = xcoord0
else
alpha0 = xcoord0
beta0 = ycoord0
end if
!#######################################################################################
deallocate(alphastv,betastv,waist1v,waist2v,rci1v,rci2v,phi1v, &
phi2v,x00v,y00v,z00v,xcoord,ycoord)
!
end subroutine read_beam2
subroutine launchangles2n(alpha,beta,xv,anv)
use const_and_precisions, only : degree
implicit none
! arguments
real(wp_), intent(in) :: alpha,beta,xv(3)
real(wp_), intent(out) :: anv(3)
! local variables
real(wp_) :: r,anr,anphi,a,b
r=sqrt(xv(1)**2+xv(2)**2)
! phi=atan2(y,x)
print'(a,2f8.3)','alpha0, beta0 = ',alpha,beta
print'(a,4f8.3)','x00, y00, R00, z00 = ',xv(1:2),r,xv(3)
print*,' '
a = degree*alpha
b = degree*beta
!
! angles alpha, beta in a local reference system as proposed by Gribov et al
!
anr = -cos(b)*cos(a)
anphi = sin(b)
! anx = -cos(b)*cos(a)
! any = sin(b)
anv(1) = (anr*xv(1) - anphi*xv(2))/r ! = anx
anv(2) = (anr*xv(2) + anphi*xv(1))/r ! = any
! anr = (anx*xv(1) + any*xv(2))/r
! anphi = (any*xv(1) - anx*xv(2))/r
anv(3) =-cos(b)*sin(a) ! = anz
end subroutine launchangles2n
subroutine xgygcoeff(fghz,ak0,bres,xgcn)
use const_and_precisions, only : qe=>ecgs_,me=>mecgs_,vc=>ccgs_,pi,wce1_
implicit none
! arguments
real(wp_), intent(in) :: fghz
real(wp_), intent(out) :: ak0,bres,xgcn
! local variables
real(wp_) :: omega
omega=2.0e9_wp_*pi*fghz ! [rad/s]
ak0=omega/vc ! [rad/cm]
!
! yg=btot/bres
!
bres=omega/wce1_ ! [T]
!
! xg=xgcn*dens19
!
xgcn=4.0e13_wp_*pi*qe**2/(me*omega**2) ! [10^-19 m^3]
end subroutine xgygcoeff
end module beams

853
src/conical.f90 Normal file
View File

@ -0,0 +1,853 @@
module conical
use const_and_precisions, only : wp_
implicit none
contains
function fconic(x,tau,m)
!
! this function subprogram computes the conical functions of the
! first kind P sub(-1/2 + i*tau) (x) for m = 0 and m = 1.
! Ref. in Kolbig, Comp. Phys. Commun. 23 (1981) 51
!
implicit none
real(wp_), intent(in) :: x, tau
integer, intent(in) :: m
real(wp_) :: fconic
real(wp_) :: t(7),h(9),v(11)
real(wp_) :: aa,a0,a1,a2,a3,a4,a5,a6,b0,b1,fm,fn,fn1,r1,r2,s,s0,s1
real(wp_) :: x1,y,y2,y3,z
integer :: jp,j,n
real(wp_), parameter :: rpi=1.7724538509055_wp_,pi2=0.63661977236758_wp_
real(wp_), parameter :: eps=1.0e-14_wp_
integer, parameter :: nout=2,nmax=200
!
complex(wp_) a,b,c,ti,r,rr,q,u,u0,u1,u2,uu
complex(wp_) v0,v1,v2,vv,w(19)
!
logical lm0,lm1,lta
fconic=0.0_wp_
lm0=m == 0
lm1=m == 1
if(.not.(lm0 .or. lm1)) then
write(nout,"(1x,'fconic ... illegal value for m = ',i4)") m
return
end if
fm=m
fconic=1.0_wp_-fm
if(x == 1.0_wp_) return
!
fconic=0.0_wp_
if(tau == 0.0_wp_ .and. abs(x-1.0_wp_) > 0.01_wp_) then
if(x > 1.0_wp_) then
y=sqrt((x-1.0_wp_)/(x+1.0_wp_))
z=ellick(y)
s=sqrt(0.5_wp_*(x+1.0_wp_))
if(lm0) fconic=pi2*z/s
if(lm1) fconic=pi2*s*(ellice(y)-z)/sqrt(x**2-1.0_wp_)
return
else
y=sqrt(0.5_wp_*(1.0_wp_-x))
z=ellick(y)
if(lm0) fconic=pi2*z
if(lm1) fconic=pi2*(ellice(y)-0.5_wp_*(1.0_wp_+x)*z)/ &
sqrt(1.0_wp_-x**2)
return
end if
else
ti=cmplx(0._wp_,tau,wp_)
!
if((-1._wp_ < x .and. x <= 0.0_wp_).or. &
(0.0_wp_ < x .and. x <= 0.1_wp_ .and.tau<= 17.0_wp_).or. &
(0.1_wp_ < x .and. x <= 0.2_wp_ .and.tau<= 5.0_wp_)) then
lta=tau <= 10.0_wp_
x1=x**2
a=0.5_wp_*(0.5_wp_-fm-ti)
b=0.5_wp_*(0.5_wp_-fm+ti)
c=0.5_wp_
jp=30
else if((0.1_wp_ < x .and. x <= 0.2_wp_ .and.tau<= 17.0_wp_) &
.or.(0.2_wp_ < x .and. x <= 1.5_wp_ .and.tau<= 20.0_wp_)) &
then
lta=x > 1.0_wp_ .or. x <= 1.0_wp_ .and. tau <= 5.0_wp_
x1=(1.0_wp_-x)/2._wp_
a=0.5_wp_+fm-ti
b=0.5_wp_+fm+ti
c=fm+1.0_wp_
jp=32
else if(1.5_wp_ < x .and. tau <= max(20.0_wp_,x)) then
lta=.true.
x1=1.0_wp_/x**2
u=exp((-0.5_wp_+ti)*log(2.0_wp_*x)+clogam(1.0_wp_+ti) &
-clogam(1.5_wp_-fm+ti))
a=0.5_wp_*(0.5_wp_-fm-ti)
b=0.5_wp_*(1.5_wp_-fm-ti)
c=1.0_wp_-ti
jp=33
else
if(x > 1.0_wp_) then
s=sqrt(x**2-1.0_wp_)
t(1)=log(x+s)
h(1)=tau*t(1)
b0=besj0l(h(1))
b1=besj1l(h(1))
z=1.0_wp_
else
s=sqrt(1.0_wp_-x**2)
t(1)=acos(x)
h(1)=tau*t(1)
b0=besi0(h(1))
b1=besi1(h(1))
z=-1.0_wp_
end if
h(1)=t(1)*x/s
v(1)=tau
do j = 2,7
t(j)=t(j-1)*t(1)
h(j)=h(j-1)*h(1)
end do
do j = 2,11
v(j)=v(j-1)*v(1)
end do
!
if(lm1) then
aa=-1.0_wp_
a0=3.0_wp_*(1.0_wp_-h(1))/(8.0_wp_*t(1))
a1=(-15.0_wp_*h(2)+6.0_wp_*h(1)+9.0_wp_+z*8.0_wp_*t(2))/ &
(128.0_wp_*t(2))
a2=3.0_wp_*(-35.0_wp_*h(3)-15.0_wp_*h(2)+15.0_wp_*h(1)+35.0_wp_ &
+z*t(2)*(32.0_wp_*h(1)+8.0_wp_))/(1024.0_wp_*t(3))
a3=(-4725.0_wp_*h(4)-6300.0_wp_*h(3)-3150.0_wp_*h(2)+3780.0_wp_*h(1) &
+10395.0_wp_-1216.0_wp_*t(4)+z*t(2)*(6000.0_wp_*h(2) &
+5760.0_wp_*h(1)+1680.0_wp_)) /(32768.0_wp_*t(4))
a4=7.0_wp_*(-10395.0_wp_*h(5)-23625.0_wp_*h(4)-28350.0_wp_*h(3) &
-14850.0_wp_*h(2)+19305.0_wp_*h(1)+57915.0_wp_ &
-t(4)*(6336.0_wp_*h(1)+6080.0_wp_)+z*t(2)*(16800.0_wp_*h(3) &
+30000.0_wp_*h(2)+25920.0_wp_*h(1)+7920.0_wp_))/ &
(262144.0_wp_*t(5))
a5=(-2837835.0_wp_*h(6)-9168390.0_wp_*h(5)-16372125.0_wp_*h(4) &
-18918900*h(3) -10135125.0_wp_*h(2)+13783770.0_wp_*h(1) &
+43648605.0_wp_-t(4)*(3044160.0_wp_*h(2)+5588352.0_wp_*h(1) &
+4213440.0_wp_)+z*t(2)*(5556600.0_wp_*h(4)+14817600.0_wp_*h(3) &
+20790000.0_wp_*h(2)+17297280.0_wp_*h(1)+5405400.0_wp_ &
+323072.0_wp_*t(4)))/ (4194304.0_wp_*t(6))
a6=0.0_wp_
else
aa=0.0_wp_
a0=1.0_wp_
a1=(h(1)-1.0_wp_)/(8.0_wp_*t(1))
a2=(9.0_wp_*h(2)+6.0_wp_*h(1)-15.0_wp_-z*8.0_wp_*t(2))/ &
(128.0_wp_*t(2))
a3=5.0_wp_*(15.0_wp_*h(3)+27.0_wp_*h(2)+21.0_wp_*h(1)-63.0_wp_ &
-z*t(2)*(16.0_wp_*h(1)+24.0_wp_))/(1024.0_wp_*t(3))
a4=7.0_wp_*(525.0_wp_*h(4)+1500.0_wp_*h(3)+2430.0_wp_*h(2) &
+1980.0_wp_*h(1)-6435.0_wp_+192.0_wp_*t(4)-z*t(2)* &
(720.0_wp_*h(2)+1600.0_wp_*h(1)+2160.0_wp_))/(32768.0_wp_*t(4))
a5=21.0_wp_*(2835.0_wp_*h(5)+11025.0_wp_*h(4)+24750.0_wp_*h(3) &
+38610.0_wp_*h(2)+32175.0_wp_*h(1)-109395.0_wp_+t(4) &
*(1984.0_wp_*h(1)+4032.0_wp_)-z*t(2) &
*(4800.0_wp_*h(3)+15120.0_wp_*h(2)+26400.0_wp_*h(1)+34320.0_wp_)) &
/(262144.0_wp_*t(5))
a6=11.0_wp_*(218295.0_wp_*h(6)+1071630.0_wp_*h(5)+3009825.0_wp_*h(4) &
+6142500.0_wp_*h(3)+9398025.0_wp_*h(2)+7936110.0_wp_*h(1) &
-27776385.0_wp_+t(4)*(254016.0_wp_*h(2) &
+749952.0_wp_*h(1)+1100736.0_wp_)-z*t(2)*(441000.0_wp_*h(4) &
+1814400.0_wp_*h(3)+4127760.0_wp_*h(2)+6552000.0_wp_*h(1) &
+8353800.0_wp_+31232.0_wp_*t(4)))/(4194304.0_wp_*t(6))
end if
s0=a0+(-4.0_wp_*a3/t(1)+a4)/v(4)+(-192.0_wp_*a5/t(3) &
+144.0_wp_*a6/t(2))/v(8)+z*(-a2/v(2)+(-24.0_wp_*a4/t(2) &
+12.0_wp_*a5/t(1)-a6)/v(6)+(-1920.0_wp_*a6/t(4))/v(10))
s1=a1/v(1)+(8.0_wp_*(a3/t(2)-a4/t(1))+a5)/v(5)+(384.0_wp_*a5/t(4) &
-768.0_wp_*a6/t(3))/v(9)+z*(aa*v(1)+(2.0_wp_*a2/t(1)-a3)/v(3) &
+(48.0_wp_*a4/t(3)-72.0_wp_*a5/t(2) &
+18.0_wp_*a6/t(1))/v(7)+(3840.0_wp_*a6/t(5))/v(11))
fconic=sqrt(t(1)/s)*(b0*s0+b1*s1)
return
end if
!
do
if(lta) then
y=-x1
y2=y**2
y3=y**3
w(1)=a+1.0_wp_
w(2)=a+2.0_wp_
w(3)=b+1.0_wp_
w(4)=b+2.0_wp_
w(5)=c+1.0_wp_
w(6)=c*w(5)
w(7)=a+b
w(8)=a*b
w(9)=(w(8)/c)*y
w(10)=w(1)*w(3)
w(11)=w(2)*w(4)
w(12)=1.0_wp_+(w(11)/(2.0_wp_*w(5)))*y
w(13)=w(7)-6.0_wp_
w(14)=w(7)+6.0_wp_
w(15)=2.0_wp_-w(8)
w(16)=w(15)-2.0_wp_*w(7)
!
v0=1.0_wp_
v1=1.0_wp_+(w(10)/(2.0_wp_*c))*y
v2=w(12)+(w(10)*w(11)/(12.0_wp_*w(6)))*y2
u0=1.0_wp_
u1=v1-w(9)
u2=v2-w(9)*w(12)+(w(8)*w(10)/(2.0_wp_*w(6)))*y2
!
r=1.0_wp_
n=2
do
n=n+1
if(n > nmax) then
write(nout,200) x,tau,m
return
end if
rr=r
fn=n
h(1)=fn-1.0_wp_
h(2)=fn-2.0_wp_
h(3)=fn-3.0_wp_
h(4)=2.0_wp_*fn
h(5)=h(4)-3.0_wp_
h(6)=2.0_wp_*h(5)
h(7)=4.0_wp_*(h(4)-1.0_wp_)*h(5)
h(8)=8.0_wp_*h(5)**2*(h(4)-5.0_wp_)
h(9)=3.0_wp_*fn**2
w(1)=a+h(1)
w(2)=a+h(2)
w(3)=b+h(1)
w(4)=b+h(2)
w(5)=c+h(1)
w(6)=c+h(2)
w(7)=c+h(3)
w(8)=h(2)-a
w(9)=h(2)-b
w(10)=h(1)-c
w(11)=w(1)*w(3)
w(12)=w(5)*w(6)
!
w(17)=1.0_wp_+((h(9)+w(13)*fn+w(16))/(h(6)*w(5)))*y
w(18)=-((w(11)*w(10)/h(6)+(h(9)-w(14)*fn+w(15))* &
w(11)*y/h(7))/w(12))*y
w(19)=(w(2)*w(11)*w(4)*w(8)*w(9)/(h(8)*w(7)*w(12)))*y3
vv=w(17)*v2+w(18)*v1+w(19)*v0
uu=w(17)*u2+w(18)*u1+w(19)*u0
r=uu/vv
if(abs(r-rr) < eps) exit
v0=v1
v1=v2
v2=vv
u0=u1
u1=u2
u2=uu
end do
else
r=1.0_wp_
q=1.0_wp_
do n = 1,nmax
fn=n
fn1=fn-1.0_wp_
rr=r
q=q*x1*(a+fn1)*(b+fn1)/((c+fn1)*fn)
r=r+q
if(abs(r-rr) < eps) exit
end do
if (n > nmax) then
write(nout,200) x,tau,m
return
end if
end if
if (jp/=30) exit
r1=real(r)/abs(exp(clogam(a+0.5_wp_)))**2
a=0.5_wp_*(1.5_wp_-fm-ti)
b=0.5_wp_*(1.5_wp_-fm+ti)
c=1.5_wp_
jp=31
end do
if (jp==31) then
r2=real(r)/abs(exp(clogam(a-0.5_wp_)))**2
fconic=rpi*(r1-2.0_wp_*x*r2)
if(lm1) fconic=(2.0_wp_/sqrt(1.0_wp_-x1))*fconic
return
else if (jp==32) then
fconic=real(r)
if(.not.lm0) then
fconic=0.5_wp_*(tau**2+0.25_wp_)*sqrt(abs(x**2-1.0_wp_))*fconic
if(x > 1.0_wp_) fconic=-fconic
end if
return
else if (jp==33) then
fconic=2.0_wp_*real(u*r*(0.5_wp_-fm+ti)/ti)/rpi
if(lm1) fconic=fconic/sqrt(1.0_wp_-x1)
return
end if
end if
!
200 format(1x,'fconic ... convergence difficulties for c function, x = ', &
e12.4,5x,'tau = ',e12.4,5x,'m = ',i5)
!
end function fconic
function clogam(z)
!
implicit none
complex(wp_) :: clogam
complex(wp_), intent(in) :: z
complex(wp_) :: v,h,r
integer :: i,n
real(wp_) :: x,t,a,c,d,e,f
integer, parameter :: nout=2
real(wp_), parameter :: pi=3.1415926535898_wp_
real(wp_), dimension(10), parameter :: b= &
(/+8.3333333333333e-2_wp_, -2.7777777777778e-3_wp_, &
+7.9365079365079e-4_wp_, -5.9523809523810e-4_wp_, &
+8.4175084175084e-4_wp_, -1.9175269175269e-3_wp_, &
+6.4102564102564e-3_wp_, -2.9550653594771e-2_wp_, &
+1.7964437236883e-1_wp_, -1.3924322169059e+0_wp_/)
!
x=real(z)
t=aimag(z)
if(-abs(x) == aint(x) .and. t == 0.0_wp_) then
write(nout,'(1x,f20.2)') x
clogam=(0.0_wp_,0.0_wp_)
return
end if
f=abs(t)
v=cmplx(x,f,wp_)
if(x < 0.0_wp_) v=1.0_wp_-v
h=(0.0_wp_,0.0_wp_)
c=real(v)
if(c < 7.0_wp_) then
n=6-int(c)
h=v
d=aimag(v)
a=atan2(d,c)
do i = 1,n
c=c+1.0_wp_
v=cmplx(c,d,wp_)
h=h*v
a=a+atan2(d,c)
end do
h=cmplx(0.5_wp_*log(real(h)**2+aimag(h)**2),a,wp_)
v=v+1.0_wp_
end if
r=1.0_wp_/v**2
clogam=0.91893853320467_wp_+(v-0.5_wp_)*log(v)-v+(b(1)+r*(b(2)+r*(b(3) &
+r*(b(4)+r*(b(5)+r*(b(6)+r*(b(7)+r*(b(8)+r*(b(9)+r*b(10)))))))))) &
/v-h
if(x < 0.0_wp_) then
!
a=aint(x)-1.0_wp_
c=pi*(x-a)
d=pi*f
e=exp(-2.0_wp_*d)
f=sin(c)
e=d+0.5_wp_*log(e*f**2+0.25_wp_*(1.0_wp_-e)**2)
f=atan2(cos(c)*tanh(d),f)-a*pi
clogam=1.1447298858494_wp_-cmplx(e,f,wp_)-clogam
!
end if
if(t < 0.0_wp_) clogam=conjg(clogam)
!
end function clogam
function ellick(xk)
implicit none
real(wp_), intent(in) :: xk
real(wp_) :: ellick, ellice
integer :: i
real(wp_) :: eta,pa,pb,pc,pd
real(wp_), dimension(10), parameter :: &
a=(/9.6573590280856e-2_wp_, 3.0885146271305e-2_wp_, &
1.4938013532687e-2_wp_, 8.7898018745551e-3_wp_, &
6.1796274460533e-3_wp_, 6.8479092826245e-3_wp_, &
9.8489293221769e-3_wp_, 8.0030039806500e-3_wp_, &
2.2966348983970e-3_wp_, 1.3930878570066e-4_wp_/), &
b=(/1.2499999999991e-1_wp_, 7.0312499739038e-2_wp_, &
4.8828041906862e-2_wp_, 3.7377739758624e-2_wp_, &
3.0124849012899e-2_wp_, 2.3931913323111e-2_wp_, &
1.5530941631977e-2_wp_, 5.9739042991554e-3_wp_, &
9.2155463496325e-4_wp_, 2.9700280966556e-5_wp_/), &
c=(/4.4314718056089e-1_wp_, 5.6805194567559e-2_wp_, &
2.1831811676130e-2_wp_, 1.1569595745295e-2_wp_, &
7.5950934225594e-3_wp_, 7.8204040609596e-3_wp_, &
1.0770635039866e-2_wp_, 8.6384421736041e-3_wp_, &
2.4685033304607e-3_wp_, 1.4946621757181e-4_wp_/), &
d=(/2.4999999999990e-1_wp_, 9.3749999721203e-2_wp_, &
5.8593661255531e-2_wp_, 4.2717890547383e-2_wp_, &
3.3478943665762e-2_wp_, 2.6145014700314e-2_wp_, &
1.6804023346363e-2_wp_, 6.4321465864383e-3_wp_, &
9.8983328462254e-4_wp_, 3.1859195655502e-5_wp_/)
!
if(abs(xk) >= 1.0_wp_) then
ellick=0.0_wp_
return
end if
eta=1.0_wp_-xk**2
pa=a(10)
do i = 1,9
pa=pa*eta+a(10-i)
end do
pa=pa*eta
pb=b(10)
do i = 1,9
pb=pb*eta+b(10-i)
end do
pb=pb*eta
ellick=1.3862943611199_wp_+pa-log(eta)*(0.5_wp_+pb)
return
!
entry ellice(xk)
!
if (abs(xk) >= 1.0_wp_) then
if (abs(xk) > 1.0_wp_) then
ellick=0.0_wp_
else
ellick=1.0_wp_
end if
return
end if
eta=1.0_wp_-xk**2
pc=c(10)
do i = 1,9
pc=pc*eta+c(10-i)
end do
pc=pc*eta
pd=d(10)
do i = 1,9
pd=pd*eta+d(10-i)
end do
pd=pd*eta
ellick=1.0_wp_+pc-log(eta)*pd
end function ellick
function besjy(x)
implicit none
real(wp_), intent(in) :: x
real(wp_) :: besjy,besj0l,besj1l
real(wp_) :: besy0,besy1
logical :: l
real(wp_) :: v,f,a,b,p,q
integer, parameter :: nout=2
!
entry besj0l(x)
!
l=.true.
v=abs(x)
if(v >= 8.0_wp_) go to 4
8 f=0.0625_wp_*x**2-2.0_wp_
a = - 0.0000000000000008_wp_
b = f * a + 0.0000000000000413_wp_
a = f * b - a - 0.0000000000019438_wp_
b = f * a - b + 0.0000000000784870_wp_
a = f * b - a - 0.0000000026792535_wp_
b = f * a - b + 0.0000000760816359_wp_
a = f * b - a - 0.0000017619469078_wp_
b = f * a - b + 0.0000324603288210_wp_
a = f * b - a - 0.0004606261662063_wp_
b = f * a - b + 0.0048191800694676_wp_
a = f * b - a - 0.0348937694114089_wp_
b = f * a - b + 0.1580671023320973_wp_
a = f * b - a - 0.3700949938726498_wp_
b = f * a - b + 0.2651786132033368_wp_
a = f * b - a - 0.0087234423528522_wp_
a = f * a - b + 0.3154559429497802_wp_
besjy=0.5_wp_*(a-b)
if(l) return
!
a = + 0.0000000000000016_wp_
b = f * a - 0.0000000000000875_wp_
a = f * b - a + 0.0000000000040263_wp_
b = f * a - b - 0.0000000001583755_wp_
a = f * b - a + 0.0000000052487948_wp_
b = f * a - b - 0.0000001440723327_wp_
a = f * b - a + 0.0000032065325377_wp_
b = f * a - b - 0.0000563207914106_wp_
a = f * b - a + 0.0007531135932578_wp_
b = f * a - b - 0.0072879624795521_wp_
a = f * b - a + 0.0471966895957634_wp_
b = f * a - b - 0.1773020127811436_wp_
a = f * b - a + 0.2615673462550466_wp_
b = f * a - b + 0.1790343140771827_wp_
a = f * b - a - 0.2744743055297453_wp_
a = f * a - b - 0.0662922264065699_wp_
besjy=0.636619772367581_wp_*log(x)*besjy+0.5_wp_*(a-b)
return
!
4 f=256.0_wp_/x**2-2.0_wp_
b = + 0.0000000000000007_wp_
a = f * b - 0.0000000000000051_wp_
b = f * a - b + 0.0000000000000433_wp_
a = f * b - a - 0.0000000000004305_wp_
b = f * a - b + 0.0000000000051683_wp_
a = f * b - a - 0.0000000000786409_wp_
b = f * a - b + 0.0000000016306465_wp_
a = f * b - a - 0.0000000517059454_wp_
b = f * a - b + 0.0000030751847875_wp_
a = f * b - a - 0.0005365220468132_wp_
a = f * a - b + 1.9989206986950373_wp_
p=a-b
b = - 0.0000000000000006_wp_
a = f * b + 0.0000000000000043_wp_
b = f * a - b - 0.0000000000000334_wp_
a = f * b - a + 0.0000000000003006_wp_
b = f * a - b - 0.0000000000032067_wp_
a = f * b - a + 0.0000000000422012_wp_
b = f * a - b - 0.0000000007271916_wp_
a = f * b - a + 0.0000000179724572_wp_
b = f * a - b - 0.0000007414498411_wp_
a = f * b - a + 0.0000683851994261_wp_
a = f * a - b - 0.0311117092106740_wp_
q=8.0_wp_*(a-b)/v
f=v-0.785398163397448_wp_
a=cos(f)
b=sin(f)
f=0.398942280401432_wp_/sqrt(v)
if(l) go to 6
besjy=f*(q*a+p*b)
return
6 besjy=f*(p*a-q*b)
return
!
entry besj1l(x)
!
l=.true.
v=abs(x)
if(v >= 8.0_wp_) go to 5
3 f=0.0625_wp_*x**2-2.0_wp_
b = + 0.0000000000000114_wp_
a = f * b - 0.0000000000005777_wp_
b = f * a - b + 0.0000000000252812_wp_
a = f * b - a - 0.0000000009424213_wp_
b = f * a - b + 0.0000000294970701_wp_
a = f * b - a - 0.0000007617587805_wp_
b = f * a - b + 0.0000158870192399_wp_
a = f * b - a - 0.0002604443893486_wp_
b = f * a - b + 0.0032402701826839_wp_
a = f * b - a - 0.0291755248061542_wp_
b = f * a - b + 0.1777091172397283_wp_
a = f * b - a - 0.6614439341345433_wp_
b = f * a - b + 1.2879940988576776_wp_
a = f * b - a - 1.1918011605412169_wp_
a = f * a - b + 1.2967175412105298_wp_
besjy=0.0625_wp_*(a-b)*x
if(l) return
!
b = - 0.0000000000000244_wp_
a = f * b + 0.0000000000012114_wp_
b = f * a - b - 0.0000000000517212_wp_
a = f * b - a + 0.0000000018754703_wp_
b = f * a - b - 0.0000000568844004_wp_
a = f * b - a + 0.0000014166243645_wp_
b = f * a - b - 0.0000283046401495_wp_
a = f * b - a + 0.0004404786298671_wp_
b = f * a - b - 0.0051316411610611_wp_
a = f * b - a + 0.0423191803533369_wp_
b = f * a - b - 0.2266249915567549_wp_
a = f * b - a + 0.6756157807721877_wp_
b = f * a - b - 0.7672963628866459_wp_
a = f * b - a - 0.1286973843813500_wp_
a = f * a - b + 0.0406082117718685_wp_
besjy=0.636619772367581_wp_*log(x)*besjy-0.636619772367581_wp_/x &
+0.0625_wp_*(a-b)*x
return
!
5 f=256.0_wp_/x**2-2.0_wp_
b = - 0.0000000000000007_wp_
a = f * b + 0.0000000000000055_wp_
b = f * a - b - 0.0000000000000468_wp_
a = f * b - a + 0.0000000000004699_wp_
b = f * a - b - 0.0000000000057049_wp_
a = f * b - a + 0.0000000000881690_wp_
b = f * a - b - 0.0000000018718907_wp_
a = f * b - a + 0.0000000617763396_wp_
b = f * a - b - 0.0000039872843005_wp_
a = f * b - a + 0.0008989898330859_wp_
a = f * a - b + 2.0018060817200274_wp_
p=a-b
b = + 0.0000000000000007_wp_
a = f * b - 0.0000000000000046_wp_
b = f * a - b + 0.0000000000000360_wp_
a = f * b - a - 0.0000000000003264_wp_
b = f * a - b + 0.0000000000035152_wp_
a = f * b - a - 0.0000000000468636_wp_
b = f * a - b + 0.0000000008229193_wp_
a = f * b - a - 0.0000000209597814_wp_
b = f * a - b + 0.0000009138615258_wp_
a = f * b - a - 0.0000962772354916_wp_
a = f * a - b + 0.0935555741390707_wp_
q=8.0_wp_*(a-b)/v
f=v-2.356194490192345_wp_
a=cos(f)
b=sin(f)
f=0.398942280401432_wp_/sqrt(v)
if(l) go to 7
besjy=f*(q*a+p*b)
return
7 besjy=f*(p*a-q*b)
if(x < 0.0_wp_) besjy=-besjy
return
!
entry besy0(x)
!
if(x <= 0.0_wp_) go to 9
l=.false.
v=x
if(v >= 8.0_wp_) go to 4
go to 8
entry besy1(x)
!
if(x <= 0.0_wp_) go to 9
l=.false.
v=x
if(v >= 8.0_wp_) go to 5
go to 3
!
9 besjy=0.0_wp_
write(nout,"(1x,'besjy ... non-positive argument x = ',e15.4)") x
end function besjy
function besik(x)
implicit none
real(wp_), intent(in) :: x
real(wp_) :: besik,ebesi0,besi0,ebesi1,besi1,ebesk0,besk0,ebesk1,besk1
logical :: l,e
real(wp_) :: v,f,a,b,z
integer, parameter :: nout=2
!
entry ebesi0(x)
!
e=.true.
go to 1
!
entry besi0(x)
!
e=.false.
1 l=.true.
v=abs(x)
if(v >= 8.0_wp_) go to 4
8 f=0.0625_wp_*x**2-2.0_wp_
a = 0.000000000000002_wp_
b = f * a + 0.000000000000120_wp_
a = f * b - a + 0.000000000006097_wp_
b = f * a - b + 0.000000000268828_wp_
a = f * b - a + 0.000000010169727_wp_
b = f * a - b + 0.000000326091051_wp_
a = f * b - a + 0.000008738315497_wp_
b = f * a - b + 0.000192469359688_wp_
a = f * b - a + 0.003416331766012_wp_
b = f * a - b + 0.047718748798174_wp_
a = f * b - a + 0.509493365439983_wp_
b = f * a - b + 4.011673760179349_wp_
a = f * b - a + 22.274819242462231_wp_
b = f * a - b + 82.489032744024100_wp_
a = f * b - a + 190.494320172742844_wp_
a = f * a - b + 255.466879624362167_wp_
besik=0.5_wp_*(a-b)
if(l .and. e) besik=exp(-v)*besik
if(l) return
!
a = + 0.000000000000003_wp_
b = f * a + 0.000000000000159_wp_
a = f * b - a + 0.000000000007658_wp_
b = f * a - b + 0.000000000318588_wp_
a = f * b - a + 0.000000011281211_wp_
b = f * a - b + 0.000000335195256_wp_
a = f * b - a + 0.000008216025940_wp_
b = f * a - b + 0.000162708379043_wp_
a = f * b - a + 0.002536308188086_wp_
b = f * a - b + 0.030080722420512_wp_
a = f * b - a + 0.259084432434900_wp_
b = f * a - b + 1.511535676029228_wp_
a = f * b - a + 5.283632866873920_wp_
b = f * a - b + 8.005368868700334_wp_
a = f * b - a - 4.563433586448395_wp_
a = f * a - b - 21.057660177402440_wp_
besik=-log(0.125_wp_*x)*besik+0.5_wp_*(a-b)
if(e) besik=exp(x)*besik
return
!
4 f=32.0_wp_/v-2.0_wp_
b = - 0.000000000000001_wp_
a = f * b - 0.000000000000001_wp_
b = f * a - b + 0.000000000000004_wp_
a = f * b - a + 0.000000000000010_wp_
b = f * a - b - 0.000000000000024_wp_
a = f * b - a - 0.000000000000104_wp_
b = f * a - b + 0.000000000000039_wp_
a = f * b - a + 0.000000000000966_wp_
b = f * a - b + 0.000000000001800_wp_
a = f * b - a - 0.000000000004497_wp_
b = f * a - b - 0.000000000033127_wp_
a = f * b - a - 0.000000000078957_wp_
b = f * a - b + 0.000000000029802_wp_
a = f * b - a + 0.000000001238425_wp_
b = f * a - b + 0.000000008513091_wp_
a = f * b - a + 0.000000056816966_wp_
b = f * a - b + 0.000000513587727_wp_
a = f * b - a + 0.000007247591100_wp_
b = f * a - b + 0.000172700630778_wp_
a = f * b - a + 0.008445122624921_wp_
a = f * a - b + 2.016558410917480_wp_
besik=0.199471140200717_wp_*(a-b)/sqrt(v)
if(e) return
besik=exp(v)*besik
return
!
entry ebesi1(x)
!
e=.true.
go to 2
!
entry besi1(x)
!
e=.false.
2 l=.true.
v=abs(x)
if(v >= 8.0_wp_) go to 3
7 f=0.0625_wp_*x**2-2.0_wp_
a = + 0.000000000000001_wp_
b = f * a + 0.000000000000031_wp_
a = f * b - a + 0.000000000001679_wp_
b = f * a - b + 0.000000000079291_wp_
a = f * b - a + 0.000000003227617_wp_
b = f * a - b + 0.000000111946285_wp_
a = f * b - a + 0.000003264138122_wp_
b = f * a - b + 0.000078756785754_wp_
a = f * b - a + 0.001543019015627_wp_
b = f * a - b + 0.023993079147841_wp_
a = f * b - a + 0.287855511804672_wp_
b = f * a - b + 2.571459906347755_wp_
a = f * b - a + 16.334550552522066_wp_
b = f * a - b + 69.395917633734448_wp_
a = f * b - a + 181.312616040570265_wp_
a = f * a - b + 259.890237806477292_wp_
besik=0.0625_wp_*(a-b)*x
if(l .and. e) besik=exp(-v)*besik
if(l) return
!
a = + 0.000000000000001_wp_
b = f * a + 0.000000000000042_wp_
a = f * b - a + 0.000000000002163_wp_
b = f * a - b + 0.000000000096660_wp_
a = f * b - a + 0.000000003696783_wp_
b = f * a - b + 0.000000119367971_wp_
a = f * b - a + 0.000003202510692_wp_
b = f * a - b + 0.000070010627855_wp_
a = f * b - a + 0.001217056994516_wp_
b = f * a - b + 0.016300049289816_wp_
a = f * b - a + 0.161074301656148_wp_
b = f * a - b + 1.101461993004852_wp_
a = f * b - a + 4.666387026862842_wp_
b = f * a - b + 9.361617831395389_wp_
a = f * b - a - 1.839239224286199_wp_
a = f * a - b - 26.688095480862668_wp_
besik=log(0.125_wp_*x)*besik+1.0_wp_/x-0.0625_wp_*(a-b)*x
if(e) besik=exp(x)*besik
return
!
3 f=32.0_wp_/v-2.0_wp_
b = + 0.000000000000001_wp_
a = f * b + 0.000000000000001_wp_
b = f * a - b - 0.000000000000005_wp_
a = f * b - a - 0.000000000000010_wp_
b = f * a - b + 0.000000000000026_wp_
a = f * b - a + 0.000000000000107_wp_
b = f * a - b - 0.000000000000053_wp_
a = f * b - a - 0.000000000001024_wp_
b = f * a - b - 0.000000000001804_wp_
a = f * b - a + 0.000000000005103_wp_
b = f * a - b + 0.000000000035408_wp_
a = f * b - a + 0.000000000081531_wp_
b = f * a - b - 0.000000000047563_wp_
a = f * b - a - 0.000000001401141_wp_
b = f * a - b - 0.000000009613873_wp_
a = f * b - a - 0.000000065961142_wp_
b = f * a - b - 0.000000629724239_wp_
a = f * b - a - 0.000009732146728_wp_
b = f * a - b - 0.000277205360764_wp_
a = f * b - a - 0.024467442963276_wp_
a = f * a - b + 1.951601204652572_wp_
besik=0.199471140200717_wp_*(a-b)/sqrt(v)
if(x < 0.0_wp_) besik=-besik
if(e) return
besik=exp(v)*besik
return
!
entry ebesk0 (x)
!
e=.true.
go to 11
!
entry besk0(x)
!
e=.false.
11 if(x <= 0.0_wp_) go to 9
l=.false.
v=x
if(x < 5.0_wp_) go to 8
f=20.0_wp_/x-2.0_wp_
a = - 0.000000000000002_wp_
b = f * a + 0.000000000000011_wp_
a = f * b - a - 0.000000000000079_wp_
b = f * a - b + 0.000000000000581_wp_
a = f * b - a - 0.000000000004580_wp_
b = f * a - b + 0.000000000039044_wp_
a = f * b - a - 0.000000000364547_wp_
b = f * a - b + 0.000000003792996_wp_
a = f * b - a - 0.000000045047338_wp_
b = f * a - b + 0.000000632575109_wp_
a = f * b - a - 0.000011106685197_wp_
b = f * a - b + 0.000269532612763_wp_
a = f * b - a - 0.011310504646928_wp_
a = f * a - b + 1.976816348461652_wp_
besik=0.626657068657750_wp_*(a-b)/sqrt(x)
if(e) return
z=besik
besik=0.0_wp_
if(x < 180.0_wp_) besik=exp(-x)*z
return
!
entry ebesk1(x)
!
e=.true.
go to 12
!
entry besk1(x)
!
e=.false.
12 if(x <= 0.0_wp_) go to 9
l=.false.
v=x
if(x < 5.0_wp_) go to 7
f=20.0_wp_/x-2.0_wp_
a = + 0.000000000000002_wp_
b = f * a - 0.000000000000013_wp_
a = f * b - a + 0.000000000000089_wp_
b = f * a - b - 0.000000000000663_wp_
a = f * b - a + 0.000000000005288_wp_
b = f * a - b - 0.000000000045757_wp_
a = f * b - a + 0.000000000435417_wp_
b = f * a - b - 0.000000004645555_wp_
a = f * b - a + 0.000000057132218_wp_
b = f * a - b - 0.000000845172048_wp_
a = f * b - a + 0.000016185063810_wp_
b = f * a - b - 0.000468475028167_wp_
a = f * b - a + 0.035465291243331_wp_
a = f * a - b + 2.071901717544716_wp_
besik=0.626657068657750_wp_*(a-b)/sqrt(x)
if(e) return
z=besik
besik=0.0_wp_
if(x < 180.0_wp_) besik=exp(-x)*z
return
9 besik=0.0_wp_
write(nout,"(1x,'besik ... non-positive argument x = ',e15.4)") x
end function besik
!
! routines for conical function: end
!
end module conical

112
src/const_and_precisions.f90
View File

@ -1,17 +1,21 @@
!########################################################################! !########################################################################!
MODULE const_and_precisions MODULE const_and_precisions
use itm_types, only : wp_ => r8
use itm_constants, only : pi => itm_pi, e_ => itm_qe, me_ => itm_me, c_ => itm_c
!########################################################################! !########################################################################!
IMPLICIT NONE IMPLICIT NONE
PUBLIC PUBLIC
!------------------------------------------------------------------------ !------------------------------------------------------------------------
! common precisions ! common precisions
!------------------------------------------------------------------------ !------------------------------------------------------------------------
! INTEGER, PARAMETER :: sp_ = 4 ! single precision ! INTEGER, PARAMETER :: i1 = SELECTED_INT_KIND (2) ! Integer*1
! INTEGER, PARAMETER :: dp_ = 8 ! double precision ! INTEGER, PARAMETER :: i2 = SELECTED_INT_KIND (4) ! Integer*2
! INTEGER, PARAMETER :: wp_ = dp_ ! work-precision INTEGER, PARAMETER :: i4 = SELECTED_INT_KIND (9) ! Integer*4
INTEGER, PARAMETER :: i8 = SELECTED_INT_KIND (18) ! Integer*8
INTEGER, PARAMETER :: r4 = SELECTED_REAL_KIND (6, 37) ! Real*4
INTEGER, PARAMETER :: r8 = SELECTED_REAL_KIND (15, 300) ! Real*8
! INTEGER, PARAMETER :: sp_ = r4 ! single precision
! INTEGER, PARAMETER :: dp_ = r8 ! double precision
INTEGER, PARAMETER :: wp_ = r8 ! work-precision
! INTEGER, PARAMETER :: odep_ = dp_ ! ODE-solver precision ! INTEGER, PARAMETER :: odep_ = dp_ ! ODE-solver precision
! INTEGER, PARAMETER :: xp_ = wp_ ! for ext. modules if necessary ! INTEGER, PARAMETER :: xp_ = wp_ ! for ext. modules if necessary
!------------------------------------------------------------------------ !------------------------------------------------------------------------
@ -26,31 +30,36 @@
!!======================================================================== !!========================================================================
! Arithmetic constants ! Arithmetic constants
!======================================================================== !========================================================================
integer, parameter :: izero = 0
REAL(wp_), PARAMETER :: zero = 0.0_wp_ REAL(wp_), PARAMETER :: zero = 0.0_wp_
REAL(wp_), PARAMETER :: unit = 1.0_wp_ REAL(wp_), PARAMETER :: half = 0.5_wp_
! REAL(wp_), PARAMETER :: pi = 3.141592653589793_wp_ REAL(wp_), PARAMETER :: one = 1.0_wp_
! REAL(wp_), PARAMETER :: sqrt_pi = 1.772453850905516_wp_ REAL(wp_), PARAMETER :: two = 2.0_wp_
real(wp_), parameter :: pi = 3.141592653589793_wp_ ! 3.141592653589793238462643383280
real(wp_), parameter :: pihalf = 1.57079632679489661923_wp_
REAL(wp_), PARAMETER :: sqrt_pi = 1.772453850905516_wp_
! REAL(wp_), PARAMETER :: sqrt_2 = 1.414213562373095_wp_ ! REAL(wp_), PARAMETER :: sqrt_2 = 1.414213562373095_wp_
! REAL(wp_), PARAMETER :: rad = pi/180.0_wp_ REAL(wp_), PARAMETER :: degree = pi/180.0_wp_
REAL(wp_), PARAMETER :: emn1 = 0.367879441171442_wp_ ! exp(-1)
!--- !---
! REAL(wp_), PARAMETER :: ex(1:3) = (/unit,zero,zero/) ! REAL(wp_), PARAMETER :: ex(1:3) = (/one ,zero,zero/)
! REAL(wp_), PARAMETER :: ey(1:3) = (/zero,unit,zero/) ! REAL(wp_), PARAMETER :: ey(1:3) = (/zero,one ,zero/)
! REAL(wp_), PARAMETER :: ez(1:3) = (/zero,zero,unit/) ! REAL(wp_), PARAMETER :: ez(1:3) = (/zero,zero,one /)
!--- !---
! REAL(wp_), PARAMETER :: kron(3,3) = reshape((/unit,zero,zero, & ! REAL(wp_), PARAMETER :: kron(3,3) = reshape((/one ,zero,zero, &
! zero,unit,zero, & ! zero,one ,zero, &
! zero,zero,unit/),(/3,3/)) ! zero,zero,one /),(/3,3/))
! COMPLEX(wp_), PARAMETER :: im = (0.0_wp_,1.0_wp_) COMPLEX(wp_), PARAMETER :: im = (0.0_wp_,1.0_wp_)
! COMPLEX(wp_), PARAMETER :: czero = (0.0_wp_,0.0_wp_) COMPLEX(wp_), PARAMETER :: czero = (0.0_wp_,0.0_wp_)
! COMPLEX(wp_), PARAMETER :: cunit = (1.0_wp_,0.0_wp_) COMPLEX(wp_), PARAMETER :: cunit = (1.0_wp_,0.0_wp_)
! COMPLEX(wp_), PARAMETER :: ctwo = (2.0_wp_,0.0_wp_) ! COMPLEX(wp_), PARAMETER :: ctwo = (2.0_wp_,0.0_wp_)
!======================================================================== !========================================================================
! Computer constants ! Computer constants
!======================================================================== !========================================================================
REAL(wp_), PARAMETER :: comp_eps = EPSILON(unit) REAL(wp_), PARAMETER :: comp_eps = EPSILON(one)
! REAL(wp_), PARAMETER :: comp_eps2 = comp_eps**2 ! REAL(wp_), PARAMETER :: comp_eps2 = comp_eps**2
! REAL(wp_), PARAMETER :: comp_tiny = TINY(unit) REAL(wp_), PARAMETER :: comp_tiny = TINY(one)
! REAL(wp_), PARAMETER :: comp_huge = HUGE(unit) REAL(wp_), PARAMETER :: comp_huge = HUGE(one)
! REAL(wp_), PARAMETER :: comp_tinylog =-200 ! LOG10(comp_tiny) ! REAL(wp_), PARAMETER :: comp_tinylog =-200 ! LOG10(comp_tiny)
! REAL(wp_), PARAMETER :: comp_hugelog =+200 ! LOG10(comp_huge) ! REAL(wp_), PARAMETER :: comp_hugelog =+200 ! LOG10(comp_huge)
! REAL(wp_), PARAMETER :: comp_tiny1 = 1d+50*comp_tiny ! REAL(wp_), PARAMETER :: comp_tiny1 = 1d+50*comp_tiny
@ -60,26 +69,42 @@
!------------------------------------------------------------------------ !------------------------------------------------------------------------
! Conventional constants ! Conventional constants
!------------------------------------------------------------------------ !------------------------------------------------------------------------
INTEGER, PARAMETER :: int_invalid = -999999999
REAL(R8), PARAMETER :: r8_invalid = -9.0e40_r8
! REAL(wp_), PARAMETER :: output_tiny = 1.0d-66 ! REAL(wp_), PARAMETER :: output_tiny = 1.0d-66
! REAL(wp_), PARAMETER :: output_huge = 1.0d+66 ! REAL(wp_), PARAMETER :: output_huge = 1.0d+66
!======================================================================== !========================================================================
! Physical constants (SI) ! Physical constants (SI)
!======================================================================== !========================================================================
! REAL(wp_), PARAMETER :: e_ = 1.602176487d-19 ! [C] real (wp_), parameter :: e_ = 1.602176487e-19_wp_ ! elementary charge, C
! REAL(wp_), PARAMETER :: me_ = 9.10938215d-31 ! [kg] real (wp_), parameter :: me_ = 9.10938215e-31_wp_ ! electron mass, kg
! REAL(wp_), PARAMETER :: mp_ = 1.672621637d-27 ! [kg] ! real (wp_), parameter :: mp_ = 1.672621637e-27_wp_ ! proton mass, kg
! REAL(wp_), PARAMETER :: rmpe_ = mp_/me_ ! real (wp_), parameter :: md_ = 3.34358320e-27_wp_ ! deuteron mass, kg
! REAL(wp_), PARAMETER :: c_ = 2.99792458d+08 ! [m/s] ! real (wp_), parameter :: mt_ = 5.00735588e-27_wp_ ! triton mass, kg
! REAL(wp_), PARAMETER :: eps0_ = 8.854187817d-12 ! [F/m] ! real (wp_), parameter :: ma_ = 6.64465620e-27_wp_ ! alpha mass, kg
! real (wp_), parameter :: amu_ = 1.660538782e-27_wp_ ! amu, kg
! REAL (wp_), PARAMETER :: rmpe_ = mp_/me_ ! proton-electron mass ratio
real (wp_), parameter :: c_ = 2.99792458e8_wp_ ! speed of light, m/s
real (wp_), parameter :: mu0_ = 4.0e-7_wp_ * pi ! magnetic permeability of vacuum
real (wp_), parameter :: eps0_ = 1.0_wp_ / (mu0_ * c_**2) ! dielectric constant of vacuum, F/m
! real (wp_), parameter :: avogr = 6.02214179e23_wp_
! real (wp_), parameter :: KBolt = 1.3806504e-23_wp_
!========================================================================
! Physical constants (cgs)
!========================================================================
real (wp_), parameter :: ccgs_ = c_*1.e2_wp_ ! speed of light, cm/s
real (wp_), parameter :: mecgs_ = me_*1.e3_wp_ ! electron mass, g
real (wp_), parameter :: ecgs_ = e_*c_*10._wp_ ! elementary charge, statcoul
!------------------------------------------------------------------------ !------------------------------------------------------------------------
! Useful definitions ! Useful definitions
!------------------------------------------------------------------------ !------------------------------------------------------------------------
REAL(wp_), PARAMETER :: keV_ = 1000*e_ ! [J] REAL(wp_), PARAMETER :: keV_ = 1.e3_wp_*e_ ! [J]
REAL(wp_), PARAMETER :: mc2_SI = me_*c_**2 ! [J] REAL(wp_), PARAMETER :: mc2_SI = me_*c_**2 ! [J]
REAL(wp_), PARAMETER :: mc2_ = mc2_SI/keV_ ! [keV] REAL(wp_), PARAMETER :: mc2_ = mc2_SI/keV_ ! [keV]
REAL(wp_), PARAMETER :: mu0inv = 1._wp_/mu0_ !
! REAL(wp_), PARAMETER :: mc_ = me_*c_ ! [kg*m/s] ! REAL(wp_), PARAMETER :: mc_ = me_*c_ ! [kg*m/s]
! ! f_ce = fce1_*B (B in Tesla): ! ! ! f_ce = fce1_*B (B in Tesla): !
! REAL(wp_), PARAMETER :: wce1_ = e_/me_ ! [rad/s] REAL(wp_), PARAMETER :: wce1_ = e_/me_ ! [rad/s]
! REAL(wp_), PARAMETER :: fce1_ = wce1_/(2*pi) ! [1/s] ! REAL(wp_), PARAMETER :: fce1_ = wce1_/(2*pi) ! [1/s]
! ! f_pl = fpe1_*sqrt(Ne) (Ne in 1/m**3): ! ! ! f_pl = fpe1_*sqrt(Ne) (Ne in 1/m**3): !
! REAL(wp_), PARAMETER :: wpe1_ = 56.4049201 ! [rad/s] ! REAL(wp_), PARAMETER :: wpe1_ = 56.4049201 ! [rad/s]
@ -100,6 +125,33 @@
! REAL(wp_), PARAMETER :: Npar_min = 1.0d-3 ! REAL(wp_), PARAMETER :: Npar_min = 1.0d-3
!########################################################################! !########################################################################!
interface is_valid
module procedure is_valid_int4, is_valid_int8, is_valid_real8
end interface
contains
logical function is_valid_int4(in_int)
implicit none
integer(i4), intent(in) :: in_int
is_valid_int4 = in_int /= int_invalid
return
end function is_valid_int4
logical function is_valid_int8(in_int)
implicit none
integer(i8), intent(in) :: in_int
is_valid_int8 = in_int /= int_invalid
return
end function is_valid_int8
logical function is_valid_real8(in_real)
implicit none
real(r8), intent(in) :: in_real
is_valid_real8 = abs(in_real - r8_invalid) > abs(r8_invalid) * 1.0e-15_r8
return
end function is_valid_real8
END MODULE const_and_precisions END MODULE const_and_precisions
!########################################################################! !########################################################################!

328
src/coreprofiles.f90 Normal file
View File

@ -0,0 +1,328 @@
module coreprofiles
use const_and_precisions, only : wp_,zero,one
implicit none
INTEGER, SAVE :: npp,nsfd
REAL(wp_), SAVE :: psdbnd,psnpp,denpp,ddenpp,d2denpp
REAL(wp_), DIMENSION(:), ALLOCATABLE, SAVE :: tfn,cfn,psrad
REAL(wp_), DIMENSION(:,:), ALLOCATABLE, SAVE :: ct,cz
REAL(wp_), SAVE :: dens0,aln1,aln2,te0,dte0,alt1,alt2,zeffan
contains
subroutine density(psin,dens,ddens)
use gray_params, only : iprof
use dierckx, only : splev,splder
implicit none
! arguments
real(wp_), intent(in) :: psin
real(wp_), intent(out) :: dens,ddens
! local variables
integer, parameter :: nn=3, nn1=nn+1, nn2=nn+2
integer :: ier,nu
real(wp_) :: profd,dprofd,dpsib,tt,fp,dfp,fh,dfh
real(wp_), dimension(1) :: xxs,ffs
real(wp_), dimension(npp+4) :: wrkfd
!
! computation of density [10^19 m^-3] and derivative wrt psi
!
dens=zero
ddens=zero
if((psin >= psdbnd).or.(psin < zero)) return
!
if(iprof == 0) then
if(psin > one) return
profd=(one-psin**aln1)**aln2
dens=dens0*profd
dprofd=-aln1*aln2*psin**(aln1-one) &
*(one-psin**aln1)**(aln2-one)
ddens=dens0*dprofd
else
if(psin > psnpp) then
! smooth interpolation for psnpp < psi < psdbnd
! dens = fp * fh
! fp: parabola matched at psi=psnpp with given profile density
! fh=(1-t)^3(1+3t+6t^2) is a smoothing function:
! fh(0)=1, fh(1)=0 and zero first and second deriv at t=0,1
!
dpsib=psin-psnpp
fp=denpp+dpsib*ddenpp+0.5_wp_*dpsib**2*d2denpp
dfp=ddenpp+dpsib*d2denpp
tt=dpsib/(psdbnd-psnpp)
fh=(one-tt)**3*(one+3.0_wp_*tt+6.0_wp_*tt**2)
dfh=-30.0_wp_*(one-tt)**2*tt**2/(psdbnd-psnpp)
dens=fp*fh
ddens=dfp*fh+fp*dfh
else
xxs(1)=psin
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 > 0) print*,ier
if(abs(dens) < 1.0e-10_wp_) dens=zero
end if
if(dens < zero) print*,' DENSITY NEGATIVE',dens
! if(dens < zero) then
! dens=zero
! ddens=zero
! end if
end if
end subroutine density
function temp(psin)
use const_and_precisions, only : wp_,zero,one
use gray_params, only : iprof
use utils, only : locate
use simplespline, only :spli
implicit none
! arguments
real(wp_), intent(in) :: psin
real(wp_) :: temp
! local variables
integer :: k
real(wp_) :: proft,dps
temp=zero
if((psin >= one).or.(psin < zero)) return
if(iprof == 0) then
proft=(1.0_wp_-psin**alt1)**alt2
temp=(te0-dte0)*proft+dte0
else
call locate(psrad,npp,psin,k)
k=max(1,min(k,npp-1))
dps=psin-psrad(k)
temp=spli(ct,npp,k,dps)
endif
end function temp
function fzeff(psin)
use const_and_precisions, only : wp_,zero,one
use gray_params, only : iprof
use utils, only : locate
use simplespline, only :spli
implicit none
! arguments
real(wp_), intent(in) :: psin
real(wp_) :: fzeff
! local variables
integer :: k
real(wp_) :: dps
fzeff=one
if((psin >= one).or.(psin < zero)) return
if(iprof == 0) then
fzeff=zeffan
else
call locate(psrad,npp,psin,k)
k=max(1,min(k,npp-1))
dps=psin-psrad(k)
fzeff=spli(cz,npp,k,dps)
endif
end function fzeff
subroutine read_profiles(filenm,psin,te,ne,zeff,unit)
use utils, only : get_free_unit
implicit none
! arguments
character(len=*), intent(in) :: filenm
real(wp_), dimension(:), allocatable, intent(out) :: psin,te,ne,zeff
integer, optional, intent(in) :: unit
! local variables
integer :: u, i, n
if (present(unit)) then
u=unit
else
u=get_free_unit()
end if
open(file=trim(filenm),status='old',action='read',unit=u)
read(u,*) n
if(allocated(psin)) deallocate(psin)
if(allocated(te)) deallocate(te)
if(allocated(ne)) deallocate(ne)
if(allocated(zeff)) deallocate(zeff)
allocate(psin(n),te(n),ne(n),zeff(n))
do i=1,n
read(u,*) psin(i),te(i),ne(i),zeff(i)
end do
psin(1)=max(psin(1),zero)
close(u)
end subroutine read_profiles
subroutine read_profiles_an(filenm,te,ne,zeff,unit)
use utils, only : get_free_unit
implicit none
! arguments
character(len=*), intent(in) :: filenm
real(wp_), dimension(:), allocatable, intent(out) :: te,ne,zeff
integer, optional, intent(in) :: unit
! local variables
integer :: u
if (present(unit)) then
u=unit
else
u=get_free_unit()
end if
if(allocated(te)) deallocate(te)
if(allocated(ne)) deallocate(ne)
if(allocated(zeff)) deallocate(zeff)
allocate(te(4),ne(3),zeff(1))
open(file=trim(filenm),status='old',action='read',unit=u)
read(u,*) ne(1:3) ! dens0,aln1,aln2
read(u,*) te(1:4) ! te0,dte0,alt1,alt2
read(u,*) zeff(1) ! zeffan
close(u)
end subroutine read_profiles_an
subroutine tene_scal(te,ne,tfact,nfact,bfact,iscal,iprof)
implicit none
! arguments
real(wp_), dimension(:), intent(inout) :: te,ne
real(wp_), intent(in) :: tfact,nfact,bfact
integer, intent(in) :: iscal,iprof
! local variables
real(wp_) :: aat,aan,ffact
integer :: lastte,lastne
if (iscal==0) then
aat=2.0_wp_/3.0_wp_
aan=4.0_wp_/3.0_wp_
else
aat=1.0_wp_
aan=1.0_wp_
end if
if(iscal==2) then
ffact=1.0_wp_
else
ffact=bfact
end if
if (iprof==0) then
lastte=2
lastne=1
else
lastte=size(te)
lastne=size(ne)
end if
te(1:lastte)=te(1:lastte)*ffact**aat*tfact
ne(1:lastne)=ne(1:lastne)*ffact**aan*nfact
end subroutine tene_scal
subroutine set_prfspl(psin,te,ne,zeff,ssplne,psdbndmx)
use simplespline, only : difcs
use dierckx, only : curfit, splev, splder
implicit none
! arguments
real(wp_), dimension(:), intent(in) :: psin,te,ne,zeff
real(wp_), intent(in) :: ssplne,psdbndmx
! local variables
integer, parameter :: iopt=0, kspl=3
integer :: n, npest, lwrkf, ier
real(wp_) :: xb, xe, fp, xnv, xxp,xxm,delta2
real(wp_), dimension(:), allocatable :: wf, wrkf
integer, dimension(:), allocatable :: iwrkf
real(wp_), dimension(1) :: dedge,ddedge,d2dedge
n=size(psin)
npest=n+4
lwrkf=n*4+npest*16
allocate(wrkf(lwrkf),iwrkf(npest),wf(n))
! if necessary, reallocate spline arrays
if(.not.allocated(psrad)) then
allocate(psrad(n),ct(n,4),cz(n,4))
else
if(size(psrad)<n) then
deallocate(psrad,ct,cz)
allocate(psrad(n),ct(n,4),cz(n,4))
end if
end if
if(.not.allocated(cfn)) then
allocate(tfn(npest),cfn(npest))
else
if(size(cfn)<npest) then
deallocate(tfn,cfn)
allocate(tfn(npest),cfn(npest))
end if
end if
! spline approximation of temperature and Zeff
call difcs(psin,te, n,iopt,ct,ier)
call difcs(psin,zeff,n,iopt,cz,ier)
psrad=psin
npp=n
! spline approximation of density
xb=zero
xe=psin(n)
wf(:)=one
call curfit(iopt,n,psin,ne,wf,xb,xe,kspl,ssplne,npest, &
nsfd,tfn,cfn,fp,wrkf,lwrkf,iwrkf,ier)
! compute polinomial extrapolation matching the spline boundary up to the
! 2nd order derivative, extending the profile up to psi=psdbnd where
! ne=ne'=ne''=0
! spline value and derivatives at the edge
call splev(tfn,nsfd,cfn,kspl,psin(n:n),dedge(1:1),1,ier)
call splder(tfn,nsfd,cfn,kspl,1,psin(n:n),ddedge(1:1), 1,wrkf(1:nsfd),ier)
call splder(tfn,nsfd,cfn,kspl,2,psin(n:n),d2dedge(1:1),1,wrkf(1:nsfd),ier)
! determination of the boundary
psdbnd=psdbndmx
psnpp=psin(n)
denpp=dedge(1)
ddenpp=ddedge(1)
d2denpp=d2dedge(1)
delta2=(ddenpp/d2denpp)**2-2.0_wp_*denpp/d2denpp
xnv=psnpp-ddenpp/d2denpp
if(delta2 < zero) then
if(xnv > psnpp) psdbnd=min(psdbnd,xnv)
else
xxm=xnv-sqrt(delta2)
xxp=xnv+sqrt(delta2)
if(xxm > psnpp) then
psdbnd=min(psdbnd,xxm)
else if (xxp > psnpp) then
psdbnd=min(psdbnd,xxp)
end if
end if
deallocate(iwrkf,wrkf,wf)
end subroutine set_prfspl
subroutine unset_prfspl
implicit none
if(allocated(psrad)) deallocate(psrad)
if(allocated(ct)) deallocate(ct)
if(allocated(cz)) deallocate(cz)
if(allocated(tfn)) deallocate(tfn)
if(allocated(cfn)) deallocate(cfn)
end subroutine unset_prfspl
subroutine set_prfan(te,ne,zeff)
implicit none
REAL(wp_), dimension(:), intent(in) :: te,ne,zeff
te0=te(1)
dte0=te(2)
alt1=te(3)
alt2=te(4)
dens0=ne(1)
aln1=ne(2)
aln2=ne(3)
zeffan=zeff(1)
psdbnd=1.0_wp_
end subroutine set_prfan
end module coreprofiles

4609
src/dierckx.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

1334
src/dispersion.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

888
src/eccd.f90 Normal file
View File

@ -0,0 +1,888 @@
module eccd
use const_and_precisions, only : wp_
implicit none
real(wp_), parameter, private :: cst2min=1.0e-6_wp_ ! min width of trap. cone
integer, parameter, private :: nfpp=13, & ! number of extra parameters passed
nfpp1=nfpp+ 1, nfpp2=nfpp+ 2, & ! to the integrand function fpp
nfpp3=nfpp+ 3, nfpp4=nfpp+ 4, &
nfpp5=nfpp+ 5
!########################################################################
! the following parameters are used by N.M. subroutines:
! The module contains few subroutines which are requested to calculate
! the current drive value by adjoint approach
!########################################################################
CHARACTER, PRIVATE, PARAMETER :: adj_appr(1:6) = & ! adj. approach switcher
(/ 'l', & ! (1)='l': collisionless limit
! (1)='c': collisional (classical) limit,
! w/o trap. part.
'm', & ! (2)='m': momentum conservation
! (2)='h': high-speed limit
!---
'l', & ! DO NOT CHANGE!
'r', & ! DO NOT CHANGE!
'v', & ! DO NOT CHANGE!
'i' /) ! DO NOT CHANGE!
!-------
REAL(wp_), PRIVATE :: r2,q2,gp1 ! coefficients for HSL integrand function
!-------
REAL(wp_), PRIVATE, PARAMETER :: delta = 1e-4 ! border for recalculation
!------- for N.M. subroutines (variational principle) -------
REAL(wp_), PRIVATE :: sfd(1:4) ! polyn. exp. of the "Spitzer"-function
INTEGER, PRIVATE, PARAMETER :: nre = 2 ! order of rel. correct.
REAL(wp_), PRIVATE, PARAMETER :: vp_mee(0:4,0:4,0:2) = &
RESHAPE((/0.0, 0.0, 0.0, 0.0, 0.0, &
0.0, 0.184875, 0.484304, 1.06069, 2.26175, &
0.0, 0.484304, 1.41421, 3.38514, 7.77817, &
0.0, 1.06069, 3.38514, 8.73232, 21.4005, &
0.0, 2.26175, 7.77817, 21.4005, 55.5079, &
! &
0.0, -1.33059,-2.57431, -5.07771, -10.3884, &
-0.846284,-1.46337, -1.4941, -0.799288, 2.57505, &
-1.1601, -1.4941, 2.25114, 14.159, 50.0534, &
-1.69257, -0.799288, 14.159, 61.4168, 204.389, &
-2.61022, 2.57505, 50.0534, 204.389, 683.756, &
! &
0.0, 2.62498, 0.985392,-5.57449, -27.683, &
0.0, 3.45785, 5.10096, 9.34463, 22.9831, &
-0.652555, 5.10096, 20.5135, 75.8022, 268.944, &
-2.11571, 9.34463, 75.8022, 330.42, 1248.69, &
-5.38358, 22.9831, 268.944, 1248.69, 4876.48/),&
(/5,5,3/))
REAL(wp_), PRIVATE, PARAMETER :: vp_mei(0:4,0:4,0:2) = &
RESHAPE((/0.0, 0.886227, 1.0, 1.32934, 2.0, &
0.886227,1.0, 1.32934, 2.0, 3.32335, &
1.0, 1.32934, 2.0, 3.32335, 6.0, &
1.32934, 2.0, 3.32335, 6.0, 11.6317, &
2.0, 3.32335, 6.0, 11.6317, 24.0, &
! &
0.0, 0.332335, 1.0, 2.49251, 6.0, &
1.66168, 1.0, 2.49251, 6.0, 14.5397, &
3.0, 2.49251, 6.0, 14.5397, 36.0, &
5.81586, 6.0, 14.5397, 36.0, 91.5999, &
12.0, 14.5397, 36.0, 91.5999, 240.0, &
! &
0.0, -0.103855, 0.0, 1.09047, 6.0, &
0.726983,0.0, 1.09047, 6.0, 24.5357, &
3.0, 1.09047, 6.0, 24.5357, 90.0, &
9.81427, 6.0, 24.5357, 90.0, 314.875, &
30.0, 24.5357, 90.0, 314.875, 1080.0 /), &
(/5,5,3/))
REAL(wp_), PRIVATE, PARAMETER :: vp_oee(0:4,0:4,0:2) = &
RESHAPE((/0.0, 0.56419, 0.707107, 1.0073, 1.59099, &
0.56419, 0.707107, 1.0073, 1.59099, 2.73981, &
0.707107,1.0073, 1.59099, 2.73981, 5.08233, &
1.0073, 1.59099, 2.73981, 5.08233, 10.0627, &
1.59099, 2.73981, 5.08233, 10.0627, 21.1138, &
! &
0.0, 1.16832, 1.90035, 3.5758, 7.41357, &
2.17562, 1.90035, 3.5758, 7.41357, 16.4891, &
3.49134, 3.5758, 7.41357, 16.4891, 38.7611, &
6.31562, 7.41357, 16.4891, 38.7611, 95.4472, &
12.4959, 16.4891, 38.7611, 95.4472, 244.803, &
! &
0.0, 2.65931, 4.64177, 9.6032, 22.6941, &
4.8652, 4.64177, 9.6032, 22.6941, 59.1437, &
9.51418, 9.6032, 22.6941, 59.1437, 165.282, &
21.061, 22.6941, 59.1437, 165.282, 485.785, &
50.8982, 59.1437, 165.282, 485.785, 1483.22/), &
(/5,5,3/))
REAL(wp_), PRIVATE, PARAMETER :: vp_g(0:4,0:2) = &
RESHAPE((/1.32934, 2.0, 3.32335, 6.0, 11.6317, &
2.49251, 0.0, 2.90793, 12.0, 39.2571, &
1.09047, 6.0, 11.45, 30.0, 98.9606/), &
(/5,3/))
!########################################################################
interface setcdcoeff
module procedure setcdcoeff_notrap,setcdcoeff_cohen,setcdcoeff_ncl
end interface setcdcoeff
contains
subroutine setcdcoeff_notrap(zeff,cst2,eccdpar)
implicit none
real(wp_), intent(in) :: zeff
real(wp_), intent(out) :: cst2
real(wp_), dimension(:), allocatable, intent(out) :: eccdpar
cst2=0.0_wp_
allocate(eccdpar(1))
eccdpar(1)=zeff
end subroutine setcdcoeff_notrap
subroutine setcdcoeff_cohen(zeff,rbn,rbx,cst2,eccdpar)
! cohen model
! rbn=B/B_min
! rbx=B/B_max
! cst2=1.0_wp_-B/B_max
! alams=sqrt(1-B_min/B_max)
! Zeff < 31 !!!
! fp0s= P_a (alams)
use conical, only : fconic
implicit none
real(wp_), intent(in) :: zeff,rbn,rbx
real(wp_), intent(out) :: cst2
real(wp_), dimension(:), allocatable, intent(out) :: eccdpar
real(wp_) :: alams,pa,fp0s
cst2=1.0_wp_-rbx
if(cst2<cst2min) cst2=0.0_wp_
alams=sqrt(1.0_wp_-rbx/rbn)
pa=sqrt(32.0_wp_/(Zeff+1.0_wp_)-1.0_wp_)/2.0_wp_
fp0s=fconic(alams,pa,0)
allocate(eccdpar(5))
eccdpar(1)=zeff
eccdpar(2)=rbn
eccdpar(3)=alams
eccdpar(4)=pa
eccdpar(5)=fp0s
end subroutine setcdcoeff_cohen
subroutine setcdcoeff_ncl(zeff,rbx,fc,amu,rhop,cst2,eccdpar)
use magsurf_data, only : ch,tjp,tlm,njpt,nlmt
use dierckx, only : profil
implicit none
integer, parameter :: ksp=3
real(wp_), intent(in) :: zeff,rbx,fc,amu,rhop
real(wp_), intent(out) :: cst2
real(wp_), dimension(:), allocatable, intent(out) :: eccdpar
real(wp_), dimension(nlmt) :: chlm
integer :: nlm,ierr,npar
cst2=1.0_wp_-rbx
if(cst2<cst2min) cst2=0.0_wp_
call SpitzFuncCoeff(amu,Zeff,fc)
nlm=nlmt
call profil(0,tjp,njpt,tlm,nlmt,ch,ksp,ksp,rhop,nlm,chlm,ierr)
if(ierr>0) write(*,*) ' Hlambda profil =',ierr
npar=3+2*nlm
allocate(eccdpar(npar))
eccdpar(1)=zeff
eccdpar(2) = fc
eccdpar(3) = rbx
eccdpar(4:3+nlm) = tlm
eccdpar(4+nlm:npar) = chlm
end subroutine setcdcoeff_ncl
subroutine eccdeff(yg,anpl,anprre,dens,amu,ex,ey,ez,nhmn,nhmx, &
ithn,cst2,fcur,eccdpar,effjcd,iokhawa,ierr)
use const_and_precisions, only : pi,qesi=>e_,mesi=>me_, &
vcsi=>c_,qe=>ecgs_,me=>mecgs_,vc=>ccgs_,mc2=>mc2_
use quadpack, only : dqagsmv
implicit none
! local constants
real(wp_), parameter :: mc2m2=1.0_wp_/mc2**2, &
canucc=2.0e13_wp_*pi*qe**4/(me**2*vc**3),ceff=qesi/(mesi*vcsi)
real(wp_), parameter :: epsa=0.0_wp_,epsr=1.0e-2_wp_,xxcr=16.0_wp_
real(wp_), parameter :: dumin=1.0e-6_wp_
integer, parameter :: lw=5000,liw=lw/4
! arguments
integer :: i,nhmn,nhmx,ithn,iokhawa,ierr
real(wp_) :: yg,anpl,anprre,dens,amu,cst2,effjcd
real(wp_), dimension(:) :: eccdpar
complex(wp_) :: ex,ey,ez
! local variables
integer :: nhn,neval,ier,last,npar
integer, dimension(liw) :: iw
real(wp_) :: anpl2,dnl,ygn,ygn2,resji,rdu2,upltp,upltm,uplp,uplm, &
rdu,rdu2t,duu,uu1,uu2,xx1,xx2,resj,resp,eji,epp,anum,denom, &
cstrdut,anucc
real(wp_), dimension(lw) :: w
real(wp_), dimension(nfpp+size(eccdpar)) :: apar
real(wp_), dimension(0:1) :: uleft,uright
! common/external functions/variables
real(wp_), external :: fcur
!
! effjpl = <J_parallel>/<p_d> /(B_min/<B>) [A m /W]
!
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)
npar=size(apar)
apar(nfpp+1:npar) = eccdpar
anpl2=anpl*anpl
effjcd=0.0_wp_
anum=0.0_wp_
denom=0.0_wp_
iokhawa=0
ierr=0
do nhn=nhmn,nhmx
ygn=nhn*yg
ygn2=ygn*ygn
rdu2=anpl2+ygn2-1.0_wp_
if (rdu2.lt.0.0_wp_) cycle
rdu=sqrt(rdu2)
dnl=1.0_wp_-anpl2
uplp=(anpl*ygn+rdu)/dnl
uplm=(anpl*ygn-rdu)/dnl
uu1=uplm
uu2=uplp
xx1=amu*(anpl*uu1+ygn-1.0_wp_)
xx2=amu*(anpl*uu2+ygn-1.0_wp_)
if(xx2.gt.xxcr) uu2=(xxcr/amu-ygn+1.0_wp_)/anpl
if(xx1.gt.xxcr) uu1=(xxcr/amu-ygn+1.0_wp_)/anpl
duu=abs(uu1-uu2)
if(duu.le.dumin) cycle
apar(12) = dble(nhn)
apar(13) = ygn
call dqagsmv(fpp,uu1,uu2,apar(1:nfpp),nfpp,epsa,epsr,resp, &
epp,neval,ier,liw,lw,last,iw,w)
if (ier.gt.0) then
ierr=90
return
end if
rdu2t=cst2*anpl2+ygn2-1.0_wp_
if (rdu2t.gt.0.0_wp_.and.cst2.gt.0.0_wp_) then
!
! resonance curve crosses the trapping region
!
iokhawa=1
cstrdut=sqrt(cst2*rdu2t)
upltm=(cst2*anpl*ygn-cstrdut)/(1.0_wp_-cst2*anpl2)
upltp=(cst2*anpl*ygn+cstrdut)/(1.0_wp_-cst2*anpl2)
uleft(0)=uplm
uright(0)=upltm
uleft(1)=upltp
uright(1)=uplp
else
!
! resonance curve does not cross the trapping region
!
iokhawa=0
uleft(0)=uplm
uright(0)=uplp
end if
resj=0.0_wp_
! do i=0,iokhawa
do i=0,1
resji=0.0_wp_
xx1=amu*(anpl*uleft(i)+ygn-1.0_wp_)
xx2=amu*(anpl*uright(i)+ygn-1.0_wp_)
if(xx1.lt.xxcr.or.xx2.lt.xxcr) then
if(xx2.gt.xxcr) uright(i)=(xxcr/amu-ygn+1.0_wp_)/anpl
if(xx1.gt.xxcr) uleft(i)=(xxcr/amu-ygn+1.0_wp_)/anpl
duu=abs(uleft(i)-uright(i))
if(duu.gt.dumin) then
call dqagsmv(fcur,uleft(i),uright(i),apar,npar,epsa,epsr, &
resji,eji,neval,ier,liw,lw,last,iw,w)
if (ier.gt.0) then
if (abs(resji).lt.1.0e-10_wp_) then
resji=0.0_wp_
else
ierr=91+iokhawa+i
return
end if
end if
end if
end if
resj=resj+resji
if(iokhawa.eq.0) exit
end do
anum=anum+resj
denom=denom+resp
end do
if(denom.gt.0.0_wp_) then
anucc=canucc*dens*(48.0_wp_-log(1.0e7_wp_*dens*mc2m2*amu**2))
effjcd=-ceff*anum/(anucc*denom)
end if
end subroutine eccdeff
function fpp(upl,extrapar,npar)
!
! computation of integral for power density, integrand function fpp
!
! ith=0 : polarization term = const
! ith=1 : polarization term Larmor radius expansion to lowest order
! ith=2 : full polarization term (J Bessel)
!
! integration variable upl passed explicitly. other variables passed
! as array of extra parameters of length npar=size(extrapar)
!
! extrapar(1) = yg
! extrapar(2) = anpl
! extrapar(3) = amu
! extrapar(4) = Re(anprw)
! extrapar(5) = Re(ex)
! extrapar(6) = Im(ex)
! extrapar(7) = Re(ey)
! extrapar(8) = Im(ey)
! extrapar(9) = Re(ez)
! extrapar(10) = Im(ez)
! extrapar(11) = double(ithn)
! extrapar(12) = double(nhn)
! extrapar(13) = ygn
!
use const_and_precisions, only : ui=>im
use math, only : fact
implicit none
! arguments
integer :: npar
real(wp_) :: upl,fpp
real(wp_), dimension(npar) :: extrapar
! local variables
integer :: ithn,nhn !,nm,np
real(wp_) :: yg,anpl,amu,anprre,ygn,upr,upr2,gam,ee,thn2,thn2u,bb,cth !, &
! ajbnm,ajbnp,ajbn
real(wp_), dimension(3) :: ajb
complex(wp_) :: ex,ey,ez,emxy,epxy
yg=extrapar(1)
anpl=extrapar(2)
amu=extrapar(3)
anprre=extrapar(4)
ex=cmplx(extrapar(5),extrapar(6),wp_)
ey=cmplx(extrapar(7),extrapar(8),wp_)
ez=cmplx(extrapar(9),extrapar(10),wp_)
ithn=int(extrapar(11))
nhn=int(extrapar(12))
ygn=extrapar(13)
gam=anpl*upl+ygn
upr2=gam*gam-1.0_wp_-upl*upl
ee=exp(-amu*(gam-1))
! thn2=1.0_wp_
thn2u=upr2 !*thn2
if(ithn.gt.0) then
emxy=ex-ui*ey
epxy=ex+ui*ey
if(upr2.gt.0.0_wp_) then
upr=sqrt(upr2)
bb=anprre*upr/yg
if(ithn.eq.1) then
! Larmor radius expansion polarization term at lowest order
cth=1.0_wp_
if(nhn.gt.1) cth=(0.5_wp_*bb)**(nhn-1)*nhn/fact(nhn)
thn2=(0.5_wp_*cth*abs(emxy+ez*anprre*upl/ygn))**2
thn2u=upr2*thn2
else
! 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.0_wp_))**2
ajb=bessel_jn(nhn-1, nhn+1, bb)
thn2u=(abs(ez*ajb(2)*upl+upr*(ajb(3)*epxy+ajb(1)*emxy)/2.0_wp_))**2
end if
end if
end if
fpp=ee*thn2u
end function fpp
function fjch(upl,extrapar,npar)
!
! computation of integral for current density
! integrand for Cohen model with trapping
!
! integration variable upl passed explicitly. Other variables passed
! as array of extra parameters of length npar=size(extrapar).
! variables with index 1..nfpp must be passed to fpp
! variable with index nfpp+1 is zeff
! variables with index gt nfpp+1 are specific of the cd model
!
! extrapar(2) = anpl
! extrapar(4) = Re(anprw)
! extrapar(13) = ygn
!
! extrapar(14) = zeff
! extrapar(15) = rb
! extrapar(16) = alams
! extrapar(17) = pa
! extrapar(18) = fp0s
!
use conical, only : fconic
implicit none
! arguments
integer :: npar
real(wp_) :: upl,fjch
real(wp_), dimension(npar) :: extrapar
! local variables
real(wp_) :: anpl,anprre,ygn,zeff,rb,alams,pa,fp0s, &
upr2,gam,u2,u,z5,xi,xib,xibi,fu2b,fu2,gu,gg,dgg,alam,fp0, &
dfp0,fh,dfhl,eta
anpl=extrapar(2)
anprre=extrapar(4)
ygn=extrapar(13)
zeff=extrapar(nfpp1)
rb=extrapar(nfpp2)
alams=extrapar(nfpp3)
pa=extrapar(nfpp4)
fp0s=extrapar(nfpp5)
gam=anpl*upl+ygn
u2=gam*gam-1.0_wp_
upr2=u2-upl*upl
u=sqrt(u2)
z5=Zeff+5.0_wp_
xi=1.0_wp_/z5**2
xib=1.0_wp_-xi
xibi=1.0_wp_/xib
fu2b=1.0_wp_+xib*u2
fu2=1.0_wp_+xi*u2
gu=(1.0_wp_-1.0_wp_/fu2b**xibi)/sqrt(fu2)
gg=u*gu/z5
dgg=(gu+u2*(2.0_wp_/fu2b**(1.0_wp_+xibi)/sqrt(fu2)-xi*gu/fu2))/z5
alam=sqrt(1.0_wp_-upr2/u2/rb)
fp0=fconic(alam,pa,0)
dfp0=-(pa*pa/2.0_wp_+0.125_wp_)
if (alam.lt.1.0_wp_) dfp0=-fconic(alam,pa,1)/sqrt(1.0_wp_-alam**2)
fh=alam*(1.0_wp_-alams*fp0/(alam*fp0s))
dfhl=1.0_wp_-alams*dfp0/fp0s
eta=gam*fh*(gg/u+dgg)+upl*(anpl*u2-upl*gam)*gg*dfhl/(u2*u*rb*alam)
if(upl.lt.0.0_wp_) eta=-eta
fjch=eta*fpp(upl,extrapar(1:nfpp),nfpp)
end function fjch
function fjch0(upl,extrapar,npar)
!
! computation of integral for current density
! integrand for Cohen model without trapping
!
! integration variable upl passed explicitly. Other variables passed
! as array of extra parameters of length npar=size(extrapar).
! variables with index 1..nfpp must be passed to fpp
! variable with index nfpp+1 is zeff
! variables with index gt nfpp+1 are specific of the cd model
!
! extrapar(2) = anpl
! extrapar(13) = ygn
!
! extrapar(14) = zeff
!
implicit none
! arguments
real(wp_) :: upl,fjch0
integer :: npar
real(wp_), dimension(npar) :: extrapar
! local variables
real(wp_) :: anpl,ygn,zeff,gam,u2,u,z5,xi,xib,xibi,fu2b,fu2,gu,gg,dgg,eta
!
anpl=extrapar(2)
ygn=extrapar(13)
zeff=extrapar(nfpp1)
gam=anpl*upl+ygn
u2=gam*gam-1.0_wp_
u=sqrt(u2)
z5=Zeff+5.0_wp_
xi=1.0_wp_/z5**2
xib=1.0_wp_-xi
xibi=1.0_wp_/xib
fu2b=1.0_wp_+xib*u2
fu2=1.0_wp_+xi*u2
gu=(1.0_wp_-1.0_wp_/fu2b**xibi)/sqrt(fu2)
gg=u*gu/z5
dgg=(gu+u2*(2.0_wp_/fu2b**(1.0_wp_+xibi)/sqrt(fu2)-xi*gu/fu2))/z5
eta=anpl*gg+gam*upl*dgg/u
fjch0=eta*fpp(upl,extrapar(1:nfpp),nfpp)
end function fjch0
function fjncl(upl,extrapar,npar)
!
! computation of integral for current density
! integrand for momentum conserv. model K(u) from Maruschenko
! gg=F(u)/u with F(u) as in Cohen paper
!
! integration variable upl passed explicitly. Other variables passed
! as array of extra parameters of length npar=size(extrapar).
! variables with index 1..nfpp must be passed to fpp
! variable with index nfpp+1 is zeff
! variables with index gt nfpp+1 are specific of the cd model
!
! extrapar(2) = anpl
! extrapar(3) = amu
! extrapar(13) = ygn
!
! extrapar(14) = zeff
! extrapar(15) = fc
! extrapar(16) = rbx
! extrapar(17:16+(npar-16)/2) = tlm
! extrapar(17+(npar-16)/2:npar) = chlm
!
use dierckx, only : splev,splder
implicit none
! arguments
integer :: npar
real(wp_) :: upl,fjncl
real(wp_), dimension(npar) :: extrapar
! local variables
integer :: nlm
real(wp_) :: anpl,amu,ygn,zeff,fc,rbx,gam,u2,u,upr2, &
bth,uth,fk,dfk,alam,fu,dfu,eta
! local variables
integer :: ier
real(wp_), dimension((npar-nfpp3)/2) :: wrk
real(wp_), dimension(1) :: xs,ys
!
anpl=extrapar(2)
amu=extrapar(3)
ygn=extrapar(13)
zeff=extrapar(nfpp1)
fc=extrapar(nfpp2)
rbx=extrapar(nfpp3)
gam=anpl*upl+ygn
u2=gam*gam-1.0_wp_
u=sqrt(u2)
upr2=u2-upl*upl
bth=sqrt(2.0_wp_/amu)
uth=u/bth
call GenSpitzFunc(Zeff,fc,uth,u,gam,fk,dfk)
fk=fk*(4.0_wp_/amu**2)
dfk=dfk*(2.0_wp_/amu)*bth
alam=upr2/u2/rbx
xs(1)=alam
nlm=(npar-nfpp3)/2
!
! extrapar(17:16+(npar-16)/2) = tlm
! extrapar(17+(npar-16)/2:npar) = chlm
!
call splev(extrapar(nfpp4:nfpp3+nlm),nlm,extrapar(nfpp4+nlm:npar),3, &
xs(1),ys(1),1,ier)
fu=ys(1)
call splder(extrapar(nfpp4:nfpp3+nlm),nlm,extrapar(nfpp4+nlm:npar),3,1, &
xs(1),ys(1),1,wrk,ier)
dfu=ys(1)
eta=gam*fu*dfk/u-2.0_wp_*(anpl-gam*upl/u2)*fk*dfu*upl/u2/rbx
if(upl.lt.0) eta=-eta
fjncl=eta*fpp(upl,extrapar(1:nfpp),nfpp)
end function fjncl
SUBROUTINE GenSpitzFunc(Zeff,fc,u,q,gam, K,dKdu)
!=======================================================================
! Author: N.B.Marushchenko
! June 2005: as start point the subroutine of Ugo Gasparino (198?)
! SpitzFunc() is taken and modified.
! 1. adapted to the Fortran-95
! 2. derivative of Spitzer function is added
! 3. separation for 2 brunches is done:
! 1st is referenced as 'with conservation of the moment',
! 2nd - as 'high speed limit'.
! The last one is taken from the Lin-Liu formulation
! (Phys.Plasmas 10 (2003) 4064) with K = F*fc.
! The asymptotical high speed limit (Taguchi-Fisch model)
! is also included as the reference case.
! Feb. 2008: non-relativ. version is replaced by the relativistic one;
! the method is the the same, but the trial-function is
! based on the relativistic formulation.
! The relativistic corrections for the collisional operator
! up to the second order, i.e. (1/mu)**2, are applied.
! Sep. 2008: generalized Spitzer function for arbitrary collisionality
! is implemented. The model is based on the concept of
! the "effective trapped particles fraction".
! The different.-integral kinetic equation for the generalized
! Spitzer function is produced with help of subroutines
! ArbColl_TrappFract_Array and ArbColl_SpitzFunc_Array,
! where the subroutines of H. Maassberg are called).
!========================================================================
! Spitzer function with & w/o trapped particle effects is given by:
!
! K(x) = x/gamma*(d1*x+d2*x^2+d4*x^3+d4*x^4),
!
! where x = v/v_th and gamma=1 for non-relativistic version (Ugo),
! or x = p/p_th for relativistic version (N.M., February 2008).
! Note, that somewhere the function F(x) instead of K(x) is applied,
!
! F(x) = K(x)/fc.
!
! Numerical inversion of the 5x5 symmetric matrix obtained from the
! generalized Spitzer problem (see paper of Taguchi for the equation
! and paper of Hirshman for the variational approach bringing to the
! matrix to be inverted).
!
! The numerical method used is an improved elimination scheme
! (Banachiewiczs-Cholesky-Crout method).
! This method is particularly simple for symmetric matrix.
! As a reference see "Mathematical Handbook" by Korn & Korn, p.635-636.
!
! Refs.: 1. S.P. Hirshman, Phys. Fluids 23 (1980) 1238
! 2. M. Rome' et al., Plasma Phys. Contr. Fus. 40 (1998) 511
! 3. N.B. Marushchenko et al., Fusion Sci. Technol. 55 (2009) 180
!========================================================================
! INPUTS:
! u - p/sqrt(2mT)
! q - p/mc;
! gam - relativistic factor;
! Zeff - effective charge;
! fc - fraction of circulating particles.
!
! OUTPUTS:
! K - Spitzer's function
! dKdu = dK/du, i.e. its derivative over normalized momentum
!=======================================================================
use const_and_precisions, only : comp_eps
IMPLICIT NONE
REAL(wp_), INTENT(in) :: Zeff,fc,u,q,gam
REAL(wp_), INTENT(out) :: K,dKdu
REAL(wp_) :: gam1,gam2,gam3
K = 0
dKdu = 0
IF (u < comp_eps) RETURN
SELECT CASE(adj_appr(2))
CASE('m') !--------------- momentum conservation ------------------!
gam1 = gam !
IF (adj_appr(4) == 'n') gam1 = 1 !
gam2 = gam1*gam1 !
gam3 = gam1*gam2 !
K = u/gam1*u*(sfd(1)+u*(sfd(2)+u*(sfd(3)+u*sfd(4)))) !
dKdu = u/gam3* (sfd(1)*(1+ gam2)+u*(sfd(2)*(1+2*gam2)+ & !
u*(sfd(3)*(1+3*gam2)+u* sfd(4)*(1+4*gam2)))) !
!--------------------- end momentum conservation -------------------!
CASE('h') !---------------- high-speed-limit ----------------------!
IF (adj_appr(4) == 'n') THEN !- non-relativ. asymptotic form -!
K = u**4 *fc/(Zeff+1+4*fc) !- (Taguchi-Fisch model) -!
dKdu = 4*u**3 *fc/(Zeff+1+4*fc) !
ELSEIF (adj_appr(4) == 'r') THEN !- relativistic, Lin-Liu form. -!
CALL SpitzFunc_HighSpeedLimit(Zeff,fc,u,q,gam, K,dKdu) !
ENDIF !
CASE default !----------------------------------------------------!
PRINT*,'GenSpitzFunc: WARNING! Spitzer function is not defined.'
RETURN
END SELECT
END SUBROUTINE GenSpitzFunc
SUBROUTINE SpitzFuncCoeff(mu,Zeff,fc)
!=======================================================================
! Calculates the matrix coefficients required for the subroutine
! "GenSpitzFunc", where the Spitzer function is defined through the
! variational principle.
!
! Weakly relativistic (upgraded) version (10.09.2008).
! Apart of the non-relativistic matrix coefficients, taken from the
! old subroutine of Ugo Gasparino, the relativistic correction written
! as series in 1/mu^n (mu=mc2/T) powers is added. Two orders are taken
! into account, i.e. n=0,1,2.
!
! In this version, the coefficients "oee", i.e. Omega_ij, are formulated
! for arbitrary collisionality.
!
! INPUT VARIABLES:
! rho = sqrt(SS) with SS - flux-surface label (norm. magn. flux)
! ne - density, 1/m^3
! mu - mc2/Te
! Zeff - effective charge
! fc - fraction of circulating particles
!
! OUTPUT VARIABLES (defined as a global ones):
! sfd(1),...,sfd(4) - coefficients of the polynomial expansion of the
! "Spitzer"-function (the same as in the Hirshman paper)
!=======================================================================
use const_and_precisions, only : mc2_
IMPLICIT NONE
REAL(wp_), INTENT(in) :: mu,Zeff,fc
INTEGER :: n,i,j
REAL(wp_) :: rtc,rtc1,y,tn(1:nre)
REAL(wp_) :: m(0:4,0:4),g(0:4)
REAL(wp_) :: gam11,gam21,gam31,gam41,gam01, &
gam22,gam32,gam42,gam02, &
gam33,gam43,gam03, &
gam44,gam04,gam00
REAL(wp_) :: alp12,alp13,alp14,alp10, &
alp23,alp24,alp20, &
alp34,alp30,alp40
REAL(wp_) :: bet0,bet1,bet2,bet3,bet4,d0
LOGICAL :: renew,rel,newmu,newZ,newfc
REAL(wp_), SAVE :: sfdx(1:4) = 0
REAL(wp_), SAVE :: mu_old =-1, Zeff_old =-1, fc_old =-1
rel = mu < mc2_
newmu = abs(mu -mu_old ) > delta*mu
newZ = abs(Zeff-Zeff_old) > delta*Zeff
newfc = abs(fc -fc_old ) > delta*fc
SELECT CASE(adj_appr(1))
CASE ('l','c')
renew = (newmu .and. rel) .OR. newZ .OR. newfc
END SELECT
IF (.not.renew) THEN
sfd(:) = sfdx(:)
RETURN
ENDIF
tn(:) = 0
IF (adj_appr(4) == 'r') THEN
IF (nre > 0) THEN
!mu = min(mu,1.e3*mc2_)
tn(1) = 1/mu
DO n=2,min(2,nre)
tn(n) = tn(n-1)/mu
ENDDO
ENDIF
ENDIF
SELECT CASE(adj_appr(1))
CASE ('l','c') !---- both classical & collisionless limits ----!
rtc = (1-fc)/fc; rtc1 = rtc+1 !
!--- !
DO i=0,4 !
g(i) = vp_g(i,0) !
DO n=1,min(2,nre) !
g(i) = g(i) + tn(n)*vp_g(i,n) !
ENDDO !
!--- !
DO j=0,4 !
IF (i == 0 .or. j == 0 .or. j >= i) THEN !
y = vp_mee(i,j,0) + rtc *vp_oee(i,j,0) + & !
Zeff*rtc1*vp_mei(i,j,0) !
DO n=1,min(2,nre) !
y = y + (vp_mee(i,j,n) + rtc *vp_oee(i,j,n) + & !
Zeff*rtc1*vp_mei(i,j,n))*tn(n) !
ENDDO !
m(i,j) = y !
ENDIF !
ENDDO !
ENDDO !
DO i=2,4 !
DO j=1,i-1 !
m(i,j) = m(j,i) !
ENDDO !
ENDDO !
m(0,0) = 0 !
CASE default !------------------------------------------------!
PRINT*,'Green_Func: WARNING! Adjoint approach is not defined.'
RETURN
END SELECT
gam11 = m(1,1)
gam21 = m(2,1)
gam31 = m(3,1)
gam41 = m(4,1)
gam01 = m(0,1)
alp12 = m(1,2)/m(1,1)
alp13 = m(1,3)/m(1,1)
alp14 = m(1,4)/m(1,1)
alp10 = m(1,0)/m(1,1)
gam22 = m(2,2)-gam21*alp12
gam32 = m(3,2)-gam31*alp12
gam42 = m(4,2)-gam41*alp12
gam02 = m(0,2)-gam01*alp12
alp23 = gam32/gam22
alp24 = gam42/gam22
alp20 = gam02/gam22
gam33 = m(3,3)-gam31*alp13-gam32*alp23
gam43 = m(4,3)-gam41*alp13-gam42*alp23
gam03 = m(0,3)-gam01*alp13-gam02*alp23
alp34 = gam43/gam33
alp30 = gam03/gam33
gam44 = m(4,4)-gam41*alp14-gam42*alp24-gam43*alp34
gam04 = m(0,4)-gam01*alp14-gam02*alp24-gam03*alp34
alp40 = gam04/gam44
gam00 = m(0,0)-gam01*alp10-gam02*alp20-gam03*alp30-gam04*alp40
bet1 = g(1)/m(1,1)
bet2 = (g(2)-gam21*bet1)/gam22
bet3 = (g(3)-gam31*bet1-gam32*bet2)/gam33
bet4 = (g(4)-gam41*bet1-gam42*bet2-gam43*bet3)/gam44
bet0 = (g(0)-gam01*bet1-gam02*bet2-gam03*bet3-gam04*bet4)/gam00
d0 = bet0
sfd(4) = bet4-alp40*d0
sfd(3) = bet3-alp30*d0-alp34*sfd(4)
sfd(2) = bet2-alp20*d0-alp24*sfd(4)-alp23*sfd(3)
sfd(1) = bet1-alp10*d0-alp14*sfd(4)-alp13*sfd(3)-alp12*sfd(2)
fc_old = fc
mu_old = mu
Zeff_old = Zeff
sfdx(1:4) = sfd(1:4)
END SUBROUTINE SpitzFuncCoeff
SUBROUTINE SpitzFunc_HighSpeedLimit(Zeff,fc,u,q,gam, K,dKdu)
!=======================================================================
! Calculates the "Spitzer function" in high velocity limit, relativistic
! formulation: Lin-Liu et al., Phys.Pl. (2003),v10, 4064, Eq.(33).
!
! Inputs:
! Zeff - effective charge
! fc - fraction of circulating electrons
! u - p/(m*vte)
! q - p/mc
! gam - relativ. factor
!
! Outputs:
! K - Spitzer function
! dKdu - its derivative
!=======================================================================
use const_and_precisions, only : zero,one
use numint, only : quanc8
IMPLICIT NONE
REAL(wp_), INTENT(in) :: Zeff,fc,u,q,gam
REAL(wp_), INTENT(out) :: K,dKdu
INTEGER :: nfun
REAL(wp_) :: gam2,err,flag,Integr
REAL(wp_), PARAMETER :: a = zero, b = one, rtol = 1e-4_wp_, atol = 1e-12_wp_
r2 = (1+Zeff)/fc ! global parameter needed for integrand, HSL_f(t)
IF (u < 1e-2) THEN
K = u**4/(r2+4)
dKdu = 4*u**3/(r2+4)
RETURN
ENDIF
q2 = q*q ! for the integrand, HSL_f
gp1 = gam+1 ! ..
CALL quanc8(HSL_f,zero,one,atol,rtol,Integr,err,nfun,flag)
gam2 = gam*gam
K = u**4 * Integr
dKdu = (u/gam)**3 * (1-r2*gam2*Integr)
END SUBROUTINE SpitzFunc_HighSpeedLimit
FUNCTION HSL_f(t) RESULT(f)
!=======================================================================
! Integrand for the high-speed limit approach (Lin-Liu's formulation)
!=======================================================================
IMPLICIT NONE
REAL(wp_), INTENT(in) :: t
REAL(wp_) :: f,g
g = sqrt(1+t*t*q2)
f = t**(3+r2)/g**3 * (gp1/(g+1))**r2
END FUNCTION HSL_f
end module eccd

906
src/eierf.f90 Normal file
View File

@ -0,0 +1,906 @@
module eierf
use const_and_precisions, only : wp_, zero, one
implicit none
real(wp_), parameter, private :: half=0.5_wp_, two=2.0_wp_, three=3.0_wp_, &
four=4.0_wp_, six=6.0_wp_, twelve=12._wp_, sixten=16.0_wp_, &
two4=24.0_wp_, fourty=40.0_wp_
contains
! ======================================================================
! nist guide to available math software.
! fullsource for module ei from package specfun.
! retrieved from netlib on fri mar 26 05:52:39 1999.
! ======================================================================
subroutine calcei(arg,result,intt)
!----------------------------------------------------------------------
!
! this fortran 77 packet computes the exponential integrals ei(x),
! e1(x), and exp(-x)*ei(x) for real arguments x where
!
! integral (from t=-infinity to t=x) (exp(t)/t), x > 0,
! ei(x) =
! -integral (from t=-x to t=infinity) (exp(t)/t), x < 0,
!
! and where the first integral is a principal value integral.
! the packet contains three function type subprograms: ei, eone,
! and expei; and one subroutine type subprogram: calcei. the
! calling statements for the primary entries are
!
! y = ei(x), where x /= 0,
!
! y = eone(x), where x > 0,
! and
! y = expei(x), where x /= 0,
!
! and where the entry points correspond to the functions ei(x),
! e1(x), and exp(-x)*ei(x), respectively. the routine calcei
! is intended for internal packet use only, all computations within
! the packet being concentrated in this routine. the function
! subprograms invoke calcei with the fortran statement
! call calcei(arg,result,intt)
! where the parameter usage is as follows
!
! function parameters for calcei
! call arg result intt
!
! ei(x) x /= 0 ei(x) 1
! eone(x) x > 0 -ei(-x) 2
! expei(x) x /= 0 exp(-x)*ei(x) 3
!----------------------------------------------------------------------
implicit none
integer, intent(in) :: intt
real(wp_), intent(in) :: arg
real(wp_), intent(out) :: result
integer :: i
real(wp_) :: ei,frac,sump,sumq,t,w,x,xmx0,y,ysq
real(wp_), dimension(10) :: px,qx
!----------------------------------------------------------------------
! mathematical constants
! exp40 = exp(40)
! x0 = zero of ei
! x01/x11 + x02 = zero of ei to extra precision
!----------------------------------------------------------------------
real(wp_), parameter :: p037=0.037_wp_, &
exp40=2.3538526683701998541e17_wp_, x01=381.5_wp_, x11=1024.0_wp_, &
x02=-5.1182968633365538008e-5_wp_, x0=3.7250741078136663466e-1_wp_
!----------------------------------------------------------------------
! machine-dependent constants
!----------------------------------------------------------------------
real(wp_), parameter :: xinf=1.79e+308_wp_,xmax=716.351_wp_,xbig=701.84_wp_
!----------------------------------------------------------------------
! coefficients for -1.0 <= x < 0.0
!----------------------------------------------------------------------
real(wp_), dimension(7), parameter :: &
a=(/1.1669552669734461083368e2_wp_, 2.1500672908092918123209e3_wp_, &
1.5924175980637303639884e4_wp_, 8.9904972007457256553251e4_wp_, &
1.5026059476436982420737e5_wp_,-1.4815102102575750838086e5_wp_, &
5.0196785185439843791020_wp_/)
real(wp_), dimension(6), parameter :: &
b=(/4.0205465640027706061433e1_wp_, 7.5043163907103936624165e2_wp_, &
8.1258035174768735759855e3_wp_, 5.2440529172056355429883e4_wp_, &
1.8434070063353677359298e5_wp_, 2.5666493484897117319268e5_wp_/)
!----------------------------------------------------------------------
! coefficients for -4.0 <= x < -1.0
!----------------------------------------------------------------------
real(wp_), dimension(9), parameter :: &
c=(/3.828573121022477169108e-1_wp_, 1.107326627786831743809e+1_wp_, &
7.246689782858597021199e+1_wp_, 1.700632978311516129328e+2_wp_, &
1.698106763764238382705e+2_wp_, 7.633628843705946890896e+1_wp_, &
1.487967702840464066613e+1_wp_, 9.999989642347613068437e-1_wp_, &
1.737331760720576030932e-8_wp_/), &
d=(/8.258160008564488034698e-2_wp_, 4.344836335509282083360e+0_wp_, &
4.662179610356861756812e+1_wp_, 1.775728186717289799677e+2_wp_, &
2.953136335677908517423e+2_wp_, 2.342573504717625153053e+2_wp_, &
9.021658450529372642314e+1_wp_, 1.587964570758947927903e+1_wp_, &
1.000000000000000000000e+0_wp_/)
!----------------------------------------------------------------------
! coefficients for x < -4.0
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
e=(/1.3276881505637444622987e+2_wp_,3.5846198743996904308695e+4_wp_, &
1.7283375773777593926828e+5_wp_,2.6181454937205639647381e+5_wp_, &
1.7503273087497081314708e+5_wp_,5.9346841538837119172356e+4_wp_, &
1.0816852399095915622498e+4_wp_,1.0611777263550331766871e03_wp_, &
5.2199632588522572481039e+1_wp_,9.9999999999999999087819e-1_wp_/),&
f=(/3.9147856245556345627078e+4_wp_,2.5989762083608489777411e+5_wp_, &
5.5903756210022864003380e+5_wp_,5.4616842050691155735758e+5_wp_, &
2.7858134710520842139357e+5_wp_,7.9231787945279043698718e+4_wp_, &
1.2842808586627297365998e+4_wp_,1.1635769915320848035459e+3_wp_, &
5.4199632588522559414924e+1_wp_,1.0_wp_/)
!----------------------------------------------------------------------
! coefficients for rational approximation to ln(x/a), |1-x/a| < .1
!----------------------------------------------------------------------
real(wp_), dimension(4), parameter :: &
plg=(/-2.4562334077563243311e+01_wp_,2.3642701335621505212e+02_wp_, &
-5.4989956895857911039e+02_wp_,3.5687548468071500413e+02_wp_/), &
qlg=(/-3.5553900764052419184e+01_wp_,1.9400230218539473193e+02_wp_, &
-3.3442903192607538956e+02_wp_,1.7843774234035750207e+02_wp_/)
!----------------------------------------------------------------------
! coefficients for 0.0 < x < 6.0,
! ratio of chebyshev polynomials
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
p=(/-1.2963702602474830028590e01_wp_,-1.2831220659262000678155e03_wp_, &
-1.4287072500197005777376e04_wp_,-1.4299841572091610380064e06_wp_, &
-3.1398660864247265862050e05_wp_,-3.5377809694431133484800e08_wp_, &
3.1984354235237738511048e08_wp_,-2.5301823984599019348858e10_wp_, &
1.2177698136199594677580e10_wp_,-2.0829040666802497120940e11_wp_/),&
q=(/ 7.6886718750000000000000e01_wp_,-5.5648470543369082846819e03_wp_, &
1.9418469440759880361415e05_wp_,-4.2648434812177161405483e06_wp_, &
6.4698830956576428587653e07_wp_,-7.0108568774215954065376e08_wp_, &
5.4229617984472955011862e09_wp_,-2.8986272696554495342658e10_wp_, &
9.8900934262481749439886e10_wp_,-8.9673749185755048616855e10_wp_/)
!----------------------------------------------------------------------
! j-fraction coefficients for 6.0 <= x < 12.0
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
r=(/-2.645677793077147237806_wp_,-2.378372882815725244124_wp_, &
-2.421106956980653511550e01_wp_, 1.052976392459015155422e01_wp_, &
1.945603779539281810439e01_wp_,-3.015761863840593359165e01_wp_, &
1.120011024227297451523e01_wp_,-3.988850730390541057912_wp_, &
9.565134591978630774217_wp_, 9.981193787537396413219e-1_wp_/)
real(wp_), dimension(9), parameter :: &
s=(/ 1.598517957704779356479e-4_wp_, 4.644185932583286942650_wp_, &
3.697412299772985940785e02_wp_,-8.791401054875438925029_wp_, &
7.608194509086645763123e02_wp_, 2.852397548119248700147e01_wp_, &
4.731097187816050252967e02_wp_,-2.369210235636181001661e02_wp_, &
1.249884822712447891440_wp_/)
!----------------------------------------------------------------------
! j-fraction coefficients for 12.0 <= x < 24.0
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
p1=(/-1.647721172463463140042_wp_,-1.860092121726437582253e01_wp_, &
-1.000641913989284829961e01_wp_,-2.105740799548040450394e01_wp_, &
-9.134835699998742552432e-1_wp_,-3.323612579343962284333e01_wp_, &
2.495487730402059440626e01_wp_, 2.652575818452799819855e01_wp_, &
-1.845086232391278674524_wp_, 9.999933106160568739091e-1_wp_/)
real(wp_), dimension(9), parameter :: &
q1=(/ 9.792403599217290296840e01_wp_, 6.403800405352415551324e01_wp_, &
5.994932325667407355255e01_wp_, 2.538819315630708031713e02_wp_, &
4.429413178337928401161e01_wp_, 1.192832423968601006985e03_wp_, &
1.991004470817742470726e02_wp_,-1.093556195391091143924e01_wp_, &
1.001533852045342697818_wp_/)
!----------------------------------------------------------------------
! j-fraction coefficients for x >= 24.0
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
p2=(/ 1.75338801265465972390e02_wp_,-2.23127670777632409550e02_wp_, &
-1.81949664929868906455e01_wp_,-2.79798528624305389340e01_wp_, &
-7.63147701620253630855_wp_,-1.52856623636929636839e01_wp_, &
-7.06810977895029358836_wp_,-5.00006640413131002475_wp_, &
-3.00000000320981265753_wp_, 1.00000000000000485503_wp_/)
real(wp_), dimension(9), parameter :: &
q2=(/ 3.97845977167414720840e04_wp_, 3.97277109100414518365_wp_, &
1.37790390235747998793e02_wp_, 1.17179220502086455287e02_wp_, &
7.04831847180424675988e01_wp_,-1.20187763547154743238e01_wp_, &
-7.99243595776339741065_wp_,-2.99999894040324959612_wp_, &
1.99999999999048104167_wp_/)
!----------------------------------------------------------------------
x = arg
if (x == zero) then
ei = -xinf
if (intt == 2) ei = -ei
else if ((x < zero) .or. (intt == 2)) then
!----------------------------------------------------------------------
! calculate ei for negative argument or for e1.
!----------------------------------------------------------------------
y = abs(x)
if (y <= one) then
sump = a(7) * y + a(1)
sumq = y + b(1)
do i = 2, 6
sump = sump * y + a(i)
sumq = sumq * y + b(i)
end do
ei = log(y) - sump / sumq
if (intt == 3) ei = ei * exp(y)
else if (y <= four) then
w = one / y
sump = c(1)
sumq = d(1)
do i = 2, 9
sump = sump * w + c(i)
sumq = sumq * w + d(i)
end do
ei = - sump / sumq
if (intt /= 3) ei = ei * exp(-y)
else
if ((y > xbig) .and. (intt < 3)) then
ei = zero
else
w = one / y
sump = e(1)
sumq = f(1)
do i = 2, 10
sump = sump * w + e(i)
sumq = sumq * w + f(i)
end do
ei = -w * (one - w * sump / sumq )
if (intt /= 3) ei = ei * exp(-y)
end if
end if
if (intt == 2) ei = -ei
else if (x < six) then
!----------------------------------------------------------------------
! to improve conditioning, rational approximations are expressed
! in terms of chebyshev polynomials for 0 <= x < 6, and in
! continued fraction form for larger x.
!----------------------------------------------------------------------
t = x + x
t = t / three - two
px(1) = zero
qx(1) = zero
px(2) = p(1)
qx(2) = q(1)
do i = 2, 9
px(i+1) = t * px(i) - px(i-1) + p(i)
qx(i+1) = t * qx(i) - qx(i-1) + q(i)
end do
sump = half * t * px(10) - px(9) + p(10)
sumq = half * t * qx(10) - qx(9) + q(10)
frac = sump / sumq
xmx0 = (x - x01/x11) - x02
if (abs(xmx0) >= p037) then
ei = log(x/x0) + xmx0 * frac
if (intt == 3) ei = exp(-x) * ei
else
!----------------------------------------------------------------------
! special approximation to ln(x/x0) for x close to x0
!----------------------------------------------------------------------
y = xmx0 / (x + x0)
ysq = y*y
sump = plg(1)
sumq = ysq + qlg(1)
do i = 2, 4
sump = sump*ysq + plg(i)
sumq = sumq*ysq + qlg(i)
end do
ei = (sump / (sumq*(x+x0)) + frac) * xmx0
if (intt == 3) ei = exp(-x) * ei
end if
else if (x < twelve) then
frac = zero
do i = 1, 9
frac = s(i) / (r(i) + x + frac)
end do
ei = (r(10) + frac) / x
if (intt /= 3) ei = ei * exp(x)
else if (x <= two4) then
frac = zero
do i = 1, 9
frac = q1(i) / (p1(i) + x + frac)
end do
ei = (p1(10) + frac) / x
if (intt /= 3) ei = ei * exp(x)
else
if ((x >= xmax) .and. (intt < 3)) then
ei = xinf
else
y = one / x
frac = zero
do i = 1, 9
frac = q2(i) / (p2(i) + x + frac)
end do
frac = p2(10) + frac
ei = y + y * y * frac
if (intt /= 3) then
if (x <= xmax-two4) then
ei = ei * exp(x)
else
!----------------------------------------------------------------------
! calculation reformulated to avoid premature overflow
!----------------------------------------------------------------------
ei = (ei * exp(x-fourty)) * exp40
end if
end if
end if
end if
result = ei
end subroutine calcei
function ei(x)
!--------------------------------------------------------------------
!
! this function program computes approximate values for the
! exponential integral ei(x), where x is real.
!
! author: w. j. cody
!
! latest modification: january 12, 1988
!
!--------------------------------------------------------------------
implicit none
integer :: intt
real(wp_) :: ei
real(wp_), intent(in) :: x
real(wp_) :: result
!--------------------------------------------------------------------
intt = 1
call calcei(x,result,intt)
ei = result
end function ei
function expei(x)
!--------------------------------------------------------------------
!
! this function program computes approximate values for the
! function exp(-x) * ei(x), where ei(x) is the exponential
! integral, and x is real.
!
! author: w. j. cody
!
! latest modification: january 12, 1988
!
!--------------------------------------------------------------------
implicit none
integer :: intt
real(wp_) :: expei
real(wp_), intent(in) :: x
real(wp_) :: result
!--------------------------------------------------------------------
intt = 3
call calcei(x,result,intt)
expei = result
end function expei
function eone(x)
!--------------------------------------------------------------------
!
! this function program computes approximate values for the
! exponential integral e1(x), where x is real.
!
! author: w. j. cody
!
! latest modification: january 12, 1988
!
!--------------------------------------------------------------------
implicit none
integer :: intt
real(wp_) :: eone
real(wp_), intent(in) :: x
real(wp_) :: result
!--------------------------------------------------------------------
intt = 2
call calcei(x,result,intt)
eone = result
end function eone
! ======================================================================
! calcei3 = calcei for int=3
! ======================================================================
subroutine calcei3(arg,result)
!----------------------------------------------------------------------
!
! this fortran 77 packet computes the exponential integrals ei(x),
! e1(x), and exp(-x)*ei(x) for real arguments x where
!
! integral (from t=-infinity to t=x) (exp(t)/t), x > 0,
! ei(x) =
! -integral (from t=-x to t=infinity) (exp(t)/t), x < 0,
!
! and where the first integral is a principal value integral.
! the packet contains three function type subprograms: ei, eone,
! and expei; and one subroutine type subprogram: calcei. the
! calling statements for the primary entries are
!
! y = ei(x), where x /= 0,
!
! y = eone(x), where x > 0,
! and
! y = expei(x), where x /= 0,
!
! and where the entry points correspond to the functions ei(x),
! e1(x), and exp(-x)*ei(x), respectively. the routine calcei
! is intended for internal packet use only, all computations within
! the packet being concentrated in this routine. the function
! subprograms invoke calcei with the fortran statement
! call calcei(arg,result,int)
! where the parameter usage is as follows
!
! function parameters for calcei
! call arg result int
!
! ei(x) x /= 0 ei(x) 1
! eone(x) x > 0 -ei(-x) 2
! expei(x) x /= 0 exp(-x)*ei(x) 3
!----------------------------------------------------------------------
implicit none
real(wp_), intent(in) :: arg
real(wp_), intent(out) :: result
integer :: i
real(wp_) :: ei,frac,sump,sumq,t,w,x,xmx0,y,ysq
real(wp_), dimension(10) :: px,qx
!----------------------------------------------------------------------
! mathematical constants
! exp40 = exp(40)
! x0 = zero of ei
! x01/x11 + x02 = zero of ei to extra precision
!----------------------------------------------------------------------
real(wp_), parameter :: p037=0.037_wp_, &
x01=381.5_wp_, x11=1024.0_wp_, x02=-5.1182968633365538008e-5_wp_, &
x0=3.7250741078136663466e-1_wp_
!----------------------------------------------------------------------
! machine-dependent constants
!----------------------------------------------------------------------
real(wp_), parameter :: xinf=1.79e+308_wp_
!----------------------------------------------------------------------
! coefficients for -1.0 <= x < 0.0
!----------------------------------------------------------------------
real(wp_), dimension(7), parameter :: &
a=(/1.1669552669734461083368e2_wp_, 2.1500672908092918123209e3_wp_, &
1.5924175980637303639884e4_wp_, 8.9904972007457256553251e4_wp_, &
1.5026059476436982420737e5_wp_,-1.4815102102575750838086e5_wp_, &
5.0196785185439843791020_wp_/)
real(wp_), dimension(6), parameter :: &
b=(/4.0205465640027706061433e1_wp_, 7.5043163907103936624165e2_wp_, &
8.1258035174768735759855e3_wp_, 5.2440529172056355429883e4_wp_, &
1.8434070063353677359298e5_wp_, 2.5666493484897117319268e5_wp_/)
!----------------------------------------------------------------------
! coefficients for -4.0 <= x < -1.0
!----------------------------------------------------------------------
real(wp_), dimension(9), parameter :: &
c=(/3.828573121022477169108e-1_wp_, 1.107326627786831743809e+1_wp_, &
7.246689782858597021199e+1_wp_, 1.700632978311516129328e+2_wp_, &
1.698106763764238382705e+2_wp_, 7.633628843705946890896e+1_wp_, &
1.487967702840464066613e+1_wp_, 9.999989642347613068437e-1_wp_, &
1.737331760720576030932e-8_wp_/), &
d=(/8.258160008564488034698e-2_wp_, 4.344836335509282083360e+0_wp_, &
4.662179610356861756812e+1_wp_, 1.775728186717289799677e+2_wp_, &
2.953136335677908517423e+2_wp_, 2.342573504717625153053e+2_wp_, &
9.021658450529372642314e+1_wp_, 1.587964570758947927903e+1_wp_, &
1.000000000000000000000e+0_wp_/)
!----------------------------------------------------------------------
! coefficients for x < -4.0
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
e=(/1.3276881505637444622987e+2_wp_,3.5846198743996904308695e+4_wp_, &
1.7283375773777593926828e+5_wp_,2.6181454937205639647381e+5_wp_, &
1.7503273087497081314708e+5_wp_,5.9346841538837119172356e+4_wp_, &
1.0816852399095915622498e+4_wp_,1.0611777263550331766871e03_wp_, &
5.2199632588522572481039e+1_wp_,9.9999999999999999087819e-1_wp_/), &
f=(/3.9147856245556345627078e+4_wp_,2.5989762083608489777411e+5_wp_, &
5.5903756210022864003380e+5_wp_,5.4616842050691155735758e+5_wp_, &
2.7858134710520842139357e+5_wp_,7.9231787945279043698718e+4_wp_, &
1.2842808586627297365998e+4_wp_,1.1635769915320848035459e+3_wp_, &
5.4199632588522559414924e+1_wp_,1.0_wp_/)
!----------------------------------------------------------------------
! coefficients for rational approximation to ln(x/a), |1-x/a| < .1
!----------------------------------------------------------------------
real(wp_), dimension(4), parameter :: &
plg=(/-2.4562334077563243311e+01_wp_,2.3642701335621505212e+02_wp_, &
-5.4989956895857911039e+02_wp_,3.5687548468071500413e+02_wp_/), &
qlg=(/-3.5553900764052419184e+01_wp_,1.9400230218539473193e+02_wp_, &
-3.3442903192607538956e+02_wp_,1.7843774234035750207e+02_wp_/)
!----------------------------------------------------------------------
! coefficients for 0.0 < x < 6.0,
! ratio of chebyshev polynomials
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
p=(/-1.2963702602474830028590e01_wp_,-1.2831220659262000678155e03_wp_, &
-1.4287072500197005777376e04_wp_,-1.4299841572091610380064e06_wp_, &
-3.1398660864247265862050e05_wp_,-3.5377809694431133484800e08_wp_, &
3.1984354235237738511048e08_wp_,-2.5301823984599019348858e10_wp_, &
1.2177698136199594677580e10_wp_,-2.0829040666802497120940e11_wp_/),&
q=(/ 7.6886718750000000000000e01_wp_,-5.5648470543369082846819e03_wp_, &
1.9418469440759880361415e05_wp_,-4.2648434812177161405483e06_wp_, &
6.4698830956576428587653e07_wp_,-7.0108568774215954065376e08_wp_, &
5.4229617984472955011862e09_wp_,-2.8986272696554495342658e10_wp_, &
9.8900934262481749439886e10_wp_,-8.9673749185755048616855e10_wp_/)
!----------------------------------------------------------------------
! j-fraction coefficients for 6.0 <= x < 12.0
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
r=(/-2.645677793077147237806_wp_,-2.378372882815725244124_wp_, &
-2.421106956980653511550e01_wp_, 1.052976392459015155422e01_wp_, &
1.945603779539281810439e01_wp_,-3.015761863840593359165e01_wp_, &
1.120011024227297451523e01_wp_,-3.988850730390541057912_wp_, &
9.565134591978630774217_wp_, 9.981193787537396413219e-1_wp_/)
real(wp_), dimension(9), parameter :: &
s=(/ 1.598517957704779356479e-4_wp_, 4.644185932583286942650_wp_, &
3.697412299772985940785e02_wp_,-8.791401054875438925029_wp_, &
7.608194509086645763123e02_wp_, 2.852397548119248700147e01_wp_, &
4.731097187816050252967e02_wp_,-2.369210235636181001661e02_wp_, &
1.249884822712447891440_wp_/)
!----------------------------------------------------------------------
! j-fraction coefficients for 12.0 <= x < 24.0
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
p1=(/-1.647721172463463140042_wp_,-1.860092121726437582253e01_wp_, &
-1.000641913989284829961e01_wp_,-2.105740799548040450394e01_wp_, &
-9.134835699998742552432e-1_wp_,-3.323612579343962284333e01_wp_, &
2.495487730402059440626e01_wp_, 2.652575818452799819855e01_wp_, &
-1.845086232391278674524_wp_, 9.999933106160568739091e-1_wp_/)
real(wp_), dimension(9), parameter :: &
q1=(/ 9.792403599217290296840e01_wp_, 6.403800405352415551324e01_wp_, &
5.994932325667407355255e01_wp_, 2.538819315630708031713e02_wp_, &
4.429413178337928401161e01_wp_, 1.192832423968601006985e03_wp_, &
1.991004470817742470726e02_wp_,-1.093556195391091143924e01_wp_, &
1.001533852045342697818_wp_/)
!----------------------------------------------------------------------
! j-fraction coefficients for x >= 24.0
!----------------------------------------------------------------------
real(wp_), dimension(10), parameter :: &
p2=(/ 1.75338801265465972390e02_wp_,-2.23127670777632409550e02_wp_, &
-1.81949664929868906455e01_wp_,-2.79798528624305389340e01_wp_, &
-7.63147701620253630855_wp_,-1.52856623636929636839e01_wp_, &
-7.06810977895029358836_wp_,-5.00006640413131002475_wp_, &
-3.00000000320981265753_wp_, 1.00000000000000485503_wp_/)
real(wp_), dimension(9), parameter :: &
q2=(/ 3.97845977167414720840e04_wp_, 3.97277109100414518365_wp_, &
1.37790390235747998793e02_wp_, 1.17179220502086455287e02_wp_, &
7.04831847180424675988e01_wp_,-1.20187763547154743238e01_wp_, &
-7.99243595776339741065_wp_,-2.99999894040324959612_wp_, &
1.99999999999048104167_wp_/)
!----------------------------------------------------------------------
x = arg
if (x == zero) then
ei = -xinf
else if ((x < zero)) then
!----------------------------------------------------------------------
! calculate ei for negative argument or for e1.
!----------------------------------------------------------------------
y = abs(x)
if (y <= one) then
sump = a(7) * y + a(1)
sumq = y + b(1)
do i = 2, 6
sump = sump * y + a(i)
sumq = sumq * y + b(i)
end do
ei = (log(y) - sump / sumq ) * exp(y)
else if (y <= four) then
w = one / y
sump = c(1)
sumq = d(1)
do i = 2, 9
sump = sump * w + c(i)
sumq = sumq * w + d(i)
end do
ei = - sump / sumq
else
w = one / y
sump = e(1)
sumq = f(1)
do i = 2, 10
sump = sump * w + e(i)
sumq = sumq * w + f(i)
end do
ei = -w * (one - w * sump / sumq )
end if
else if (x < six) then
!----------------------------------------------------------------------
! to improve conditioning, rational approximations are expressed
! in terms of chebyshev polynomials for 0 <= x < 6, and in
! continued fraction form for larger x.
!----------------------------------------------------------------------
t = x + x
t = t / three - two
px(1) = zero
qx(1) = zero
px(2) = p(1)
qx(2) = q(1)
do i = 2, 9
px(i+1) = t * px(i) - px(i-1) + p(i)
qx(i+1) = t * qx(i) - qx(i-1) + q(i)
end do
sump = half * t * px(10) - px(9) + p(10)
sumq = half * t * qx(10) - qx(9) + q(10)
frac = sump / sumq
xmx0 = (x - x01/x11) - x02
if (abs(xmx0) >= p037) then
ei = exp(-x) * ( log(x/x0) + xmx0 * frac )
else
!----------------------------------------------------------------------
! special approximation to ln(x/x0) for x close to x0
!----------------------------------------------------------------------
y = xmx0 / (x + x0)
ysq = y*y
sump = plg(1)
sumq = ysq + qlg(1)
do i = 2, 4
sump = sump*ysq + plg(i)
sumq = sumq*ysq + qlg(i)
end do
ei = exp(-x) * (sump / (sumq*(x+x0)) + frac) * xmx0
end if
else if (x < twelve) then
frac = zero
do i = 1, 9
frac = s(i) / (r(i) + x + frac)
end do
ei = (r(10) + frac) / x
else if (x <= two4) then
frac = zero
do i = 1, 9
frac = q1(i) / (p1(i) + x + frac)
end do
ei = (p1(10) + frac) / x
else
y = one / x
frac = zero
do i = 1, 9
frac = q2(i) / (p2(i) + x + frac)
end do
frac = p2(10) + frac
ei = y + y * y * frac
end if
result = ei
end subroutine calcei3
! subroutine calerf(arg,result,jintt)
!!------------------------------------------------------------------
!!
!! this packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x)
!! for a real argument x. it contains three function type
!! subprograms: erf, erfc, and erfcx (or derf, derfc, and derfcx),
!! and one subroutine type subprogram, calerf. the calling
!! statements for the primary entries are:
!!
!! y=erf(x) (or y=derf(x)),
!!
!! y=erfc(x) (or y=derfc(x)),
!! and
!! y=erfcx(x) (or y=derfcx(x)).
!!
!! the routine calerf is intended for internal packet use only,
!! all computations within the packet being concentrated in this
!! routine. the function subprograms invoke calerf with the
!! statement
!!
!! call calerf(arg,result,jintt)
!!
!! where the parameter usage is as follows
!!
!! function parameters for calerf
!! call arg result jintt
!!
!! erf(arg) any real argument erf(arg) 0
!! erfc(arg) abs(arg) < xbig erfc(arg) 1
!! erfcx(arg) xneg < arg < xmax erfcx(arg) 2
!!
!!*******************************************************************
!!*******************************************************************
!!
!! Explanation of machine-dependent constants
!!
!! XMIN = the smallest positive floating-point number.
!! XINF = the largest positive finite floating-point number.
!! XNEG = the largest negative argument acceptable to ERFCX;
!! the negative of the solution to the equation
!! 2*exp(x*x) = XINF.
!! XSMALL = argument below which erf(x) may be represented by
!! 2*x/sqrt(pi) and above which x*x will not underflow.
!! A conservative value is the largest machine number X
!! such that 1.0 + X = 1.0 to machine precision.
!! XBIG = largest argument acceptable to ERFC; solution to
!! the equation: W(x) * (1-0.5/x**2) = XMIN, where
!! W(x) = exp(-x*x)/[x*sqrt(pi)].
!! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to
!! machine precision. A conservative value is
!! 1/[2*sqrt(XSMALL)]
!! XMAX = largest acceptable argument to ERFCX; the minimum
!! of XINF and 1/[sqrt(pi)*XMIN].
!!
!!*******************************************************************
!!*******************************************************************
!!
!! error returns
!!
!! the program returns erfc = 0 for arg >= xbig;
!!
!! erfcx = xinf for arg < xneg;
!! and
!! erfcx = 0 for arg >= xmax.
!!
!!
!! intrinsic functions required are:
!!
!! abs, aint, exp
!!
!!
!! author: w. j. cody
!! mathematics and computer science division
!! argonne national laboratory
!! argonne, il 60439
!!
!! latest modification: march 19, 1990
!!
!!------------------------------------------------------------------
! implicit none
! real(wp_), intent(in) :: arg
! real(wp_), intent(out) :: result
! integer, intent(in) :: jintt
! integer :: i
! real(wp_) :: del,x,xden,xnum,y,ysq
!!------------------------------------------------------------------
!! mathematical constants
!!------------------------------------------------------------------
! real(wp_), parameter :: sqrpi=5.6418958354775628695e-1_wp_, &
! thresh=0.46875_wp_
!!------------------------------------------------------------------
!! machine-dependent constants
!!------------------------------------------------------------------
! real(wp_), parameter :: xinf=1.79e308_wp_, & ! ~huge
! xneg=-26.628_wp_, & ! ?
! xsmall=1.11e-16_wp_, & ! ~epsilon/2
! xbig=26.543_wp_, & ! ?
! xhuge=6.71e7_wp_, & ! ~1/sqrt(epsilon)
! xmax=2.53e307_wp_ ! ?
!!------------------------------------------------------------------
!! coefficients for approximation to erf in first interval
!!------------------------------------------------------------------
! real(wp_), dimension(5), parameter :: &
! a=(/3.16112374387056560_wp_,1.13864154151050156e02_wp_, &
! 3.77485237685302021e02_wp_,3.20937758913846947e03_wp_, &
! 1.85777706184603153e-1_wp_/)
! real(wp_), dimension(4), parameter :: &
! b=(/2.36012909523441209e01_wp_,2.44024637934444173e02_wp_, &
! 1.28261652607737228e03_wp_,2.84423683343917062e03_wp_/)
!!------------------------------------------------------------------
!! coefficients for approximation to erfc in second interval
!!------------------------------------------------------------------
! real(wp_), dimension(9), parameter :: &
! c=(/5.64188496988670089e-1_wp_,8.88314979438837594_wp_, &
! 6.61191906371416295e01_wp_,2.98635138197400131e02_wp_, &
! 8.81952221241769090e02_wp_,1.71204761263407058e03_wp_, &
! 2.05107837782607147e03_wp_,1.23033935479799725e03_wp_, &
! 2.15311535474403846e-8_wp_/)
! real(wp_), dimension(8), parameter :: &
! d=(/1.57449261107098347e01_wp_,1.17693950891312499e02_wp_, &
! 5.37181101862009858e02_wp_,1.62138957456669019e03_wp_, &
! 3.29079923573345963e03_wp_,4.36261909014324716e03_wp_, &
! 3.43936767414372164e03_wp_,1.23033935480374942e03_wp_/)
!!------------------------------------------------------------------
!! coefficients for approximation to erfc in third interval
!!------------------------------------------------------------------
! real(wp_), dimension(6), parameter :: &
! p=(/3.05326634961232344e-1_wp_,3.60344899949804439e-1_wp_, &
! 1.25781726111229246e-1_wp_,1.60837851487422766e-2_wp_, &
! 6.58749161529837803e-4_wp_,1.63153871373020978e-2_wp_/)
! real(wp_), dimension(5), parameter :: &
! q=(/2.56852019228982242_wp_,1.87295284992346047_wp_, &
! 5.27905102951428412e-1_wp_,6.05183413124413191e-2_wp_, &
! 2.33520497626869185e-3_wp_/)
!!------------------------------------------------------------------
! x = arg
! y = abs(x)
! if (y <= thresh) then
!!------------------------------------------------------------------
!! evaluate erf for |x| <= 0.46875
!!------------------------------------------------------------------
! ysq = zero
! if (y > xsmall) ysq = y * y
! xnum = a(5)*ysq
! xden = ysq
! do i = 1, 3
! xnum = (xnum + a(i)) * ysq
! xden = (xden + b(i)) * ysq
! end do
! result = x * (xnum + a(4)) / (xden + b(4))
! if (jintt /= 0) result = one - result
! if (jintt == 2) result = exp(ysq) * result
! return
!!------------------------------------------------------------------
!! evaluate erfc for 0.46875 <= |x| <= 4.0
!!------------------------------------------------------------------
! else if (y <= four) then
! xnum = c(9)*y
! xden = y
! do i = 1, 7
! xnum = (xnum + c(i)) * y
! xden = (xden + d(i)) * y
! end do
! result = (xnum + c(8)) / (xden + d(8))
! if (jintt /= 2) then
! ysq = aint(y*sixten)/sixten
! del = (y-ysq)*(y+ysq)
! result = exp(-ysq*ysq) * exp(-del) * result
! end if
!!------------------------------------------------------------------
!! evaluate erfc for |x| > 4.0
!!------------------------------------------------------------------
! else if (y < xbig .or. (y < xmax .and. jintt == 2)) then
! ysq = one / (y * y)
! xnum = p(6)*ysq
! xden = ysq
! do i = 1, 4
! xnum = (xnum + p(i)) * ysq
! xden = (xden + q(i)) * ysq
! end do
! result = ysq *(xnum + p(5)) / (xden + q(5))
! result = (sqrpi - result) / y
! if (jintt /= 2) then
! ysq = aint(y*sixten)/sixten
! del = (y-ysq)*(y+ysq)
! result = exp(-ysq*ysq) * exp(-del) * result
! end if
! else if (y >= xhuge) then
! result = sqrpi / y
! else
! result = zero
! end if
!!------------------------------------------------------------------
!! fix up for negative argument, erf, etc.
!!------------------------------------------------------------------
! if (jintt == 0) then
! result = (half - result) + half
! if (x < zero) result = -result
! else if (jintt == 1) then
! if (x < zero) result = two - result
! else
! if (x < zero) then
! if (x < xneg) then
! result = xinf
! else
! ysq = aint(x*sixten)/sixten
! del = (x-ysq)*(x+ysq)
! y = exp(ysq*ysq) * exp(del)
! result = (y+y) - result
! end if
! end if
! end if
! end subroutine calerf
!
! function derf(x)
!!--------------------------------------------------------------------
!!
!! this subprogram computes approximate values for erf(x).
!! (see comments heading calerf).
!!
!! author/date: w. j. cody, january 8, 1985
!!
!!--------------------------------------------------------------------
! implicit none
! real(wp_) :: derf
! real(wp_), intent(in) :: x
! integer :: jintt
! real(wp_) :: result
!!------------------------------------------------------------------
! jintt = 0
! call calerf(x,result,jintt)
! derf = result
! end function derf
!
! function derfc(x)
!!--------------------------------------------------------------------
!!
!! this subprogram computes approximate values for erfc(x).
!! (see comments heading calerf).
!!
!! author/date: w. j. cody, january 8, 1985
!!
!!--------------------------------------------------------------------
! implicit none
! real(wp_) :: derfc
! real(wp_), intent(in) :: x
! integer :: jintt
! real(wp_) :: result
!!------------------------------------------------------------------
! jintt = 1
! call calerf(x,result,jintt)
! derfc = result
! end function derfc
!
! function derfcx(x)
!!------------------------------------------------------------------
!!
!! this subprogram computes approximate values for exp(x*x) * erfc(x).
!! (see comments heading calerf).
!!
!! author/date: w. j. cody, march 30, 1987
!!
!!------------------------------------------------------------------
! implicit none
! real(wp_) :: derfcx
! real(wp_), intent(in) :: x
! integer :: jintt
! real(wp_) :: result
!!------------------------------------------------------------------
! jintt = 2
! call calerf(x,result,jintt)
! derfcx = result
! end function derfcx
end module eierf

1085
src/equilibrium.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

891
src/gray-externals.f90 Normal file
View File

@ -0,0 +1,891 @@
! program gray
! use gray_params, only : ipass,igrad
! implicit none
!! local variables
! real(wp_) :: p0mw1
!! common/external functions/variables
! integer :: ierr,index_rt
! real(wp_) :: sox,p0mw,powrfl,taumn,taumx,pabstot,currtot,
!!
! common/ierr/ierr
! common/mode/sox
! common/p0/p0mw
! common/powrfl/powrfl
! common/index_rt/index_rt
! common/taumnx/taumn,taumx,pabstot,currtot
!!
! if (ipass.gt.1) then
!! 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.0_wp_-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
!!
! end program gray
!
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 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(sox,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(sox,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(sox,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.0e-2_wp_*sqrt(xv(1)**2+xv(2)**2)
! zzm=1.0e-2_wp_*xv(3)
! ywrk(1:3,j,k)=xv
! ywrk(4:6,j,k)=anv
! igrad=0
! call gwork(sox,xgcn,bres,j,k)
! if (ins_pl) then
! iop(j,k)=iop(j,k)+1
! call pol_limit(sox,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.0_wp_
! do j=1,nrayr
! kkk=nrayth
! if(j.eq.1) kkk=1
! do k=1,kkk
! print*,i,j,k
! print*,anwcl,xwcl,anvjk(1:2,j,k)
! 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.0_wp_
! end if
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!! single pass is stopped when all the rays have crossed the plasma
!! or complete absorption has occurred
!! same for successive passes of multi-pass simulations (here exit
!! from vessel is detected too
!! first pass in multi-pass simulation is stopped when at least one
!! ray has reflected and all rays are directed away from
!! reflection point, or when no reflection has occurred and
!! central ray re-enters the plasma
!
! if((ipass.eq.1 .and. ((iopmin.gt.1) .or.
! . (taumn.lt.1.0e+30_wp_.and.taumn.gt.taucr)))
! . .or.(index_rt.gt.1 .and. (iopmin.gt.1 .or. iowmin.gt.1 .or.
! . (taumn.lt.1.0e+30_wp_.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
!! flag second pass mode coupling as unset
! powrfl=-1.0_wp_
! qqout=0.0_wp_
! uuout=0.0_wp_
! vvout=0.0_wp_
! do j=1,nrayr
! kkk=nrayth
! if(j.eq.1) kkk=1
! do k=1,kkk
!! 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
!! determine mode coupling at the plasma boundary
! if (powrfl.lt.0.0_wp_) then
! call vacuum_rt(xvjk(:,j,k),anvjk(:,j,k),xvvac,ivac)
!! look for first ray hitting the plasma, starting from the central
!! and evaluate polarization
! if (ivac.eq.1) then
! y(1:3)=xvjk(:,j,k)
! y(4:6)=anvjk(:,j,k)
! call fwork(sox,xgcn,bres,y,dery)
! call pol_limit(sox,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
!! look for first ray which completed the first pass in the plasma
! if (iop(j1,k1).gt.1) then
!! 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
!! if no ray completed a first pass in the plasma, use central ray
!! initial polarization (possibly reflected)
! if (qqout.le.0.0_wp_) then
! call stokes(ext(1,1,0),eyt(1,1,0),qqout,uuout,vvout)
! end if
! powrfl=0.5_wp_*(1.0_wp_+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,*) psipol,chipol,powrfl
! istop=1
! end if
!
! return
! end
!
!
!
! subroutine ic_rt(x00,y00,z00,anx0c,any0c,anz0c,ak0,xgcn,bres,
! . wcsi,weta,rcicsi,rcieta,phiw,phir,sox,psipol0,chipol0)
!! ray tracing initial conditions igrad=0
!!
! use const_and_precisions, only : wp_,izero,zero,one,pi,
! . cvdr=>degree,ui=>im
! use gray_params, only : ipol
! use beamdata, only : nrayr,nrayth,rwmax,ywrk0=>ywrk,ypwrk0=>ypwrk,
! . xc0=>xc,du10=>du1,dffiu,ddffiu,grad2,dgrad2v,gri,ggri,ext,eyt
! implicit none
!! arguments
! real(wp_), intent(in) :: x00,y00,z00,anx0c,any0c,anz0c
! real(wp_), intent(in) :: ak0,xgcn,bres
! real(wp_), intent(in) :: wcsi,weta,rcicsi,rcieta,phiw,phir
! real(wp_), intent(in) :: sox,psipol0,chipol0
!! local constants
! integer, parameter :: ndim=6,ndimm=3
!! local variables
! integer :: j,k,iv,jv,iproj,nfilp
! real(wp_) :: csth,snth,csps,snps,phiwrad,csphiw,snphiw,dr,da,u,
! . alfak,dcsiw,detaw,dx0t,dy0t,x0t,y0t,z0t,dx0,dy0,dz0,x0,y0,z0,
! . anzt,anxt,anyt,anx,any,anz,an20,an0,anx0,any0,anz0,vgradi,r0,
! . x0m,y0m,r0m,z0m,ancsi,aneta,ppcsi,ppeta,deltapol,qq,uu,vv
! real(wp_), dimension(ndim) :: ytmp,yptmp
!! common/external functions/variables
! real(wp_) :: dd,an2s,an2,fdia,bdotgr,ddi,ddr11,psinv,dens,ddens,
! . tekev,anpl,anpr,brr,bphi,bzz,ajphi,psipol,chipol,psinv11
!
!!
! common/ddd/dd,an2s,an2,fdia,bdotgr,ddi,ddr11
! common/nplr/anpl,anpr
! common/psival/psinv
! common/parpl/brr,bphi,bzz,ajphi
! common/dens/dens,ddens
! common/tete/tekev
! common/polcof/psipol,chipol
! common/psinv11/psinv11
!!
! csth=anz0c
! snth=sqrt(1.0_wp_-csth**2)
! csps=1.0_wp_
! snps=0.0_wp_
! if(snth.gt.0.0_wp_) then
! csps=any0c/snth
! snps=anx0c/snth
! end if
!!
! phiwrad=phiw*cvdr
! csphiw=cos(phiwrad)
! snphiw=sin(phiwrad)
!!
! dr=1.0_wp_
! if(nrayr.gt.1) dr=rwmax/dble(nrayr-1)
! da=2.0_wp_*pi/dble(nrayth)
! z0t=0.0_wp_
!!
! do j=1,nrayr
! u=dble(j-1)
! dffiu(j)=0.0_wp_
! ddffiu(j)=0.0_wp_
! 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
!!
!! csiw=u*dcsiw
!! etaw=u*detaw
!! csir=csiw
!! etar=etaw
!!
! 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
!!
! ppcsi=u*dr*cos(alfak)*rcicsi
! ppeta=u*dr*sin(alfak)*rcieta
!!
! anzt=1.0_wp_/sqrt(1.0_wp_+ppcsi**2+ppeta**2)
! ancsi=ppcsi*anzt
! aneta=ppeta*anzt
!!
! anxt=ancsi*csphiw-aneta*snphiw
! anyt=ancsi*snphiw+aneta*csphiw
!!
! anx= anxt*csps+snps*(anyt*csth+anzt*snth)
! any=-anxt*snps+csps*(anyt*csth+anzt*snth)
! anz= anzt*csth-anyt*snth
!!
! an20=1.0_wp_
! an0=sqrt(an20)
! anx0=anx
! any0=any
! anz0=anz
!!
! xc0(1,j,k)=x0
! xc0(2,j,k)=y0
! xc0(3,j,k)=z0
!!
! 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
!!
! ypwrk0(1,j,k) = anx0/an0
! ypwrk0(2,j,k) = any0/an0
! ypwrk0(3,j,k) = anz0/an0
! ypwrk0(4,j,k) = 0.0_wp_
! ypwrk0(5,j,k) = 0.0_wp_
! ypwrk0(6,j,k) = 0.0_wp_
!!
! ytmp=ywrk0(:,j,k)
! yptmp=ypwrk0(:,j,k)
! call fwork(sox,xgcn,bres,ytmp,yptmp)
!
! if(ipol.eq.0) then
! call pol_limit(sox,ext(j,k,0),eyt(j,k,0))
! qq=abs(ext(j,k,0))**2-abs(eyt(j,k,0))**2
! uu=2.0_wp_*dble(ext(j,k,0)*dconjg(eyt(j,k,0)))
! vv=2.0_wp_*dimag(ext(j,k,0)*dconjg(eyt(j,k,0)))
! call polellipse(qq,uu,vv,psipol0,chipol0)
! else
! qq=cos(2.0_wp_*chipol0*cvdr)*cos(2.0_wp_*psipol0*cvdr)
! uu=cos(2.0_wp_*chipol0*cvdr)*sin(2.0_wp_*psipol0*cvdr)
! vv=sin(2.0_wp_*chipol0*cvdr)
! if(qq**2.lt.1.0_wp_) then
!! deltapol=phix-phiy, phix =0
! deltapol=atan2(vv,uu)
! ext(j,k,0)= sqrt((1.0_wp_+qq)/2)
! eyt(j,k,0)= sqrt((1.0_wp_-qq)/2)*exp(-ui*deltapol)
! else
! if(qq.gt.0.0_wp_) then
! ext(j,k,0)= 1.0_wp_
! eyt(j,k,0)= 0.0_wp_
! else
! eyt(j,k,0)= 1.0_wp_
! ext(j,k,0)= 0.0_wp_
! end if
! end if
! endif
! psipol=psipol0
! chipol=chipol0
!!
! do iv=1,3
! gri(iv,j,k)=0.0_wp_
! dgrad2v(iv,j,k)=0.0_wp_
! du10(iv,j,k)=0.0_wp_
! do jv=1,3
! ggri(iv,jv,j,k)=0.0_wp_
! end do
! end do
! grad2(j,k)=0.0_wp_
!!
! dd=anx0**2+any0**2+anz0**2-an20
! vgradi=0.0_wp_
! ddi=2.0_wp_*vgradi
!!
! r0=sqrt(x0**2+y0**2)
! x0m=x0/1.0e2_wp_
! y0m=y0/1.0e2_wp_
! r0m=r0/1.0e2_wp_
! z0m=z0/1.0e2_wp_
! 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
! psinv11=psinv
! write(17,99) zero,zero,zero,zero
! write(4,99) zero,r0m,z0m,atan2(y0m,x0m)*180.0_wp_/pi,
! . psinv,one,dens,tekev,brr,bphi,bzz,
! . ajphi*1.0e-6_wp_,sqrt(anpl**2+anpr**2),anpl,zero,
! . zero,zero,zero,zero,zero,zero,zero,one
! end if
! end do
! end do
!
! call pweigth
!!
! if(nrayr.gt.1) then
! iproj=0
! nfilp=8
! call projxyzt(iproj,nfilp)
! end if
!!
! return
!99 format(24(1x,e16.8e3))
!111 format(3i5,20(1x,e16.8e3))
! end
subroutine prfile
implicit none
write(4,*)' #sst R z phi psi rhot ne Te Btot '// &
'Nperp Npl ki alpha tau Pt dIds nh iohkw index_rt ddr'
write(8,*) ' #istep j k xt yt zt rt psin'
write(9,*) ' #istep j k xt yt zt rt psin'
write(17,*) ' #sst Dr_Nr1 Di_Nr1'
write(33,*) ' #i jk 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,*) '#rhop rhot Jphi Jcdb dPdV Icdins Pins'
write(66,*) "# psipol0 chipol0 powrfl"
end subroutine prfile
subroutine print_prof
use const_and_precisions, only : wp_
use equilibrium, only : psinr,nq,fq,frhotor,tor_curr_psi
use coreprofiles, only : density, temp
implicit none
! local constants
real(wp_), parameter :: eps=1.e-4_wp_
! local variables
integer :: i
real(wp_) :: psin,rhop,rhot,ajphi,te,qq
real(wp_) :: dens,ddens
write(55,*) ' #psi rhot ne Te q Jphi'
do i=1,nq
psin=psinr(i)
rhop=sqrt(psin)
call density(psin,dens,ddens)
te=temp(psin)
qq=fq(psin)
rhot=frhotor(rhop)
call tor_curr_psi(max(eps,psin),ajphi)
write(55,"(12(1x,e12.5))") psin,rhot,dens,te,qq,ajphi*1.e-6_wp_
end do
end subroutine print_prof
subroutine print_prof_an
use const_and_precisions, only : wp_
use coreprofiles, only : density, temp
use equilibrium, only : frhotor
implicit none
! local constants
integer, parameter :: nst=51
! local variables
integer :: i
real(wp_) :: psin,rhop,rhot,te
real(wp_) :: dens,ddens
write(55,*) ' #psi rhot ne Te'
do i=1,nst
psin=dble(i-1)/dble(nst-1)
rhop=sqrt(psin)
rhot=frhotor(rhop)
call density(psin,dens,ddens)
te=temp(psin)
write(55,"(12(1x,e12.5))") psin,rhot,dens,te
end do
end subroutine print_prof_an
subroutine surfq(psinq,qpsi,nq,qval)
use const_and_precisions, only : wp_
use equilibrium, only : rmaxis,zmaxis,zbinf,zbsup,frhotor
use magsurf_data, only : npoints,contours_psi
use utils, only : locate, intlin
implicit none
! arguments
integer, intent(in) :: nq
real(wp_), dimension(nq), intent(in) :: psinq,qpsi
real(wp_) :: qval
! local variables
integer :: ncnt,i1,ipr
real(wp_) :: rup,zup,rlw,zlw,rhot,psival
real(wp_), dimension(npoints) :: rcn,zcn
ncnt=(npoints-1)/2
! locate psi surface for q=qval
call locate(abs(qpsi),nq,qval,i1)
if (i1>0.and.i1<nq) then
call intlin(abs(qpsi(i1)),psinq(i1),abs(qpsi(i1+1)),psinq(i1+1),qval,psival)
rup=rmaxis
rlw=rmaxis
zup=(zbsup+zmaxis)/2.0_wp_
zlw=(zmaxis+zbinf)/2.0_wp_
ipr=1
call contours_psi(psival,rup,zup,rlw,zlw,rcn,zcn,ipr)
rhot=frhotor(sqrt(psival))
print'(4(a,f8.5))','q = ',qval, ' psi = ',psival, &
' rhop = ',sqrt(psival),' rhot = ',rhot
end if
end
subroutine bfield_res(rv,zv,nr,nz,bres)
use const_and_precisions, only : wp_
use equilibrium, only : bfield
implicit none
! arguments
integer, intent(in) :: nr, nz
real(wp_), intent(in) :: rv(nr), zv(nz), bres
! local constants
integer, parameter :: icmx=2002
! local variables
integer :: j,k,n,nconts,inc,nctot
integer, dimension(10) :: ncpts
real(wp_) :: btmx,btmn,zzk,rrj,bbphi,bbr,bbz,bbb
real(wp_), dimension(icmx) :: rrcb,zzcb
real(wp_), dimension(nr,nz) :: btotal
! Btotal on psi grid
btmx=-1.0e30_wp_
btmn=1.0e30_wp_
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)
enddo
enddo
! compute Btot=Bres/n with n=1,5
write(70,*)'#i Btot R z'
do n=1,5
bbb=bres/dble(n)
if (bbb.ge.btmn.and.bbb.le.btmx) then
nconts=size(ncpts)
nctot=size(rrcb)
call cniteq(rv,zv,btotal,nr,nz,bbb,nconts,ncpts,nctot,rrcb,zzcb)
do inc=1,nctot
write(70,'(i6,12(1x,e12.5))') inc,bbb,rrcb(inc),zzcb(inc)
end do
end if
write(70,*)
end do
end subroutine bfield_res
subroutine bres_anal(bres)
use const_and_precisions, only : wp_,pi
use equilibrium, only : aminor,rmaxis,zmaxis
implicit none
! arguments
real(wp_) :: bres
! local variables
integer :: i
integer, parameter :: ngrid=51
real(wp_) :: dxgrid
real(wp_), dimension(ngrid) :: rv,zv
dxgrid=2.0_wp_*aminor/dble(ngrid-1)
do i=1,ngrid
rv(i) = rmaxis - aminor + dxgrid*(i-1)
zv(i) = zmaxis - aminor + dxgrid*(i-1)
end do
call bfield_res(rv,zv,ngrid,ngrid,bres)
end subroutine bres_anal
subroutine cniteq(rqgrid,zqgrid,matr2dgrid,nr,nz,h,ncon,npts,icount,rcon,zcon)
use const_and_precisions, only : wp_
! v2.01 12/07/95 -- written by d v bartlett, jet joint undertaking.
! (based on an older code)
use const_and_precisions, only : wp_
implicit none
! arguments
integer, intent(in) :: nr,nz
real(wp_), dimension(nr), intent(in) :: rqgrid
real(wp_), dimension(nz), intent(in) :: zqgrid
real(wp_), dimension(nr,nz), intent(in) :: matr2dgrid
real(wp_), intent(in) :: h
integer, intent(inout) :: ncon, icount
integer, dimension(ncon), intent(out) :: npts
real(wp_), dimension(icount), intent(out) :: rcon,zcon
! local variables
integer :: i,j,k,l,nrqmax,iclast,mpl,ix,jx,mxr,n1,jm,jfor,lda,ldb
integer :: jabs,jnb,kx,ikx,itm,inext,in
integer, dimension(3,2) :: ja
integer, dimension(icount/2-1) :: lx
real(wp_) :: drgrd,dzgrd,ah,adn,px,x,y
real(wp_), dimension(nr*nz) :: a
logical :: flag1
px = 0.5_wp_
a = reshape(matr2dgrid,(/nr*nz/))
rcon = 0.0_wp_
zcon = 0.0_wp_
nrqmax = nr
drgrd = rqgrid(2) - rqgrid(1)
dzgrd = zqgrid(2) - zqgrid(1)
ncon = 0
npts = 0
iclast = 0
icount = 0
mpl = 0
ix = 0
mxr = nrqmax * (nz - 1)
n1 = nr - 1
do jx=2,n1
do jm=jx,mxr,nrqmax
j = jm + nrqmax
ah=a(j)-h
if (ah <= 0.0_wp_ .and. a(jm) > h .or. &
ah > 0.0_wp_ .and. a(jm) <= h) then
ix=ix+1
lx(ix)=-j
end if
if (ah <= 0.0_wp_ .and. a(j-1) > h .or. &
ah > 0.0_wp_ .and. a(j-1) <= h) then
ix=ix+1
lx(ix)=j
end if
end do
end do
do jm=nr,mxr,nrqmax
j = jm + nrqmax
ah=a(j)-h
if (ah <= 0.0_wp_ .and. a(j-1) > h .or. &
ah > 0.0_wp_ .and. a(j-1) <= h) then
ix=ix+1
lx(ix)=j
end if
if (ah <= 0.0_wp_ .and. a(jm) > h .or. &
ah > 0.0_wp_ .and. a(jm) <= h) then
ix=ix+1
lx(ix)=-j
end if
end do
do jm=1,mxr,nrqmax
j = jm + nrqmax
if (a(j) <= h .and. a(jm) > h .or. &
a(j) > h .and. a(jm) <= h) then
ix=ix+1
lx(ix) =-j
end if
end do
do j=2,nr
if (a(j) <= h .and. a(j-1) > h .or. &
a(j) > h .and. a(j-1) <= h) then
ix=ix+1
lx(ix)=j
end if
end do
if(ix<=0) return
bb: do
in=ix
jx=lx(in)
jfor=0
lda=1
ldb=2
do
if(jx<0) then
jabs=-jx
jnb = jabs - nrqmax
else
jabs=jx
jnb=jabs-1
end if
adn=a(jabs)-a(jnb)
if(adn/=0) px=(a(jabs)-h)/adn
kx = (jabs - 1) / nrqmax
ikx = jabs - nrqmax * kx - 1
if(jx<0) then
x = drgrd * ikx
y = dzgrd * (kx - px)
else
x = drgrd * (ikx - px)
y = dzgrd * kx
end if
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<=0) then
ja(1,1) = -jabs-1
j=2
end if
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<=0 .or. ikx<=0) then
lda=1
ldb=lda
else if (ikx + 1 - nr >= 0 .and. jx <= 0) then
lda=2
ldb=lda
else if(jfor/=0) then
lda=2
do i=1,3
if(jfor==ja(i,2)) then
lda=1
exit
end if
end do
ldb=lda
end if
flag1=.false.
aa: do k=1,3
do l=lda,ldb
do i=1,ix
if(lx(i)==ja(k,l)) then
itm=itm+1
inext= i
if(jfor/=0) exit aa
if(itm .gt. 3) then
flag1=.true.
exit aa
end if
end if
end do
end do
end do aa
if(.not.flag1) then
lx(in)=0
if(itm .eq. 1) exit
end if
jfor=jx
jx=lx(inext)
in = inext
end do
do
if(lx(ix)/=0) then
if(mpl>=4) then
ncon = ncon + 1
npts(ncon) = icount - iclast
iclast = icount
end if
exit
end if
ix= ix-1
if(ix<=0) exit bb
end do
end do bb
if(mpl >= 4) then
ncon = ncon + 1
npts(ncon) = icount - iclast
iclast = icount
end if
end subroutine cniteq
logical function inside_plasma(rrm,zzm)
use const_and_precisions, only : wp_, zero, one
use gray_params, only : iequil
use coreprofiles, only : psdbnd
use equilibrium, only : zbinf,zbsup,equinum_psi,equian
implicit none
! arguments
real(wp_), intent(in) :: rrm,zzm
! local variables
real(wp_) :: psinv
if(iequil.eq.1) then
call equian(rrm,zzm,psinv)
else
call equinum_psi(rrm,zzm,psinv)
end if
inside_plasma = (psinv >= zero .and. psinv < psdbnd) .and. &
(psinv >= one .or. (zzm >= zbinf .and. zzm <= zbsup))
end function inside_plasma
subroutine vacuum_rt(xv0,anv0,xvend,dstvac,ivac)
use const_and_precisions, only : wp_
use reflections, only : inters_linewall,inside,rlim,zlim,nlim
use beamdata, only : dst
implicit none
! arguments
real(wp_), dimension(3), intent(in) :: xv0,anv0
real(wp_), dimension(3), intent(out) :: xvend
real(wp_), intent(out) :: dstvac
integer, intent(out) :: ivac
! local variables
integer :: i
real(wp_) :: st,rrm,zzm,smax
real(wp_), dimension(3) :: walln
logical :: plfound
! common/external functions/variables
logical, external :: inside_plasma
! ivac=1 plasma hit before wall reflection
! ivac=2 wall hit before plasma
! ivac=-1 vessel (and thus plasma) never crossed
call inters_linewall(xv0/1.0e2_wp_,anv0,rlim(1:nlim),zlim(1:nlim), &
nlim,smax,walln)
smax=smax*1.0e2_wp_
rrm=1.0e-2_wp_*sqrt(xv0(1)**2+xv0(2)**2)
zzm=1.0e-2_wp_*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.0_wp_
xvend=xv0
ivac=-1
return
end if
! search second wall interface (inside-outside)
st=smax
xvend=xv0+st*anv0
call inters_linewall(xvend/1.0e2_wp_,anv0,rlim(1:nlim), &
zlim(1:nlim),nlim,smax,walln)
smax=smax*1.0e2_wp_+st
end if
i=0
do
st=i*dst
xvend=xv0+st*anv0
rrm=1.0e-2_wp_*sqrt(xvend(1)**2+xvend(2)**2)
zzm=1.0e-2_wp_*xvend(3)
plfound=inside_plasma(rrm,zzm)
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
end subroutine vacuum_rt

7700
src/gray.f
View File

File diff suppressed because it is too large Load Diff

208
src/gray_params.f90 Normal file
View File

@ -0,0 +1,208 @@
module gray_params
use const_and_precisions, only : wp_
implicit none
integer, parameter :: lenfnm=256
type antctrl_type
real(wp_) :: alpha, beta, power
real(wp_) :: psi, chi
integer :: iox
integer :: ibeam
character(len=lenfnm) :: filenm
end type antctrl_type
type eqparam_type
real(wp_) :: ssplps, ssplf, factb
integer :: sgnb, sgni, ixp
integer :: iequil, icocos, ipsinorm, idesc, ifreefmt
character(len=lenfnm) :: filenm
end type eqparam_type
type prfparam_type
real(wp_) :: psnbnd, sspld, factne, factte
integer :: iscal, irho !, icrho, icte, icne, iczf
integer :: iprof
character(len=lenfnm) :: filenm
end type prfparam_type
type rtrparam_type
real(wp_) :: rwmax, dst
integer :: nrayr, nrayth, nstep
integer :: igrad, idst, ipass, ipol
end type rtrparam_type
type hcdparam_type
integer :: iwarm, ilarm, imx, ieccd
end type hcdparam_type
type outparam_type
integer :: ipec, nrho, istpr, istpl
end type outparam_type
integer, save :: iequil,iprof,ipol
integer, save :: iwarm,ilarm,imx,ieccd
integer, save :: igrad,idst,ipass
integer, save :: istpr0,istpl0
integer, save :: ipec,nnd
contains
subroutine read_inputs(filenm,antctrl,eqparam,rwall,prfparam,outparam,unit)
use const_and_precisions, only : wp_
use utils, only : get_free_unit
implicit none
! arguments
character(len=*), intent(in) :: filenm
type(antctrl_type), intent(out) :: antctrl
type(eqparam_type), intent(out) :: eqparam
real(wp_), intent(out) :: rwall
type(prfparam_type), intent(out) :: prfparam
type(outparam_type), intent(out) :: outparam
integer, intent(in), optional :: unit
! local variables
integer :: u
if (present(unit)) then
u=unit
else
u = get_free_unit()
end if
open(u,file=filenm,status= 'old',action='read')
! alpha0, beta0 (cartesian) launching angles
read(u,*) antctrl%alpha, antctrl%beta
! p0mw injected power (MW)
read(u,*) antctrl%power
! abs(iox)=1/2 OM/XM
! psipol0,chipol0 polarization angles at the antenna (if iox<0)
read(u,*) antctrl%iox, antctrl%psi, antctrl%chi
! ibeam=0 :read data for beam as above
! ibeam=1 :read data from file simple astigmatic beam
! ibeam=2 :read data from file general astigmatic beam
read(u,*) antctrl%ibeam
read(u,*) antctrl%filenm
! iequil=0 :vacuum
! iequil=1 :analytical equilibrium
! iequil=2 :read eqdsk
read(u,*) eqparam%iequil
read(u,*) eqparam%filenm
! icocos :index for equilibrium from COCOS - O. Sauter Feb 2012
! ipsinorm :0 standard EQDSK format, 1 format Portone summer 2004
read(u,*) eqparam%icocos, eqparam%ipsinorm, eqparam%idesc, eqparam%ifreefmt
! ixp=0,-1,+1 : no X point , bottom/up X point
! ssplps : spline parameter for psi interpolation
read(u,*) eqparam%ixp, eqparam%ssplps !, eqparam%ssplf
eqparam%ssplf=0.01_wp_
! signum of toroidal B and I
! factb factor for magnetic field (only for numerical equil)
! scaling adopted: beta=const, qpsi=const, nustar=const
read(u,*) eqparam%sgnb, eqparam%sgni, eqparam%factb
read(u,*) rwall
! iprof=0 :analytical density and temp. profiles
! iprof>0 :numerical density and temp. profiles
read(u,*) prfparam%iprof, prfparam%irho ! irho=0,1,2 -> num profiles vs rhot,rhop,psin
read(u,*) prfparam%filenm
! psbnd value of psi ( > 1 ) of density boundary
read(u,*) prfparam%psnbnd !, prfparam%sspld
prfparam%sspld=0.001_wp_
! iscal ne Te scaling 0: nustar=const, 1: n_greenw=const; 2 no rescaling
! factT factn factor for Te&ne scaling
read(u,*) prfparam%factte, prfparam%factne, prfparam%iscal
! ipec=0/1 :pec profiles grid in psi/rhop
! nrho :number of grid steps for pec profiles +1
read(u,*) outparam%ipec, outparam%nrho
! istpr0 projection step = dsdt*istprj
! istpl0 plot step = dsdt*istpl
read(u,*) outparam%istpr, outparam%istpl
close(u)
end subroutine read_inputs
subroutine read_params(filenm,rtrparam,hcdparam,unit)
use utils, only : get_free_unit
implicit none
! arguments
character(len=*), intent(in) :: filenm
type(rtrparam_type), intent(out) :: rtrparam
type(hcdparam_type), intent(out) :: hcdparam
integer, intent(in), optional :: unit
! local variables
integer :: u
if (present(unit)) then
u=unit
else
u = get_free_unit()
end if
open(u,file=filenm,status= 'old',action='read')
! nrayr number of rays in radial direction
! nrayth number of rays in angular direction
! rwmax normalized maximum radius of beam power
! rwmax=1 -> last ray at radius = waist
read(u,*) rtrparam%nrayr, rtrparam%nrayth, rtrparam%rwmax
! igrad=0 optical ray-tracing, initial conditions as for beam
! igrad=1 quasi-optical ray-tracing
! igrad=-1 ray-tracing, init. condit.
! from center of mirror and with angular spread
! ipass=1/2 1 or 2 passes into plasma
! ipol=0 compute mode polarization at antenna, ipol=1 use polariz angles
read(u,*) rtrparam%igrad, rtrparam%ipass, rtrparam%ipol
! dst integration step
! nstep maximum number of integration steps
! idst=0/1/2 0 integration in s, 1 integr. in ct, 2 integr. in Sr
read(u,*) rtrparam%dst, rtrparam%nstep, rtrparam%idst
! iwarm=0 :no absorption and cd
! iwarm=1 :weakly relativistic absorption
! iwarm=2 :relativistic absorption, n<1 asymptotic expansion
! iwarm=3 :relativistic absorption, numerical integration
! ilarm :order of larmor expansion
! imx :max n of iterations in dispersion, imx<0 uses 1st
! iteration in case of failure after |imx| iterations
read(u,*) hcdparam%iwarm,hcdparam%ilarm,hcdparam%imx
! ieccd 0/1 NO/YES ECCD calculation ieccd>0 different CD models
read(u,*) hcdparam%ieccd
close(u)
end subroutine read_params
subroutine set_codepar(eqparam,prfparam,outparam,rtrparam,hcdparam)
implicit none
type(eqparam_type), intent(in) :: eqparam
type(prfparam_type), intent(in) :: prfparam
type(outparam_type), intent(in) :: outparam
type(rtrparam_type), intent(in) :: rtrparam
type(hcdparam_type), intent(in) :: hcdparam
iequil=eqparam%iequil
iprof=prfparam%iprof
ipec=outparam%ipec
nnd=outparam%nrho
istpr0=outparam%istpr
istpl0=outparam%istpl
ipol=rtrparam%ipol
igrad=rtrparam%igrad
idst=rtrparam%idst
ipass=rtrparam%ipass
if (rtrparam%nrayr<5) then
igrad=0
print*,' nrayr < 5 ! => OPTICAL CASE ONLY'
print*,' '
end if
iwarm=hcdparam%iwarm
ilarm=hcdparam%ilarm
imx=hcdparam%imx
ieccd=hcdparam%ieccd
end subroutine set_codepar
end module gray_params

1389
src/graycore.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

11681
src/grayl.f
View File

File diff suppressed because it is too large Load Diff

437
src/green_func_p.f90
View File

@ -1,437 +0,0 @@
!########################################################################
MODULE green_func_p
!########################################################################
!
! The module contains few subroutines which are requested to calculate
! the current drive value by adjoint approach
!
!########################################################################
USE const_and_precisions
!-------
IMPLICIT NONE
CHARACTER(Len=1), PRIVATE :: adj_appr(6) ! adjoint approach switcher
!-------
REAL(wp_), PRIVATE :: r2,q2,gp1,Rfactor
!-------
REAL(wp_), PRIVATE, PARAMETER :: delta = 1e-4 ! border for recalculation
!------- for N.M. subroutines (variational principle) -------
REAL(wp_), PRIVATE :: sfd(1:4)
INTEGER, PRIVATE, PARAMETER :: nre = 2 ! order of rel. correct.
REAL(wp_), PRIVATE, PARAMETER :: vp_mee(0:4,0:4,0:2) = &
RESHAPE((/0.0, 0.0, 0.0, 0.0, 0.0, &
0.0, 0.184875, 0.484304, 1.06069, 2.26175, &
0.0, 0.484304, 1.41421, 3.38514, 7.77817, &
0.0, 1.06069, 3.38514, 8.73232, 21.4005, &
0.0, 2.26175, 7.77817, 21.4005, 55.5079, &
! &
0.0, -1.33059,-2.57431, -5.07771, -10.3884, &
-0.846284,-1.46337, -1.4941, -0.799288, 2.57505, &
-1.1601, -1.4941, 2.25114, 14.159, 50.0534, &
-1.69257, -0.799288, 14.159, 61.4168, 204.389, &
-2.61022, 2.57505, 50.0534, 204.389, 683.756, &
! &
0.0, 2.62498, 0.985392,-5.57449, -27.683, &
0.0, 3.45785, 5.10096, 9.34463, 22.9831, &
-0.652555, 5.10096, 20.5135, 75.8022, 268.944, &
-2.11571, 9.34463, 75.8022, 330.42, 1248.69, &
-5.38358, 22.9831, 268.944, 1248.69, 4876.48/),&
(/5,5,3/))
REAL(wp_), PRIVATE, PARAMETER :: vp_mei(0:4,0:4,0:2) = &
RESHAPE((/0.0, 0.886227, 1.0, 1.32934, 2.0, &
0.886227,1.0, 1.32934, 2.0, 3.32335, &
1.0, 1.32934, 2.0, 3.32335, 6.0, &
1.32934, 2.0, 3.32335, 6.0, 11.6317, &
2.0, 3.32335, 6.0, 11.6317, 24.0, &
! &
0.0, 0.332335, 1.0, 2.49251, 6.0, &
1.66168, 1.0, 2.49251, 6.0, 14.5397, &
3.0, 2.49251, 6.0, 14.5397, 36.0, &
5.81586, 6.0, 14.5397, 36.0, 91.5999, &
12.0, 14.5397, 36.0, 91.5999, 240.0, &
! &
0.0, -0.103855, 0.0, 1.09047, 6.0, &
0.726983,0.0, 1.09047, 6.0, 24.5357, &
3.0, 1.09047, 6.0, 24.5357, 90.0, &
9.81427, 6.0, 24.5357, 90.0, 314.875, &
30.0, 24.5357, 90.0, 314.875, 1080.0 /), &
(/5,5,3/))
REAL(wp_), PRIVATE, PARAMETER :: vp_oee(0:4,0:4,0:2) = &
RESHAPE((/0.0, 0.56419, 0.707107, 1.0073, 1.59099, &
0.56419, 0.707107, 1.0073, 1.59099, 2.73981, &
0.707107,1.0073, 1.59099, 2.73981, 5.08233, &
1.0073, 1.59099, 2.73981, 5.08233, 10.0627, &
1.59099, 2.73981, 5.08233, 10.0627, 21.1138, &
! &
0.0, 1.16832, 1.90035, 3.5758, 7.41357, &
2.17562, 1.90035, 3.5758, 7.41357, 16.4891, &
3.49134, 3.5758, 7.41357, 16.4891, 38.7611, &
6.31562, 7.41357, 16.4891, 38.7611, 95.4472, &
12.4959, 16.4891, 38.7611, 95.4472, 244.803, &
! &
0.0, 2.65931, 4.64177, 9.6032, 22.6941, &
4.8652, 4.64177, 9.6032, 22.6941, 59.1437, &
9.51418, 9.6032, 22.6941, 59.1437, 165.282, &
21.061, 22.6941, 59.1437, 165.282, 485.785, &
50.8982, 59.1437, 165.282, 485.785, 1483.22/), &
(/5,5,3/))
REAL(wp_), PRIVATE, PARAMETER :: vp_g(0:4,0:2) = &
RESHAPE((/1.32934, 2.0, 3.32335, 6.0, 11.6317, &
2.49251, 0.0, 2.90793, 12.0, 39.2571, &
1.09047, 6.0, 11.45, 30.0, 98.9606/), &
(/5,3/))
!########################################################################
CONTAINS
!#######################################################################
SUBROUTINE Setup_SpitzFunc
!=======================================================================
IMPLICIT NONE
!=======================================================================
adj_appr(1) = 'l' ! collisionless limit
! adj_appr(1) = 'c' ! collisional (classical) limit, w/o trap. part.
adj_appr(2) = 'm' ! momentum conservation
! adj_appr(2) = 'h' ! high-speed limit
!---
adj_appr(3) = 'l' ! DO NOT CHANGE!
adj_appr(4) = 'r' ! DO NOT CHANGE!
adj_appr(5) = 'v' ! DO NOT CHANGE!
adj_appr(6) = 'i' ! DO NOT CHANGE!
!=======================================================================
!.....
!=======================================================================
RETURN
END SUBROUTINE Setup_SpitzFunc
SUBROUTINE GenSpitzFunc(Te,Zeff,fc,u,q,gam, K,dKdu)
!=======================================================================
! Author: N.B.Marushchenko
! June 2005: as start point the subroutine of Ugo Gasparino (198?)
! SpitzFunc() is taken and modified.
! 1. adapted to the Fortran-95
! 2. derivative of Spitzer function is added
! 3. separation for 2 brunches is done:
! 1st is referenced as 'with conservation of the moment',
! 2nd - as 'high speed limit'.
! The last one is taken from the Lin-Liu formulation
! (Phys.Plasmas 10 (2003) 4064) with K = F*fc.
! The asymptotical high speed limit (Taguchi-Fisch model)
! is also included as the reference case.
! Feb. 2008: non-relativ. version is replaced by the relativistic one;
! the method is the the same, but the trial-function is
! based on the relativistic formulation.
! The relativistic corrections for the collisional operator
! up to the second order, i.e. (1/mu)**2, are applied.
! Sep. 2008: generalized Spitzer function for arbitrary collisionality
! is implemented. The model is based on the concept of
! the "effective trapped particles fraction".
! The different.-integral kinetic equation for the generalized
! Spitzer function is produced with help of subroutines
! ArbColl_TrappFract_Array and ArbColl_SpitzFunc_Array,
! where the subroutines of H. Maassberg are called).
!========================================================================
! Spitzer function with & w/o trapped particle effects is given by:
!
! K(x) = x/gamma*(d1*x+d2*x^2+d4*x^3+d4*x^4),
!
! where x = v/v_th and gamma=1 for non-relativistic version (Ugo),
! or x = p/p_th for relativistic version (N.M., February 2008).
! Note, that somewhere the function F(x) instead of K(x) is applied,
!
! F(x) = K(x)/fc.
!
! Numerical inversion of the 5x5 symmetric matrix obtained from the
! generalized Spitzer problem (see paper of Taguchi for the equation
! and paper of Hirshman for the variational approach bringing to the
! matrix to be inverted).
!
! The numerical method used is an improved elimination scheme
! (Banachiewiczs-Cholesky-Crout method).
! This method is particularly simple for symmetric matrix.
! As a reference see "Mathematical Handbook" by Korn & Korn, p.635-636.
!
! Refs.: 1. S.P. Hirshman, Phys. Fluids 23 (1980) 1238
! 2. M. Rome' et al., Plasma Phys. Contr. Fus. 40 (1998) 511
! 3. N.B. Marushchenko et al., Fusion Sci. Technol. 55 (2009) 180
!========================================================================
! INPUTS:
! u - p/sqrt(2mT)
! q - p/mc;
! gam - relativistic factor;
! mu - mc2/Te
! Zeff - effective charge;
! fc - fraction of circulating particles.
!
! OUTPUTS:
! K - Spitzer's function
! dKdu = dK/du, i.e. its derivative over normalized momentum
!=======================================================================
IMPLICIT NONE
REAL(wp_), INTENT(in) :: Te,Zeff,fc,u,q,gam
REAL(wp_), INTENT(out) :: K,dKdu
REAL(wp_) :: mu,gam1,gam2,gam3,w,dwdu
!=======================================================================
K = 0
dKdu = 0
IF (u < comp_eps) RETURN
!---
mu = mc2_/max(Te,1d-3)
SELECT CASE(adj_appr(2))
CASE('m') !--------------- momentum conservation ------------------!
gam1 = gam !
IF (adj_appr(4) == 'n') gam1 = 1 !
gam2 = gam1*gam1 !
gam3 = gam1*gam2 !
K = u/gam1*u*(sfd(1)+u*(sfd(2)+u*(sfd(3)+u*sfd(4)))) !
dKdu = u/gam3* (sfd(1)*(1+ gam2)+u*(sfd(2)*(1+2*gam2)+ & !
u*(sfd(3)*(1+3*gam2)+u* sfd(4)*(1+4*gam2)))) !
!--------------------- end momentum conservation -------------------!
CASE('h') !---------------- high-speed-limit ----------------------!
IF (adj_appr(4) == 'n') THEN !- non-relativ. asymptotic form -!
K = u**4 *fc/(Zeff+1+4*fc) !- (Taguchi-Fisch model) -!
dKdu = 4*u**3 *fc/(Zeff+1+4*fc) !
ELSEIF (adj_appr(4) == 'r') THEN !- relativistic, Lin-Liu form. -!
CALL SpitzFunc_HighSpeedLimit(Zeff,fc,u,q,gam, K,dKdu) !
ENDIF !
CASE default !----------------------------------------------------!
PRINT*,'GenSpitzFunc: WARNING! Spitzer function is not defined.'
RETURN
END SELECT
!=======================================================================
RETURN
END SUBROUTINE GenSpitzFunc
!#######################################################################
!#######################################################################
!#######################################################################
SUBROUTINE SpitzFuncCoeff(Te,Zeff,fc)
!=======================================================================
! Calculates the matrix coefficients required for the subroutine
! "GenSpitzFunc", where the Spitzer function is defined through the
! variational principle.
!
! Weakly relativistic (upgraded) version (10.09.2008).
! Apart of the non-relativistic matrix coefficients, taken from the
! old subroutine of Ugo Gasparino, the relativistic correction written
! as series in 1/mu^n (mu=mc2/T) powers is added. Two orders are taken
! into account, i.e. n=0,1,2.
!
! In this version, the coefficients "oee", i.e. Omega_ij, are formulated
! for arbitrary collisionality.
!
! INPUT VARIABLES:
! rho = sqrt(SS) with SS - flux-surface label (norm. magn. flux)
! ne - density, 1/m^3
! Te - temperature, keV
! Zeff - effective charge
! fc - fraction of circulating particles
!
! OUTPUT VARIABLES (defined as a global ones):
! sfd(1),...,sfd(4) - coefficients of the polynomial expansion of the
! "Spitzer"-function (the same as in the Hirshman paper)
!=======================================================================
IMPLICIT NONE
REAL(wp_), INTENT(in) :: Te,Zeff,fc
INTEGER :: n,i,j
REAL(wp_) :: rtc,rtc1,mu,y,tn(1:nre)
REAL(wp_) :: m(0:4,0:4),g(0:4)
REAL(wp_) :: om(0:4,0:4)
REAL(wp_) :: gam11,gam21,gam31,gam41,gam01, &
gam22,gam32,gam42,gam02, &
gam33,gam43,gam03, &
gam44,gam04,gam00
REAL(wp_) :: alp12,alp13,alp14,alp10, &
alp23,alp24,alp20, &
alp34,alp30,alp40
REAL(wp_) :: bet0,bet1,bet2,bet3,bet4,d0
LOGICAL :: renew,rel,newTe,newne,newZ,newfc
REAL(wp_), SAVE :: sfdx(1:4) = 0
REAL(wp_), SAVE :: ne_old =-1, Te_old =-1, Zeff_old =-1, fc_old =-1
!=======================================================================
rel = Te > 1
newTe = abs(Te -Te_old ) > delta*Te
newZ = abs(Zeff-Zeff_old) > delta*Zeff
newfc = abs(fc -fc_old ) > delta*fc
SELECT CASE(adj_appr(1))
CASE ('l','c')
renew = (newTe .and. rel) .OR. newZ .OR. newfc
END SELECT
!---
IF (.not.renew) THEN
sfd(:) = sfdx(:)
RETURN
ENDIF
!=======================================================================
tn(:) = 0
IF (adj_appr(4) == 'r') THEN
IF (nre > 0) THEN
mu = mc2_/max(Te,1d-3)
tn(1) = 1/mu
DO n=2,min(2,nre)
tn(n) = tn(n-1)/mu
ENDDO
ENDIF
ENDIF
!---
SELECT CASE(adj_appr(1))
CASE ('l','c') !---- both classical & collisionless limits ----!
rtc = (1-fc)/fc; rtc1 = rtc+1 !
!--- !
DO i=0,4 !
g(i) = vp_g(i,0) !
DO n=1,min(2,nre) !
g(i) = g(i) + tn(n)*vp_g(i,n) !
ENDDO !
!--- !
DO j=0,4 !
IF (i == 0 .or. j == 0 .or. j >= i) THEN !
y = vp_mee(i,j,0) + rtc *vp_oee(i,j,0) + & !
Zeff*rtc1*vp_mei(i,j,0) !
DO n=1,min(2,nre) !
y = y + (vp_mee(i,j,n) + rtc *vp_oee(i,j,n) + & !
Zeff*rtc1*vp_mei(i,j,n))*tn(n) !
ENDDO !
m(i,j) = y !
ENDIF !
ENDDO !
ENDDO !
DO i=2,4 !
DO j=1,i-1 !
m(i,j) = m(j,i) !
ENDDO !
ENDDO !
m(0,0) = 0 !
CASE default !------------------------------------------------!
PRINT*,'Green_Func: WARNING! Adjoint approach is not defined.'
RETURN
END SELECT
!=======================================================================
gam11 = m(1,1)
gam21 = m(2,1)
gam31 = m(3,1)
gam41 = m(4,1)
gam01 = m(0,1)
!
alp12 = m(1,2)/m(1,1)
alp13 = m(1,3)/m(1,1)
alp14 = m(1,4)/m(1,1)
alp10 = m(1,0)/m(1,1)
!
gam22 = m(2,2)-gam21*alp12
gam32 = m(3,2)-gam31*alp12
gam42 = m(4,2)-gam41*alp12
gam02 = m(0,2)-gam01*alp12
!
alp23 = gam32/gam22
alp24 = gam42/gam22
alp20 = gam02/gam22
!
gam33 = m(3,3)-gam31*alp13-gam32*alp23
gam43 = m(4,3)-gam41*alp13-gam42*alp23
gam03 = m(0,3)-gam01*alp13-gam02*alp23
!
alp34 = gam43/gam33
alp30 = gam03/gam33
!
gam44 = m(4,4)-gam41*alp14-gam42*alp24-gam43*alp34
gam04 = m(0,4)-gam01*alp14-gam02*alp24-gam03*alp34
!
alp40 = gam04/gam44
!
gam00 = m(0,0)-gam01*alp10-gam02*alp20-gam03*alp30-gam04*alp40
!
bet1 = g(1)/m(1,1)
bet2 = (g(2)-gam21*bet1)/gam22
bet3 = (g(3)-gam31*bet1-gam32*bet2)/gam33
bet4 = (g(4)-gam41*bet1-gam42*bet2-gam43*bet3)/gam44
bet0 = (g(0)-gam01*bet1-gam02*bet2-gam03*bet3-gam04*bet4)/gam00
!
d0 = bet0
sfd(4) = bet4-alp40*d0
sfd(3) = bet3-alp30*d0-alp34*sfd(4)
sfd(2) = bet2-alp20*d0-alp24*sfd(4)-alp23*sfd(3)
sfd(1) = bet1-alp10*d0-alp14*sfd(4)-alp13*sfd(3)-alp12*sfd(2)
!=======================================================================
fc_old = fc
Te_old = Te
Zeff_old = Zeff
!---
sfdx(1:4) = sfd(1:4)
!=======================================================================
RETURN
END SUBROUTINE SpitzFuncCoeff
!#######################################################################
!#######################################################################
!#######################################################################
SUBROUTINE SpitzFunc_HighSpeedLimit(Zeff,fc,u,q,gam, K,dKdu)
!=======================================================================
! Calculates the "Spitzer function" in high velocity limit, relativistic
! formulation: Lin-Liu et al., Phys.Pl. (2003),v10, 4064, Eq.(33).
!
! Inputs:
! Zeff - effective charge
! fc - fraction of circulating electrons
! u - p/(m*vte)
! q - p/mc
! gam - relativ. factor
!
! Outputs:
! K - Spitzer function
! dKdu - its derivative
!=======================================================================
IMPLICIT NONE
REAL(wp_), INTENT(in) :: Zeff,fc,u,q,gam
REAL(wp_), INTENT(out) :: K,dKdu
INTEGER :: nfun
REAL(8) :: gam2,err,flag,Integr
REAL(8), PARAMETER :: a = 0d0, b = 1d0, rtol = 1d-4, atol = 1d-12
!=======================================================================
r2 = (1+Zeff)/fc ! global parameter needed for integrand, HSL_f(t)
!------------------
IF (u < 1e-2) THEN
K = u**4/(r2+4)
dKdu = 4*u**3/(r2+4)
RETURN
ENDIF
!=======================================================================
q2 = q*q ! for the integrand, HSL_f
gp1 = gam+1 ! ..
!---
CALL quanc8(HSL_f,zero,unit,atol,rtol,Integr,err,nfun,flag)
!=======================================================================
gam2 = gam*gam
!---
K = u**4 * Integr
dKdu = (u/gam)**3 * (1-r2*gam2*Integr)
!=======================================================================
RETURN
END SUBROUTINE SpitzFunc_HighSpeedLimit
!#######################################################################
!#######################################################################
!#######################################################################
FUNCTION HSL_f(t) RESULT(f)
!=======================================================================
! Integrand for the high-speed limit approach (Lin-Liu's formulation)
!=======================================================================
IMPLICIT NONE
REAL(8), INTENT(in) :: t
REAL(8) :: f,g
g = sqrt(1+t*t*q2)
f = t**(3+r2)/g**3 * (gp1/(g+1))**r2
END FUNCTION HSL_f
!#######################################################################
END MODULE green_func_p
!#######################################################################

32
src/itm_constants.f90
View File

@ -1,32 +0,0 @@
!> Module implementing the ITM physics constants
!>
!> Source:
!> based on SOLPS b2mod_constants.F
!> '09/12/07 xpb : source CODATA 2006 (http://www.nist.gov/)'
!> pulled from ets r100
!>
!> \author David Coster
!>
!> \version "$Id: itm_constants.f90 37 2009-08-17 17:15:00Z coster $"
module itm_constants
use itm_types
real (kind = R8), parameter :: itm_pi = 3.141592653589793238462643383280_R8
real (kind = R8), parameter :: itm_c = 2.99792458e8_R8 ! speed of light, m/s
real (kind = R8), parameter :: itm_me = 9.10938215e-31_R8 ! electron mass, kg
real (kind = R8), parameter :: itm_mp = 1.672621637e-27_R8 ! proton mass, kg
real (kind = R8), parameter :: itm_md = 3.34358320e-27_R8 ! deuteron mass, kg
real (kind = R8), parameter :: itm_mt = 5.00735588e-27_R8 ! triton mass, kg
real (kind = R8), parameter :: itm_ma = 6.64465620e-27_R8 ! alpha mass, kg
real (kind = R8), parameter :: itm_amu = 1.660538782e-27_R8 ! amu, kg
real (kind = R8), parameter :: itm_ev = 1.602176487e-19_R8
real (kind = R8), parameter :: itm_qe = itm_ev
real (kind = R8), parameter :: itm_mu0 = 4.0e-7_R8 * itm_pi
real (kind = R8), parameter :: itm_eps0 = 1.0_R8 / (itm_mu0 * itm_c * itm_c)
real (kind = R8), parameter :: itm_avogr = 6.02214179e23_R8
real (kind = R8), parameter :: itm_KBolt = 1.3806504e-23_R8
character (len=64), parameter :: itm_constants_version = '$Id: itm_constants.f90 37 2009-08-17 17:15:00Z coster $'
end module itm_constants

50
src/itm_types.f90
View File

@ -1,50 +0,0 @@
!> Module implementing the ITM basic types
!>
!> Source:
!> based on SOLPS b2mod_types.F
!> pulled from ets r100 and extended with input from C. Konz, T. Ribeiro & B. Scott
!>
!> \author David Coster
!>
!> \version "$Id: itm_types.f90 144 2010-10-07 09:26:24Z konz $"
module itm_types
INTEGER, PARAMETER :: ITM_I1 = SELECTED_INT_KIND (2) ! Integer*1
INTEGER, PARAMETER :: ITM_I2 = SELECTED_INT_KIND (4) ! Integer*2
INTEGER, PARAMETER :: ITM_I4 = SELECTED_INT_KIND (9) ! Integer*4
INTEGER, PARAMETER :: ITM_I8 = SELECTED_INT_KIND (18) ! Integer*8
INTEGER, PARAMETER :: R4 = SELECTED_REAL_KIND (6, 37) ! Real*4
INTEGER, PARAMETER :: R8 = SELECTED_REAL_KIND (15, 300) ! Real*8
INTEGER, PARAMETER :: itm_int_invalid = -999999999
REAL(R8), PARAMETER :: itm_r8_invalid = -9.0D40
interface itm_is_valid
module procedure itm_is_valid_int4, itm_is_valid_int8, itm_is_valid_real8
end interface
contains
logical function itm_is_valid_int4(in_int)
implicit none
integer(ITM_I4) in_int
itm_is_valid_int4 = in_int .ne. itm_int_invalid
return
end function itm_is_valid_int4
logical function itm_is_valid_int8(in_int)
implicit none
integer(ITM_I8) in_int
itm_is_valid_int8 = in_int .ne. itm_int_invalid
return
end function itm_is_valid_int8
logical function itm_is_valid_real8(in_real)
implicit none
real(R8) in_real
itm_is_valid_real8 = abs(in_real - itm_r8_invalid) .gt. abs(itm_r8_invalid) * 1.0e-15_R8
return
end function itm_is_valid_real8
end module itm_types

572
src/magsurf_data.f90 Normal file
View File

@ -0,0 +1,572 @@
module magsurf_data
use const_and_precisions, only : wp_
implicit none
integer, save :: npsi, npoints !# sup mag, # punti per sup
integer, save :: njpt, nlmt
real(wp_), save :: rarea
real(wp_), dimension(:), allocatable, save :: psicon,pstab,rhot_eq, &
rhotqv,bav,varea,vcurrp,vajphiav,qqv,ffc,vratja,vratjb
real(wp_), dimension(:), allocatable, save :: rpstab
real(wp_), dimension(:), allocatable, save :: vvol,rri,rbav,bmxpsi,bmnpsi
real(wp_), dimension(:), allocatable, save :: tjp,tlm,ch,ch01
real(wp_), dimension(:,:), allocatable, save :: rcon,zcon
real(wp_), dimension(:,:), allocatable, save :: cdadrhot,cdvdrhot
real(wp_), dimension(:,:), allocatable, save :: cvol,crri,crbav,cbmx,cbmn,carea,cfc
real(wp_), dimension(:,:), allocatable, save :: crhotq
real(wp_), dimension(:,:), allocatable, save :: cratja,cratjb,cratjpl
contains
subroutine alloc_surf_anal(ierr)
implicit none
integer, intent(out) :: ierr
if(npsi.le.0.or.npoints.le.0) then
ierr = -1
return
end if
call dealloc_surf_anal
allocate(psicon(npsi),rcon(npsi,npoints), &
zcon(npsi,npoints),stat=ierr)
if (ierr/=0) call dealloc_surf_anal
end subroutine alloc_surf_anal
subroutine dealloc_surf_anal
implicit none
if(allocated(psicon)) deallocate(psicon)
if(allocated(rcon)) deallocate(rcon)
if(allocated(zcon)) deallocate(zcon)
end subroutine dealloc_surf_anal
subroutine alloc_surfvec(ierr)
implicit none
integer, intent(out) :: ierr
if(npsi.le.0.or.npoints.le.0) then
ierr = -1
return
end if
call dealloc_surfvec
allocate(psicon(npsi),rcon(npsi,npoints),zcon(npsi,npoints),pstab(npsi), &
rhot_eq(npsi),rhotqv(npsi),bav(npsi),bmxpsi(npsi),bmnpsi(npsi),varea(npsi), &
vvol(npsi),vcurrp(npsi),vajphiav(npsi),qqv(npsi),ffc(npsi),vratja(npsi), &
vratjb(npsi),rpstab(npsi),rri(npsi),rbav(npsi),cdadrhot(npsi,4), &
cdvdrhot(npsi,4),cbmx(npsi,4),cbmn(npsi,4),crbav(npsi,4),cvol(npsi,4), &
crri(npsi,4),carea(npsi,4),cfc(npsi,4),crhotq(npsi,4),cratjpl(npsi,4), &
cratja(npsi,4),cratjb(npsi,4),stat=ierr)
if (ierr/=0) call dealloc_surf_anal
end subroutine alloc_surfvec
subroutine dealloc_surfvec
implicit none
if(allocated(psicon)) deallocate(psicon)
if(allocated(rcon)) deallocate(rcon)
if(allocated(zcon)) deallocate(zcon)
if(allocated(pstab)) deallocate(pstab)
if(allocated(rhot_eq)) deallocate(rhot_eq)
if(allocated(rhotqv)) deallocate(rhotqv)
if(allocated(bav)) deallocate(bav)
if(allocated(bmxpsi)) deallocate(bmxpsi)
if(allocated(bmnpsi)) deallocate(bmnpsi)
if(allocated(varea)) deallocate(varea)
if(allocated(vvol)) deallocate(vvol)
if(allocated(vcurrp)) deallocate(vcurrp)
if(allocated(vajphiav)) deallocate(vajphiav)
if(allocated(qqv)) deallocate(qqv)
if(allocated(ffc)) deallocate(ffc)
if(allocated(vratja)) deallocate(vratja)
if(allocated(vratjb)) deallocate(vratjb)
if(allocated(rpstab)) deallocate(rpstab)
if(allocated(rri)) deallocate(rri)
if(allocated(rbav)) deallocate(rbav)
if(allocated(cdadrhot)) deallocate(cdadrhot)
if(allocated(cdvdrhot)) deallocate(cdvdrhot)
if(allocated(cbmx)) deallocate(cbmx)
if(allocated(cbmn)) deallocate(cbmn)
if(allocated(crbav)) deallocate(crbav)
if(allocated(cvol)) deallocate(cvol)
if(allocated(crri)) deallocate(crri)
if(allocated(carea)) deallocate(carea)
if(allocated(cfc)) deallocate(cfc)
if(allocated(crhotq)) deallocate(crhotq)
if(allocated(cratjpl)) deallocate(cratjpl)
if(allocated(cratja)) deallocate(cratja)
if(allocated(cratjb)) deallocate(cratjb)
end subroutine dealloc_surfvec
subroutine contours_psi(h,rup,zup,rlw,zlw,rcn,zcn,ipr)
use const_and_precisions, only : wp_,pi
use equilibrium, only : psiant,psinop,nsr,nsz,cc=>cceq,tr,tz,kspl, &
points_tgo
use dierckx, only : profil,sproota
use reflections, only : rwallm
implicit none
! local constants
integer, parameter :: mest=4
! arguments
integer, intent(in) :: ipr
real(wp_), intent(in) :: h
real(wp_), intent(inout) :: rup,zup,rlw,zlw
real(wp_), dimension(npoints), intent(out) :: rcn,zcn
! local variables
integer :: np,info,ic,ier,ii,iopt,m
real(wp_) :: ra,rb,za,zb,th,zc,val
real(wp_), dimension(mest) :: zeroc
real(wp_), dimension(nsr) :: czc
np=(npoints-1)/2
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.0_wp_-cos(th*(ic-1)))/2.0_wp_
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)
rcn(npoints+1-ic)=zeroc(2)
else
rcn(ic)=zeroc(2)
rcn(npoints+1-ic)=zeroc(3)
end if
zcn(ic)=zc
zcn(npoints+1-ic)=zc
end do
if (ipr.gt.0) then
do ii=1,npoints
write(71,'(i6,12(1x,e12.5))') ii,h,rcn(ii),zcn(ii)
end do
write(71,*)
write(71,*)
end if
end subroutine contours_psi
subroutine contours_psi_an(h,rcn,zcn,ipr)
use const_and_precisions, only : wp_,pi
use equilibrium, only : frhotor,aminor,rmaxis,zmaxis
implicit none
! arguments
integer :: ipr
real(wp_) :: h
real(wp_), dimension(npoints) :: rcn,zcn
! local variables
integer :: np,ic
real(wp_) :: rn,th
np=(npoints-1)/2
th=pi/dble(np)
rn=frhotor(sqrt(h))
do ic=1,npoints
zcn(ic)=zmaxis+aminor*rn*sin(th*(ic-1))
rcn(ic)=rmaxis+aminor*rn*cos(th*(ic-1))
if (ipr.gt.0) write(71,'(i6,12(1x,e12.5))') ic,h,rcn(ic),zcn(ic)
end do
if (ipr.gt.0) write(71,*)
end subroutine contours_psi_an
subroutine flux_average
use const_and_precisions, only : wp_,zero,one,pi,ccj=>mu0inv
use gray_params, only : iequil
use equilibrium, only : btrcen,btaxis,rmaxis,zmaxis,phitedge,zbsup,zbinf, &
equian,equinum_psi,bfield,frhotor,fq,tor_curr
use simplespline, only : difcs
use dierckx, only : regrid,coeff_parder
use utils, only : get_free_unit
implicit none
! local constants
integer, parameter :: nnintp=101,ncnt=100,nlam=101,ksp=3, &
njest=nnintp+ksp+1,nlest=nlam+ksp+1, &
lwrk=4*(nnintp+nlam)+11*(njest+nlest)+njest*nnintp+nlest+54, &
kwrk=nnintp+nlam+njest+nlest+3,lw01=nnintp*4+nlam*3+nnintp*nlam
! local variables
integer :: ier,ierr,l,jp,ipr,jpr,inc,inc1,iopt,njp,nlm,ninpr
integer, dimension(kwrk) :: iwrk
real(wp_) :: lam,dlam,anorm,b2av,dvdpsi,dadpsi,ratio_cdator, &
ratio_cdbtor,ratio_pltor,fc,height,r2iav,currp, &
area,volume,ajphiav,bbav,bmmx,bmmn,btot0,bpoloid0,rpsim0,dla,dlb, &
dlp,drc,ph,area2,rzp,rz,rpsim,zpsim,btot,bpoloid,dlph,ajphi0, &
shlam,srl,rl2,rl0,rl,dhlam,dhlam0,ccfh,s,ajphi, &
bphi,brr,bzz,riav,fp,psinjp,rhopjp,rhotjp,qq,rup,rlw,zup,zlw
real(wp_), dimension(nnintp) :: dadrhotv,dvdrhotv,vratjpl
real(wp_), dimension(2*ncnt) :: dlpv
real(wp_), dimension(2*ncnt+1) :: bv,bpv
real(wp_), dimension(nlam) :: alam,weights
real(wp_), dimension(nnintp,nlam) :: fhlam
real(wp_), dimension(nnintp*nlam) :: ffhlam,dffhlam
real(wp_), dimension(lwrk) :: wrk
real(wp_), dimension(:), allocatable :: rctemp,zctemp
! common/external functions/variables
real(wp_) :: fpolv,ddpsidrr,ddpsidzz
npsi=nnintp
ninpr=(npsi-1)/10
npoints = 2*ncnt+1
call alloc_surfvec(ierr)
if(allocated(tjp)) deallocate(tjp)
if(allocated(tlm)) deallocate(tlm)
if(allocated(ch)) deallocate(ch)
allocate(tjp(njest),tlm(nlest),ch((njest-4)*(nlest-4)), &
rctemp(npoints),zctemp(npoints),stat=ierr)
if (ierr.ne.0) return
! computation of flux surface averaged quantities
write(71,*)' #i psin R z'
dlam=1.0_wp_/dble(nlam-1)
do l=1,nlam-1
alam(l)=dble(l-1)*dlam
fhlam(1,l)=sqrt(1.0_wp_-alam(l))
ffhlam(l)=fhlam(1,l)
dffhlam(l)=-0.5_wp_/sqrt(1.0_wp_-alam(l))
weights(l)=1.0_wp_
end do
weights(1)=0.5_wp_
weights(nlam)=0.5_wp_
alam(nlam)=1.0_wp_
fhlam(1,nlam)=0.0_wp_
ffhlam(nlam)=0.0_wp_
dffhlam(nlam)=-99999.0_wp_
jp=1
anorm=2.0_wp_*pi*rmaxis/abs(btaxis)
dvdpsi=2.0_wp_*pi*anorm
dadpsi=2.0_wp_*pi/abs(btaxis)
b2av=btaxis**2
ratio_cdator=abs(btaxis/btrcen)
ratio_cdbtor=1.0_wp_
ratio_pltor=1.0_wp_
fc=1.0_wp_
if(iequil < 2) then
call equian(rmaxis,zmaxis,ddpsidrr=ddpsidrr,ddpsidzz=ddpsidzz)
else
call equinum_psi(rmaxis,zmaxis,ddpsidrr=ddpsidrr,ddpsidzz=ddpsidzz)
end if
qq=btaxis/sqrt(ddpsidrr*ddpsidzz)
ajphiav=-ccj*(ddpsidrr+ddpsidzz)/rmaxis
psicon(1)=0.0_wp_
rcon(1,:)=rmaxis
zcon(1,:)=zmaxis
pstab(1)=0.0_wp_
rpstab(1)=0.0_wp_
vcurrp(1)=0.0_wp_
vajphiav(1)=ajphiav
bmxpsi(1)=abs(btaxis)
bmnpsi(1)=abs(btaxis)
bav(1)=abs(btaxis)
rbav(1)=1.0_wp_
rri(1)=rmaxis
varea(1)=0.0_wp_
vvol(1)=0.0_wp_
vratjpl(1)=ratio_pltor
vratja(1)=ratio_cdator
vratjb(1)=ratio_cdbtor
ffc(1)=fc
qqv(1)=qq
dadrhotv(1)=0.0_wp_
dvdrhotv(1)=0.0_wp_
rup=rmaxis
rlw=rmaxis
zup=zmaxis+(zbsup-zmaxis)/10.0_wp_
zlw=zmaxis-(zmaxis-zbinf)/10.0_wp_
do jp=2,npsi
height=dble(jp-1)/dble(npsi-1)
if(jp.eq.npsi) height=0.9999_wp_
ipr=0
jpr=mod(jp,ninpr)
if(jpr.eq.1) ipr=1
rhopjp=height
psinjp=height*height
rhotjp=frhotor(rhopjp)
psicon(jp)=height
if(iequil<2) then
call contours_psi_an(psinjp,rctemp,zctemp,ipr)
else
call contours_psi(psinjp,rup,zup,rlw,zlw,rctemp,zctemp,ipr)
end if
rcon(jp,:) = rctemp
zcon(jp,:) = zctemp
r2iav=0.0_wp_
anorm=0.0_wp_
dadpsi=0.0_wp_
currp=0.0_wp_
b2av=0.0_wp_
area=0.0_wp_
volume=0.0_wp_
ajphiav=0.0_wp_
bbav=0.0_wp_
bmmx=-1.0e+30_wp_
bmmn=1.0e+30_wp_
call tor_curr(rctemp(1),zctemp(1),ajphi0)
call bfield(rctemp(1),zctemp(1),bphi,br=brr,bz=bzz)
fpolv=bphi*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))
! compute length, area and volume defined by psi=psinjp=height^2
ph=0.5_wp_*(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
! compute line integrals on the contour psi=psinjp=height^2
rpsim=rctemp(inc1)
zpsim=zctemp(inc1)
call bfield(rpsim,zpsim,br=brr,bz=bzz)
call tor_curr(rpsim,zpsim,ajphi)
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.5_wp_*dlp
anorm=anorm+dlph*(1.0_wp_/bpoloid+1.0_wp_/bpoloid0)
dadpsi=dadpsi+dlph*(1.0_wp_/(bpoloid*rpsim)+1.0_wp_/(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.0_wp_/(bpoloid*rpsim**2)+1.0_wp_/(bpoloid0*rpsim0**2))
ajphiav=ajphiav+dlph*(ajphi0/(bpoloid0*rpsim0)+ajphi/(bpoloid*rpsim))
ajphi0=ajphi
rpsim0=rpsim
bpoloid0=bpoloid
btot0=btot
! computation maximum/minimum B values on given flux surface
if(btot.le.bmmn) bmmn=btot
if(btot.ge.bmmx) bmmx=btot
end do
! bav=<B> [T] , b2av=<B^2> [T^2] , rbav=<B>/b_min
! anorm = int d l_p/B_p = dV/dpsi/(2pi)
! r2iav=<1/R^2> [m^-2] ,
! riav=<1/R> [m^-1] = dA/dpsi/(dV/dpsi/(2pi)),
! rri = <B>/(|R B_tor|<1/R^2>) , used to compute I_tor [m^-1]
! currp = plasma current within psi=const
bbav=bbav/anorm
r2iav=r2iav/anorm
dvdpsi=2.0_wp_*pi*anorm
riav=dadpsi/anorm
b2av=b2av/anorm
vcurrp(jp)=ccj*currp
vajphiav(jp)=ajphiav/dadpsi
! area == varea, volume == vvol
! flux surface minor radius == (area/pi)^1/2
! ratio_cdator = Jcd_astra/J_phi Jcd_astra = <Jcd.B>/B0
! ratio_cdbtor = Jcd_jintrac/J_phi Jcd_jintrac = <Jcd.B>/<B>
! ratio_pltor = Jcd_||/J_phi Jcd_|| = <Jcd.b>
pstab(jp)=psinjp
rpstab(jp)=rhopjp
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.0_wp_*pi*pi))
qqv(jp)=qq
dadrhotv(jp)=phitedge*frhotor(rhopjp)/fq(psinjp)*dadpsi/pi
dvdrhotv(jp)=phitedge*frhotor(rhopjp)/fq(psinjp)*dvdpsi/pi
! computation of fraction of circulating/trapped fraction fc, ft
! and of function H(lambda,rhop)
! ffhlam = Bmn/Bmx/fc integral_lambda^1 dlam/<sqrt(1-lam*B(rhop)/Bmx)>
fc=0.0_wp_
shlam=0.0_wp_
do l=nlam,1,-1
lam=alam(l)
srl=0.0_wp_
rl2=1.0_wp_-lam*bv(1)/bmmx
rl0=0.0_wp_
if(rl2.gt.0) rl0=sqrt(rl2)
do inc=1,npoints-1
rl2=1.0_wp_-lam*bv(inc+1)/bmmx
rl=0.0_wp_
if(rl2.gt.0) rl=sqrt(rl2)
srl=srl+0.5_wp_*dlpv(inc)*(rl/bpv(inc+1)+rl0/bpv(inc))
rl0=rl
end do
srl=srl/anorm
dhlam=0.5_wp_/srl
fc=fc+lam/srl*weights(l)
if(l.eq.nlam) then
fhlam(jp,l)=0.0_wp_
ffhlam(nlam*(jp-1)+l)=0.0_wp_
dffhlam(nlam*(jp-1)+l)=-dhlam
dhlam0=dhlam
else
shlam=shlam+0.5_wp_*(dhlam+dhlam0)*dlam
fhlam(jp,l)=shlam
dffhlam(nlam*(jp-1)+l)=-dhlam
dhlam0=dhlam
end if
end do
fc=0.75_wp_*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,*)' #rhop rhot |<B>| |Bmx| |Bmn| Area Vol |I_pl| <J_phi> fc ratJa ratJb'
do jp=1,npsi
if(jp.eq.npsi) then
rpstab(jp)=1.0_wp_
pstab(jp)=1.0_wp_
end if
rhotjp=frhotor(rpstab(jp))
write(56,99) rpstab(jp),rhotjp,bav(jp),bmxpsi(jp),bmnpsi(jp), &
varea(jp),vvol(jp),vcurrp(jp),vajphiav(jp),ffc(jp), &
vratja(jp),vratjb(jp)
end do
! spline coefficients of area,vol,rbav,rri,bmxpsi,bmnpsi,fc,dadrhot,dvdrhot,ratioJs
! used for computations of dP/dV and J_cd
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,dadrhotv,npsi,iopt,cdadrhot,ier)
iopt=0
call difcs(rpstab,dvdrhotv,npsi,iopt,cdvdrhot,ier)
! iopt=0
! call difcs(rpstab,qqv,npsi,iopt,cqq,ier)
! spline interpolation of H(lambda,rhop) and dH/dlambda
iopt=0
s=0.0_wp_
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
99 format(20(1x,e12.5))
end subroutine flux_average
subroutine fluxval(rhop,area,vol,dervol,dadrhot,dvdrhot, &
rri,rbav,bmn,bmx,fc,ratja,ratjb,ratjpl)
use const_and_precisions, only : wp_
use utils, only : locate
use simplespline, only :spli,splid
implicit none
! arguments
real(wp_), intent(in) :: rhop
real(wp_), intent(out), optional :: vol,area,rri,rbav,dervol,bmn,bmx,fc, &
ratja,ratjb,ratjpl,dadrhot,dvdrhot
! local variables
integer :: ip
real(wp_) :: drh
call locate(rpstab,npsi,rhop,ip)
ip=min(max(1,ip),npsi-1)
drh=rhop-rpstab(ip)
if (present(area)) area=spli(carea,npsi,ip,drh)
if (present(vol)) vol=spli(cvol,npsi,ip,drh)
if (present(dervol)) dervol=splid(cvol,npsi,ip,drh)
if (present(dadrhot)) dadrhot=spli(cdadrhot,npsi,ip,drh)
if (present(dvdrhot)) dvdrhot=spli(cdvdrhot,npsi,ip,drh)
if (present(rri)) rri=spli(crri,npsi,ip,drh)
if (present(rbav)) rbav=spli(crbav,npsi,ip,drh)
if (present(bmn)) bmn=spli(cbmn,npsi,ip,drh)
if (present(bmx)) bmx=spli(cbmx,npsi,ip,drh)
if (present(fc)) fc=spli(cfc,npsi,ip,drh)
if (present(ratja)) ratja=spli(cratja,npsi,ip,drh)
if (present(ratjb)) ratjb=spli(cratjb,npsi,ip,drh)
if (present(ratjpl)) ratjpl=spli(cratjpl,npsi,ip,drh)
end subroutine fluxval
end module magsurf_data

133
src/main.f90 Normal file
View File

@ -0,0 +1,133 @@
program gray_main
use const_and_precisions, only : wp_,one
use graycore, only : gray
use gray_params, only : read_inputs,read_params, antctrl_type,eqparam_type, &
prfparam_type,outparam_type,rtrparam_type,hcdparam_type
use beams, only : read_beam0, read_beam1, read_beam2
use equilibrium, only : read_equil_an,read_eqdsk,change_cocos,eq_scal, &
set_rhospl,setqphi_num,frhopolv
use coreprofiles, only : read_profiles_an,read_profiles,tene_scal
use reflections, only : range2rect
implicit none
type(antctrl_type) :: antp
type(eqparam_type) :: eqp
type(prfparam_type) :: prfp
type(outparam_type) :: outp
type(rtrparam_type) :: rtrp
type(hcdparam_type) :: hcdp
real(wp_), dimension(:), allocatable :: psrad, terad, derad, zfc
real(wp_), dimension(:), allocatable :: rv, zv, psinr, fpol, qpsi
real(wp_), dimension(:), allocatable :: rbnd, zbnd, rlim, zlim
real(wp_), dimension(:,:), allocatable :: psin
real(wp_) :: psia, rvac, rax, zax
integer :: iox0
real(wp_) :: p0mw, fghz, psipol0, chipol0
real(wp_) :: alpha0, beta0, x0, y0, z0, w1, w2, ri1, ri2, phiw, phir
real(wp_) :: pec,icd
integer :: ierr
real(wp_), dimension(:), allocatable :: xrad, rhot, dpdv, jcd
real(wp_) :: rwallm, rmxm, r0m, z0m, dzmx
! ======= read parameters BEGIN =======
call read_inputs('graynew.data',antp,eqp,rwallm,prfp,outp)
call read_params('gray_params.data',rtrp,hcdp)
! ======= read parameters END =======
! ======= read input data BEGIN =======
!------------ equilibrium ------------
if(eqp%iequil<2) then
call read_equil_an(eqp%filenm, rv, zv, fpol, qpsi)
! psia sign set to give the correct sign to Iphi (COCOS=3: psia<0 for Iphi>0)
psia = sign(one,qpsi(2)*fpol(1))
else
call read_eqdsk(eqp%filenm, rv,zv,psin, psia, psinr,fpol,qpsi, rvac, &
rax,zax, rbnd,zbnd, rlim,zlim, eqp%ipsinorm,eqp%idesc,eqp%ifreefmt)
call change_cocos(psia, fpol, qpsi, eqp%icocos, 3)
end if
! re-scale B/I and/or force signs. If sgn=0 on input, set to fpol/-psia signs on output
call eq_scal(psia, fpol, eqp%sgni, eqp%sgnb, eqp%factb)
qpsi(1) = sign(qpsi(1),qpsi(1)*qpsi(2)*psia*fpol(1))
qpsi(2) = sign(qpsi(2),psia*fpol(1))
!------------- profiles -------------
if(prfp%iprof==0) then
call read_profiles_an(prfp%filenm, terad, derad, zfc)
else
call read_profiles(prfp%filenm, xrad, terad, derad, zfc)
allocate(psrad(size(xrad)))
if(prfp%irho==0) then
call setqphi_num(psinr,qpsi,psia,rhot)
call set_rhospl(sqrt(psinr),rhot)
psrad=frhopolv(xrad)
else if(prfp%irho == 1) then
psrad=xrad**2
else
psrad=xrad
end if
deallocate(xrad)
end if
! re-scale input data
call tene_scal(terad,derad,prfp%factte,prfp%factne,eqp%factb,prfp%iscal, &
prfp%iprof)
!------------- antenna --------------
! interpolate beam table if antctrl%ibeam>0
select case (antp%ibeam)
case (2)
! to be completed: now 1st beamd always selected, iox read from table
call read_beam2(antp%filenm,1,antp%alpha,antp%beta,fghz,antp%iox,x0,y0,z0, &
w1,w2,ri1,ri2,phiw,phir)
case (1)
call read_beam1(antp%filenm,antp%alpha,antp%beta,fghz,x0,y0,z0, &
w1,w2,ri1,ri2,phiw,phir)
case default
call read_beam0(antp%filenm,fghz,x0,y0,z0,w1,w2,ri1,ri2,phiw,phir)
end select
alpha0=antp%alpha
beta0=antp%beta
p0mw=antp%power
psipol0=antp%psi
chipol0=antp%chi
iox0=antp%iox
!--------------- wall ---------------
! set simple limiter if not read from EQDSK
! need to clean up...
r0m=sqrt(x0**2+y0**2)*0.01_wp_
dzmx=rtrp%dst*rtrp%nstep*0.01_wp_
z0m=z0*0.01_wp_
if (.not.allocated(rlim).or.rtrp%ipass<0) then
rtrp%ipass=abs(rtrp%ipass)
if(eqp%iequil<2) then
rmxm=(rv(1)+rv(2))*0.01_wp_
else
rmxm=rv(size(rv))
end if
call range2rect(rwallm,max(r0m,rmxm),z0m-dzmx,z0m+dzmx,rlim,zlim)
end if
! ======= read input data END =======
! ========================= MAIN SUBROUTINE CALL =========================
allocate(dpdv(outp%nrho),jcd(outp%nrho))
call gray(rv,zv,psin,psia,psinr,fpol,qpsi,rvac,rax,zax,rbnd,zbnd,eqp, &
psrad,terad,derad,zfc,prfp, rlim,zlim, &
p0mw,fghz,alpha0,beta0,(/x0,y0,z0/),w1,w2,ri1,ri2,phiw,phir,iox0, &
psipol0,chipol0, dpdv,jcd,pec,icd, outp,rtrp,hcdp,ierr)
! ========================================================================
! ======= control prints BEGIN =======
if(ierr/=0) print*,' IERR = ', ierr
print*,' '
print*,'Pabs (MW), Icd (kA) = ', pec,icd*1.0e3_wp_
! ======= control prints END =======
! ======= free memory BEGIN =======
if(allocated(psrad)) deallocate(psrad)
if(allocated(terad)) deallocate(terad, derad, zfc)
if(allocated(rv)) deallocate(rv, zv, fpol, qpsi)
if(allocated(psin)) deallocate(psin, psinr)
if(allocated(rbnd)) deallocate(rbnd,zbnd)
if(allocated(rlim)) deallocate(rlim,zlim)
if(allocated(dpdv)) deallocate(dpdv, jcd)
! ======= free memory END ======
end program gray_main

125
src/math.f90 Normal file
View File

@ -0,0 +1,125 @@
module math
use const_and_precisions, only : wp_, zero, one
implicit none
contains
function catand(z)
!***begin prologue catan
!***purpose compute the complex arc tangent.
!***library slatec (fnlib)
!***category c4a
!***type complex (catan-c)
!***keywords arc tangent, elementary functions, fnlib, trigonometric
!***author fullerton, w., (lanl)
!***description
!
! catan(z) calculates the complex trigonometric arc tangent of z.
! the result is in units of radians, and the real part is in the first
! or fourth quadrant.
!
!***references (none)
!***routines called (none)
!***revision history (yymmdd)
! 770801 date written
! 890531 changed all specific intrinsics to generic. (wrb)
! 890531 revision date from version 3.2
! 891214 prologue converted to version 4.0 format. (bab)
! 900315 calls to xerror changed to calls to xermsg. (thj)
! 900326 removed duplicate information from description section.
! (wrb)
!***end prologue catan
use const_and_precisions, only : comp_eps, pi2=>pihalf, czero, cunit
implicit none
complex(wp_) :: catand
complex(wp_), intent(in) :: z
complex(wp_) :: z2
real(wp_) :: r,x,y,r2,xans,yans,twoi
integer :: i
logical, save :: first=.true.
integer, save :: nterms
real(wp_), save :: rmin, rmax, sqeps
!***first executable statement catan
if (first) then
! nterms = log(eps)/log(rbnd) where rbnd = 0.1
nterms = int(-0.4343_wp_*log(0.5_wp_*comp_eps) + 1.0_wp_)
sqeps = sqrt(comp_eps)
rmin = sqrt (1.5_wp_*comp_eps)
rmax = 2.0_wp_/comp_eps
endif
first = .false.
!
r = abs(z)
if (r<=0.1_wp_) then
!
catand = z
if (r<rmin) return
!
catand = czero
z2 = z*z
do i=1,nterms
twoi = 2*(nterms-i) + 1
catand = 1.0_wp_/twoi - z2*catand
end do
catand = z*catand
!
else if (r<=rmax) then
x = real(z)
y = aimag(z)
r2 = r*r
if (r2==one.and.x==zero) print*,'catand, z is +i or -i'
if (abs(r2-one)<=sqeps) then
if (abs(cunit+z*z) < sqeps) &
print*,'catand, answer lt half precision, z**2 close to -1'
!
end if
xans = 0.5_wp_*atan2(2.0_wp_*x, one)
yans = 0.25_wp_*log((r2+2.0_wp_*y+one)/(r2-2.0_wp_*y+one))
catand = cmplx(xans, yans, wp_)
!
else
catand = cmplx(pi2, zero, wp_)
if (real(z)<zero) catand = cmplx(-pi2, zero, wp_)
end if
end function catand
function fact(k)
implicit none
integer, intent(in) :: k
real(wp_) :: fact
integer :: i
! Factorial function
fact=zero
if(k<0) return
fact=one
if(k==0) return
do i=1,k
fact=fact*i
end do
end function fact
function gamm(xx)
implicit none
real(wp_) :: gamm
real(wp_), intent(in) :: xx
! Returns the value Gamma(xx) for xx > 0.
INTEGER :: j
real(wp_) :: ser,tmp,x,y
real(wp_), parameter :: stp=2.5066282746310005_wp_
real(wp_), dimension(6), parameter :: cof=(/76.18009172947146_wp_, &
-86.50532032941677_wp_,24.01409824083091_wp_,-1.231739572450155_wp_, &
.1208650973866179e-2_wp_,-.5395239384953e-5_wp_/)
x=xx
y=x
tmp=x+5.5_wp_
tmp=(x+0.5_wp_)*log(tmp)-tmp
ser=1.000000000190015_wp_
do j=1,6
y=y+1._wp_
ser=ser+cof(j)/y
end do
gamm=exp(tmp)*(stp*ser/x)
end function gamm
end module math

1985
src/minpack.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

257
src/numint.f90 Normal file
View File

@ -0,0 +1,257 @@
module numint
use const_and_precisions, only : wp_, zero, one
implicit none
contains
subroutine simpson (n,h,fi,s)
! subroutine for integration over f(x) with the simpson rule. fi:
! integrand f(x); h: interval; s: integral. copyright (c) tao pang 1997.
implicit none
integer, intent(in) :: n
real(wp_), intent(in) :: h
real(wp_), dimension(n), intent(in) :: fi
real(wp_), intent(out) :: s
integer :: i
real(wp_) :: s0,s1,s2
s = zero
s0 = zero
s1 = zero
s2 = zero
do i = 2, n-1, 2
s1 = s1+fi(i-1)
s0 = s0+fi(i)
s2 = s2+fi(i+1)
end do
s = h*(s1+4.0_wp_*s0+s2)/3.0_wp_
! if n is even, add the last slice separately
if (mod(n,2).eq.0) s = s+h*(5.0_wp_*fi(n)+8.0_wp_*fi(n-1)-fi(n-2))/12.0_wp_
end subroutine simpson
subroutine trapezoid(n,xi,fi,s)
! subroutine for integration with the trapezoidal rule.
! fi: integrand f(x); xi: abscissa x;
! s: integral Int_{xi(1)}^{xi(n)} f(x)dx
implicit none
integer, intent(in) :: n
real(wp_), dimension(n), intent(in) :: xi,fi
real(wp_), intent(out) :: s
integer :: i
s = zero
do i = 1, n-1
s = s+(xi(i+1)-xi(i))*(fi(i+1)-fi(i))
end do
s = 0.5_wp_*s
end subroutine trapezoid
subroutine quanc8(fun,a,b,abserr,relerr,result,errest,nofun,flag)
implicit none
real(wp_), intent(in) :: a, b, abserr, relerr
real(wp_), intent(out) :: result, errest, flag
integer, intent(out) :: nofun
!
! estimate the integral of fun(x) from a to b
! to a user provided tolerance.
! an automatic adaptive routine based on
! the 8-panel newton-cotes rule.
!
! input ..
!
! fun the name of the integrand function subprogram fun(x).
! a the lower limit of integration.
! b the upper limit of integration.(b may be less than a.)
! relerr a relative error tolerance. (should be non-negative)
! abserr an absolute error tolerance. (should be non-negative)
!
! output ..
!
! result an approximation to the integral hopefully satisfying the
! least stringent of the two error tolerances.
! errest an estimate of the magnitude of the actual error.
! nofun the number of function values used in calculation of result.
! flag a reliability indicator. if flag is zero, then result
! probably satisfies the error tolerance. if flag is
! xxx.yyy , then xxx = the number of intervals which have
! not converged and 0.yyy = the fraction of the interval
! left to do when the limit on nofun was approached.
!
real(wp_) :: w0,w1,w2,w3,w4,area,x0,f0,stone,step,cor11,temp
real(wp_) :: qprev,qnow,qdiff,qleft,esterr,tolerr
real(wp_), dimension(31) :: qright
real(wp_), dimension(16) :: f,x
real(wp_), dimension(8,30) :: fsave,xsave
integer :: levmin,levmax,levout,nomax,nofin,lev,nim,i,j
interface
function fun(x)
use const_and_precisions, only : wp_
implicit none
real(wp_), intent(in) :: x
real(wp_) :: fun
end function fun
end interface
!
! *** stage 1 *** general initialization
! set constants.
!
levmin = 1
levmax = 30
levout = 6
nomax = 5000
nofin = nomax - 8*(levmax-levout+2**(levout+1))
!
! trouble when nofun reaches nofin
!
w0 = 3956.0_wp_ / 14175.0_wp_
w1 = 23552.0_wp_ / 14175.0_wp_
w2 = -3712.0_wp_ / 14175.0_wp_
w3 = 41984.0_wp_ / 14175.0_wp_
w4 = -18160.0_wp_ / 14175.0_wp_
!
! initialize running sums to zero.
!
flag = zero
result = zero
cor11 = zero
errest = zero
area = zero
nofun = 0
if (a .eq. b) return
!
! *** stage 2 *** initialization for first interval
!
lev = 0
nim = 1
x0 = a
x(16) = b
qprev = zero
f0 = fun(x0)
stone = (b - a) / 16.0_wp_
x(8) = (x0 + x(16)) / 2.0_wp_
x(4) = (x0 + x(8)) / 2.0_wp_
x(12) = (x(8) + x(16)) / 2.0_wp_
x(2) = (x0 + x(4)) / 2.0_wp_
x(6) = (x(4) + x(8)) / 2.0_wp_
x(10) = (x(8) + x(12)) / 2.0_wp_
x(14) = (x(12) + x(16)) / 2.0_wp_
do j = 2, 16, 2
f(j) = fun(x(j))
end do
nofun = 9
!
! *** stage 3 *** central calculation
! requires qprev,x0,x2,x4,...,x16,f0,f2,f4,...,f16.
! calculates x1,x3,...x15, f1,f3,...f15,qleft,qright,qnow,qdiff,area.
!
do
do
x(1) = (x0 + x(2)) / 2.0_wp_
f(1) = fun(x(1))
do j = 3, 15, 2
x(j) = (x(j-1) + x(j+1)) / 2.0_wp_
f(j) = fun(x(j))
end do
nofun = nofun + 8
step = (x(16) - x0) / 16.0_wp_
qleft = (w0*(f0 + f(8)) + w1*(f(1)+f(7)) + w2*(f(2)+f(6)) &
+ w3*(f(3)+f(5)) + w4*f(4)) * step
qright(lev+1)=(w0*(f(8)+f(16))+w1*(f(9)+f(15))+w2*(f(10)+f(14)) &
+ w3*(f(11)+f(13)) + w4*f(12)) * step
qnow = qleft + qright(lev+1)
qdiff = qnow - qprev
area = area + qdiff
!
! *** stage 4 *** interval convergence test
!
esterr = abs(qdiff) / 1023.0_wp_
tolerr = max(abserr,relerr*abs(area)) * (step/stone)
if (lev .ge. levmin) then
!
! *** stage 6 *** trouble section
! number of function values is about to exceed limit.
!
if (lev .ge. levmax) then
!
! current level is levmax.
!
flag = flag + one
exit
end if
if (nofun .gt. nofin) then
nofin = 2*nofin
levmax = levout
flag = flag + (b - x0) / (b - a)
exit
end if
if (esterr .le. tolerr) exit
end if
!
! *** stage 5 *** no convergence
! locate next interval.
!
nim = 2*nim
lev = lev+1
!
! store right hand elements for future use.
!
do i = 1, 8
fsave(i,lev) = f(i+8)
xsave(i,lev) = x(i+8)
end do
!
! assemble left hand elements for immediate use.
!
qprev = qleft
do i = 1, 8
j = -i
f(2*j+18) = f(j+9)
x(2*j+18) = x(j+9)
end do
end do
!
! *** stage 7 *** interval converged
! add contributions into running sums.
!
result = result + qnow
errest = errest + esterr
cor11 = cor11 + qdiff / 1023.0_wp_
!
! locate next interval.
!
do
if (nim .eq. 2*(nim/2)) exit
nim = nim/2
lev = lev-1
end do
nim = nim + 1
if (lev .le. 0) exit
!
! assemble elements required for the next interval.
!
qprev = qright(lev)
x0 = x(16)
f0 = f(16)
do i = 1, 8
f(2*i) = fsave(i,lev)
x(2*i) = xsave(i,lev)
end do
end do
!
! *** stage 8 *** finalize and return
!
result = result + cor11
!
! make sure errest not less than roundoff level.
!
if (errest .eq. zero) return
do
temp = abs(result) + errest
if (temp .ne. abs(result)) return
errest = 2.0_wp_*errest
end do
end subroutine quanc8
end module numint

387
src/pec.f90 Normal file
View File

@ -0,0 +1,387 @@
module pec
use const_and_precisions, only : wp_,zero,one
implicit none
real(wp_), dimension(:), allocatable, save :: rhop_tab,rhot_tab
real(wp_), dimension(:), allocatable, save :: rtabpsi1
real(wp_), dimension(:), allocatable, save :: dvol,darea
real(wp_), dimension(:), allocatable, save :: ratjav,ratjbv,ratjplv
contains
subroutine pec_init(ipec,rt_in)
use equilibrium, only : frhotor,frhopol
use gray_params, only : nnd
use magsurf_data, only : fluxval
implicit none
! arguments
integer, intent(in) :: ipec
real(wp_), dimension(nnd), intent(in), optional :: rt_in
! local variables
integer :: it
real(wp_) :: drt,rt,rt1,rhop1
real(wp_) :: ratjai,ratjbi,ratjpli
real(wp_) :: voli0,voli1,areai0,areai1
! rt_in present: read input grid
! else: build equidistant grid dimension nnd
! ipec=1 rho_pol grid
! ipec=2 rho_tor grid
call dealloc_pec
allocate(rhop_tab(nnd),rhot_tab(nnd),rtabpsi1(0:nnd),dvol(nnd),darea(nnd), &
ratjav(nnd),ratjbv(nnd),ratjplv(nnd))
voli0 = zero
areai0 = zero
rtabpsi1(0) = zero
do it=1,nnd
if(present(rt_in)) then
! read radial grid from input
rt = rt_in(it)
if(it<nnd) then
drt = rt_in(it+1)-rt
end if
else
! build equidistant radial grid
drt = one/dble(nnd-1)
rt = dble(it-1)*drt
end if
! radial coordinate of i-(i+1) interval mid point
if(it < nnd) then
rt1 = rt + drt/2.0_wp_
else
rt1 = one
end if
if (ipec == 1) then
rhop_tab(it) = rt
rhot_tab(it) = frhotor(rt)
rhop1 = rt1
else
rhot_tab(it) = rt
rhop_tab(it) = frhopol(rt)
rhop1 = frhopol(rt1)
end if
! psi grid at mid points, dimension nnd+1, for use in pec_tab
rtabpsi1(it) = rhop1**2
call fluxval(rhop1,area=areai1,vol=voli1)
dvol(it) = abs(voli1 - voli0)
darea(it) = abs(areai1 - areai0)
voli0 = voli1
areai0 = areai1
call fluxval(rhop_tab(it),ratja=ratjai,ratjb=ratjbi,ratjpl=ratjpli)
ratjav(it) = ratjai
ratjbv(it) = ratjbi
ratjplv(it) = ratjpli
end do
end subroutine pec_init
subroutine spec(psjki,ppabs,ccci,iiv,pabs,currt,dpdv,ajphiv,ajcd,pins,currins)
use gray_params, only : nnd
use beamdata, only : nray,nstep
implicit none
! local constants
real(wp_), parameter :: rtbc=one
! arguments
real(wp_), dimension(nray,nstep), intent(in) :: psjki,ppabs,ccci
integer, dimension(nray), intent(in) :: iiv
real(wp_), intent(in) :: pabs,currt
real(wp_), dimension(nnd), intent(out) :: dpdv,ajphiv,ajcd,pins,currins
! local variables
integer :: i,ii,jk
real(wp_) :: spds,sccs,facpds,facjs
real(wp_), dimension(nstep):: xxi,ypt,yamp
real(wp_), dimension(nnd) :: wdpdv,wajphiv
! calculation of dP and dI over radial grid
dpdv=zero
ajphiv=zero
do jk=1,nray
ii=iiv(jk)
if (ii < nstep ) then
if(psjki(jk,ii+1) /= zero) ii=ii+1
end if
xxi=zero
ypt=zero
yamp=zero
do i=1,ii
xxi(i)=abs(psjki(jk,i))
if(xxi(i) <= one) then
ypt(i)=ppabs(jk,i)
yamp(i)=ccci(jk,i)
end if
end do
call pec_tab(xxi,ypt,yamp,ii,rtabpsi1,wdpdv,wajphiv)
dpdv = dpdv + wdpdv
ajphiv = ajphiv + wajphiv
end do
! here dpdv is still dP (not divided yet by dV)
! here ajphiv is still dI (not divided yet by dA)
spds=zero
sccs=zero
do i=1,nnd
spds=spds+dpdv(i)
sccs=sccs+ajphiv(i)
pins(i)=spds
currins(i)=sccs
end do
facpds=one
facjs=one
if(spds > zero) facpds=pabs/spds
if(sccs /= zero) facjs=currt/sccs
dpdv=facpds*(dpdv/dvol)
ajphiv=facjs*(ajphiv/darea)
ajcd=ajphiv*ratjbv
! now dpdv is dP/dV [MW/m^3]
! now ajphiv is J_phi=dI/dA [MA/m^2]
end subroutine spec
subroutine pec_tab(xxi,ypt,yamp,ii,xtab1,wdpdv,wajphiv)
! Power and current projected on psi grid - mid points
use const_and_precisions, only : wp_,one,zero
use gray_params, only : nnd
use utils, only : locatex,intlin
! arguments
integer, intent(in) :: ii
real(wp_), dimension(ii), intent(in) :: xxi,ypt,yamp
real(wp_), dimension(0:nnd), intent(in) :: xtab1
real(wp_), dimension(nnd), intent(out) :: wdpdv,wajphiv
! local variables
integer, parameter :: llmx = 21
integer, dimension(llmx) ::isev
real(wp_) :: ppa1,ppa2,cci1,cci2,dppa,didst,rt1
integer :: i,is,ise0,idecr,iise0,iise,iis,iis1
integer :: ind1,ind2,iind,ind,indi,itb1
isev = 0
ise0 = 0
idecr = -1
is = 1
wdpdv = zero
wajphiv = zero
do i=1,ii
if(ise0 == 0) then
if(xxi(i) < one) then
ise0 = i
isev(is) = i - 1
is = is + 1
end if
else
if (idecr == -1) then
if(xxi(i) > xxi(i-1)) then
isev(is) = i - 1
is = is + 1
idecr = 1
end if
else
if(xxi(i) > one) exit
if(xxi(i) < xxi(i-1)) then
isev(is) = i - 1
is = is + 1
idecr = -1
end if
end if
end if
end do
isev(is) = i-1
ppa1 = zero
cci1 = zero
do iis=1,is-1
iis1 = iis + 1
iise0 = isev(iis)
iise = isev(iis1)
if (mod(iis,2) /= 0) then
idecr = -1
ind1 = nnd
ind2 = 2
iind = -1
else
idecr = 1
ind1 = 1
ind2 = nnd
iind = 1
end if
do ind=ind1,ind2,iind
indi = ind
if (idecr == -1) indi = ind - 1
rt1 = xtab1(indi)
call locatex(xxi,iise,iise0,iise,rt1,itb1)
if(itb1 >= iise0 .and. itb1 < 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
didst = cci2 - cci1
wdpdv(ind) = wdpdv(ind) + dppa
wajphiv(ind) = wajphiv(ind) + didst
ppa1 = ppa2
cci1 = cci2
end if
end do
end do
end subroutine pec_tab
subroutine postproc_profiles(pabs,currt,rhot_tab,dpdv,ajphiv, &
rhotpav,drhotpav,rhotjava,drhotjava)
! radial average values over power and current density profile
use const_and_precisions, only : pi
use gray_params, only : nnd
use equilibrium, only : frhopol
use magsurf_data, only : fluxval
implicit none
real(wp_), intent(in) :: pabs,currt
real(wp_), dimension(nnd), intent(in) :: rhot_tab
real(wp_), dimension(nnd), intent(in) :: dpdv,ajphiv
real(wp_), intent(out) :: rhotpav,rhotjava
real(wp_), intent(out) :: drhotpav,drhotjava
real(wp_) :: rhopjava,rhoppav
real(wp_) :: dpdvp,dpdvmx,rhotp,drhotp
real(wp_) :: ajphip,ajmxfi,rhotjfi,drhotjfi
real(wp_) :: ratjamx,ratjbmx,ratjplmx
real(wp_) :: sccsa
real(wp_) :: rhotjav,rhot2pav,rhot2java,dvdrhotav,dadrhotava
rhotpav=zero
rhot2pav=zero
rhotjav=zero
rhotjava=zero
rhot2java=zero
if (pabs > zero) then
rhotpav = sum(rhot_tab *dpdv*dvol)/pabs
rhot2pav = sum(rhot_tab**2*dpdv*dvol)/pabs
end if
if (abs(currt) > zero) then
rhotjav = sum(rhot_tab*ajphiv*darea)/currt
end if
sccsa = sum(abs(ajphiv)*darea)
if (sccsa > zero) then
rhotjava = sum(rhot_tab *abs(ajphiv)*darea)/sccsa
rhot2java = sum(rhot_tab**2*abs(ajphiv)*darea)/sccsa
end if
! factor sqrt(8) = 2sqrt(2) to match full width of gaussian profile
drhotpav = sqrt(8._wp_*(rhot2pav -rhotpav**2))
drhotjava = sqrt(8._wp_*(rhot2java-rhotjava**2))
rhoppav = frhopol(rhotpav)
rhopjava = frhopol(rhotjava)
if (pabs > zero) then
call fluxval(rhoppav,dvdrhot=dvdrhotav)
dpdvp = pabs*2.0_wp_/(sqrt(pi)*drhotpav*dvdrhotav)
call profwidth(nnd,rhot_tab,dpdv,rhotp,dpdvmx,drhotp)
else
dpdvp = zero
rhotp = zero
dpdvmx = zero
drhotp = zero
end if
if (sccsa > zero) then
call fluxval(rhopjava,dadrhot=dadrhotava,ratja=ratjamx,ratjb=ratjbmx, &
ratjpl=ratjplmx)
ajphip = currt*2.0_wp_/(sqrt(pi)*drhotjava*dadrhotava)
call profwidth(nnd,rhot_tab,ajphiv,rhotjfi,ajmxfi,drhotjfi)
else
ajphip = zero
rhotjfi = zero
ajmxfi = zero
drhotjfi = zero
end if
end subroutine postproc_profiles
subroutine profwidth(nd,xx,yy,xpk,ypk,dxxe)
use const_and_precisions, only : wp_,emn1
use utils, only : locatex, locate, intlin, vmaxmini
implicit none
! arguments
integer :: nd
real(wp_), dimension(nd) :: xx,yy
real(wp_), intent(out) :: xpk,ypk,dxxe
! local variables
integer :: imn,imx,ipk,ie
real(wp_) :: xmn,xmx,ymn,ymx,xpkp,xpkm,yye,rte1,rte2
real(wp_) :: ypkp,ypkm
call vmaxmini(yy,nd,ymn,ymx,imn,imx)
ypk = zero
xmx = xx(imx)
xmn = xx(imn)
if (abs(ymx) > abs(ymn)) then
ipk = imx
ypkp = ymx
xpkp = xmx
if(abs(ymn/ymx) < 1.0e-2_wp_) ymn = 0.0_wp_
ypkm = ymn
xpkm = xmn
else
ipk = imn
ypkp = ymn
xpkp = xmn
if(abs(ymx/ymn) < 1.0e-2_wp_) ymx = 0.0_wp_
ypkm = ymx
xpkm = xmx
end if
if(xpkp > zero) then
xpk = xpkp
ypk = ypkp
yye = ypk*emn1
call locatex(yy,nd,1,ipk,yye,ie)
if(ie > 0 .and. ie < nd) then
call intlin(yy(ie),xx(ie),yy(ie+1),xx(ie+1),yye,rte1)
else
rte1 = zero
end if
call locatex(yy,nd,ipk,nd,yye,ie)
if(ie > 0 .and. ie < nd) then
call intlin(yy(ie),xx(ie),yy(ie+1),xx(ie+1),yye,rte2)
else
rte2 = zero
end if
else
ipk=2
xpk=xx(2)
ypk=yy(2)
rte1=0.0_wp_
yye=ypk*emn1
call locate(yy,nd,yye,ie)
if(ie > 0 .and. ie < nd) then
call intlin(yy(ie),xx(ie),yy(ie+1),xx(ie+1),yye,rte2)
else
rte2 = zero
end if
end if
dxxe = rte2 - rte1
if(ymx /= zero .and. ymn /= zero) dxxe = -dxxe
end subroutine profwidth
subroutine dealloc_pec
implicit none
if (allocated(rhop_tab)) deallocate(rhop_tab)
if (allocated(rhot_tab)) deallocate(rhot_tab)
if (allocated(rtabpsi1)) deallocate(rtabpsi1)
if (allocated(dvol)) deallocate(dvol)
if (allocated(darea)) deallocate(darea)
if (allocated(ratjav)) deallocate(ratjav)
if (allocated(ratjbv)) deallocate(ratjbv)
if (allocated(ratjplv)) deallocate(ratjplv)
end subroutine dealloc_pec
end module pec

152
src/polarization.f90 Normal file
View File

@ -0,0 +1,152 @@
module polarization
interface stokes
module procedure stokes_ce,stokes_ell
end interface
contains
subroutine stokes_ce(ext,eyt,qq,uu,vv)
use const_and_precisions, only : wp_,two
implicit none
! arguments
complex(wp_), intent(in) :: ext,eyt
real(wp_), intent(out) :: qq,uu,vv
qq = abs(ext)**2 - abs(eyt)**2
uu = two* dble(ext*dconjg(eyt))
vv = two*dimag(ext*dconjg(eyt))
end subroutine stokes_ce
subroutine stokes_ell(chi,psi,qq,uu,vv)
use const_and_precisions, only : wp_,two
implicit none
! arguments
real(wp_), intent(in) :: chi,psi
real(wp_), intent(out) :: qq,uu,vv
qq=cos(two*chi)*cos(two*psi)
uu=cos(two*chi)*sin(two*psi)
vv=sin(two*chi)
end subroutine stokes_ell
subroutine polellipse(qq,uu,vv,psi,chi)
use const_and_precisions, only : wp_,half
implicit none
! arguments
real(wp_), intent(in) :: qq,uu,vv
real(wp_), intent(out) :: psi,chi
! real(wp_) :: ll,aa,bb,ell
! ll = sqrt(qq**2 + uu**2)
! aa = sqrt(half*(1 + ll))
! bb = sqrt(half*(1 - ll))
! ell = bb/aa
psi = half*atan2(uu,qq)
chi = half*asin(vv)
end subroutine polellipse
subroutine pol_limit(anv,bv,bres,sox,ext,eyt) !,gam)
use const_and_precisions, only : wp_,ui=>im,pi,zero,one
implicit none
! arguments
real(wp_), dimension(3), intent(in) :: anv,bv
real(wp_), intent(in) :: bres,sox
complex(wp_), intent(out) :: ext,eyt
! real(wp_), optional, intent(out) :: gam
! local variables
real(wp_), dimension(3) :: bnv
real(wp_) :: anx,any,anz,an2,an,anpl2,anpl,anpr,anxy, &
btot,yg,den,dnl,del0,ff,ff2,sngam,csgam
!
btot = sqrt(bv(1)**2+bv(2)**2+bv(3)**2)
bnv = bv/btot
yg = btot/bres
anx = anv(1)
any = anv(2)
anz = anv(3)
an2 = anx**2 + any**2 + anz**2
an = sqrt(an2)
anxy = sqrt(anx**2 + any**2)
anpl = (anv(1)*bnv(1) + anv(2)*bnv(2) + anv(3)*bnv(3))
anpl2= anpl**2
anpr = sqrt(an2 - anpl2)
dnl = one - anpl2
del0 = sqrt(dnl**2 + 4.0_wp_*anpl2/yg**2)
sngam = (anz*anpl - an2*bnv(3))/(an*anxy*anpr)
csgam = -(any*bnv(1) - anx*bnv(2))/ (anxy*anpr)
ff = 0.5_wp_*yg*(dnl - sox*del0)
ff2 = ff**2
den = ff2 + anpl2
if (den>zero) then
ext = (ff*csgam - ui*anpl*sngam)/sqrt(den)
eyt = (-ff*sngam - ui*anpl*csgam)/sqrt(den)
else ! only for XM (sox=+1) when N//=0
ext = -ui*sngam
eyt = -ui*csgam
end if
! gam = atan2(sngam,csgam)/degree
end subroutine pol_limit
subroutine polarcold(anpl,anpr,xg,yg,sox,exf,eyif,ezf,elf,etf)
use const_and_precisions, only : wp_,zero,one
implicit none
! arguments
real(wp_), intent(in) :: anpl,anpr,xg,yg,sox
real(wp_), intent(out) :: exf,eyif,ezf,elf,etf
! local variables
real(wp_) :: anpl2,anpr2,an2,yg2,dy2,aa,e3,qq,p
if(xg <= zero) then
exf = zero
if(sox < zero) then
ezf = one
eyif = zero
else
ezf = zero
eyif = one
end if
elf = zero
etf = one
else
anpl2 = anpl**2
anpr2 = anpr**2
an2 = anpl2 + anpr2
yg2=yg**2
aa=1.0_wp_-xg-yg2
dy2 = one - yg2
qq = xg*yg/(an2*dy2 - aa)
if (anpl == zero) then
if(sox < zero) then
exf = zero
eyif = zero
ezf = one
else
qq = -aa/(xg*yg)
exf = one/sqrt(one + qq**2)
eyif = qq*exf
ezf = zero
end if
else
e3 = one - xg
p = (anpr2 - e3)/(anpl*anpr) ! undef for anpr==0
exf = p*ezf
eyif = qq*exf
ezf = one/sqrt(one + p**2*(one + qq**2))
end if
elf = (anpl*ezf + anpr*exf)/sqrt(an2)
etf = sqrt(one - elf**2)
end if
end subroutine polarcold
end module polarization

4541
src/quadpack.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

313
src/reflections.f90
View File

@ -1,21 +1,28 @@
module reflections module reflections
use const_and_precisions, only : wp_, comp_tiny, comp_eps, comp_huge, zero, one
implicit none implicit none
! === 1D array limiter Rlim_i, Zlim_i
integer, public, save :: nlim
real(wp_), public, save :: rwallm
real(wp_), public, dimension(:), allocatable, save :: rlim,zlim
private private
integer, parameter :: r8=selected_real_kind(15,300)
real(r8), parameter :: tinyr8=tiny(1._r8)
public :: reflect,inters_linewall,inside public :: reflect,inters_linewall,inside
public :: linecone_coord,interssegm_coord,interssegm public :: linecone_coord,interssegm_coord,interssegm
public :: alloc_lim,wall_refl,range2rect,set_lim
contains contains
subroutine reflect(ki,nsurf,ko) subroutine reflect(ki,nsurf,ko)
implicit none implicit none
real(r8), intent(in), dimension(3) :: ki real(wp_), intent(in), dimension(3) :: ki
real(r8), intent(in), dimension(3) :: nsurf real(wp_), intent(in), dimension(3) :: nsurf
real(r8), intent(out), dimension(3) :: ko real(wp_), intent(out), dimension(3) :: ko
real(r8) :: twokn,norm2 real(wp_) :: twokn,norm2
norm2 = dot_product(nsurf,nsurf) norm2 = dot_product(nsurf,nsurf)
if (norm2>0.0_r8) then if (norm2>zero) then
twokn = 2.0_r8*dot_product(ki,nsurf)/norm2 twokn = 2.0_wp_*dot_product(ki,nsurf)/norm2
ko=ki-twokn*nsurf ko=ki-twokn*nsurf
else else
ko=ki ko=ki
@ -24,30 +31,38 @@ end subroutine reflect
subroutine inters_linewall(xv,kv,rw,zw,nw,sint,normw) subroutine inters_linewall(xv,kv,rw,zw,nw,sint,normw)
implicit none implicit none
real(r8), intent(in), dimension(3) :: xv,kv real(wp_), intent(in), dimension(3) :: xv,kv
integer, intent(in) :: nw integer, intent(in) :: nw
real(r8), dimension(nw), intent(in) :: rw,zw real(wp_), dimension(nw), intent(in) :: rw,zw
real(r8), intent(out) :: sint real(wp_), intent(out) :: sint
real(r8), dimension(3), intent(out) :: normw real(wp_), dimension(3), intent(out) :: normw
integer :: i,j,ni,iint integer :: i,j,ni,iint,nneg
real(r8), dimension(2) :: si,ti real(wp_), dimension(2) :: si,ti
real(r8) :: drw,dzw,xint,yint,rint,l,kxy real(wp_) :: drw,dzw,xint,yint,rint,l,kxy
real(r8) :: tol real(wp_) :: tol
tol=sqrt(epsilon(1.0_r8)) tol=sqrt(comp_eps)
sint=huge(sint) sint=comp_huge
iint=0 iint=0
normw=0.0_r8 normw=zero
do i=1,nw-1 do i=1,nw-1
!search intersections with i-th wall segment !search intersections with i-th wall segment
call linecone_coord(xv,kv,rw(i:i+1),zw(i:i+1),si,ti,ni) call linecone_coord(xv,kv,rw(i:i+1),zw(i:i+1),si,ti,ni)
do while (ni>0 .and. si(1)<=tol) !discard solutions with s<=0
!remove solutions with s<=0 nneg=0
ni = ni-1
si(1) = si(2)
ti(1) = ti(2)
end do
do j=1,ni do j=1,ni
if ((si(j)<sint .or. iint==0) .and. ti(j)>=0._r8 .and. ti(j)<=1._r8) then if (si(j)<=tol) then
nneg=j
else
exit
end if
end do
! do while (ni>0 .and. si(1)<=tol)
! ni = ni-1
! si(1) = si(2) ???
! ti(1) = ti(2) ???
! end do
do j=nneg+1,ni
if ((si(j)<sint .or. iint==0) .and. ti(j)>=zero .and. ti(j)<=one) then
!check intersection is in r,z range and keep the closest !check intersection is in r,z range and keep the closest
sint = si(j) sint = si(j)
iint = i iint = i
@ -64,7 +79,7 @@ subroutine inters_linewall(xv,kv,rw,zw,nw,sint,normw)
l = sqrt(drw**2+dzw**2) l = sqrt(drw**2+dzw**2)
kxy = sqrt(kv(1)**2+kv(2)**2) kxy = sqrt(kv(1)**2+kv(2)**2)
normw(3) = -drw/l normw(3) = -drw/l
if (rint>0.0_r8) then if (rint>zero) then
normw(1) = xint/rint*dzw/l normw(1) = xint/rint*dzw/l
normw(2) = yint/rint*dzw/l normw(2) = yint/rint*dzw/l
else else
@ -72,17 +87,18 @@ subroutine inters_linewall(xv,kv,rw,zw,nw,sint,normw)
normw(2) = kv(2)/kxy*dzw/l normw(2) = kv(2)/kxy*dzw/l
end if end if
!reverse normal if k.n>0 !reverse normal if k.n>0
if (dot_product(normw,kv)>0.0_r8) normw=-normw if (dot_product(normw,kv)>zero) normw=-normw
end subroutine inters_linewall end subroutine inters_linewall
subroutine linecone_coord(xv,kv,rs,zs,s,t,n) subroutine linecone_coord(xv,kv,rs,zs,s,t,n)
use utils, only : bubble
implicit none implicit none
real(r8), intent(in), dimension(3) :: xv,kv real(wp_), intent(in), dimension(3) :: xv,kv
real(r8), intent(in), dimension(2) :: rs,zs real(wp_), intent(in), dimension(2) :: rs,zs
real(r8), dimension(2), intent(out) :: s,t real(wp_), dimension(2), intent(out) :: s,t
integer, intent(out) :: n integer, intent(out) :: n
real(r8) :: x0,y0,z0,kx,ky,kz real(wp_) :: x0,y0,z0,kx,ky,kz
real(r8) :: dr,dz,r,a,bhalf,c,delta,tvertex,zvertex,srmin,rmin,zrmin real(wp_) :: dr,dz,r,a,bhalf,c,delta,tvertex,zvertex,srmin,rmin,zrmin
x0=xv(1) x0=xv(1)
y0=xv(2) y0=xv(2)
z0=xv(3) z0=xv(3)
@ -93,9 +109,9 @@ subroutine linecone_coord(xv,kv,rs,zs,s,t,n)
dz = zs(2)-zs(1) dz = zs(2)-zs(1)
s = 0 s = 0
t = 0 t = 0
if (abs(dz)<tinyr8) then if (abs(dz)<comp_tiny) then
!surface in horizontal plane !surface in horizontal plane
if (abs(kz)<tinyr8 .or. abs(dr)<tinyr8) then if (abs(kz)<comp_tiny .or. abs(dr)<comp_tiny) then
n = 0 n = 0
else else
s(1) = (zs(1)-z0)/kz s(1) = (zs(1)-z0)/kz
@ -107,9 +123,9 @@ subroutine linecone_coord(xv,kv,rs,zs,s,t,n)
a = (kx**2+ky**2) - (dr/dz*kz)**2 a = (kx**2+ky**2) - (dr/dz*kz)**2
bhalf = -dr/dz*kz*rs(1) + (kx*x0 + ky*y0) - (dr/dz)**2*kz*(z0-zs(1)) bhalf = -dr/dz*kz*rs(1) + (kx*x0 + ky*y0) - (dr/dz)**2*kz*(z0-zs(1))
c = (x0**2+y0**2) - (rs(1) + dr/dz*(z0-zs(1)))**2 c = (x0**2+y0**2) - (rs(1) + dr/dz*(z0-zs(1)))**2
if (abs(a)<tinyr8) then if (abs(a)<comp_tiny) then
!line parallel to cone generator !line parallel to cone generator
if (abs(dr)<tinyr8) then if (abs(dr)<comp_tiny) then
!cylinder and vertical line !cylinder and vertical line
n = 0 n = 0
else else
@ -118,14 +134,14 @@ subroutine linecone_coord(xv,kv,rs,zs,s,t,n)
srmin = -(kx*x0 + ky*y0)/(kx**2+ky**2) srmin = -(kx*x0 + ky*y0)/(kx**2+ky**2)
rmin = sqrt((x0+srmin*kx)**2+(y0+srmin*ky)**2) rmin = sqrt((x0+srmin*kx)**2+(y0+srmin*ky)**2)
zrmin = z0 + srmin*kz zrmin = z0 + srmin*kz
if (rmin<tinyr8 .and. abs(zrmin-zvertex)<tinyr8) then if (rmin<comp_tiny .and. abs(zrmin-zvertex)<comp_tiny) then
!line passing by cone vertex !line passing by cone vertex
!s(1) = srmin !s(1) = srmin
!t(1) = tvertex !t(1) = tvertex
!n = 1 !n = 1
n = 0 n = 0
else else
s(1) = -0.5_r8*c/bhalf s(1) = -0.5_wp_*c/bhalf
t(1) = (kz*s(1)+(z0-zs(1)))/dz t(1) = (kz*s(1)+(z0-zs(1)))/dz
n = 1 n = 1
end if end if
@ -147,18 +163,18 @@ end subroutine linecone_coord
subroutine interssegm_coord(xa,ya,xb,yb,s,t,ierr) subroutine interssegm_coord(xa,ya,xb,yb,s,t,ierr)
implicit none implicit none
real(r8), dimension(2), intent(in) :: xa,ya,xb,yb real(wp_), dimension(2), intent(in) :: xa,ya,xb,yb
real(r8), intent(out) :: s,t real(wp_), intent(out) :: s,t
integer, intent(out) :: ierr integer, intent(out) :: ierr
real(r8) :: crossprod,dxa,dya,dxb,dyb real(wp_) :: crossprod,dxa,dya,dxb,dyb
dxa = xa(2)-xa(1) dxa = xa(2)-xa(1)
dya = ya(2)-ya(1) dya = ya(2)-ya(1)
dxb = xb(2)-xb(1) dxb = xb(2)-xb(1)
dyb = yb(2)-yb(1) dyb = yb(2)-yb(1)
crossprod = dxb*dya - dxa*dyb crossprod = dxb*dya - dxa*dyb
if (abs(crossprod)<tiny(crossprod)) then if (abs(crossprod)<comp_tiny) then
s = 0.0_r8 s = zero
t = 0.0_r8 t = zero
ierr = 1 ierr = 1
else else
s = (dyb*(xa(1)-xb(1)) - dxb*(ya(1)-yb(1)))/crossprod s = (dyb*(xa(1)-xb(1)) - dxb*(ya(1)-yb(1)))/crossprod
@ -169,25 +185,26 @@ end subroutine interssegm_coord
function interssegm(xa,ya,xb,yb) function interssegm(xa,ya,xb,yb)
implicit none implicit none
real(r8), dimension(2), intent(in) :: xa,ya,xb,yb real(wp_), dimension(2), intent(in) :: xa,ya,xb,yb
logical :: interssegm logical :: interssegm
real(r8) :: s,t real(wp_) :: s,t
integer :: ierr integer :: ierr
interssegm = .false. interssegm = .false.
call interssegm_coord(xa,ya,xb,yb,s,t,ierr) call interssegm_coord(xa,ya,xb,yb,s,t,ierr)
if (ierr==0 .and. s>=0._r8 .and. s<=1._r8 .and. & if (ierr==0 .and. s>=zero .and. s<=one .and. &
t>=0._r8 .and. t<=1._r8) interssegm = .true. t>=zero .and. t<=one) interssegm = .true.
end function interssegm end function interssegm
function inside(xc,yc,n,x,y) function inside(xc,yc,n,x,y)
use utils, only : locatef, locate_unord, intlinf, bubble
implicit none implicit none
integer, intent(in) :: n integer, intent(in) :: n
real(r8), dimension(n), intent(in) :: xc,yc real(wp_), dimension(n), intent(in) :: xc,yc
real(r8), intent(in) :: x,y real(wp_), intent(in) :: x,y
logical :: inside logical :: inside
integer, dimension(n) :: jint integer, dimension(n) :: jint
real(r8), dimension(n) :: xint real(wp_), dimension(n) :: xint
real(r8), dimension(n+1) :: xclosed,yclosed real(wp_), dimension(n+1) :: xclosed,yclosed
integer :: i,nj integer :: i,nj
xclosed(1:n)=xc(1:n) xclosed(1:n)=xc(1:n)
yclosed(1:n)=yc(1:n) yclosed(1:n)=yc(1:n)
@ -197,92 +214,130 @@ function inside(xc,yc,n,x,y)
inside=.false. inside=.false.
if (nj==0) return if (nj==0) return
do i=1,nj do i=1,nj
xint(i)=intlin(yclosed(jint(i)),xclosed(jint(i)), & xint(i)=intlinf(yclosed(jint(i)),xclosed(jint(i)), &
yclosed(jint(i)+1),xclosed(jint(i)+1),y) yclosed(jint(i)+1),xclosed(jint(i)+1),y)
end do end do
call bubble(xint,nj) call bubble(xint,nj)
inside=(mod(locate(xint,nj,x),2)==1) inside=(mod(locatef(xint,nj,x),2)==1)
end function inside end function inside
function intlin(x1,y1,x2,y2,x) result(y) subroutine alloc_lim(ier)
!linear interpolation
!must be x1 != x2
implicit none implicit none
real(r8),intent(in) :: x1,y1,x2,y2,x integer, intent(out) :: ier
real(r8) :: y
real(r8) :: a
a=(x2-x)/(x2-x1)
y=a*y1+(1._r8-a)*y2
end function intlin
subroutine locate_unord(a,n,x,j,m,nj) if(nlim.lt.0) then
implicit none ier = -1
integer, intent(in) :: n,m return
integer, intent(out) :: nj
real(r8), dimension(n), intent(in) :: a
real(r8), intent(in) :: x
integer, dimension(m), intent(inout) :: j
integer :: i
nj=0
do i=1,n-1
if (x>a(i).neqv.x>a(i+1)) then
nj=nj+1
if (nj<=m) j(nj)=i
end if
end do
end subroutine locate_unord
function locate(a,n,x) result(j)
!Given an array a(n), and a value x, with a(n) monotonic, either
!increasing or decreasing, returns a value j such that
!a(j) < x <= a(j+1) for a increasing, and such that
!a(j+1) < x <= a(j) for a decreasing.
!j=0 or j=n indicate that x is out of range (Numerical Recipes)
implicit none
integer, intent(in) :: n
real(r8), dimension(n), intent(in) :: a
real(r8), intent(in) :: x
integer :: j
integer :: jl,ju,jm
logical :: incr
jl=0
ju=n+1
incr=a(n)>a(1)
do while ((ju-jl)>1)
jm=(ju+jl)/2
if(incr.eqv.(x>a(jm))) then
jl=jm
else
ju=jm
endif
end do
j=jl
end function locate
subroutine order(p,q)
!returns p,q in ascending order
implicit none
real(r8), intent(inout) :: p,q
real(r8) :: temp
if (p>q) then
temp=p
p=q
q=temp
end if end if
end subroutine order
subroutine bubble(a,n) call dealloc_lim
!bubble sorting of array a allocate(rlim(nlim),zlim(nlim), &
stat=ier)
if (ier/=0) call dealloc_lim
end subroutine alloc_lim
subroutine dealloc_lim
implicit none implicit none
integer, intent(in) :: n if(allocated(rlim)) deallocate(rlim)
real(r8), dimension(n), intent(inout) :: a if(allocated(zlim)) deallocate(zlim)
integer :: i, j end subroutine dealloc_lim
do i=1,n
do j=n,i+1,-1 subroutine wall_refl(xv,anv,ext,eyt,xvrfl,anvrfl,extr,eytr,walln,irfl)
call order(a(j-1), a(j)) implicit none
end do ! arguments
end do integer :: irfl
end subroutine bubble real(wp_), dimension(3) :: xv,anv,xvrfl,anvrfl,walln
complex(wp_) :: ext,eyt,extr,eytr
! local variables
real(wp_) :: smax,rrm,zzm
real(wp_), dimension(3) :: anv0,vv1,vv2,vv3
complex(wp_) :: eztr
complex(wp_), dimension(3) :: evin,evrfl
!
anv0=anv/sqrt(anv(1)**2+anv(2)**2+anv(3)**2)
rrm=1.0e-2_wp_*sqrt(xv(1)**2+xv(2)**2)
zzm=1.0e-2_wp_*xv(3)
!
! computation of reflection coordinates and normal to the wall
call inters_linewall(xv/1.0e2_wp_,anv0,rlim(1:nlim),zlim(1:nlim), &
nlim,smax,walln)
smax=smax*1.0e2_wp_
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.0e2_wp_,anv0,rlim(1:nlim), &
zlim(1:nlim),nlim,smax,walln)
smax=smax*1.0e2_wp_
xvrfl=xvrfl+smax*anv0
irfl=2
end if
!
! rotation matrix from local to lab frame
vv1(1)=anv0(2)
vv1(2)=-anv0(1)
vv1(3)=0.0_wp_
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
! wave vector and electric field after reflection in lab frame
anvrfl=anv0-2.0_wp_* &
(anv0(1)*walln(1)+anv0(2)*walln(2)+anv0(3)*walln(3))*walln
evrfl=-evin+2.0_wp_* &
(evin(1)*walln(1)+evin(2)*walln(2)+evin(3)*walln(3))*walln
!
vv1(1)=anvrfl(2)
vv1(2)=-anvrfl(1)
vv1(3)=0.0_wp_
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)
end subroutine wall_refl
subroutine range2rect(xmin,xmax,ymin,ymax,xv,yv)
implicit none
real(wp_), intent(in) :: xmin,xmax,ymin,ymax
real(wp_), intent(out), dimension(:), allocatable :: xv,yv
if (allocated(xv)) deallocate(xv)
if (allocated(yv)) deallocate(yv)
allocate(xv(5),yv(5))
xv=(/xmin,xmax,xmax,xmin,xmin/)
yv=(/ymin,ymin,ymax,ymax,ymin/)
end subroutine range2rect
subroutine set_lim(rv,zv)
implicit none
real(wp_), intent(in), dimension(:) :: rv,zv
if (allocated(rlim)) deallocate(rlim)
if (allocated(zlim)) deallocate(zlim)
nlim=size(rv)
allocate(rlim(nlim),zlim(nlim))
rlim=rv
zlim=zv
rwallm=minval(rlim)
end subroutine set_lim
end module reflections end module reflections

273
src/simplespline.f90 Normal file
View File

@ -0,0 +1,273 @@
module simplespline
use const_and_precisions, only : wp_
implicit none
contains
function spli(cspli,n,k,dx)
implicit none
integer, intent(in) :: n, k
real(wp_), intent(in) :: cspli(n,4), dx
real(wp_) :: spli
spli=cspli(k,1)+dx*(cspli(k,2)+dx*(cspli(k,3)+dx*cspli(k,4)))
end function spli
function splid(cspli,n,k,dx)
implicit none
integer, intent(in) :: n, k
real(wp_), intent(in) :: cspli(n,4), dx
real(wp_) :: splid
splid=cspli(k,2)+dx*(2.0_wp_*cspli(k,3)+3.0_wp_*dx*cspli(k,4))
end function splid
subroutine difcs(x,y,n,iopt,c,ier)
implicit none
integer, intent(in) :: n, iopt
real(wp_), intent(in) :: x(n), y(n)
real(wp_), intent(inout) :: c(n*4)
integer :: ier
integer :: jmp,iol,ioh,i,ii,j,j1,j2,j3
real(wp_) :: xb,xc,ya,yb,h,a,r,dya,dyb,dy2
jmp =1
if (n <= 1) return
!
! initialization
!
xc =x(1)
yb =y(1)
h =0.0_wp_
a =0.0_wp_
r =0.0_wp_
dyb =0.0_wp_
!
! iol=0 - given derivative at first point
! ioh=0 - given derivative at last point
!
iol =iopt-1
ioh =iopt-2
if (ioh == 1) then
iol =0
ioh =0
end if
dy2 =c(2)
!
! form the system of linear equations
! and eliminate subsequentially
!
j =1
do i=1,n
j2 =n+i
j3 =j2+n
a =h*(2.0_wp_-a)
dya =dyb+h*r
if (i>=n) then
!
! set derivative dy2 at last point
!
dyb =dy2
h =0.0_wp_
if (ioh/=0) then
dyb =dya
goto 13
end if
else
j =j+jmp
xb =xc
xc =x(j)
h =xc-xb
!
! ii=0 - increasing abscissae
! ii=1 - decreasing abscissae
!
ii =0
if (h==0) return
if (h<0) ii =1
ya =yb
yb =y(j)
dyb =(yb-ya)/h
if (i<=1) then
j1 =ii
if (iol/=0) goto 13
dya =c(1)
end if
end if
if (j1-ii /= 0) return
a =1.0_wp_/(h+h+a)
13 continue
r =a*(dyb-dya)
c(j3)=r
a =h*a
c(j2)=a
c(i) =dyb
end do
!
! back substitution of the system of linear equations
! and computation of the other coefficients
!
a =1.0_wp_
j1 =j3+n+ii-ii*n
i =n
do iol=1,n
xb =x(j)
h =xc-xb
xc =xb
a =a+h
yb =r
r =c(j3)-r*c(j2)
ya =r+r
c(j3)=ya+r
c(j2)=c(i)-h*(ya+yb)
c(j1)=(yb-r)/a
c(i) =y(j)
a =0.0_wp_
j =j-jmp
i =i-1
j2 =j2-1
j3 =j3-1
j1 =j3+n+ii
end do
ier =0
end subroutine difcs
subroutine difcsn(xx,yy,nmx,n,iopt,cc,ier)
!
! same as difcs but with dimension(xx,yy) = nmx > n
!
implicit none
integer, intent(in) :: nmx, n, iopt
real(wp_), intent(in) :: xx(nmx), yy(nmx)
real(wp_), intent(inout) :: cc(nmx,4)
integer :: ier
integer :: jmp,iol,ioh,i,ii,j,j1,j2,j3
real(wp_) :: x(n),y(n),c(n*4),xb,xc,ya,yb,h,a,r,dya,dyb,dy2
!
do i=1,n
x(i)=xx(i)
y(i)=yy(i)
end do
ii=0
do j=1,4
do i=1,n
ii=ii+1
c(ii)=cc(i,j)
end do
end do
!
jmp =1
if (n>1) then
!
! initialization
!
xc =x(1)
yb =y(1)
h =0.0_wp_
a =0.0_wp_
r =0.0_wp_
dyb =0.0_wp_
!
! iol=0 - given derivative at first point
! ioh=0 - given derivative at last point
!
iol =iopt-1
ioh =iopt-2
if (ioh==1) then
iol =0
ioh =0
end if
dy2 =c(2)
!
! form the system of linear equations
! and eliminate subsequentially
!
j =1
do i=1,n
j2 =n+i
j3 =j2+n
a =h*(2.0_wp_-a)
dya =dyb+h*r
if (i>=n) then
!
! set derivative dy2 at last point
!
dyb =dy2
h =0.0_wp_
if (ioh/=0) then
dyb =dya
goto 13
end if
else
j =j+jmp
xb =xc
xc =x(j)
h =xc-xb
!
! ii=0 - increasing abscissae
! ii=1 - decreasing abscissae
!
ii =0
if (h==0) goto 16
if (h<0) ii =1
ya =yb
yb =y(j)
dyb =(yb-ya)/h
if (i<=1) then
j1 =ii
if (iol/=0) goto 13
dya =c(1)
end if
end if
if (j1/=ii) goto 16
a =1.0_wp_/(h+h+a)
13 continue
r =a*(dyb-dya)
c(j3)=r
a =h*a
c(j2)=a
c(i) =dyb
end do
!
! back substitution of the system of linear equations
! and computation of the other coefficients
!
a =1.0_wp_
j1 =j3+n+ii-ii*n
i =n
do iol=1,n
xb =x(j)
h =xc-xb
xc =xb
a =a+h
yb =r
r =c(j3)-r*c(j2)
ya =r+r
c(j3)=ya+r
c(j2)=c(i)-h*(ya+yb)
c(j1)=(yb-r)/a
c(i) =y(j)
a =0.0_wp_
j =j-jmp
i =i-1
j2 =j2-1
j3 =j3-1
j1 =j3+n+ii
end do
ier =0
end if
!
16 continue
ii=0
do j=1,4
do i=1,nmx
if(i<=n) then
ii=ii+1
cc(i,j)=c(ii)
else
cc(i,j)=0.0_wp_
end if
end do
end do
!
end subroutine difcsn
end module simplespline

278
src/utils.f90 Normal file
View File

@ -0,0 +1,278 @@
module utils
use const_and_precisions, only : wp_
implicit none
contains
function locatef(a,n,x) result(j)
! Given an array a(n), and a value x, with a(n) monotonic, either
! increasing or decreasing, returns a value j such that
! a(j) < x <= a(j+1) for a increasing, and such that
! a(j+1) < x <= a(j) for a decreasing.
! j=0 or j=n indicate that x is out of range (Numerical Recipes)
implicit none
integer, intent(in) :: n
real(wp_), dimension(n), intent(in) :: a
real(wp_), intent(in) :: x
integer :: j
integer :: jl,ju,jm
logical :: incr
jl=0
ju=n+1
incr=a(n)>a(1)
do while ((ju-jl)>1)
jm=(ju+jl)/2
if(incr.eqv.(x>a(jm))) then
jl=jm
else
ju=jm
endif
end do
j=jl
end function locatef
subroutine locate(xx,n,x,j)
implicit none
integer, intent(in) :: n
real(wp_), intent(in) :: xx(n), x
integer, intent(out) :: j
integer :: jl,ju,jm
logical :: incr
!
! Given an array xx(n), and a value x
! returns a value j such that xx(j) < x < xx(j+1)
! xx(n) must be monotonic, either increasing or decreasing.
! j=0 or j=n indicate that x is out of range (Numerical Recipes)
!
jl=0
ju=n+1
incr=xx(n)>xx(1)
do while ((ju-jl)>1)
jm=(ju+jl)/2
if(incr .eqv. (x>xx(jm))) then
jl=jm
else
ju=jm
endif
end do
j=jl
end subroutine locate
subroutine locatex(xx,n,n1,n2,x,j)
implicit none
integer, intent(in) :: n,n1,n2
real(wp_), intent(in) :: xx(n), x
integer, intent(out) :: j
integer :: jl,ju,jm
!
! Given an array xx(n), and a value x
! returns a value j such that xx(j) < x < xx(j+1)
! xx(n) must be monotonic, either increasing or decreasing.
! j=n1-1or j=n2+1 indicate that x is out of range
! modified from subr. locate (Numerical Recipes)
!
jl=n1-1
ju=n2+1
do while ((ju-jl)>1)
jm=(ju+jl)/2
if((xx(n2)>xx(n1)) .eqv. (x>xx(jm))) then
jl=jm
else
ju=jm
endif
end do
j=jl
end subroutine locatex
subroutine locate_unord(a,n,x,j,m,nj)
implicit none
integer, intent(in) :: n,m
integer, intent(out) :: nj
real(wp_), dimension(n), intent(in) :: a
real(wp_), intent(in) :: x
integer, dimension(m), intent(inout) :: j
integer :: i
nj=0
do i=1,n-1
if (x>a(i).neqv.x>a(i+1)) then
nj=nj+1
if (nj<=m) j(nj)=i
end if
end do
end subroutine locate_unord
function intlinf(x1,y1,x2,y2,x) result(y)
!linear interpolation
!must be x1 != x2
use const_and_precisions, only : one
implicit none
real(wp_),intent(in) :: x1,y1,x2,y2,x
real(wp_) :: y
real(wp_) :: a
a=(x2-x)/(x2-x1)
y=a*y1+(one-a)*y2
end function intlinf
subroutine intlin(x1,y1,x2,y2,x,y)
implicit none
real(wp_), intent(in) :: x1,y1,x2,y2,x
real(wp_), intent(out) :: y
real(wp_) :: dx,aa,bb
!
! linear interpolation
! (x1,y1) < (x,y) < (x2,y2)
!
dx=x2-x1
aa=(x2-x)/dx
bb=1.0_wp_-aa
y=aa*y1+bb*y2
end subroutine intlin
subroutine vmax(x,n,xmax,imx)
implicit none
integer, intent(in) :: n
real(wp_), intent(in) :: x(n)
real(wp_), intent(out) :: xmax
integer, intent(out) :: imx
integer :: i
if (n<1) then
imx=0
return
end if
imx=1
xmax=x(1)
do i=2,n
if(x(i)>xmax) then
xmax=x(i)
imx=i
end if
end do
end subroutine vmax
subroutine vmin(x,n,xmin,imn)
implicit none
integer, intent(in) :: n
real(wp_), intent(in) :: x(n)
real(wp_), intent(out) :: xmin
integer, intent(out) :: imn
integer :: i
if (n<1) then
imn=0
return
end if
imn=1
xmin=x(1)
do i=2,n
if(x(i)<xmin) then
xmin=x(i)
imn=i
end if
end do
end subroutine vmin
subroutine vmaxmini(x,n,xmin,xmax,imn,imx)
implicit none
integer, intent(in) :: n
real(wp_), intent(in) :: x(n)
real(wp_), intent(out) :: xmin, xmax
integer, intent(out) :: imn, imx
integer :: i
if (n<1) then
imn=0
imx=0
return
end if
imn=1
imx=1
xmin=x(1)
xmax=x(1)
do i=2,n
if(x(i)<xmin) then
xmin=x(i)
imn=i
else if(x(i)>xmax) then
xmax=x(i)
imx=i
end if
end do
end subroutine vmaxmini
subroutine vmaxmin(x,n,xmin,xmax)
implicit none
integer, intent(in) :: n
real(wp_), intent(in) :: x(n)
real(wp_), intent(out) :: xmin, xmax
integer :: i
if (n<1) then
return
end if
xmin=x(1)
xmax=x(1)
do i=2,n
if(x(i)<xmin) then
xmin=x(i)
else if(x(i)>xmax) then
xmax=x(i)
end if
end do
end subroutine vmaxmin
subroutine order(p,q)
! returns p,q in ascending order
implicit none
real(wp_), intent(inout) :: p,q
real(wp_) :: temp
if (p>q) then
temp=p
p=q
q=temp
end if
end subroutine order
subroutine bubble(a,n)
! bubble sorting of array a
implicit none
integer, intent(in) :: n
real(wp_), dimension(n), intent(inout) :: a
integer :: i, j
do i=1,n
do j=n,i+1,-1
call order(a(j-1), a(j))
end do
end do
end subroutine bubble
function get_free_unit(umin,umax) result(i)
implicit none
integer :: i
integer, intent(in), optional :: umin, umax
integer, parameter :: max_allowed = 999
integer :: ierr, iend
logical :: ex, op
if (present(umin)) then
i = max(0,umin) ! start searching from unit min
else
i = 0
end if
if (present(umax)) then
iend = min(max(0,umax),max_allowed)
else
iend = max_allowed
end if
do
if (i>iend) then
i=-1 ! no free units found
exit
end if
inquire(unit=i,exist=ex,opened=op,iostat=ierr)
if (ierr==0.and.ex.and..not.op) exit ! unit i exists and is not open
i = i + 1
end do
end function get_free_unit
end module utils