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

79
src/beams.f90
View File

@ -97,7 +97,7 @@ contains
! - φ_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
@ -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)
@ -131,10 +132,7 @@ contains
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

164
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,8 +28,10 @@ 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(spline_simple), save :: temp_spline
type(spline_simple), save :: zeff_spline
type(density_tail), save :: tail type(density_tail), save :: tail
type(analytic_model), save :: model type(analytic_model), save :: model
@ -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
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 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 (ψ > ψ₀)
@ -159,8 +141,6 @@ contains
! !
! 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

855
src/equilibrium.f90
View File

File diff suppressed because it is too large Load Diff

74
src/gray_core.f90
View File

@ -2187,7 +2187,7 @@ 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
@ -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,7 +2218,7 @@ 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

160
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,10 +59,7 @@ 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), &
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 end subroutine alloc_surfvec
subroutine dealloc_surfvec subroutine dealloc_surfvec
@ -84,20 +82,20 @@ contains
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(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)
if(allocated(tjp)) deallocate(tjp,tlm,ch) if(allocated(tjp)) deallocate(tjp,tlm,ch)
call cvol%deinit
call crbav%deinit
call crri%deinit
call cbmx%deinit
call cbmn%deinit
call cratja%deinit
call cratjb%deinit
call cratjpl%deinit
call carea%deinit
call cfc%deinit
call cdadrhot%deinit
call cdvdrhot%deinit
end subroutine dealloc_surfvec end subroutine dealloc_surfvec
@ -106,7 +104,6 @@ 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
@ -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