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

simplify handling of splines

Browse Source 
This adds a new `splines` module which implements a high-level interface
for creating and evaluating splines and rewrite almost all modules to
use it. Also, notably:

1. both `simplespline` and DIERCKX splines can now used with a uniform
   interface

2. most complexity due to handling working space arrays is gone

3. memory management has been significantly simplified too
This commit is contained in:
Michele Guerini Rocco 2022-12-18 14:09:40 +01:00
parent 1261860f40
commit b1accf0ae3
Signed by: rnhmjoj
GPG Key ID: BFBAF4C975F76450
10 changed files with 1181 additions and 1080 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
src/beams.f90
View File

@ -96,10 +96,10 @@ contains
! directions (mm⁻¹) ! directions (mm⁻¹)
! - φ_w, φ_R are the angles of the amplitude and phase ellipses (deg) ! - φ_w, φ_R are the angles of the amplitude and phase ellipses (deg)
use gray_params, only : antenna_parameters use gray_params, only : antenna_parameters
use simplespline, only : spli, difcs use splines, only : spline_simple
use utils, only : get_free_unit,locate use utils, only : get_free_unit,locate
use logger, only : log_error use logger, only : log_error
implicit none implicit none
@ -108,13 +108,14 @@ contains
integer, intent(in), optional :: unit integer, intent(in), optional :: unit
! local variables ! local variables
integer :: u, iopt, ier, nisteer, i, k, ii integer :: u, nisteer, i, k, ii
real(wp_) :: steer, dal real(wp_) :: steer, dal
real(wp_), dimension(:), allocatable :: & real(wp_), dimension(:), allocatable :: &
alphastv, betastv, x00v, y00v, & alphastv, betastv, x00v, y00v, &
z00v, waist1v, waist2v, rci1v, rci2v, phi1v, phi2v, & z00v, waist1v, waist2v, rci1v, rci2v, phi1v, phi2v
cbeta, cx0, cy0, cz0, cwaist1, cwaist2, & type(spline_simple) :: beta, waist1, waist2, &
crci1, crci2, cphi1, cphi2 rci1, rci2, phi1, phi2, &
x0, y0, z0
integer :: err integer :: err
u = get_free_unit(unit) u = get_free_unit(unit)
@ -128,13 +129,10 @@ contains
read(u,*) params%fghz read(u,*) params%fghz
read(u,*) nisteer read(u,*) nisteer
allocate(alphastv(nisteer), betastv(nisteer), waist1v(nisteer), & allocate(alphastv(nisteer), betastv(nisteer), waist1v(nisteer), &
waist2v(nisteer), rci1v(nisteer), rci2v(nisteer), & waist2v(nisteer), rci1v(nisteer), rci2v(nisteer), &
phi1v(nisteer), phi2v(nisteer), x00v(nisteer), & phi1v(nisteer), phi2v(nisteer), x00v(nisteer), &
y00v(nisteer), z00v(nisteer), cbeta(4*nisteer), & y00v(nisteer), z00v(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))
do i=1,nisteer do i=1,nisteer
read(u, *) steer, alphastv(i), betastv(i), & read(u, *) steer, alphastv(i), betastv(i), &
@ -151,34 +149,33 @@ contains
z00v = 0.1_wp_ * z00v z00v = 0.1_wp_ * z00v
waist1v = 0.1_wp_ * waist1v waist1v = 0.1_wp_ * waist1v
waist2v = 0.1_wp_ * waist2v waist2v = 0.1_wp_ * waist2v
rci1v = 10._wp_ * rci1v rci1v = 10 * rci1v
rci2v = 10._wp_ * rci2v rci2v = 10 * rci2v
iopt = 0 call beta%init(alphastv, betastv, nisteer)
call difcs(alphastv, betastv, nisteer, iopt, cbeta, ier) call waist1%init(alphastv, waist1v, nisteer)
call difcs(alphastv, waist1v, nisteer, iopt, cwaist1, ier) call waist2%init(alphastv, waist2v, nisteer)
call difcs(alphastv, rci1v, nisteer, iopt, crci1, ier) call rci1%init(alphastv, rci1v, nisteer)
call difcs(alphastv, waist2v, nisteer, iopt, cwaist2, ier) call rci2%init(alphastv, rci2v, nisteer)
call difcs(alphastv, rci2v, nisteer, iopt, crci2, ier) call phi1%init(alphastv, phi1v, nisteer)
call difcs(alphastv, phi1v, nisteer, iopt, cphi1, ier) call phi2%init(alphastv, phi2v, nisteer)
call difcs(alphastv, phi2v, nisteer, iopt, cphi2, ier) call x0%init(alphastv, x00v, nisteer)
call difcs(alphastv, x00v, nisteer, iopt, cx0, ier) call y0%init(alphastv, y00v, nisteer)
call difcs(alphastv, y00v, nisteer, iopt, cy0, ier) call z0%init(alphastv, z00v, nisteer)
call difcs(alphastv, z00v, nisteer, iopt, cz0, ier)
if((params%alpha > alphastv(1)) .and. (params%alpha < alphastv(nisteer))) then if((params%alpha > alphastv(1)) .and. (params%alpha < alphastv(nisteer))) then
call locate(alphastv, nisteer, params%alpha , k) call locate(alphastv, nisteer, params%alpha , k)
dal = params%alpha - alphastv(k) dal = params%alpha - alphastv(k)
params%beta = spli(cbeta, nisteer, k, dal) params%beta = beta%raw_eval(k, dal)
params%pos(1) = spli(cx0, nisteer, k, dal) params%pos(1) = x0%raw_eval(k, dal)
params%pos(2) = spli(cy0, nisteer, k, dal) params%pos(2) = y0%raw_eval(k, dal)
params%pos(3) = spli(cz0, nisteer, k, dal) params%pos(3) = z0%raw_eval(k, dal)
params%w(1) = spli(cwaist1, nisteer, k, dal) params%w(1) = waist1%raw_eval(k, dal)
params%w(2) = spli(cwaist2, nisteer, k, dal) params%w(2) = waist2%raw_eval(k, dal)
params%ri(1) = spli(crci1, nisteer, k, dal) params%ri(1) = rci1%raw_eval(k, dal)
params%ri(2) = spli(crci2, nisteer, k, dal) params%ri(2) = rci2%raw_eval(k, dal)
params%phi(1) = spli(cphi1, nisteer, k, dal) params%phi(1) = phi1%raw_eval(k, dal)
params%phi(2) = spli(cphi2, nisteer, k, dal) params%phi(2) = phi2%raw_eval(k, dal)
else else
! params%alpha outside table range ! params%alpha outside table range
if(params%alpha >= alphastv(nisteer)) ii=nisteer if(params%alpha >= alphastv(nisteer)) ii=nisteer
@ -196,10 +193,20 @@ contains
params%phi(2) = phi2v(ii) params%phi(2) = phi2v(ii)
end if end if
deallocate(alphastv, betastv, waist1v, waist2v, rci1v, rci2v, & deallocate(alphastv, betastv, waist1v, waist2v, &
phi1v, phi2v, x00v, y00v, z00v, cbeta, & rci1v, rci2v, phi1v, phi2v, &
cx0, cy0, cz0, cwaist1, cwaist2, & x00v, y00v, z00v)
crci1, crci2, cphi1, cphi2)
call beta%deinit
call waist1%deinit
call waist2%deinit
call rci1%deinit
call rci2%deinit
call phi1%deinit
call phi2%deinit
call x0%deinit
call y0%deinit
call z0%deinit
end subroutine read_beam1 end subroutine read_beam1

172
src/coreprofiles.f90
View File

@ -1,4 +1,4 @@
! This modules handles the loading, interpolation and evaluation of the ! This module handles the loading, interpolation and evaluation of the
! plasma profiles (density, temperature, effective charge) ! plasma profiles (density, temperature, effective charge)
! !
! Two kinds of profiles are supported: analytical (suffix `_an` in the ! Two kinds of profiles are supported: analytical (suffix `_an` in the
@ -6,20 +6,10 @@
! the data is interpolated using splines. ! the data is interpolated using splines.
module coreprofiles module coreprofiles
use const_and_precisions, only : wp_, zero, one use const_and_precisions, only : wp_, zero, one
use splines, only : spline_simple, spline_1d
implicit none implicit none
! Parameters of the plasma profiles splines
type spline_parameters
integer :: ndata ! Number of data points
integer :: nknots ! Number of spline knots
! Density spline (ψ, knots, B-spline coefficients)
real(wp_), dimension(:), allocatable :: knots, coeffs
! Temperature and effective charge arrays (ψ, T(ψ), Zeff(ψ))
real(wp_), dimension(:), allocatable :: psi
real(wp_), dimension(:, :), allocatable :: temp, zeff
end type
! Parameters of the C² polynomial tail of the density spline ! Parameters of the C² polynomial tail of the density spline
type density_tail type density_tail
real(wp_) :: start ! ψ₀, start of the tail real(wp_) :: start ! ψ₀, start of the tail
@ -38,10 +28,12 @@ module coreprofiles
real(wp_) :: zeff ! Effective charge real(wp_) :: zeff ! Effective charge
end type end type
! Global variable storing the state of the module ! Global variables storing the state of the module
type(spline_parameters), save :: spline type(spline_1d), save :: dens_spline
type(density_tail), save :: tail type(spline_simple), save :: temp_spline
type(analytic_model), save :: model type(spline_simple), save :: zeff_spline
type(density_tail), save :: tail
type(analytic_model), save :: model
private private
public read_profiles, read_profiles_an ! Reading data files public read_profiles, read_profiles_an ! Reading data files
@ -58,7 +50,6 @@ contains
! !
! Note: density has units of 10¹⁹ m⁻³. ! Note: density has units of 10¹⁹ m⁻³.
use gray_params, only : iprof use gray_params, only : iprof
use dierckx, only : splev, splder
use logger, only : log_error use logger, only : log_error
implicit none implicit none
@ -68,14 +59,11 @@ contains
real(wp_), intent(out) :: dens, ddens ! density and first derivative real(wp_), intent(out) :: dens, ddens ! density and first derivative
! local variables ! local variables
integer :: ier ! dierck error code character(256) :: msg ! for log messages formatting
real(wp_) :: f(1) ! dierck output (must be an array)
real(wp_) :: wrkfd(spline%ndata+4) ! dierck working space array
character(256) :: msg ! for log messages formatting
! Initialise both to zero ! Initialise both to zero
dens = zero dens = 0
ddens = zero ddens = 0
! Outside the tail end both density and its ! Outside the tail end both density and its
! derivatives are identically zero ! derivatives are identically zero
@ -97,16 +85,10 @@ contains
! Use the interpolating spline when in range ! Use the interpolating spline when in range
! Evaluate the spline ! Evaluate the spline
ier = 0 dens = dens_spline%eval(psin)
call splev(spline%knots, spline%nknots, spline%coeffs, & ddens = dens_spline%deriv(psin)
3, [psin], f, 1, ier)
dens = f(1)
! Evaluate the spline 1st derivative ! Evaluate the spline 1st derivative
ier = 0
call splder(spline%knots, spline%nknots, spline%coeffs, &
3, 1, [psin], f, 1, wrkfd, ier)
ddens = f(1)
if (abs(dens) < 1.0e-10_wp_) dens = zero if (abs(dens) < 1.0e-10_wp_) dens = zero
else else
! Use a C² polynomial extension outside (ψ > ψ₀) ! Use a C² polynomial extension outside (ψ > ψ₀)
@ -158,9 +140,7 @@ contains
! normalised poloidal flux. ! normalised poloidal flux.
! !
! Note: temperature has units of keV. ! Note: temperature has units of keV.
use gray_params, only : iprof use gray_params, only : iprof
use utils, only : locate
use simplespline, only : spli
implicit none implicit none
@ -169,10 +149,9 @@ contains
real(wp_) :: temp real(wp_) :: temp
! local variables ! local variables
integer :: k real(wp_) :: proft
real(wp_) :: proft, dps
temp = zero temp = 0
if (psin >= 1 .or. psin < 0) return if (psin >= 1 .or. psin < 0) return
if (iprof == 0) then if (iprof == 0) then
! Use the analytical model ! Use the analytical model
@ -183,10 +162,7 @@ contains
temp = (model%te0 - model%te1)*proft + model%te1 temp = (model%te0 - model%te1)*proft + model%te1
else else
! Use the interpolated numerical data ! Use the interpolated numerical data
call locate(spline%psi, spline%ndata, psin, k) temp = temp_spline%eval(psin)
k = max(1, min(k, spline%ndata - 1))
dps = psin - spline%psi(k)
temp = spli(spline%temp, spline%ndata, k, dps)
endif endif
end function temp end function temp
@ -195,8 +171,6 @@ contains
! Computes the effective charge Zeff as a ! Computes the effective charge Zeff as a
! function of the normalised poloidal flux. ! function of the normalised poloidal flux.
use gray_params, only : iprof use gray_params, only : iprof
use utils, only : locate
use simplespline, only : spli
implicit none implicit none
@ -204,10 +178,6 @@ contains
real(wp_), intent(in) :: psin real(wp_), intent(in) :: psin
real(wp_) :: fzeff real(wp_) :: fzeff
! local variables
integer :: k
real(wp_) :: dps
fzeff = one fzeff = one
if (psin >= 1 .or. psin < 0) return if (psin >= 1 .or. psin < 0) return
if (iprof == 0) then if (iprof == 0) then
@ -215,10 +185,7 @@ contains
fzeff = model%zeff fzeff = model%zeff
else else
! Use the interpolated numerical data ! Use the interpolated numerical data
call locate(spline%psi, spline%ndata, psin, k) fzeff = zeff_spline%eval(psin)
k = max(1, min(k, spline%ndata - 1))
dps = psin - spline%psi(k)
fzeff = spli(spline%zeff, spline%ndata, k, dps)
endif endif
end function fzeff end function fzeff
@ -378,8 +345,6 @@ contains
! When `launch_pos` (cartesian launch coordinates in cm) is present, ! When `launch_pos` (cartesian launch coordinates in cm) is present,
! the subroutine will also check that the wave launcher is strictly ! the subroutine will also check that the wave launcher is strictly
! outside the reconstructed plasma density boundary. ! outside the reconstructed plasma density boundary.
use simplespline, only : difcs
use dierckx, only : curfit, splev, splder
use gray_params, only : profiles_parameters, profiles_data use gray_params, only : profiles_parameters, profiles_data
use logger, only : log_debug, log_info, log_warning, log_error use logger, only : log_debug, log_info, log_warning, log_error
@ -390,68 +355,28 @@ contains
type(profiles_data), intent(inout) :: data type(profiles_data), intent(inout) :: data
real(wp_), optional, intent(in) :: launch_pos(3) real(wp_), optional, intent(in) :: launch_pos(3)
! curfit parameters
integer, parameter :: iopt = 0 ! smoothing spline mode
integer, parameter :: kspl = 3 ! order of spline (cubic)
! local variables ! local variables
integer :: n, npest, ier integer :: n, err
real(wp_) :: xb, xe, fp, ssplne_loc
! working space arrays for the dierckx functions
integer :: lwrkf
real(wp_), dimension(:), allocatable :: wf, wrkf
integer, dimension(:), allocatable :: iwrkf
! for log messages formatting ! for log messages formatting
character(256) :: msg character(256) :: msg
n = size(data%psrad) n = size(data%psrad)
npest = n + 4
lwrkf = n*4 + npest*16
allocate(wrkf(lwrkf), iwrkf(npest), wf(n))
ssplne_loc=params%sspld
! If necessary, reallocate the spline arrays
if (.not. allocated(spline%psi)) then
allocate(spline%psi(n), spline%temp(n, 4), spline%zeff(n, 4))
else
if (size(spline%psi) < n) then
deallocate(spline%psi, spline%temp, spline%zeff)
allocate(spline%psi(n), spline%temp(n, 4), spline%zeff(n, 4))
end if
end if
if (.not. allocated(spline%coeffs)) then
allocate(spline%knots(npest), spline%coeffs(npest))
else
if (size(spline%coeffs) < npest) then
deallocate(spline%knots, spline%coeffs)
allocate(spline%knots(npest), spline%coeffs(npest))
end if
end if
! Spline interpolation of temperature and effective charge ! Spline interpolation of temperature and effective charge
call difcs(data%psrad, data%terad, n, iopt, spline%temp, ier) call temp_spline%init(data%psrad, data%terad, n)
call difcs(data%psrad, data%zfc, n, iopt, spline%zeff, ier) call zeff_spline%init(data%psrad, data%zfc, n)
spline%psi = data%psrad
spline%ndata = n
! Spline interpolation of density ! Spline interpolation of density (smooth spline)
xb = zero call dens_spline%init(data%psrad, data%derad, n, range=[zero, data%psrad(n)], &
xe = data%psrad(n) tension=params%sspld, err=err)
wf(:) = one
call curfit(iopt, n, data%psrad, data%derad, wf, xb, xe, kspl, & ! if failed, re-fit with an interpolating spline (zero tension)
ssplne_loc, npest, spline%nknots, spline%knots, & if (err == -1) then
spline%coeffs, fp, wrkf, lwrkf, iwrkf, ier) call log_warning('density fit failed with error -1: re-fitting with '// &
! if ier=-1 data are re-fitted using sspl=0 'zero tension', mod='coreprofiles', proc='density')
if (ier == -1) then call dens_spline%init(data%psrad, data%derad, n, &
call log_warning('curfit failed with error -1: re-fitting with '// & range=[zero, data%psrad(n)], tension=zero)
's=0', mod='coreprofiles', proc='density')
ssplne_loc = zero
call curfit(iopt, n, data%psrad, data%derad, wf, xb, xe, kspl, &
ssplne_loc, npest, spline%nknots, spline%knots, &
spline%coeffs, fp, wrkf, lwrkf, iwrkf, ier)
end if end if
! Computation of the polynomial tail parameters ! Computation of the polynomial tail parameters
@ -460,9 +385,9 @@ contains
! at the edge. The spline thus has to be extended to transition ! at the edge. The spline thus has to be extended to transition
! smoothly from the last profile point to 0 outside the plasma. ! smoothly from the last profile point to 0 outside the plasma.
block block
real(wp_), dimension(1) :: s0, s1, s2 ! spline, 1st, 2nd derivative real(wp_) :: s0, s1, s2 ! spline, 1st, 2nd derivative
real(wp_), dimension(1) :: delta4 ! discriminant Δ/4 of q(x) real(wp_) :: delta4 ! discriminant Δ/4 of q(x)
real(wp_), dimension(1) :: x0, x1 ! vertex of q(x), solution real(wp_) :: x0, x1 ! vertex of q(x), solution
! Compute the coefficients of a 2nd order Taylor polinomial to ! Compute the coefficients of a 2nd order Taylor polinomial to
! extend the spline beyond the last point: ! extend the spline beyond the last point:
@ -471,12 +396,9 @@ contains
! !
! where s(ψ) is the spline and ψ₀ the last point. ! where s(ψ) is the spline and ψ₀ the last point.
! !
call splev(spline%knots, spline%nknots, spline%coeffs, kspl, & s0 = dens_spline%eval(data%psrad(n))
data%psrad(n:n), s0, 1, ier) s1 = dens_spline%deriv(data%psrad(n), order=1)
call splder(spline%knots, spline%nknots, spline%coeffs, kspl, 1, & s2 = dens_spline%deriv(data%psrad(n), order=2)
data%psrad(n:n), s1, 1, wrkf(1:spline%nknots), ier)
call splder(spline%knots, spline%nknots, spline%coeffs, kspl, 2, &
data%psrad(n:n), s2, 1, wrkf(1:spline%nknots), ier)
! Determine where to end the tail (to ensure the density remains ! Determine where to end the tail (to ensure the density remains
! positive) from the zeros of the Taylor polynomial p(ψ) ! positive) from the zeros of the Taylor polynomial p(ψ)
@ -491,7 +413,7 @@ contains
x0 = -s1 / s2 ! vertex of parabola y=q(x) x0 = -s1 / s2 ! vertex of parabola y=q(x)
delta4 = (s1 / s2)**2 - 2*s0/s2 ! Δ/4 of q(x) delta4 = (s1 / s2)**2 - 2*s0/s2 ! Δ/4 of q(x)
if (delta4(1) > 0) then if (delta4 > 0) then
! Pick the smallest positive zero (implying >ψ₀) ! Pick the smallest positive zero (implying >ψ₀)
x1 = x0 + sign(sqrt(delta4), sqrt(delta4) - x0) x1 = x0 + sign(sqrt(delta4), sqrt(delta4) - x0)
else else
@ -503,10 +425,10 @@ contains
! Store the tail parameters ! Store the tail parameters
tail%start = data%psrad(n) tail%start = data%psrad(n)
tail%end = tail%start + x1(1) tail%end = tail%start + x1
tail%value = s0(1) tail%value = s0
tail%deriv1 = s1(1) tail%deriv1 = s1
tail%deriv2 = s2(1) tail%deriv2 = s2
end block end block
! Make sure the wave launcher does not fall inside the tail ! Make sure the wave launcher does not fall inside the tail
@ -550,8 +472,6 @@ contains
write (msg, '(a,g0.4)') 'density boundary: ψ=', tail%end write (msg, '(a,g0.4)') 'density boundary: ψ=', tail%end
call log_info(msg, mod='coreprofiles', proc='set_profiles_spline') call log_info(msg, mod='coreprofiles', proc='set_profiles_spline')
deallocate(iwrkf, wrkf, wf)
end subroutine set_profiles_spline end subroutine set_profiles_spline
@ -560,11 +480,9 @@ contains
implicit none implicit none
if (allocated(spline%psi)) deallocate(spline%psi) call dens_spline%deinit
if (allocated(spline%temp)) deallocate(spline%temp) call temp_spline%deinit
if (allocated(spline%zeff)) deallocate(spline%zeff) call zeff_spline%deinit
if (allocated(spline%knots)) deallocate(spline%knots)
if (allocated(spline%coeffs)) deallocate(spline%coeffs)
end subroutine unset_profiles_spline end subroutine unset_profiles_spline

879
src/equilibrium.f90
View File

File diff suppressed because it is too large Load Diff

80
src/gray_core.f90
View File

@ -2187,9 +2187,9 @@ bb: do
subroutine print_prof subroutine print_prof
! Prints the (input) plasma kinetic profiles (unit 98) ! Prints the (input) plasma kinetic profiles (unit 98)
use equilibrium, only : psinr, nq, fq, frhotor, tor_curr_psi use equilibrium, only : q_spline, fq, frhotor, tor_curr_psi
use coreprofiles, only : density, temp use coreprofiles, only : density, temp
use units, only : uprfin, unit_active use units, only : uprfin, unit_active
implicit none implicit none
@ -2198,19 +2198,19 @@ bb: do
! local variables ! local variables
integer :: i integer :: i
real(wp_) :: psin, rhot, ajphi, dens, ddens real(wp_) :: psin, rhot, jphi, dens, ddens
if (.not. unit_active(uprfin)) return if (.not. unit_active(uprfin)) return
write (uprfin, *) '#psi rhot ne Te q Jphi' write (uprfin, *) '#psi rhot ne Te q Jphi'
do i=1,nq do i = 1, q_spline%ndata
psin = psinr(i) psin = q_spline%data(i)
rhot = frhotor(sqrt(psin)) rhot = frhotor(sqrt(psin))
call density(psin, dens, ddens) call density(psin, dens, ddens)
call tor_curr_psi(max(eps, psin), ajphi) jphi = tor_curr_psi(max(eps, psin))
write (uprfin, '(12(1x,e12.5))') & write (uprfin, '(12(1x,e12.5))') &
psin, rhot, dens, temp(psin), fq(psin), ajphi*1.e-6_wp_ psin, rhot, dens, temp(psin), fq(psin), jphi*1.e-6_wp_
end do end do
end subroutine print_prof end subroutine print_prof
@ -2218,8 +2218,8 @@ bb: do
subroutine print_bres(bres) subroutine print_bres(bres)
! Prints the EC resonance surface table (unit 70) ! Prints the EC resonance surface table (unit 70)
use equilibrium, only : rmnm, rmxm, zmnm, zmxm, bfield, nq use equilibrium, only : rmnm, rmxm, zmnm, zmxm, bfield, q_spline
use units, only : ubres, unit_active use units, only : ubres, unit_active
implicit none implicit none
@ -2234,14 +2234,14 @@ bb: do
integer, dimension(10) :: ncpts integer, dimension(10) :: ncpts
real(wp_) :: dr,dz,btmx,btmn,zzk,rrj,bbphi,bbr,bbz,bbb real(wp_) :: dr,dz,btmx,btmn,zzk,rrj,bbphi,bbr,bbz,bbb
real(wp_), dimension(icmx) :: rrcb,zzcb real(wp_), dimension(icmx) :: rrcb,zzcb
real(wp_) :: rv(nq), zv(nq) real(wp_) :: rv(q_spline%ndata), zv(q_spline%ndata)
real(wp_), dimension(nq,nq) :: btotal real(wp_), dimension(q_spline%ndata,q_spline%ndata) :: btotal
if (.not. unit_active(ubres)) return if (.not. unit_active(ubres)) return
dr = (rmxm - rmnm)/(nq - 1) dr = (rmxm - rmnm)/(q_spline%ndata - 1)
dz = (zmxm - zmnm)/(nq - 1) dz = (zmxm - zmnm)/(q_spline%ndata - 1)
do j=1,nq do j=1,q_spline%ndata
rv(j) = rmnm + dr*(j - 1) rv(j) = rmnm + dr*(j - 1)
zv(j) = zmnm + dz*(j - 1) zv(j) = zmnm + dz*(j - 1)
end do end do
@ -2249,9 +2249,9 @@ bb: do
! Btotal on psi grid ! Btotal on psi grid
btmx = -1.0e30_wp_ btmx = -1.0e30_wp_
btmn = 1.0e30_wp_ btmn = 1.0e30_wp_
do k=1,nq do k = 1, q_spline%ndata
zzk = zv(k) zzk = zv(k)
do j=1,nq do j = 1, q_spline%ndata
rrj = rv(j) rrj = rv(j)
call bfield(rrj, zzk, bbphi, bbr, bbz) call bfield(rrj, zzk, bbphi, bbr, bbz)
btotal(j,k) = sqrt(bbr**2 + bbz**2 + bbphi**2) btotal(j,k) = sqrt(bbr**2 + bbz**2 + bbphi**2)
@ -2262,14 +2262,14 @@ bb: do
! compute Btot=Bres/n with n=1,5 ! compute Btot=Bres/n with n=1,5
write (ubres, *) '#i Btot R z' write (ubres, *) '#i Btot R z'
do n=1,5 do n = 1, 5
bbb = bres/dble(n) bbb = bres/dble(n)
if (bbb >= btmn .and. bbb <= btmx) then if (bbb >= btmn .and. bbb <= btmx) then
nconts = size(ncpts) nconts = size(ncpts)
nctot = size(rrcb) nctot = size(rrcb)
call cniteq(rv, zv, btotal, nq, nq, bbb, & call cniteq(rv, zv, btotal, q_spline%ndata, q_spline%ndata, bbb, &
nconts, ncpts, nctot, rrcb, zzcb) nconts, ncpts, nctot, rrcb, zzcb)
do j=1,nctot do j = 1, nctot
write (ubres, '(i6,12(1x,e12.5))') j, bbb, rrcb(j), zzcb(j) write (ubres, '(i6,12(1x,e12.5))') j, bbb, rrcb(j), zzcb(j)
end do end do
end if end if
@ -2284,7 +2284,7 @@ bb: do
use gray_params, only : iequil use gray_params, only : iequil
use equilibrium, only : rmnm, rmxm, zmnm, zmxm, equian, equinum_psi, & use equilibrium, only : rmnm, rmxm, zmnm, zmxm, equian, equinum_psi, &
equinum_fpol, nq equinum_fpol, q_spline
use coreprofiles, only : density, temp use coreprofiles, only : density, temp
use units, only : umaps, unit_active use units, only : umaps, unit_active
@ -2297,28 +2297,28 @@ bb: do
integer :: j,k integer :: j,k
real(wp_) :: dr, dz, zk, rj, bphi, br, bz, btot, & real(wp_) :: dr, dz, zk, rj, bphi, br, bz, btot, &
psin, ne, dne, te, xg, yg, anpl psin, ne, dne, te, xg, yg, anpl
real(wp_), dimension(nq) :: r, z real(wp_), dimension(q_spline%ndata) :: r, z
if (.not. unit_active(umaps)) return if (.not. unit_active(umaps)) return
dr = (rmxm-rmnm)/(nq - 1) dr = (rmxm-rmnm)/(q_spline%ndata - 1)
dz = (zmxm-zmnm)/(nq - 1) dz = (zmxm-zmnm)/(q_spline%ndata - 1)
do j=1,nq do j=1,q_spline%ndata
r(j) = rmnm + dr*(j - 1) r(j) = rmnm + dr*(j - 1)
z(j) = zmnm + dz*(j - 1) z(j) = zmnm + dz*(j - 1)
end do end do
write (umaps, *) '#R z psin Br Bphi Bz Btot ne Te X Y Npl' write (umaps, *) '#R z psin Br Bphi Bz Btot ne Te X Y Npl'
do j=1,nq do j = 1, q_spline%ndata
rj = r(j) rj = r(j)
anpl = anpl0 * r0/rj anpl = anpl0 * r0/rj
do k=1,nq do k = 1, q_spline%ndata
zk = z(k) zk = z(k)
if (iequil < 2) then if (iequil < 2) then
call equian(rj, zk, psinv=psin, fpolv=bphi, dpsidr=bz, dpsidz=br) call equian(rj, zk, psi=psin, fpolv=bphi, dpsidr=bz, dpsidz=br)
else else
call equinum_psi(rj, zk, psinv=psin, dpsidr=bz, dpsidz=br) call equinum_psi(rj, zk, psi=psin, dpsidr=bz, dpsidz=br)
call equinum_fpol(psin, fpolv=bphi) call equinum_fpol(psin, fpol=bphi)
end if end if
br = -br/rj br = -br/rj
bphi = bphi/rj bphi = bphi/rj
@ -2340,7 +2340,7 @@ bb: do
subroutine print_surfq(qval) subroutine print_surfq(qval)
! Print constant ψ surfaces for a given `q` value ! Print constant ψ surfaces for a given `q` value
use equilibrium, only : psinr, nq, fq, frhotor, & use equilibrium, only : q_spline, fq, frhotor, &
rmaxis, zmaxis, zbsup, zbinf rmaxis, zmaxis, zbsup, zbinf
use magsurf_data, only : contours_psi, npoints, print_contour use magsurf_data, only : contours_psi, npoints, print_contour
use utils, only : locate, intlin use utils, only : locate, intlin
@ -2355,23 +2355,23 @@ bb: do
integer :: i1,i integer :: i1,i
real(wp_) :: rup,zup,rlw,zlw,rhot,psival real(wp_) :: rup,zup,rlw,zlw,rhot,psival
real(wp_), dimension(npoints) :: rcn,zcn real(wp_), dimension(npoints) :: rcn,zcn
real(wp_), dimension(nq) :: qpsi real(wp_), dimension(q_spline%ndata) :: qpsi
character(256) :: msg ! for log messages formatting character(256) :: msg ! for log messages formatting
! build q profile on psin grid ! build the q profile on the ψ grid
do i=1,nq do i = 1, q_spline%ndata
qpsi(i) = fq(psinr(i)) qpsi(i) = fq(q_spline%data(i))
end do end do
! locate ψ surface for q=qval ! locate ψ surface for q=qval
call log_info('constant ψ surfaces for:', & call log_info('constant ψ surfaces for:', &
mod='gray_core', proc='print_surfq') mod='gray_core', proc='print_surfq')
do i=1,size(qval) do i=1, size(qval)
! FIXME: check for non monotonous q profile ! FIXME: check for non monotonous q profile
call locate(abs(qpsi),nq,qval(i),i1) call locate(abs(qpsi), q_spline%ndata, qval(i), i1)
if (i1>0 .and. i1<nq) then if (i1 > 0 .and. i1 < q_spline%ndata) then
call intlin(abs(qpsi(i1)), psinr(i1), abs(qpsi(i1+1)), psinr(i1+1), & call intlin(abs(qpsi(i1)), q_spline%data(i1), abs(qpsi(i1+1)), &
qval(i),psival) q_spline%data(i1+1), qval(i), psival)
rup = rmaxis rup = rmaxis
rlw = rmaxis rlw = rmaxis
zup = (zbsup + zmaxis)/2.0_wp_ zup = (zbsup + zmaxis)/2.0_wp_

4
src/gray_jetto1beam.f90
View File

@ -127,13 +127,11 @@ subroutine gray_jetto1beam(ijetto, mr, mz, r, z, psin, psia, rax, zax, &
! Free memory ! Free memory
free_memory: block free_memory: block
use equilibrium, only : unset_equil_spline, unset_rho_spline, unset_q use equilibrium, only : unset_equil_spline
use coreprofiles, only : unset_profiles_spline use coreprofiles, only : unset_profiles_spline
! Unset global variables of the `equilibrium` module ! Unset global variables of the `equilibrium` module
call unset_equil_spline call unset_equil_spline
call unset_rho_spline
call unset_q
! Unset global variables of the `coreprofiles` module ! Unset global variables of the `coreprofiles` module
call unset_profiles_spline call unset_profiles_spline

200
src/magsurf_data.f90
View File

@ -1,5 +1,7 @@
module magsurf_data module magsurf_data
use const_and_precisions, only : wp_ use const_and_precisions, only : wp_
use splines, only : spline_simple
implicit none implicit none
integer, save :: npsi, npoints !# sup mag, # punti per sup integer, save :: npsi, npoints !# sup mag, # punti per sup
@ -14,12 +16,11 @@ module magsurf_data
real(wp_), dimension(:), allocatable, save :: tjp,tlm,ch,ch01 real(wp_), dimension(:), allocatable, save :: tjp,tlm,ch,ch01
real(wp_), dimension(:,:), allocatable, save :: rcon,zcon 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
type(spline_simple), save :: cvol, crri, crbav, cbmx, cbmn, carea, cfc
type(spline_simple), save :: crhotq
type(spline_simple), save :: cratja, cratjb, cratjpl
type(spline_simple), save :: cdadrhot, cdvdrhot
contains contains
@ -58,46 +59,43 @@ contains
allocate(pstab(npsi), & allocate(pstab(npsi), &
rhot_eq(npsi),rhotqv(npsi),bav(npsi),bmxpsi(npsi),bmnpsi(npsi),varea(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), & vvol(npsi),vcurrp(npsi),vajphiav(npsi),qqv(npsi),ffc(npsi),vratja(npsi), &
vratjb(npsi),rpstab(npsi),rri(npsi),rbav(npsi),cdadrhot(npsi,4), & vratjb(npsi),rpstab(npsi),rri(npsi),rbav(npsi))
cdvdrhot(npsi,4),cbmx(npsi,4),cbmn(npsi,4),crbav(npsi,4),cvol(npsi,4), & end subroutine alloc_surfvec
crri(npsi,4),carea(npsi,4),cfc(npsi,4),crhotq(npsi,4),cratjpl(npsi,4), &
cratja(npsi,4),cratjb(npsi,4))
end subroutine alloc_surfvec
subroutine dealloc_surfvec subroutine dealloc_surfvec
implicit none implicit none
call dealloc_cnt call dealloc_cnt
if(allocated(pstab)) deallocate(pstab) if(allocated(pstab)) deallocate(pstab)
if(allocated(rhot_eq)) deallocate(rhot_eq) if(allocated(rhot_eq)) deallocate(rhot_eq)
if(allocated(rhotqv)) deallocate(rhotqv) if(allocated(rhotqv)) deallocate(rhotqv)
if(allocated(bav)) deallocate(bav) if(allocated(bav)) deallocate(bav)
if(allocated(bmxpsi)) deallocate(bmxpsi) if(allocated(bmxpsi)) deallocate(bmxpsi)
if(allocated(bmnpsi)) deallocate(bmnpsi) if(allocated(bmnpsi)) deallocate(bmnpsi)
if(allocated(varea)) deallocate(varea) if(allocated(varea)) deallocate(varea)
if(allocated(vvol)) deallocate(vvol) if(allocated(vvol)) deallocate(vvol)
if(allocated(vcurrp)) deallocate(vcurrp) if(allocated(vcurrp)) deallocate(vcurrp)
if(allocated(vajphiav)) deallocate(vajphiav) if(allocated(vajphiav)) deallocate(vajphiav)
if(allocated(qqv)) deallocate(qqv) if(allocated(qqv)) deallocate(qqv)
if(allocated(ffc)) deallocate(ffc) if(allocated(ffc)) deallocate(ffc)
if(allocated(vratja)) deallocate(vratja) if(allocated(vratja)) deallocate(vratja)
if(allocated(vratjb)) deallocate(vratjb) if(allocated(vratjb)) deallocate(vratjb)
if(allocated(rpstab)) deallocate(rpstab) if(allocated(rpstab)) deallocate(rpstab)
if(allocated(rri)) deallocate(rri) if(allocated(rri)) deallocate(rri)
if(allocated(rbav)) deallocate(rbav) if(allocated(rbav)) deallocate(rbav)
if(allocated(cdadrhot)) deallocate(cdadrhot) if(allocated(tjp)) deallocate(tjp,tlm,ch)
if(allocated(cdvdrhot)) deallocate(cdvdrhot)
if(allocated(cbmx)) deallocate(cbmx) call cvol%deinit
if(allocated(cbmn)) deallocate(cbmn) call crbav%deinit
if(allocated(crbav)) deallocate(crbav) call crri%deinit
if(allocated(cvol)) deallocate(cvol) call cbmx%deinit
if(allocated(crri)) deallocate(crri) call cbmn%deinit
if(allocated(carea)) deallocate(carea) call cratja%deinit
if(allocated(cfc)) deallocate(cfc) call cratjb%deinit
if(allocated(crhotq)) deallocate(crhotq) call cratjpl%deinit
if(allocated(cratjpl)) deallocate(cratjpl) call carea%deinit
if(allocated(cratja)) deallocate(cratja) call cfc%deinit
if(allocated(cratjb)) deallocate(cratjb) call cdadrhot%deinit
if(allocated(tjp)) deallocate(tjp,tlm,ch) call cdvdrhot%deinit
end subroutine dealloc_surfvec end subroutine dealloc_surfvec
@ -106,8 +104,7 @@ contains
use gray_params, only : iequil use gray_params, only : iequil
use equilibrium, only : btrcen,btaxis,rmaxis,zmaxis,phitedge,zbsup,zbinf, & use equilibrium, only : btrcen,btaxis,rmaxis,zmaxis,phitedge,zbsup,zbinf, &
equian,equinum_psi,bfield,frhotor,fq,tor_curr equian,equinum_psi,bfield,frhotor,fq,tor_curr
use simplespline, only : difcs use dierckx, only : regrid,coeff_parder
use dierckx, only : regrid,coeff_parder
implicit none implicit none
! local constants ! local constants
@ -232,7 +229,7 @@ contains
bmmx=-1.0e+30_wp_ bmmx=-1.0e+30_wp_
bmmn=1.0e+30_wp_ bmmn=1.0e+30_wp_
call tor_curr(rctemp(1),zctemp(1),ajphi0) ajphi0 = tor_curr(rctemp(1),zctemp(1))
call bfield(rctemp(1),zctemp(1),bphi,br=brr,bz=bzz) call bfield(rctemp(1),zctemp(1),bphi,br=brr,bz=bzz)
fpolv=bphi*rctemp(1) fpolv=bphi*rctemp(1)
btot0=sqrt(bphi**2+brr**2+bzz**2) btot0=sqrt(bphi**2+brr**2+bzz**2)
@ -260,7 +257,7 @@ contains
rpsim=rctemp(inc1) rpsim=rctemp(inc1)
zpsim=zctemp(inc1) zpsim=zctemp(inc1)
call bfield(rpsim,zpsim,br=brr,bz=bzz) call bfield(rpsim,zpsim,br=brr,bz=bzz)
call tor_curr(rpsim,zpsim,ajphi) ajphi = tor_curr(rpsim,zpsim)
bphi=fpolv/rpsim bphi=fpolv/rpsim
btot=sqrt(bphi**2+brr**2+bzz**2) btot=sqrt(bphi**2+brr**2+bzz**2)
bpoloid=sqrt(brr**2+bzz**2) bpoloid=sqrt(brr**2+bzz**2)
@ -372,36 +369,22 @@ contains
rpstab(npsi)=1.0_wp_ rpstab(npsi)=1.0_wp_
pstab(npsi)=1.0_wp_ pstab(npsi)=1.0_wp_
! spline coefficients of area,vol,rbav,rri,bmxpsi,bmnpsi,fc,dadrhot,dvdrhot,ratioJs ! spline coefficients of area,vol,rbav,rri,bmxpsi,bmnpsi,fc,dadrhot,dvdrhot,ratioJs
! used for computations of dP/dV and J_cd ! used for computations of dP/dV and J_cd
iopt=0 call cvol%init(rpstab, vvol, npsi)
call difcs(rpstab,vvol,npsi,iopt,cvol,ier) call crbav%init(rpstab, rbav, npsi)
iopt=0 call crri%init(rpstab, rri, npsi)
call difcs(rpstab,rbav,npsi,iopt,crbav,ier) call cbmx%init(rpstab, bmxpsi, npsi)
iopt=0 call cbmn%init(rpstab, bmnpsi, npsi)
call difcs(rpstab,rri,npsi,iopt,crri,ier) call cratja%init(rpstab, vratja, npsi)
iopt=0 call cratjb%init(rpstab, vratjb, npsi)
call difcs(rpstab,bmxpsi,npsi,iopt,cbmx,ier) call cratjpl%init(rpstab, vratjpl, npsi)
iopt=0 call carea%init(rpstab, varea, npsi)
call difcs(rpstab,bmnpsi,npsi,iopt,cbmn,ier) call cfc%init(rpstab, ffc, npsi)
iopt=0 call cdadrhot%init(rpstab, dadrhotv, npsi)
call difcs(rpstab,vratja,npsi,iopt,cratja,ier) call cdvdrhot%init(rpstab, dvdrhotv, npsi)
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 ! spline interpolation of H(lambda,rhop) and dH/dlambda
iopt=0 iopt=0
s=0.0_wp_ s=0.0_wp_
call regrid(iopt,npsi,rpstab,nlam,alam,ffhlam,zero,one,zero,one, & call regrid(iopt,npsi,rpstab,nlam,alam,ffhlam,zero,one,zero,one, &
@ -430,37 +413,30 @@ contains
subroutine fluxval(rhop,area,vol,dervol,dadrhot,dvdrhot, & subroutine fluxval(rhop,area,vol,dervol,dadrhot,dvdrhot, &
rri,rbav,bmn,bmx,fc,ratja,ratjb,ratjpl) rri,rbav,bmn,bmx,fc,ratja,ratjb,ratjpl)
use const_and_precisions, only : wp_ use const_and_precisions, only : wp_
use utils, only : locate
use simplespline, only :spli,splid
implicit none implicit none
! arguments
! subroutine arguments
real(wp_), intent(in) :: rhop real(wp_), intent(in) :: rhop
real(wp_), intent(out), optional :: vol,area,rri,rbav,dervol,bmn,bmx,fc, & real(wp_), intent(out), optional :: &
ratja,ratjb,ratjpl,dadrhot,dvdrhot vol, area, rri, rbav, dervol, bmn, bmx, fc, &
! local variables ratja, ratjb, ratjpl, dadrhot, dvdrhot
integer :: ip
real(wp_) :: drh
call locate(rpstab,npsi,rhop,ip) if (present(area)) area = carea%eval(rhop)
ip=min(max(1,ip),npsi-1) if (present(vol)) vol = cvol%eval(rhop)
drh=rhop-rpstab(ip)
if (present(area)) area=spli(carea,npsi,ip,drh) if (present(dervol)) dervol = cvol%deriv(rhop)
if (present(vol)) vol=spli(cvol,npsi,ip,drh) if (present(dadrhot)) dadrhot = cdadrhot%eval(rhop)
if (present(dvdrhot)) dvdrhot = cdvdrhot%eval(rhop)
if (present(dervol)) dervol=splid(cvol,npsi,ip,drh) if (present(rri)) rri = crri%eval(rhop)
if (present(dadrhot)) dadrhot=spli(cdadrhot,npsi,ip,drh) if (present(rbav)) rbav = crbav%eval(rhop)
if (present(dvdrhot)) dvdrhot=spli(cdvdrhot,npsi,ip,drh) if (present(bmn)) bmn = cbmn%eval(rhop)
if (present(bmx)) bmx = cbmx%eval(rhop)
if (present(fc)) fc = cfc%eval(rhop)
if (present(rri)) rri=spli(crri,npsi,ip,drh) if (present(ratja)) ratja = cratja%eval(rhop)
if (present(rbav)) rbav=spli(crbav,npsi,ip,drh) if (present(ratjb)) ratjb = cratjb%eval(rhop)
if (present(bmn)) bmn=spli(cbmn,npsi,ip,drh) if (present(ratjpl)) ratjpl = cratjpl%eval(rhop)
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 subroutine fluxval
@ -470,22 +446,26 @@ contains
use const_and_precisions, only : wp_,pi use const_and_precisions, only : wp_,pi
use gray_params, only : iequil use gray_params, only : iequil
use logger, only : log_warning use logger, only : log_warning
use dierckx, only : profil,sproota use dierckx, only : profil, sproota
use equilibrium, only : rmaxis,zmaxis,aminor,frhotor,tr,nsr,tz,nsz,cceq, & use equilibrium, only : rmaxis, zmaxis, aminor, frhotor, psi_spline, &
kspl,psiant,psinop,points_tgo kspl, psiant, psinop, points_tgo
use limiter, only : rwallm use limiter, only : rwallm
implicit none implicit none
! local constants
! local constants
integer, parameter :: mest=4 integer, parameter :: mest=4
! arguments
! subroutine arguments
real(wp_), intent(in) :: h real(wp_), intent(in) :: h
real(wp_), dimension(:), intent(out) :: rcn,zcn real(wp_), dimension(:), intent(out) :: rcn,zcn
real(wp_), intent(inout) :: rup,zup,rlw,zlw real(wp_), intent(inout) :: rup,zup,rlw,zlw
! local variables
! local variables
integer :: npoints,np,info,ic,ier,iopt,m integer :: npoints,np,info,ic,ier,iopt,m
real(wp_) :: ra,rb,za,zb,rn,th,zc,val real(wp_) :: ra,rb,za,zb,rn,th,zc,val
real(wp_), dimension(mest) :: zeroc real(wp_), dimension(mest) :: zeroc
real(wp_), dimension(nsr) :: czc real(wp_), dimension(psi_spline%nknots_x) :: czc
npoints=size(rcn) npoints=size(rcn)
np=(npoints-1)/2 np=(npoints-1)/2
@ -517,7 +497,10 @@ contains
do ic=2,np do ic=2,np
zc=zlw+(zup-zlw)*(1.0_wp_-cos(th*(ic-1)))/2.0_wp_ zc=zlw+(zup-zlw)*(1.0_wp_-cos(th*(ic-1)))/2.0_wp_
iopt=1 iopt=1
call profil(iopt,tr,nsr,tz,nsz,cceq,kspl,kspl,zc,nsr,czc,ier) call profil(iopt, psi_spline%knots_x, psi_spline%nknots_x, &
psi_spline%knots_y, psi_spline%nknots_y, &
psi_spline%coeffs, kspl, kspl, zc, &
psi_spline%nknots_x, czc, ier)
if (ier > 0) then if (ier > 0) then
block block
character(256) :: msg character(256) :: msg
@ -527,7 +510,8 @@ contains
end block end block
end if end if
val=h*psiant+psinop val=h*psiant+psinop
call sproota(val,tr,nsr,czc,zeroc,mest,m,ier) call sproota(val, psi_spline%knots_x, psi_spline%nknots_x, &
czc, zeroc, mest, m, ier)
if (zeroc(1).gt.rwallm) then if (zeroc(1).gt.rwallm) then
rcn(ic)=zeroc(1) rcn(ic)=zeroc(1)
rcn(npoints+1-ic)=zeroc(2) rcn(npoints+1-ic)=zeroc(2)

8
src/main.f90
View File

@ -193,7 +193,7 @@ contains
! or an analytical description) and initialises the respective ! or an analytical description) and initialises the respective
! GRAY parameters and data. ! GRAY parameters and data.
use equilibrium, only : read_equil_an, read_eqdsk, change_cocos, & use equilibrium, only : read_equil_an, read_eqdsk, change_cocos, &
set_equil_an, set_equil_spline, eq_scal set_equil_an, set_equil_spline, scale_equil
use logger, only : log_debug use logger, only : log_debug
implicit none implicit none
@ -223,7 +223,7 @@ contains
end if end if
! Rescale B, I and/or force their signs ! Rescale B, I and/or force their signs
call eq_scal(params%equilibrium, data%equilibrium) call scale_equil(params%equilibrium, data%equilibrium)
! Set global variables (for splines) ! Set global variables (for splines)
if (params%equilibrium%iequil < 2) then if (params%equilibrium%iequil < 2) then
@ -239,7 +239,7 @@ contains
subroutine deinit_equilibrium(data) subroutine deinit_equilibrium(data)
! Free all memory allocated by the init_equilibrium subroutine. ! Free all memory allocated by the init_equilibrium subroutine.
use gray_params, only : equilibrium_data use gray_params, only : equilibrium_data
use equilibrium, only : unset_equil_spline, unset_rho_spline, unset_q use equilibrium, only : unset_equil_spline
implicit none implicit none
@ -254,8 +254,6 @@ contains
! Unset global variables of the `equilibrium` module ! Unset global variables of the `equilibrium` module
call unset_equil_spline call unset_equil_spline
call unset_rho_spline
call unset_q
end subroutine deinit_equilibrium end subroutine deinit_equilibrium

273
src/simplespline.f90
View File

@ -1,273 +0,0 @@
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

546
src/splines.f90 Normal file
View File

@ -0,0 +1,546 @@
! This module provides a high-level interface for creating and evaluating
! several kind of splines:
!
! `spline_simple` is a simple interpolating cubic spline,
! `spline_1d` and `spline_2d` are wrapper around the DIERCKX cubic splines.
module splines
use const_and_precisions, only : wp_
implicit none
! A 1D interpolating cubic spline
type spline_simple
integer :: ndata ! Number of data points
real(wp_), allocatable :: data(:) ! Data points (ndata)
real(wp_), allocatable :: coeffs(:,:) ! Spline coefficients (ndata, 4)
contains
procedure :: init => spline_simple_init
procedure :: deinit => spline_simple_deinit
procedure :: eval => spline_simple_eval
procedure :: raw_eval => spline_simple_raw_eval
procedure :: deriv => spline_simple_deriv
end type
! A 1D smoothing/interpolating cubic spline
type spline_1d
integer :: nknots ! Number of spline knots
real(wp_), allocatable :: knots(:) ! Knots positions
real(wp_), allocatable :: coeffs(:) ! B-spline coefficients
contains
procedure :: init => spline_1d_init
procedure :: deinit => spline_1d_deinit
procedure :: eval => spline_1d_eval
procedure :: deriv => spline_1d_deriv
end type
! A 2D smoothing/interpolating cubic spline s(x, y)
type spline_2d
integer :: nknots_x ! Number of x knots
integer :: nknots_y ! Number of y knots
real(wp_), allocatable :: knots_x(:) ! Knots x positions
real(wp_), allocatable :: knots_y(:) ! Knots y positions
real(wp_), allocatable :: coeffs(:) ! B-spline coefficients
! B-spline coefficients of the partial derivatives
type(pointer), allocatable :: partial(:,:)
contains
procedure :: init => spline_2d_init
procedure :: deinit => spline_2d_deinit
procedure :: eval => spline_2d_eval
procedure :: init_deriv => spline_2d_init_deriv
procedure :: deriv => spline_2d_deriv
end type
! Wrapper to store pointers in an array
type pointer
real(wp_), pointer :: ptr(:) => null()
end type
private
public spline_simple, spline_1d, spline_2d
contains
subroutine spline_simple_init(self, x, y, n)
! Initialises the spline
implicit none
! subroutine arguments
class(spline_simple), intent(inout) :: self
integer, intent(in) :: n
real(wp_), dimension(n), intent(in) :: x, y
call self%deinit
self%ndata = n
allocate(self%data(n))
allocate(self%coeffs(n, 4))
self%data = x
call spline_simple_coeffs(x, y, n, self%coeffs)
end subroutine spline_simple_init
subroutine spline_simple_deinit(self)
! Deinitialises a simple_spline
implicit none
! subroutine arguments
class(spline_simple), intent(inout) :: self
if (allocated(self%data)) deallocate(self%data)
if (allocated(self%coeffs)) deallocate(self%coeffs)
self%ndata = 0
end subroutine spline_simple_deinit
function spline_simple_eval(self, x) result(y)
! Evaluates the spline at x
use utils, only : locate
implicit none
! subroutine arguments
class(spline_simple), intent(in) :: self
real(wp_), intent(in) :: x
real(wp_) :: y
! local variables
integer :: i
real(wp_) :: dx
call locate(self%data, self%ndata, x, i)
i = min(max(1, i), self%ndata - 1)
dx = x - self%data(i)
y = self%raw_eval(i, dx)
end function spline_simple_eval
function spline_simple_raw_eval(self, i, dx) result(y)
! Evaluates the i-th polynomial of the spline at dx
implicit none
! subroutine arguments
class(spline_simple), intent(in) :: self
integer, intent(in) :: i
real(wp_), intent(in) :: dx
real(wp_) :: y
y = self%coeffs(i,1) + dx*(self%coeffs(i,2) &
+ dx*(self%coeffs(i,3) + dx*self%coeffs(i,4)))
end function spline_simple_raw_eval
function spline_simple_deriv(self, x) result(y)
! Computes the derivative of the spline at x
use utils, only : locate
implicit none
! subroutine arguments
class(spline_simple), intent(in) :: self
real(wp_), intent(in) :: x
real(wp_) :: y
! local variables
integer :: i
real(wp_) :: dx
call locate(self%data, self%ndata, x, i)
i = min(max(1, i), self%ndata - 1)
dx = x - self%data(i)
y = self%coeffs(i,2) + dx*(2*self%coeffs(i,3) + 3*dx*self%coeffs(i,4))
end function spline_simple_deriv
subroutine spline_simple_coeffs(x, y, n, c)
! Computes the cubic coefficients of all n polynomials
implicit none
! subroutine arguments
integer, intent(in) :: n
real(wp_), intent(in) :: x(n), y(n)
real(wp_), intent(inout) :: c(n*4)
! local variables
integer :: jmp, i, ii, j, j1, j2, j3, k
real(wp_) :: xb, xc, ya, yb, h, a, r, dya, dyb, dy2
jmp = 1
if (n <= 1) return
! initialisation
xc = x(1)
yb = y(1)
h = 0
a = 0
r = 0
dyb = 0
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 - a)
dya = dyb + h*r
if (i >= n) then
! set derivative dy2 at last point
dyb = dy2
h = 0
dyb = dya
goto 13
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
goto 13
end if
end if
if (j1-ii /= 0) return
a = 1 / (2*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
j1 = j3+n+ii-ii*n
i = n
do k = 1, n
xb = x(j)
h = xc - xb
xc = xb
a = a+h
yb = r
r = c(j3)-r*c(j2)
ya = 2*r
c(j3) = ya + r
c(j2) = c(i) - h*(ya+yb)
c(j1) = (yb - r)/a
c(i) = y(j)
a = 0
j = j-jmp
i = i-1
j2 = j2-1
j3 = j3-1
j1 = j3+n+ii
end do
end subroutine spline_simple_coeffs
subroutine spline_1d_init(self, x, y, n, range, weights, tension, err)
! Initialises a spline_1d.
! Takes:
! x: x data points
! y: y data points
! n: number of data points
! range: interpolation range as [x_min, x_max]
! weights: factors weighting the data points (default: all 1)
! tension: parameter controlling the amount of smoothing (default: 0)
! Returns:
! err: error code of `curfit`
use dierckx, only : curfit
implicit none
! subroutine arguments
class(spline_1d), intent(inout) :: self
real(wp_), intent(in) :: x(n)
real(wp_), intent(in) :: y(n)
integer, intent(in) :: n
real(wp_), intent(in) :: range(2)
real(wp_), intent(in), optional :: weights(n)
real(wp_), intent(in), optional :: tension
integer, intent(out), optional :: err
! local variables
integer :: nknots_est ! over-estimate of the number of knots
real(wp_) :: residuals ! sum of the residuals
integer :: work_int(n + 4) ! integer working space
real(wp_) :: work_real(4*n + 16*(n + 4)) ! real working space
! default values
integer :: err_def
real(wp_) :: weights_def(n), tension_def
weights_def = 1
tension_def = 0
if (present(weights)) weights_def = weights
if (present(tension)) tension_def = tension
! clear memory, if necessary
call self%deinit
! allocate the spline arrays
nknots_est = n + 4
allocate(self%knots(nknots_est), self%coeffs(nknots_est))
call curfit(0, n, x, y, weights_def, range(1), range(2), 3, tension_def, &
nknots_est, self%nknots, self%knots, self%coeffs, residuals, &
work_real, size(work_real), work_int, err_def)
if (present(err)) err = err_def
end subroutine spline_1d_init
subroutine spline_1d_deinit(self)
! Deinitialises a spline_1d
implicit none
class(spline_1d), intent(inout) :: self
if (allocated(self%knots)) deallocate(self%knots)
if (allocated(self%coeffs)) deallocate(self%coeffs)
self%nknots = 0
end subroutine spline_1d_deinit
function spline_1d_eval(self, x) result(y)
! Evaluates the spline at x
use dierckx, only : splev
implicit none
! subroutine arguments
class(spline_1d), intent(in) :: self
real(wp_), intent(in) :: x
real(wp_) :: y
! local variables
integer :: err
real(wp_) :: yv(1) ! because splev returns a vector
call splev(self%knots, self%nknots, self%coeffs, 3, [x], yv, 1, err)
y = yv(1)
end function spline_1d_eval
function spline_1d_deriv(self, x, order) result(y)
! Evaluates the spline n-th order derivative at x
use dierckx, only : splder
implicit none
! subroutine arguments
class(spline_1d), intent(in) :: self
real(wp_), intent(in) :: x
integer, intent(in), optional :: order
real(wp_) :: y
! local variables
integer :: err, n
real(wp_) :: yv(1) ! because splev returns a vector
real(wp_) :: work(self%nknots) ! working space array
n = 1
if (present(order)) n = order
call splder(self%knots, self%nknots, self%coeffs, &
3, n, [x], yv, 1, work, err)
y = yv(1)
end function spline_1d_deriv
subroutine spline_2d_init(self, x, y, z, nx, ny, range, tension, err)
! Initialises a spline_2d.
! Takes:
! x, y: data points on a regular grid
! z: data points of z(x, y)
! n: number of data points
! range: interpolation range as [x_min, x_max, y_min, y_max]
! weights: factors weighting the data points (default: all 1)
! tension: parameter controlling the amount of smoothing (default: 0)
! Returns:
! err: error code of `curfit`
use dierckx, only : regrid
implicit none
! subroutine arguments
class(spline_2d), intent(inout) :: self
real(wp_), intent(in) :: x(nx)
real(wp_), intent(in) :: y(ny)
real(wp_), intent(in) :: z(nx * ny)
integer, intent(in) :: nx, ny
real(wp_), intent(in) :: range(4)
real(wp_), intent(in), optional :: tension
integer, intent(out), optional :: err
! local variables
integer :: nknots_x_est ! over-estimate of the number of knots
integer :: nknots_y_est !
real(wp_) :: residuals ! sum of the residuals
! working space arrays
integer :: work_int(2*(ny + nx) + 11)
real(wp_) :: work_real(15*(nx + ny) + ny*(nx + 4) + 92 + max(ny, nx + 4))
! default values
integer :: err_def
real(wp_) :: tension_def
tension_def = 0
if (present(tension)) tension_def = tension
! clear memory, if necessary
call self%deinit
! allocate the spline arrays
nknots_x_est = nx + 4
nknots_y_est = ny + 4
allocate(self%knots_x(nknots_x_est), self%knots_y(nknots_y_est))
allocate(self%coeffs(nx * ny))
call regrid(0, nx, x, ny, y, z, range(1), range(2), range(3), range(4), &
3, 3, tension_def, nknots_x_est, nknots_y_est, &
self%nknots_x, self%knots_x, self%nknots_y, self%knots_y, &
self%coeffs, residuals, work_real, size(work_real), &
work_int, size(work_int), err_def)
if (present(err)) err = err_def
end subroutine spline_2d_init
subroutine spline_2d_deinit(self)
! Deinitialises a spline_2d
implicit none
class(spline_2d), intent(inout) :: self
if (allocated(self%knots_x)) deallocate(self%knots_x)
if (allocated(self%knots_y)) deallocate(self%knots_y)
if (allocated(self%coeffs)) deallocate(self%coeffs)
! Note: partial derivatives coeff. are pointers
if (allocated(self%partial)) then
deallocate(self%partial(1, 0)%ptr)
deallocate(self%partial(0, 1)%ptr)
deallocate(self%partial(1, 1)%ptr)
deallocate(self%partial(2, 0)%ptr)
deallocate(self%partial(0, 2)%ptr)
deallocate(self%partial)
end if
self%nknots_x = 0
self%nknots_y = 0
end subroutine spline_2d_deinit
function spline_2d_eval(self, x, y) result(z)
! Evaluates the spline at (x, y)
use dierckx, only : fpbisp
implicit none
! subroutine arguments
class(spline_2d), intent(in) :: self
real(wp_), intent(in) :: x, y
real(wp_) :: z
! local variables
real(wp_) :: zv(1) ! because fpbisp returns a vector
integer :: work_int(8) ! integer working space
real(wp_) :: work_real(8) ! real working space
! Note: see https://netlib.org/dierckx/bispev.f for
! this apparently nonsensical invocation
call fpbisp(self%knots_x, self%nknots_x, &
self%knots_y, self%nknots_y, &
self%coeffs, 3, 3, [x], 1, [y], 1, &
zv, work_real(1), work_real(5), &
work_int(1), work_int(2))
z = zv(1)
end function spline_2d_eval
subroutine spline_2d_init_deriv(self, p, q, n, m)
! Computes the spline coefficients of n-th partial derivative
! w.r.t x and m-th partial derivative w.r.t y on a grid of
! p×q points.
!
! Note: for simplicity, only up to second-order is supported.
use dierckx, only : coeff_parder
implicit none
! subroutine arguments
class(spline_2d), intent(inout) :: self
integer, intent(in) :: p, q ! grid dimensions
integer, intent(in) :: n, m ! derivative order
! local variables
integer :: coeff_size
integer :: err
! coeff. array (actually, the working space) size
coeff_size = p*(4 - n) + q*(4 - m) + p*q
! allocate slots for storing the derivatives (first call only)
if (.not. allocated(self%partial)) allocate(self%partial(0:2, 0:2))
! allocate the coefficients array
allocate(self%partial(n, m)%ptr(coeff_size))
! compute the coefficients
call coeff_parder(self%knots_x, self%nknots_x, &
self%knots_y, self%nknots_y, &
self%coeffs, 3, 3, n, m, &
self%partial(n, m)%ptr, coeff_size, err)
end subroutine spline_2d_init_deriv
function spline_2d_deriv(self, x, y, n, m) result(z)
! Evaluates the spline n-th partial derivative w.r.t x
! and m-th partial derivative w.r.t y at (x, y)
!
! Note: the coefficients of the derivative must have been
! initialised with init_deriv before calling this method.
use dierckx, only : fpbisp
implicit none
! subroutine arguments
class(spline_2d), intent(in) :: self
real(wp_), intent(in) :: x, y
integer, intent(in) :: n, m
real(wp_) :: z
! local variables
real(wp_), dimension(1) :: zv ! because splev returns a vector
integer, dimension(1) :: work_int_x, work_int_y ! integer working space
real(wp_), dimension(1,4) :: work_real_x, work_real_y ! real working space
call fpbisp(self%knots_x(1 + n), self%nknots_x - 2*n, &
self%knots_y(1 + m), self%nknots_y - 2*m, &
self%partial(n, m)%ptr, &
3 - n, 3 - m, [x], 1, [y], 1, zv, &
work_real_x, work_real_y, work_int_x, work_int_y)
z = zv(1)
end function spline_2d_deriv
end module splines